archive: Add '--generate-key'.

* guix/pk-crypto.scm (error-source, error-string): New procedures.
* guix/pki.scm (%private-key-file): New variable.
* guix/scripts/archive.scm (show-help): Document '--generate-key'.
  (%options): Add "generate-key".
  (generate-key-pair): New procedure.
  (guix-archive): Call 'generate-key' when OPTS contains a
  'generate-key' pair.
* doc/guix.texi (Setting Up the Daemon): Suggest generating a key pair.
  (Invoking guix archive): Document '--generate-key'.

4 files changed, 108 insertions, 10 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index afa7654d54..ec529346c7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -237,6 +237,14 @@ case, shared memory support is unavailable in the chroot environment.
 The workaround is to make sure that @file{/dev/shm} is directly a
 @code{tmpfs} mount point.}.
 
+Finally, you may want to generate a key pair to allow the daemon to
+export signed archives of files from the store (@pxref{Invoking guix
+archive}):
+
+@example
+# guix archive --generate-key
+@end example
+
 Guix may also be used in a single-user setup, with @command{guix-daemon}
 running as an unprivileged user.  However, to maximize non-interference
 of build processes, the daemon still needs to perform certain operations
@@ -948,6 +956,20 @@ resulting archive to the standard output.
 Read an archive from the standard input, and import the files listed
 therein into the store.  Abort if the archive has an invalid digital
 signature.
+
+@item --generate-key[=@var{parameters}]
+Generate a new key pair for the daemons.  This is a prerequisite before
+archives can be exported with @code{--export}.  Note that this operation
+usually takes time, because it needs to gather enough entropy to
+generate the key pair.
+
+The generated key pair is typically stored under @file{/etc/guix}, in
+@file{signing-key.pub} (public key) and @file{signing-key.sec} (private
+key, which must be kept secret.)  When @var{parameters} is omitted, it
+is a 4096-bit RSA key.  Alternately, @var{parameters} can specify
+@code{genkey} parameters suitable for Libgcrypt (@pxref{General
+public-key related Functions, @code{gcry_pk_genkey},, gcrypt, The
+Libgcrypt Reference Manual}).
 @end table
 
 To export store files as an archive to the standard output, run:
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
index d5b3eeb350..50f709418c 100644
--- a/guix/pk-crypto.scm
+++ b/guix/pk-crypto.scm
@@ -25,6 +25,8 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:export (canonical-sexp?
+            error-source
+            error-string
             string->canonical-sexp
             canonical-sexp->string
             number->canonical-sexp
@@ -98,6 +100,22 @@
       (set-pointer-finalizer! ptr finalize-canonical-sexp!))
     sexp))
 
+(define error-source
+  (let* ((ptr  (libgcrypt-func "gcry_strsource"))
+         (proc (pointer->procedure '* ptr (list int))))
+    (lambda (err)
+      "Return the error source (a string) for ERR, an error code as thrown
+along with 'gcry-error'."
+      (pointer->string (proc err)))))
+
+(define error-string
+  (let* ((ptr  (libgcrypt-func "gcry_strerror"))
+         (proc (pointer->procedure '* ptr (list int))))
+    (lambda (err)
+      "Return the error description (a string) for ERR, an error code as
+thrown along with 'gcry-error'."
+      (pointer->string (proc err)))))
+
 (define string->canonical-sexp
   (let* ((ptr  (libgcrypt-func "gcry_sexp_new"))
          (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
diff --git a/guix/pki.scm b/guix/pki.scm
index 1ed84e55f0..759cd040e9 100644
--- a/guix/pki.scm
+++ b/guix/pki.scm
@@ -23,6 +23,7 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs io ports)
   #:export (%public-key-file
+            %private-key-file
             current-acl
             public-keys->acl
             acl->public-keys
@@ -69,6 +70,9 @@ element in KEYS must be a canonical sexp with type 'public-key'."
 (define %public-key-file
   (string-append %config-directory "/signing-key.pub"))
 
+(define %private-key-file
+  (string-append %config-directory "/signing-key.sec"))
+
 (define (ensure-acl)
   "Make sure the ACL file exists, and create an initialized one if needed."
   (unless (file-exists? %acl-file)
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index df538ed1b7..a9e4155393 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -23,6 +23,8 @@
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix ui)
+  #:use-module (guix pki)
+  #:use-module (guix pk-crypto)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -53,6 +55,9 @@ Export/import one or more packages from/to the store.\n"))
       --import           import from the archive passed on stdin"))
   (newline)
   (display (_ "
+      --generate-key[=PARAMETERS]
+                         generate a key pair with the given parameters"))
+  (display (_ "
   -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
   (display (_ "
   -S, --source           build the packages' source derivations"))
@@ -95,6 +100,17 @@ Export/import one or more packages from/to the store.\n"))
         (option '("import") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'import #t result)))
+        (option '("generate-key") #f #t
+                (lambda (opt name arg result)
+                  (catch 'gcry-error
+                    (lambda ()
+                      (let ((params
+                             (string->canonical-sexp
+                              (or arg "(genkey (rsa (nbits 4:4096)))"))))
+                        (alist-cons 'generate-key params result)))
+                    (lambda args
+                      (leave (_ "invalid key generation parameters: ~s~%")
+                             arg)))))
 
         (option '(#\S "source") #f #f
                 (lambda (opt name arg result)
@@ -204,7 +220,41 @@ resulting archive to the standard output port."
     (if (or (assoc-ref opts 'dry-run?)
             (build-derivations store drv))
         (export-paths store files (current-output-port))
-        (leave (_ "unable to export the given packages")))))
+        (leave (_ "unable to export the given packages~%")))))
+
+(define (generate-key-pair parameters)
+  "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the
+right place."
+  (when (or (file-exists? %public-key-file)
+            (file-exists? %private-key-file))
+    (leave (_ "key pair exists under '~a'; remove it first~%")
+           (dirname %public-key-file)))
+
+  (format (current-error-port)
+          (_ "Please wait while gathering entropy to generate the key pair;
+this may take time...~%"))
+
+  (let* ((pair   (catch 'gcry-error
+                   (lambda ()
+                     (generate-key parameters))
+                   (lambda (key err)
+                     (leave (_ "key generation failed: ~a: ~a~%")
+                            (error-source err)
+                            (error-string err)))))
+         (public (find-sexp-token pair 'public-key))
+         (secret (find-sexp-token pair 'private-key)))
+    ;; Create the following files as #o400.
+    (umask #o266)
+
+    (with-atomic-file-output %public-key-file
+      (lambda (port)
+        (display (canonical-sexp->string public) port)))
+    (with-atomic-file-output %private-key-file
+      (lambda (port)
+        (display (canonical-sexp->string secret) port)))
+
+    ;; Make the public key readable by everyone.
+    (chmod %public-key-file #o444)))
 
 (define (guix-archive . args)
   (define (parse-options)
@@ -220,13 +270,17 @@ resulting archive to the standard output port."
     ;; Ask for absolute file names so that .drv file names passed from the
     ;; user to 'read-derivation' are absolute when it returns.
     (with-fluids ((%file-port-name-canonicalization 'absolute))
-      (let* ((opts  (parse-options))
-             (store (open-connection)))
-
-        (cond ((assoc-ref opts 'export)
-               (export-from-store store opts))
-              ((assoc-ref opts 'import)
-               (import-paths store (current-input-port)))
+      (let ((opts (parse-options)))
+        (cond ((assoc-ref opts 'generate-key)
+               =>
+               generate-key-pair)
               (else
-               (leave
-                (_ "either '--export' or '--import' must be specified"))))))))
+               (let ((store (open-connection)))
+                 (cond ((assoc-ref opts 'export)
+                        (export-from-store store opts))
+                       ((assoc-ref opts 'import)
+                        (import-paths store (current-input-port)))
+                       (else
+                        (leave
+                         (_ "either '--export' or '--import' \
+must be specified~%")))))))))))