From 554f26ece3c6e3fb04d8069e6be1095e622a97c5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Dec 2013 22:46:21 +0100 Subject: 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'. --- guix/pk-crypto.scm | 18 ++++++++++++ guix/pki.scm | 4 +++ guix/scripts/archive.scm | 74 +++++++++++++++++++++++++++++++++++++++++------- 3 files changed, 86 insertions(+), 10 deletions(-) (limited to 'guix') 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 @@ (define-module (guix pk-crypto) #: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 @@ (define-inlinable (pointer->canonical-sexp ptr) (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 @@ (define-module (guix pki) #: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 @@ (define %acl-file (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 @@ (define-module (guix scripts archive) #: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) @@ -52,6 +54,9 @@ (define (show-help) (display (_ " --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 (_ " @@ -95,6 +100,17 @@ (define %options (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 @@ (define (export-from-store store opts) (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 @@ (define (parse-options) ;; 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~%"))))))))))) -- cgit v1.2.3