03/04: publish: Handle '/file' URLs, for content-addressed files.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit ff6638d112d794c9c433731643711932452fd2ff
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jul 20 16:54:31 2016 +0200

    publish: Handle '/file' URLs, for content-addressed files.
    
    * guix/scripts/publish.scm (render-content-addressed-file): New procedure.
    (http-write): Add 'application/octet-stream' case.
    (make-request-handler): Add /file/NAME/sha256/HASH URLs.
    * tests/publish.scm ("/file/NAME/sha256/HASH")
    ("/file/NAME/sha256/INVALID-NIX-BASE32-STRING")
    ("/file/NAME/sha256/INVALID-HASH"): New tests.
    * doc/guix.texi (Invoking guix publish): Mention the /file URLs.
---
 doc/guix.texi            |   14 +++++++++++
 guix/scripts/publish.scm |   59 +++++++++++++++++++++++++++++++++++++++++++++-
 tests/publish.scm        |   34 ++++++++++++++++++++++++++
 3 files changed, 106 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7ea9ddf..e7b233d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5633,6 +5633,20 @@ archive}), the daemon may download substitutes from it:
 guix-daemon --substitute-urls=http://example.org:8080
 @end example
 
+As a bonus, @command{guix publish} also serves as a content-addressed
+mirror for source files referenced in @code{origin} records
+(@pxref{origin Reference}).  For instance, assuming @command{guix
+publish} is running on @code{example.org}, the following URL returns the
+raw @file{hello-2.10.tar.gz} file with the given SHA256 hash
+(represented in @code{nix-base32} format, @pxref{Invoking guix hash}):
+
address@hidden
+http://example.org/file/hello-2.10.tar.gz/sha256/address@hidden
address@hidden example
+
+Obviously, these URLs only work for files that are in the store; in
+other cases, they return 404 (``Not Found'').
+
 The following options are available:
 
 @table @code
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 3baceaf..2ca2aee 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -31,6 +31,7 @@
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:use-module (web http)
   #:use-module (web request)
@@ -49,6 +50,7 @@
   #:use-module (guix zlib)
   #:use-module (guix ui)
   #:use-module (guix scripts)
+  #:use-module ((guix build utils) #:select (dump-port))
   #:export (guix-publish))
 
 (define (show-help)
@@ -308,6 +310,25 @@ appropriate duration."
                 store-path)
         (not-found request))))
 
+(define (render-content-addressed-file store request
+                                       name algo hash)
+  "Return the content of the result of the fixed-output derivation NAME that
+has the given HASH of type ALGO."
+  ;; TODO: Support other hash algorithms.
+  (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash)))
+      (let ((item (fixed-output-path name hash
+                                     #:hash-algo algo
+                                     #:recursive? #f)))
+        (if (valid-path? store item)
+            (values `((content-type . (application/octet-stream
+                                       (charset . "ISO-8859-1"))))
+                    ;; XXX: We're not returning the actual contents, deferring
+                    ;; instead to 'http-write'.  This is a hack to work around
+                    ;; <http://bugs.gnu.org/21093>.
+                    item)
+            (not-found request)))
+      (not-found request)))
+
 (define extract-narinfo-hash
   (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
     (lambda (str)
@@ -398,6 +419,34 @@ blocking."
           (swallow-zlib-error
            (close-port port))
           (values)))))
+    (('application/octet-stream . _)
+     ;; Send a raw file in a separate thread.
+     (call-with-new-thread
+      (lambda ()
+        (catch 'system-error
+          (lambda ()
+            (call-with-input-file (utf8->string body)
+              (lambda (input)
+                (let* ((size     (stat:size (stat input)))
+                       (headers  (alist-cons 'content-length size
+                                             (alist-delete 'content-length
+                                                           (response-headers 
response)
+                                                           eq?)))
+                       (response (write-response (set-field response
+                                                            (response-headers)
+                                                            headers)
+                                                 client))
+                       (output   (response-port response)))
+                  (dump-port input output)
+                  (close-port output)
+                  (values)))))
+          (lambda args
+            ;; If the file was GC'd behind our back, that's fine.  Likewise if
+            ;; the client closes the connection.
+            (unless (memv (system-error-errno args)
+                          (list ENOENT EPIPE ECONNRESET))
+              (apply throw args))
+            (values))))))
     (_
      ;; Handle other responses sequentially.
      (%http-write server client response body))))
@@ -418,7 +467,7 @@ blocking."
     (format #t "~a ~a~%"
             (request-method request)
             (uri-path (request-uri request)))
-    (if (get-request? request) ; reject POST, PUT, etc.
+    (if (get-request? request)                    ;reject POST, PUT, etc.
         (match (request-path-components request)
           ;; /nix-cache-info
           (("nix-cache-info")
@@ -450,6 +499,14 @@ blocking."
                              (_
                               %default-gzip-compression)))
                (not-found request)))
+
+          ;; /nar/file/NAME/sha256/HASH
+          (("file" name "sha256" hash)
+           (guard (c ((invalid-base32-character? c)
+                      (not-found request)))
+             (let ((hash (nix-base32-string->bytevector hash)))
+               (render-content-addressed-file store request
+                                              name 'sha256 hash))))
           (_ (not-found request)))
         (not-found request))))
 
diff --git a/tests/publish.scm b/tests/publish.scm
index 9bf181f..0ba3348 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -26,6 +26,8 @@
   #:use-module (guix utils)
   #:use-module (guix hash)
   #:use-module (guix store)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
   #:use-module (guix base32)
   #:use-module (guix base64)
   #:use-module ((guix records) #:select (recutils->alist))
@@ -210,4 +212,36 @@ References: ~%"
         (display "This file is not a valid store item." port)))
     (response-code (http-get (publish-uri (string-append "/nar/invalid"))))))
 
+(test-equal "/file/NAME/sha256/HASH"
+  "Hello, Guix world!"
+  (let* ((data "Hello, Guix world!")
+         (hash (call-with-input-string data port-sha256))
+         (drv  (run-with-store %store
+                 (gexp->derivation "the-file.txt"
+                                   #~(call-with-output-file #$output
+                                       (lambda (port)
+                                         (display #$data port)))
+                                   #:hash-algo 'sha256
+                                   #:hash hash)))
+         (out  (build-derivations %store (list drv))))
+    (utf8->string
+     (http-get-body
+      (publish-uri
+       (string-append "/file/the-file.txt/sha256/"
+                      (bytevector->nix-base32-string hash)))))))
+
+(test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING"
+  404
+  (let ((uri (publish-uri
+              "/file/the-file.txt/sha256/not-a-nix-base32-string")))
+    (response-code (http-get uri))))
+
+(test-equal "/file/NAME/sha256/INVALID-HASH"
+  404
+  (let ((uri (publish-uri
+              (string-append "/file/the-file.txt/sha256/"
+                             (bytevector->nix-base32-string
+                              (call-with-input-string "" port-sha256))))))
+    (response-code (http-get uri))))
+
 (test-end "publish")