03/04: download: Support content-addressed mirrors.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit cd436bf05a8344acf4462f3602e7d360821a902a
Author: Ludovic Courtès <address@hidden>
Date:   Sat May 14 17:37:47 2016 +0200

    download: Support content-addressed mirrors.
    
    * guix/download.scm (%content-addressed-mirrors)
    (%content-addressed-mirror-file): New variables.
    * guix/download.scm (url-fetch)[builder]: Define
    'value-from-environment.  Pass #:hashes and
     #:content-addressed-mirrors to 'url-fetch'.
    Define "guix download hashes" environment variable.
    * guix/build/download.scm (url-fetch): Add #:content-addressed-mirrors
    and #:hashes.
    [content-addressed-urls]: New variable.
    Use it.
---
 guix/build/download.scm |   26 +++++++++++++++++++++++---
 guix/download.scm       |   42 +++++++++++++++++++++++++++++++++++-------
 2 files changed, 58 insertions(+), 10 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index fec4cec..824e1c3 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -605,10 +605,22 @@ Return a list of URIs."
     (else
      (list uri))))
 
-(define* (url-fetch url file #:key (mirrors '()))
+(define* (url-fetch url file
+                    #:key
+                    (mirrors '()) (content-addressed-mirrors '())
+                    (hashes '()))
   "Fetch FILE from URL; URL may be either a single string, or a list of
 string denoting alternate URLs for FILE.  Return #f on failure, and FILE
-on success."
+on success.
+
+When MIRRORS is defined, it must be an alist of mirrors; it is used to resolve
+'mirror://' URIs.
+
+HASHES must be a list of algorithm/hash pairs, where each algorithm is a
+symbol such as 'sha256 and each hash is a bytevector.
+CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash
+algorithm and a hash, return a URL where the specified data can be retrieved
+or #f."
   (define uri
     (append-map (cut maybe-expand-mirrors <> mirrors)
                 (match url
@@ -628,13 +640,21 @@ on success."
                uri)
        #f)))
 
+  (define content-addressed-urls
+    (append-map (lambda (make-url)
+                  (filter-map (match-lambda
+                                ((hash-algo . hash)
+                                 (make-url hash-algo hash)))
+                              hashes))
+                content-addressed-mirrors))
+
   ;; Make this unbuffered so 'progress-proc' works as expected.  _IOLBF means
   ;; '\n', not '\r', so it's not appropriate here.
   (setvbuf (current-output-port) _IONBF)
 
   (setvbuf (current-error-port) _IOLBF)
 
-  (let try ((uri uri))
+  (let try ((uri (append uri content-addressed-urls)))
     (match uri
       ((uri tail ...)
        (or (fetch uri file)
diff --git a/guix/download.scm b/guix/download.scm
index 88f285d..ff0bef3 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -210,6 +210,22 @@
   ;; 'object->string'.
   (plain-file "mirrors" (object->string %mirrors)))
 
+(define %content-addressed-mirrors
+  ;; List of content-addressed mirrors.  Each mirror is represented as a
+  ;; procedure that takes an algorithm (symbol) and a hash (bytevector), and
+  ;; returns a URL or #f.
+  ;; TODO: Add more.
+  '(list (lambda (algo hash)
+           ;; 'tarballs.nixos.org' supports several algorithms.
+           (string-append "http://tarballs.nixos.org/";
+                          (symbol->string algo) "/"
+                          (bytevector->nix-base32-string hash)))))
+
+(define %content-addressed-mirror-file
+  ;; Content-addressed mirrors stored in a file.
+  (plain-file "content-addressed-mirrors"
+              (object->string %content-addressed-mirrors)))
+
 (define (gnutls-package)
   "Return the default GnuTLS package."
   (let ((module (resolve-interface '(gnu packages tls))))
@@ -258,12 +274,21 @@ in the store."
                               %load-path)))
               #~#t)
 
-        (use-modules (guix build download))
+        (use-modules (guix build download)
+                     (guix base32))
+
+        (let ((value-from-environment (lambda (variable)
+                                        (call-with-input-string
+                                            (getenv variable)
+                                          read))))
+          (url-fetch (value-from-environment "guix download url")
+                     #$output
+                     #:mirrors (call-with-input-file #$%mirror-file read)
 
-        (url-fetch (call-with-input-string (getenv "guix download url")
-                     read)
-                   #$output
-                   #:mirrors (call-with-input-file #$%mirror-file read))))
+                     ;; Content-addressed mirrors.
+                     #:hashes (value-from-environment "guix download hashes")
+                     #:content-addressed-mirrors
+                     (primitive-load #$%content-addressed-mirror-file)))))
 
   (let ((uri (and (string? url) (string->uri url))))
     (if (or (and (string? url) (not uri))
@@ -278,14 +303,17 @@ in the store."
                             #:hash hash
                             #:modules '((guix build download)
                                         (guix build utils)
-                                        (guix ftp-client))
+                                        (guix ftp-client)
+                                        (guix base32))
 
                             ;; Use environment variables and a fixed script
                             ;; name so there's only one script in store for
                             ;; all the downloads.
                             #:script-name "download"
                             #:env-vars
-                            `(("guix download url" . ,(object->string url)))
+                            `(("guix download url" . ,(object->string url))
+                              ("guix download hashes"
+                               . ,(object->string `((,hash-algo . ,hash)))))
 
                             ;; Honor the user's proxy settings.
                             #:leaked-env-vars '("http_proxy" "https_proxy")