Serve narinfo files for derivations

guix-data-service/web/controller.scm

@@ -322,11 +322,11 @@
      (render-narinfos conn filename))
     (((or 'GET 'POST) "build-server" _ ...)
      (delegate-to-with-secret-key-base build-server-controller))
-    (('GET "nar" _ ...) (delegate-to nar-controller))
     (('GET "compare" _ ...)             (delegate-to compare-controller))
     (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
     (('GET "jobs")         (delegate-to jobs-controller))
     (('GET "jobs" "queue") (delegate-to jobs-controller))
     (('GET "job" job-id)   (delegate-to jobs-controller))
+    (('GET _ ...) (delegate-to nar-controller))
     ((method path ...)
      (not-found (request-uri request)))))

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)))

scripts/guix-data-service.in

@@ -27,8 +27,11 @@
              (srfi srfi-37)
              (ice-9 textual-ports)
              (system repl server)
+             (gcrypt pk-crypto)
+             (guix pki)
              (guix-data-service config)
-             (guix-data-service web server))
+             (guix-data-service web server)
+             (guix-data-service web nar controller))
 
 (define %default-repl-server-port
   ;; Default port to run REPL server on, if --listen-repl is provided
@@ -56,6 +59,12 @@
                               (string-trim-right
                                (call-with-input-file arg get-string-all))
                               result)))
+        (option '("narinfo-signing-public-key") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'narinfo-signing-public-key-file arg result)))
+        (option '("narinfo-signing-private-key") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'narinfo-signing-private-key-file arg result)))
         (option '("update-database") #f #f
                 (lambda (opt name _ result)
                   (alist-cons 'update-database #t result)))
@@ -74,6 +83,8 @@
 (define %default-options
   ;; Alist of default option values
   `((listen-repl                          . #f)
+    (narinfo-signing-public-key           . ,%public-key-file)
+    (narinfo-signing-private-key          . ,%private-key-file)
     (update-database                      . #f)
     (port                                 . 8765)
     (host                                 . "0.0.0.0")))
@@ -129,6 +140,27 @@
   (simple-format #t "starting the server on port ~A\n"
                  (assq-ref opts 'port))
 
+  (parameterize ((%narinfo-signing-public-key
+                  (and=> (assoc-ref opts 'narinfo-signing-public-key)
+                         read-file-sexp))
+                 (%narinfo-signing-private-key
+                  (catch
+                    'system-error
+                    (lambda ()
+                      (and=> (assoc-ref opts 'narinfo-signing-private-key)
+                             read-file-sexp))
+                    (lambda (key . args)
+                      (simple-format
+                       (current-error-port)
+                       "warning: failed to load narinfo signing private key from ~A\n"
+                       (assoc-ref opts 'narinfo-signing-private-key))
+                      (simple-format (current-error-port)
+                                     "  ~A: ~A\n"
+                                     key args)
+                      (display "warning: not signing narinfo files\n"
+                               (current-error-port))
+                      #f))))
+
     (start-guix-data-service-web-server (assq-ref opts 'port)
                                         (assq-ref opts 'host)
-                                      (assq-ref opts 'secret-key-base)))
+                                        (assq-ref opts 'secret-key-base))))