02/05: publish: The public and private keys are now SRFI-39 parameters.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit ab2a74e4dbfd396566a8b14223f5849304d4fe6b
Author: Ludovic Courtès <address@hidden>
Date:   Wed Mar 22 09:50:06 2017 +0100

    publish: The public and private keys are now SRFI-39 parameters.
    
    * guix/scripts/publish.scm (%default-options): Add 'public-key-file' and
    'private-key-file'.
    (lazy-read-file-sexp): Remove.
    (%private-key, %public-key): Turn into SRFI-39 parameters.
    (signed-string, render-narinfo): Adjust accordingly.
    (guix-publish): Honor 'public-key-file' and 'private-key-file' from
    OPTS.  Use 'parameterize'.
    * guix/pk-crypto.scm (read-file-sexp): New procedure.
    * tests/publish.scm: Initialize '%public-key' and '%private-key'.
---
 guix/pk-crypto.scm       |  8 ++++++
 guix/scripts/publish.scm | 63 +++++++++++++++++++++++++-----------------------
 tests/publish.scm        |  5 ++++
 3 files changed, 46 insertions(+), 30 deletions(-)

diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
index 7017006..55ba7b1 100644
--- a/guix/pk-crypto.scm
+++ b/guix/pk-crypto.scm
@@ -23,11 +23,13 @@
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
   #:export (canonical-sexp?
             error-source
             error-string
             string->canonical-sexp
             canonical-sexp->string
+            read-file-sexp
             number->canonical-sexp
             canonical-sexp-car
             canonical-sexp-cdr
@@ -143,6 +145,12 @@ thrown along with 'gcry-error'."
               (loop (* len 2))
               (pointer->string buf size "ISO-8859-1")))))))
 
+(define (read-file-sexp file)
+  "Return the canonical sexp read from FILE."
+  (call-with-input-file file
+    (compose string->canonical-sexp
+             read-string)))
+
 (define canonical-sexp-car
   (let* ((ptr  (libgcrypt-func "gcry_sexp_car"))
          (proc (pointer->procedure '* ptr '(*))))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 33a7b3b..57eea79 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <address@hidden>
-;;; Copyright © 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,7 +52,10 @@
   #:use-module (guix scripts)
   #:use-module ((guix utils) #:select (compressed-file?))
   #:use-module ((guix build utils) #:select (dump-port))
-  #:export (guix-publish))
+  #:export (%public-key
+            %private-key
+
+            guix-publish))
 
 (define (show-help)
   (format #t (_ "Usage: guix publish [OPTION]...
@@ -154,6 +157,9 @@ compression disabled~%"))
 (define %default-options
   `((port . 8080)
 
+    (public-key-file . ,%public-key-file)
+    (private-key-file . ,%private-key-file)
+
     ;; Default to fast & low compression.
     (compression . ,(if (zlib-available?)
                         %default-gzip-compression
@@ -162,18 +168,11 @@ compression disabled~%"))
     (address . ,(make-socket-address AF_INET INADDR_ANY 0))
     (repl . #f)))
 
-(define (lazy-read-file-sexp file)
-  "Return a promise to read the canonical sexp from FILE."
-  (delay
-    (call-with-input-file file
-      (compose string->canonical-sexp
-               read-string))))
-
+;; The key pair used to sign narinfos.
 (define %private-key
-  (lazy-read-file-sexp %private-key-file))
-
+  (make-parameter #f))
 (define %public-key
-  (lazy-read-file-sexp %public-key-file))
+  (make-parameter #f))
 
 (define %nix-cache-info
   `(("StoreDir" . ,%store-directory)
@@ -186,10 +185,10 @@ compression disabled~%"))
 
 (define (signed-string s)
   "Sign the hash of the string S with the daemon's key."
-  (let* ((public-key (force %public-key))
+  (let* ((public-key (%public-key))
          (hash (bytevector->hash-data (sha256 (string->utf8 s))
                                       #:key-type (key-type public-key))))
-    (signature-sexp hash (force %private-key) public-key)))
+    (signature-sexp hash (%private-key) public-key)))
 
 (define base64-encode-string
   (compose base64-encode string->utf8))
@@ -279,7 +278,7 @@ appropriate duration."
                         `((cache-control (max-age . ,ttl)))
                         '()))
                 (cut display
-                  (narinfo-string store store-path (force %private-key)
+                  (narinfo-string store store-path (%private-key)
                                   #:compression compression)
                   <>)))))
 
@@ -566,11 +565,12 @@ blocking."
                                            (sockaddr:addr addr)
                                            port)))
            (socket  (open-server-socket address))
-           (repl-port (assoc-ref opts 'repl)))
-      ;; Read the key right away so that (1) we fail early on if we can't
-      ;; access them, and (2) we can then drop privileges.
-      (force %private-key)
-      (force %public-key)
+           (repl-port (assoc-ref opts 'repl))
+
+           ;; Read the key right away so that (1) we fail early on if we can't
+           ;; access them, and (2) we can then drop privileges.
+           (public-key  (read-file-sexp (assoc-ref opts 'public-key-file)))
+           (private-key (read-file-sexp (assoc-ref opts 'private-key-file))))
 
       (when user
         ;; Now that we've read the key material and opened the socket, we can
@@ -580,13 +580,16 @@ blocking."
       (when (zero? (getuid))
         (warning (_ "server running as root; \
 consider using the '--user' option!~%")))
-      (format #t (_ "publishing ~a on ~a, port ~d~%")
-              %store-directory
-              (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
-              (sockaddr:port address))
-      (when repl-port
-        (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
-      (with-store store
-        (run-publish-server socket store
-                            #:compression compression
-                            #:narinfo-ttl ttl)))))
+
+      (parameterize ((%public-key public-key)
+                     (%private-key private-key))
+        (format #t (_ "publishing ~a on ~a, port ~d~%")
+                %store-directory
+                (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
+                (sockaddr:port address))
+        (when repl-port
+          (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
+        (with-store store
+          (run-publish-server socket store
+                              #:compression compression
+                              #:narinfo-ttl ttl))))))
diff --git a/tests/publish.scm b/tests/publish.scm
index 0fd3b50..c0a0f72 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -33,6 +33,7 @@
   #:use-module ((guix records) #:select (recutils->alist))
   #:use-module ((guix serialization) #:select (restore-file))
   #:use-module (guix pk-crypto)
+  #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
   #:use-module (guix zlib)
   #:use-module (web uri)
   #:use-module (web client)
@@ -100,6 +101,10 @@
 ;; Wait until the two servers are ready.
 (wait-until-ready 6789)
 
+;; Initialize the public/private key SRFI-39 parameters.
+(%public-key (read-file-sexp %public-key-file))
+(%private-key (read-file-sexp %private-key-file))
+
 
 (test-begin "publish")