Add experimental support for serving files by hash

This route can be used to provide source files used in packages. The
URL pattern is the same as used by guix publish.

The main issue with the implementation is that the fibers web server
expects the entire response to be in memory, so I'm not sure how well
this will scale. Additionally, the code for extracting the file from
the nar isn't ideal.

1 files changed, 127 insertions, 0 deletions

diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 68e3219..4743627 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -18,15 +18,33 @@
 
 (define-module (nar-herder server)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (rnrs bytevectors)
   #:use-module (web uri)
   #:use-module (web response)
   #:use-module (web request)
   #:use-module (logging logger)
   #:use-module (prometheus)
   #:use-module (json)
+  #:use-module ((system foreign)
+                #:select (bytevector->pointer pointer->bytevector))
+  #:use-module (guix store)
+  #:use-module (guix base32)
+  #:use-module (guix serialization)
+  #:use-module ((guix utils)
+                #:select (decompressed-port))
+  #:use-module ((guix build utils)
+                #:select (dump-port))
   #:use-module (nar-herder database)
   #:use-module (nar-herder storage)
+
+  
+  #:use-module (ice-9 textual-ports)
+
+  
   #:export (make-request-handler))
 
 (define* (render-json json #:key (extra-headers '())
@@ -73,6 +91,66 @@
             (metric-set metric value))))
        metrics))))
 
+(define (serve-fixed-output-file input compression proc)
+  ;; TODO It's hard with fold-archive from (guix serialization) to
+  ;; read just the singular file from the archive, so the following
+  ;; procedures allow to just read the parts prior to the file, which
+  ;; includes the file length
+
+  (define (sub-bytevector bv len)
+    (define max (bytevector-length bv))
+    (cond ((= len max) bv)
+          ((< len max)
+           ;; Yes, this is safe because the result of each conversion procedure
+           ;; has its life cycle synchronized with that of its argument.
+           (pointer->bytevector (bytevector->pointer bv) len))
+          (else
+           (error "sub-bytevector called to get a super bytevector"))))
+
+  (define (read-long-long p)
+    (let ((b (get-bytevector-n p 8)))
+      (bytevector-u64-ref b 0 (endianness little))))
+
+  (define (read-int p)
+    (let ((b (get-bytevector-n p 8)))
+      (bytevector-u32-ref b 0 (endianness little))))
+
+  (define (read-byte-string p)
+    (let* ((len (read-int p))
+           (m   (modulo len 8))
+           (pad (if (zero? m) 0 (- 8 m)))
+           (bv  (get-bytevector-n p (+ len pad))))
+      (sub-bytevector bv len)))
+
+  (define (read-string p)
+    (utf8->string (read-byte-string p)))
+
+  (let*-values (((port pids)
+                 (decompressed-port
+                  (string->symbol compression)
+                  input)))
+
+    ;; The decompressor can be an external program, so wait for it to
+    ;; exit
+    (every (compose zero? cdr waitpid) pids)
+
+    (match (list
+            (read-string port)
+            (read-string port)
+            (read-string port)
+            (read-string port)
+
+            (match (read-string port)
+              ("contents" 'regular)
+              ("executable"
+               (match (list (read-string port) (read-string port))
+                 (("" "contents") 'executable))))
+
+            (read-long-long port))
+      (("nix-archive-1" "(" "type" "regular" type size)
+
+       (proc port size)))))
+
 (define* (make-request-handler database storage-root
                                #:key ttl negative-ttl logger
                                metrics-registry)
@@ -178,6 +256,55 @@
                      #f)
              (values (build-response #:code 404)
                      "404"))))
+      (('GET "file" name algo hash)
+       (guard (c ((invalid-base32-character? c)
+                  (values (build-response #:code 404)
+                          "404")))
+         (let ((hash-bytevector (nix-base32-string->bytevector hash)))
+           (if (and (string=? algo "sha256") (= 32 (bytevector-length
+                                                    hash-bytevector)))
+               (let* ((store-path
+                       (fixed-output-path name hash-bytevector
+                                          #:hash-algo
+                                          (string->symbol algo)
+                                          #:recursive? #f))
+                      (store-path-hash
+                       (store-path-hash-part store-path))
+                      (narinfo-files
+                       (database-select-narinfo-files
+                        database
+                        store-path-hash))
+                      (selected-narinfo-file
+                       ;; TODO Select intelligently
+                       (first narinfo-files)))
+
+                 (if selected-narinfo-file
+                     (let* ((url
+                             (assq-ref selected-narinfo-file 'url))
+                            (filename
+                             (string-append storage-root
+                                            (uri-decode url))))
+
+                       (serve-fixed-output-file
+                        (open-input-file filename)
+                        (assq-ref selected-narinfo-file
+                                  'compression)
+                        (lambda (nar-port bytes)
+                          (values `((content-type   . (application/octet-stream
+                                                       (charset . "ISO-8859-1")))
+                                    (content-length . ,bytes))
+                                  (lambda (output-port)
+                                    (dump-port nar-port
+                                               output-port
+                                               bytes)
+
+                                    (close-port output-port))))))
+
+                     (values (build-response #:code 404)
+                             "404")))
+               (values (build-response #:code 404)
+                       "404")))))
+
       (('GET "recent-changes")
        (let ((query-parameters
               (or (and=> (uri-query (request-uri request))