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'.

3 files changed, 86 insertions, 10 deletions

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~%")))))))))))