Serve narinfo files for derivations

1 files changed, 109 insertions, 1 deletions

diff --git a/guix-data-service/web/nar/controller.scm b/guix-data-service/web/nar/controller.scm
index bdc8ec7..783fd12 100644
--- a/guix-data-service/web/nar/controller.scm
+++ b/guix-data-service/web/nar/controller.scm
@@ -16,28 +16,95 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-data-service web nar controller)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 iconv)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
+  #:use-module (gcrypt hash)
+  #:use-module (gcrypt pk-crypto)
+  #:use-module (web uri)
   #:use-module (web request)
   #:use-module (web response)
+  #:use-module (guix pki)
+  #:use-module (guix base32)
+  #:use-module (guix base64)
   #:use-module (guix serialization)
   #:use-module (guix-data-service web render)
   #:use-module (guix-data-service model derivation)
-  #:export (nar-controller))
+  #:export (nar-controller
+
+            %narinfo-signing-private-key
+            %narinfo-signing-public-key))
+
+
+(define %narinfo-signing-private-key
+  (make-parameter #f))
+
+(define %narinfo-signing-public-key
+  (make-parameter #f))
 
 (define (nar-controller request
                           method-and-path-components
                           mime-types
                           body
                           conn)
+  (define (.narinfo-suffix s)
+    (string-suffix? ".narinfo" s))
+
   (match method-and-path-components
     (('GET "nar" derivation)
      (render-nar request
                  mime-types
                  conn
                  (string-append "/gnu/store/" derivation)))
+    (('GET (? .narinfo-suffix path))
+     (let* ((hash (string-drop-right
+                   path
+                   (string-length ".narinfo")))
+            (derivation (select-derivation-by-file-name-hash
+                         conn
+                         hash)))
+       (if derivation
+           (list (build-response
+                  #:code 200
+                  #:headers '((content-type . (application/x-narinfo))))
+                 (let* ((derivation-file-name
+                         (second derivation))
+                        (derivation-text
+                         (select-serialized-derivation-by-file-name
+                          conn
+                          derivation-file-name))
+                        (derivation-bytevector
+                         (string->bytevector derivation-text
+                                             "ISO-8859-1"))
+                        (derivation-references
+                         (select-derivation-references-by-derivation-id
+                          conn
+                          (first derivation)))
+                        (nar-bytevector
+                         (call-with-values
+                             (lambda ()
+                               (open-bytevector-output-port))
+                           (lambda (port get-bytevector)
+                             (write-file-tree
+                              derivation-file-name
+                              port
+                              #:file-type+size
+                              (lambda (file)
+                                (values 'regular
+                                        (bytevector-length derivation-bytevector)))
+                              #:file-port
+                              (lambda (file)
+                                (open-bytevector-input-port derivation-bytevector)))
+                             (get-bytevector)))))
+                 (lambda (port)
+                   (display (narinfo-string derivation-file-name
+                                            nar-bytevector
+                                            derivation-references)
+                            port))))
+           (not-found (request-uri request)))))
     (_ #f)))
 
 (define (render-nar request
@@ -68,3 +135,44 @@
                    (lambda (file)
                      (open-bytevector-input-port derivation-bytevector))))))
         (not-found (request-uri request)))))
+
+(define* (narinfo-string store-item
+                         nar-bytevector
+                         references
+                         #:key
+                         (nar-path "nar"))
+  (define (signed-string s)
+    (let* ((public-key (%narinfo-signing-public-key))
+           (hash (bytevector->hash-data (sha256 (string->utf8 s))
+                                        #:key-type (key-type public-key))))
+      (signature-sexp hash (%narinfo-signing-private-key) public-key)))
+
+  (let* ((hash       (bytevector->nix-base32-string
+                      (sha256 nar-bytevector)))
+         (size       (bytevector-length nar-bytevector))
+         (references (string-join
+                      (map basename references)
+                      " "))
+         (info (format #f
+                             "\
+StorePath: ~a
+URL: ~a
+Compression: none
+NarHash: sha256:~a
+NarSize: ~d
+References: ~a~%"
+                             store-item
+                             (encode-and-join-uri-path
+                              (list nar-path
+                                    (basename store-item)))
+                             hash
+                             size
+                             references)))
+    (if (%narinfo-signing-private-key)
+        (format #f "~aSignature: 1;~a;~a~%"
+                info
+                (gethostname)
+                (base64-encode
+                 (string->utf8
+                  (canonical-sexp->string (signed-string info)))))
+        info)))