From 3476ded934dc0beab1801d7fcdcc37b5c17bbf01 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Dec 2013 00:36:26 +0100 Subject: Add (guix pk-crypto). * guix/pk-crypto.scm, tests/pk-crypto.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. --- guix/pk-crypto.scm | 167 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 167 insertions(+) create mode 100644 guix/pk-crypto.scm (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm new file mode 100644 index 0000000000..9d093b34b0 --- /dev/null +++ b/guix/pk-crypto.scm @@ -0,0 +1,167 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix pk-crypto) + #:use-module (guix config) + #:use-module ((guix utils) #:select (bytevector->base16-string)) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:export (gcry-sexp? + string->gcry-sexp + gcry-sexp->string + number->gcry-sexp + bytevector->hash-data + sign + verify + generate-key + find-sexp-token)) + + +;;; Commentary: +;;; +;;; Public key cryptographic routines from GNU Libgcrypt. +;;;; +;;; Libgcrypt uses s-expressions to represent key material, parameters, and +;;; data. We keep it as an opaque object rather than attempting to map them +;;; to Scheme s-expressions because (1) Libgcrypt sexps are stored in secure +;;; memory, and (2) the read syntax is different. +;;; +;;; Code: + +;; Libgcrypt "s-expressions". +(define-wrapped-pointer-type + gcry-sexp? + naked-pointer->gcry-sexp + gcry-sexp->pointer + (lambda (obj port) + ;; Don't print OBJ's external representation: we don't want key material + ;; to leak in backtraces and such. + (format port "#" + (number->string (object-address obj) 16) + (number->string (pointer-address (gcry-sexp->pointer obj)) + 16)))) + +(define libgcrypt-func + (let ((lib (dynamic-link %libgcrypt))) + (lambda (func) + "Return a pointer to symbol FUNC in libgcrypt." + (dynamic-func func lib)))) + +(define finalize-gcry-sexp! + (libgcrypt-func "gcry_sexp_release")) + +(define-inlinable (pointer->gcry-sexp ptr) + "Return a that wraps PTR." + (let* ((sexp (naked-pointer->gcry-sexp ptr)) + (ptr* (gcry-sexp->pointer sexp))) + ;; Did we already have a object for PTR? + (when (equal? ptr ptr*) + ;; No, so we can safely add a finalizer (in Guile 2.0.9 + ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the + ;; existing one.) + (set-pointer-finalizer! ptr finalize-gcry-sexp!)) + sexp)) + +(define string->gcry-sexp + (let* ((ptr (libgcrypt-func "gcry_sexp_new")) + (proc (pointer->procedure int ptr `(* * ,size_t ,int)))) + (lambda (str) + "Parse STR and return the corresponding gcrypt s-expression." + (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*)))) + (err (proc sexp (string->pointer str) 0 1))) + (if (= 0 err) + (pointer->gcry-sexp (dereference-pointer sexp)) + (throw 'gcry-error err)))))) + +(define-syntax GCRYSEXP_FMT_ADVANCED + (identifier-syntax 3)) + +(define gcry-sexp->string + (let* ((ptr (libgcrypt-func "gcry_sexp_sprint")) + (proc (pointer->procedure size_t ptr `(* ,int * ,size_t)))) + (lambda (sexp) + "Return a textual representation of SEXP." + (let loop ((len 1024)) + (let* ((buf (bytevector->pointer (make-bytevector len))) + (size (proc (gcry-sexp->pointer sexp) + GCRYSEXP_FMT_ADVANCED buf len))) + (if (zero? size) + (loop (* len 2)) + (pointer->string buf size "ISO-8859-1"))))))) + +(define (number->gcry-sexp number) + "Return an s-expression representing NUMBER." + (string->gcry-sexp (string-append "#" (number->string number 16) "#"))) + +(define* (bytevector->hash-data bv #:optional (hash-algo "sha256")) + "Given BV, a bytevector containing a hash, return an s-expression suitable +for use as the data for 'sign'." + (string->gcry-sexp + (format #f "(data (flags pkcs1) (hash \"~a\" #~a#))" + hash-algo + (bytevector->base16-string bv)))) + +(define sign + (let* ((ptr (libgcrypt-func "gcry_pk_sign")) + (proc (pointer->procedure int ptr '(* * *)))) + (lambda (data secret-key) + "Sign DATA (an s-expression) with SECRET-KEY (an s-expression whose car +is 'private-key'.)" + (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*)))) + (err (proc sig (gcry-sexp->pointer data) + (gcry-sexp->pointer secret-key)))) + (if (= 0 err) + (pointer->gcry-sexp (dereference-pointer sig)) + (throw 'gry-error err)))))) + +(define verify + (let* ((ptr (libgcrypt-func "gcry_pk_verify")) + (proc (pointer->procedure int ptr '(* * *)))) + (lambda (signature data public-key) + "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of +which are gcrypt s-expressions." + (zero? (proc (gcry-sexp->pointer signature) + (gcry-sexp->pointer data) + (gcry-sexp->pointer public-key)))))) + +(define generate-key + (let* ((ptr (libgcrypt-func "gcry_pk_genkey")) + (proc (pointer->procedure int ptr '(* *)))) + (lambda (params) + "Return as an s-expression a new key pair for PARAMS. PARAMS must be an +s-expression like: (genkey (rsa (nbits 4:2048)))." + (let* ((key (bytevector->pointer (make-bytevector (sizeof '*)))) + (err (proc key (gcry-sexp->pointer params)))) + (if (zero? err) + (pointer->gcry-sexp (dereference-pointer key)) + (throw 'gcry-error err)))))) + +(define find-sexp-token + (let* ((ptr (libgcrypt-func "gcry_sexp_find_token")) + (proc (pointer->procedure '* ptr `(* * ,size_t)))) + (lambda (sexp token) + "Find in SEXP the first element whose 'car' is TOKEN and return it; +return #f if not found." + (let* ((token (string->pointer (symbol->string token))) + (res (proc (gcry-sexp->pointer sexp) token 0))) + (if (null-pointer? res) + #f + (pointer->gcry-sexp res)))))) + +;;; pk-crypto.scm ends here -- cgit v1.2.3 From ce507041f79bd66f54ce406d20b9e33a328a3f3d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Dec 2013 15:22:15 +0100 Subject: pk-crypto: Add a few sexp utility procedures. * guix/pk-crypto.scm (gcry-sexp-car, gcry-sexp-cdr, gcry-sexp-nth, gcry-sexp-nth-data, dereference-size_t, latin1-string->bytevector, hash-data->bytevector): New procedures. * tests/pk-crypto.scm ("gcry-sexp-car + cdr", "gcry-sexp-nth", "gcry-sexp-nth-data", "bytevector->hash-data->bytevector"): New tests. --- guix/pk-crypto.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++- tests/pk-crypto.scm | 42 +++++++++++++++++++++++++++ 2 files changed, 124 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 9d093b34b0..d8fbb6f85b 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -18,7 +18,9 @@ (define-module (guix pk-crypto) #:use-module (guix config) - #:use-module ((guix utils) #:select (bytevector->base16-string)) + #:use-module ((guix utils) + #:select (bytevector->base16-string + base16-string->bytevector)) #:use-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -26,7 +28,12 @@ string->gcry-sexp gcry-sexp->string number->gcry-sexp + gcry-sexp-car + gcry-sexp-cdr + gcry-sexp-nth + gcry-sexp-nth-data bytevector->hash-data + hash-data->bytevector sign verify generate-key @@ -105,6 +112,61 @@ (loop (* len 2)) (pointer->string buf size "ISO-8859-1"))))))) +(define gcry-sexp-car + (let* ((ptr (libgcrypt-func "gcry_sexp_car")) + (proc (pointer->procedure '* ptr '(*)))) + (lambda (lst) + "Return the first element of LST, an sexp, if that element is a list; +return #f if LST or its first element is not a list (this is different from +the usual Lisp 'car'.)" + (let ((result (proc (gcry-sexp->pointer lst)))) + (if (null-pointer? result) + #f + (pointer->gcry-sexp result)))))) + +(define gcry-sexp-cdr + (let* ((ptr (libgcrypt-func "gcry_sexp_cdr")) + (proc (pointer->procedure '* ptr '(*)))) + (lambda (lst) + "Return the tail of LST, an sexp, or #f if LST is not a list." + (let ((result (proc (gcry-sexp->pointer lst)))) + (if (null-pointer? result) + #f + (pointer->gcry-sexp result)))))) + +(define gcry-sexp-nth + (let* ((ptr (libgcrypt-func "gcry_sexp_nth")) + (proc (pointer->procedure '* ptr `(* ,int)))) + (lambda (lst index) + "Return the INDEXth nested element of LST, an s-expression. Return #f +if that element does not exist, or if it's an atom. (Note: this is obviously +different from Scheme's 'list-ref'.)" + (let ((result (proc (gcry-sexp->pointer lst) index))) + (if (null-pointer? result) + #f + (pointer->gcry-sexp result)))))) + +(define (dereference-size_t p) + "Return the size_t value pointed to by P." + (bytevector-uint-ref (pointer->bytevector p (sizeof size_t)) + 0 (native-endianness) + (sizeof size_t))) + +(define gcry-sexp-nth-data + (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data")) + (proc (pointer->procedure '* ptr `(* ,int *)))) + (lambda (lst index) + "Return as a string the INDEXth data element (atom) of LST, an +s-expression. Return #f if that element does not exist, or if it's a list. +Note that the result is a Scheme string, but depending on LST, it may need to +be interpreted in the sense of a C string---i.e., as a series of octets." + (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*)))) + (result (proc (gcry-sexp->pointer lst) index size*))) + (if (null-pointer? result) + #f + (pointer->string result (dereference-size_t size*) + "ISO-8859-1")))))) + (define (number->gcry-sexp number) "Return an s-expression representing NUMBER." (string->gcry-sexp (string-append "#" (number->string number 16) "#"))) @@ -117,6 +179,25 @@ for use as the data for 'sign'." hash-algo (bytevector->base16-string bv)))) +(define (latin1-string->bytevector str) + "Return a bytevector representing STR." + ;; XXX: In Guile 2.0.9 and later, we would use 'string->bytevector' for + ;; that. + (let ((bytes (map char->integer (string->list str)))) + (u8-list->bytevector bytes))) + +(define (hash-data->bytevector data) + "Return two values: the hash algorithm (a string) and the hash value (a +bytevector) extract from DATA, an sexp as returned by 'bytevector->hash-data'. +Return #f if DATA does not conform." + (let ((hash (find-sexp-token data 'hash))) + (if hash + (let ((algo (gcry-sexp-nth-data hash 1)) + (value (gcry-sexp-nth-data hash 2))) + (values (latin1-string->bytevector value) + algo)) + (values #f #f)))) + (define sign (let* ((ptr (libgcrypt-func "gcry_pk_sign")) (proc (pointer->procedure int ptr '(* * *)))) diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 1acce13f0a..7c54e729ad 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -21,6 +21,8 @@ #:use-module (guix utils) #:use-module (guix hash) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) @@ -75,6 +77,38 @@ (gc) +(test-equal "gcry-sexp-car + cdr" + '("(b \n (c xyz)\n )") + (let ((lst (string->gcry-sexp "(a (b (c xyz)))"))) + (map (lambda (sexp) + (and sexp (string-trim-both (gcry-sexp->string sexp)))) + ;; Note: 'car' returns #f when the first element is an atom. + (list (gcry-sexp-car (gcry-sexp-cdr lst)))))) + +(gc) + +(test-equal "gcry-sexp-nth" + '(#f "(b pqr)" "(c \"456\")" "(d xyz)" #f #f) + (let ((lst (string->gcry-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))"))) + (map (lambda (sexp) + (and sexp (string-trim-both (gcry-sexp->string sexp)))) + (unfold (cut > <> 5) + (cut gcry-sexp-nth lst <>) + 1+ + 0)))) + +(gc) + +(test-equal "gcry-sexp-nth-data" + '("Name" "Otto" "Meier" #f #f #f) + (let ((lst (string->gcry-sexp "(Name Otto Meier (address Burgplatz))"))) + (unfold (cut > <> 5) + (cut gcry-sexp-nth-data lst <>) + 1+ + 0))) + +(gc) + ;; XXX: The test below is typically too long as it needs to gather enough entropy. ;; (test-assert "generate-key" @@ -85,6 +119,14 @@ ;; (find-sexp-token key 'public-key) ;; (find-sexp-token key 'private-key)))) +(test-assert "bytevector->hash-data->bytevector" + (let* ((bv (sha256 (string->utf8 "Hello, world."))) + (data (bytevector->hash-data bv "sha256"))) + (and (gcry-sexp? data) + (let-values (((value algo) (hash-data->bytevector data))) + (and (string=? algo "sha256") + (bytevector=? value bv)))))) + (test-assert "sign + verify" (let* ((pair (string->gcry-sexp %key-pair)) (secret (find-sexp-token pair 'private-key)) -- cgit v1.2.3 From 526382ff92b20f6c651f03711c160c0c88264b88 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Dec 2013 17:17:42 +0100 Subject: daemon: Implement signed archive import/export. * guix/scripts/authenticate.scm, nix/scripts/guix-authenticate.in, tests/signing-key.pub, tests/signing-key.sec: New files. * po/POTFILES.in: Add 'guix/scripts/authenticate.scm'. * guix/store.scm (dump-port): New procedure. (process-stderr): Add 'user-port' optional parameter. Handle the %STDERR-WRITE and %STDERR-READ cases as expected. (import-paths, export-path, export-paths): New procedures. * tests/store.scm ("export/import several paths", "import corrupt path"): New tests. * Makefile.am (MODULES): Add 'guix/scripts/authenticate.scm'. (EXTRA_DIST): Add 'tests/signing-key.{pub,sec}'. * daemon.am (libstore_a_CPPFLAGS)[-DNIX_CONF_DIR]: Change 'NIX_CONF_DIR' to .../guix. Change 'OPENSSL_PATH' to 'guix-authenticate'. * config-daemon.ac: Instantiate 'nix/scripts/guix-authenticate'. * nix/nix-daemon/guix-daemon.cc (main): Augment $PATH to include 'settings.nixLibexecDir'. * test-env.in: Export 'NIX_CONF_DIR' and 'NIX_LIBEXEC_DIR'. Populate $NIX_CONF_DIR. --- .gitignore | 1 + Makefile.am | 3 ++ config-daemon.ac | 2 + daemon.am | 4 +- guix/scripts/authenticate.scm | 98 ++++++++++++++++++++++++++++++++++++++++ guix/store.scm | 79 ++++++++++++++++++++++++++++++-- nix/nix-daemon/guix-daemon.cc | 6 +++ nix/scripts/guix-authenticate.in | 11 +++++ po/POTFILES.in | 1 + test-env.in | 18 +++++++- tests/signing-key.pub | 4 ++ tests/signing-key.sec | 8 ++++ tests/store.scm | 45 ++++++++++++++++++ 13 files changed, 273 insertions(+), 7 deletions(-) create mode 100644 guix/scripts/authenticate.scm create mode 100644 nix/scripts/guix-authenticate.in create mode 100644 tests/signing-key.pub create mode 100644 tests/signing-key.sec (limited to 'guix') diff --git a/.gitignore b/.gitignore index a8a5cad74c..09a593e9fa 100644 --- a/.gitignore +++ b/.gitignore @@ -84,3 +84,4 @@ GPATH GRTAGS GTAGS /nix-setuid-helper +/nix/scripts/guix-authenticate diff --git a/Makefile.am b/Makefile.am index 2db77d57f3..34846c3e29 100644 --- a/Makefile.am +++ b/Makefile.am @@ -73,6 +73,7 @@ MODULES = \ guix/scripts/hash.scm \ guix/scripts/pull.scm \ guix/scripts/substitute-binary.scm \ + guix/scripts/authenticate.scm \ guix/scripts/refresh.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) @@ -172,6 +173,8 @@ EXTRA_DIST = \ srfi/srfi-64.scm \ srfi/srfi-64.upstream.scm \ tests/test.drv \ + tests/signing-key.pub \ + tests/signing-key.sec \ build-aux/config.rpath \ bootstrap \ release.nix \ diff --git a/config-daemon.ac b/config-daemon.ac index 5db08d099d..0717141198 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -105,6 +105,8 @@ if test "x$guix_build_daemon" = "xyes"; then [chmod +x nix/scripts/list-runtime-roots]) AC_CONFIG_FILES([nix/scripts/substitute-binary], [chmod +x nix/scripts/substitute-binary]) + AC_CONFIG_FILES([nix/scripts/guix-authenticate], + [chmod +x nix/scripts/guix-authenticate]) fi AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"]) diff --git a/daemon.am b/daemon.am index 77bfe71987..27c631b2da 100644 --- a/daemon.am +++ b/daemon.am @@ -112,10 +112,10 @@ libstore_a_CPPFLAGS = \ -DNIX_DATA_DIR=\"$(datadir)\" \ -DNIX_STATE_DIR=\"$(localstatedir)/nix\" \ -DNIX_LOG_DIR=\"$(localstatedir)/log/nix\" \ - -DNIX_CONF_DIR=\"$(sysconfdir)/nix\" \ + -DNIX_CONF_DIR=\"$(sysconfdir)/guix\" \ -DNIX_LIBEXEC_DIR=\"$(libexecdir)\" \ -DNIX_BIN_DIR=\"$(bindir)\" \ - -DOPENSSL_PATH="\"openssl\"" + -DOPENSSL_PATH="\"guix-authenticate\"" libstore_a_CXXFLAGS = \ $(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm new file mode 100644 index 0000000000..cbafed79d0 --- /dev/null +++ b/guix/scripts/authenticate.scm @@ -0,0 +1,98 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts authenticate) + #:use-module (guix config) + #:use-module (guix utils) + #:use-module (guix pk-crypto) + #:use-module (guix ui) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:export (guix-authenticate)) + +;;; Commentary: +;;; +;;; This program is used internally by the daemon to sign exported archive +;;; (the 'export-paths' RPC), and to authenticate imported archives (the +;;; 'import-paths' RPC.) +;;; +;;; Code: + +(define (read-gcry-sexp file) + "Read a gcrypt sexp from FILE and return it." + (call-with-input-file file + (compose string->gcry-sexp get-string-all))) + +(define (read-hash-data file) + "Read sha256 hash data from FILE and return it as a gcrypt sexp." + (let* ((hex (call-with-input-file file get-string-all)) + (bv (base16-string->bytevector (string-trim-both hex)))) + (bytevector->hash-data bv))) + + +;;; +;;; Entry point with 'openssl'-compatible interface. We support this +;;; interface because that's what the daemon expects, and we want to leave it +;;; unmodified currently. +;;; + +(define (guix-authenticate . args) + (match args + (("rsautl" "-sign" "-inkey" key "-in" hash-file) + ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes + ;; both the hash and the actual signature. + (let* ((secret-key (read-gcry-sexp key)) + (data (read-hash-data hash-file))) + (format #t + "(guix-signature ~a (payload ~a))" + (gcry-sexp->string (sign data secret-key)) + (gcry-sexp->string data)) + #t)) + (("rsautl" "-verify" "-inkey" key "-pubin" "-in" signature-file) + ;; Read the signature as produced above, check it against KEY, and print + ;; the signed data to stdout upon success. + (let* ((public-key (read-gcry-sexp key)) + (sig+data (read-gcry-sexp signature-file)) + (data (find-sexp-token sig+data 'payload)) + (signature (find-sexp-token sig+data 'sig-val))) + (if (and data signature) + (if (verify signature data public-key) + (begin + (display (bytevector->base16-string + (hash-data->bytevector data))) + #t) ; success + (begin + (format (current-error-port) + "error: invalid signature: ~a~%" + (gcry-sexp->string signature)) + (exit 1))) + (begin + (format (current-error-port) + "error: corrupt signature data: ~a~%" + (gcry-sexp->string sig+data)) + (exit 1))))) + (("--help") + (display (_ "Usage: guix authenticate OPTION... +Sign or verify the signature on the given file. This tool is meant to +be used internally by 'guix-daemon'.\n"))) + (("--version") + (show-version-and-exit "guix authenticate")) + (else + (leave (_ "wrong arguments"))))) + +;;; authenticate.scm ends here diff --git a/guix/store.scm b/guix/store.scm index 08b0671b29..4ceca0daa2 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -80,6 +80,8 @@ dead-paths collect-garbage delete-paths + import-paths + export-paths current-build-output-port @@ -323,7 +325,30 @@ operate, should the disk become full. Return a server object." ;; The port where build output is sent. (make-parameter (current-error-port))) -(define (process-stderr server) +(define* (dump-port in out + #:optional len + #:key (buffer-size 16384)) + "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it +to OUT, using chunks of BUFFER-SIZE bytes." + (define buffer + (make-bytevector buffer-size)) + + (let loop ((total 0) + (bytes (get-bytevector-n! in buffer 0 + (if len + (min len buffer-size) + buffer-size)))) + (or (eof-object? bytes) + (and len (= total len)) + (let ((total (+ total bytes))) + (put-bytevector out buffer 0 bytes) + (loop total + (get-bytevector-n! in buffer 0 + (if len + (min (- len total) buffer-size) + buffer-size))))))) + +(define* (process-stderr server #:optional user-port) "Read standard output and standard error from SERVER, writing it to CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and #f otherwise; in the latter case, the caller should call `process-stderr' @@ -344,17 +369,30 @@ encoding conversion errors." (let ((k (read-int p))) (cond ((= k %stderr-write) - (read-latin1-string p) + ;; Write a byte stream to USER-PORT. + (let* ((len (read-int p)) + (m (modulo len 8))) + (dump-port p user-port len) + (unless (zero? m) + ;; Consume padding, as for strings. + (get-bytevector-n p (- 8 m)))) #f) ((= k %stderr-read) - (let ((len (read-int p))) - (read-latin1-string p) ; FIXME: what to do? + ;; Read a byte stream from USER-PORT. + (let* ((max-len (read-int p)) + (data (get-bytevector-n user-port max-len)) + (len (bytevector-length data))) + (write-int len p) + (put-bytevector p data) + (write-padding len p) #f)) ((= k %stderr-next) + ;; Log a string. (let ((s (read-latin1-string p))) (display s (current-build-output-port)) #f)) ((= k %stderr-error) + ;; Report an error. (let ((error (read-latin1-string p)) ;; Currently the daemon fails to send a status code for early ;; errors like DB schema version mismatches, so check for EOF. @@ -624,6 +662,39 @@ MIN-FREED bytes have been collected. Return the paths that were collected, and the number of bytes freed." (run-gc server (gc-action delete-specific) paths min-freed)) +(define (import-paths server port) + "Import the set of store paths read from PORT into SERVER's store. An error +is raised if the set of paths read from PORT is not signed (as per +'export-path #:sign? #t'.) Return the list of store paths imported." + (let ((s (nix-server-socket server))) + (write-int (operation-id import-paths) s) + (let loop ((done? (process-stderr server port))) + (or done? (loop (process-stderr server port)))) + (read-store-path-list s))) + +(define* (export-path server path port #:key (sign? #t)) + "Export PATH to PORT. When SIGN? is true, sign it." + (let ((s (nix-server-socket server))) + (write-int (operation-id export-path) s) + (write-store-path path s) + (write-arg boolean sign? s) + (let loop ((done? (process-stderr server port))) + (or done? (loop (process-stderr server port)))) + (= 1 (read-int s)))) + +(define* (export-paths server paths port #:key (sign? #t)) + "Export the store paths listed in PATHS to PORT, signing them if SIGN? +is true." + (let ((s (nix-server-socket server))) + (let loop ((paths paths)) + (match paths + (() + (write-int 0 port)) + ((head tail ...) + (write-int 1 port) + (and (export-path server head port #:sign? sign?) + (loop tail))))))) + ;;; ;;; Store paths. diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index 484a390936..cf87e39354 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -216,6 +216,12 @@ main (int argc, char *argv[]) { settings.processEnvironment (); + /* Hackily help 'local-store.cc' find our 'guix-authenticate' program, which + is known as 'OPENSSL_PATH' here. */ + std::string search_path (getenv ("PATH")); + search_path = settings.nixLibexecDir + ":" + search_path; + setenv ("PATH", search_path.c_str (), 1); + /* Use our substituter by default. */ settings.substituters.clear (); settings.useSubstitutes = true; diff --git a/nix/scripts/guix-authenticate.in b/nix/scripts/guix-authenticate.in new file mode 100644 index 0000000000..5ce57915f0 --- /dev/null +++ b/nix/scripts/guix-authenticate.in @@ -0,0 +1,11 @@ +#!@SHELL@ +# A shorthand for "guix authenticate", for use by the daemon. + +if test "x$GUIX_UNINSTALLED" = "x" +then + prefix="@prefix@" + exec_prefix="@exec_prefix@" + exec "@bindir@/guix" authenticate "$@" +else + exec guix authenticate "$@" +fi diff --git a/po/POTFILES.in b/po/POTFILES.in index 0e30bb0880..beefdc901b 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -11,6 +11,7 @@ guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/pull.scm guix/scripts/substitute-binary.scm +guix/scripts/authenticate.scm guix/gnu-maintenance.scm guix/ui.scm guix/http-client.scm diff --git a/test-env.in b/test-env.in index 9224a80537..df73ecdc7a 100644 --- a/test-env.in +++ b/test-env.in @@ -40,6 +40,22 @@ then # Currently, in Nix builds, we're at ~106 chars... NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" + # The configuration directory, for import/export signing keys. + NIX_CONF_DIR="@GUIX_TEST_ROOT@/etc" + if [ ! -d "$NIX_CONF_DIR" ] + then + # Copy the keys so that the secret key has the right permissions (the + # daemon errors out when this is not the case.) + mkdir -p "$NIX_CONF_DIR" + cp "@abs_top_srcdir@/tests/signing-key.sec" \ + "@abs_top_srcdir@/tests/signing-key.pub" \ + "$NIX_CONF_DIR" + chmod 400 "$NIX_CONF_DIR/signing-key.sec" + fi + + # For 'guix-authenticate'. + NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts" + # A place to store data of the substituter. GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data" rm -rf "$NIX_STATE_DIR/substituter-data" @@ -51,7 +67,7 @@ then export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \ NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL \ - XDG_CACHE_HOME + NIX_CONF_DIR NIX_LIBEXEC_DIR XDG_CACHE_HOME # Do that because store.scm calls `canonicalize-path' on it. mkdir -p "$NIX_STORE_DIR" diff --git a/tests/signing-key.pub b/tests/signing-key.pub new file mode 100644 index 0000000000..092424a15d --- /dev/null +++ b/tests/signing-key.pub @@ -0,0 +1,4 @@ +(public-key + (rsa + (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#) + (e #010001#))) diff --git a/tests/signing-key.sec b/tests/signing-key.sec new file mode 100644 index 0000000000..558e189102 --- /dev/null +++ b/tests/signing-key.sec @@ -0,0 +1,8 @@ +(private-key + (rsa + (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#) + (e #010001#) + (d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#) + (p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#) + (q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#) + (u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#))) diff --git a/tests/store.scm b/tests/store.scm index 281b923c28..6834ebc5e9 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -28,10 +28,12 @@ #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) @@ -344,6 +346,49 @@ Deriver: ~a~%" (build-derivations s (list d)) #f)))) +(test-assert "export/import several paths" + (let* ((texts (unfold (cut >= <> 10) + (lambda _ (random-text)) + 1+ + 0)) + (files (map (cut add-text-to-store %store "text" <>) texts)) + (dump (call-with-bytevector-output-port + (cut export-paths %store files <>)))) + (delete-paths %store files) + (and (every (negate file-exists?) files) + (let* ((source (open-bytevector-input-port dump)) + (imported (import-paths %store source))) + (and (equal? imported files) + (every file-exists? files) + (equal? texts + (map (lambda (file) + (call-with-input-file file + get-string-all)) + files))))))) + +(test-assert "import corrupt path" + (let* ((text (random-text)) + (file (add-text-to-store %store "text" text)) + (dump (call-with-bytevector-output-port + (cut export-paths %store (list file) <>)))) + (delete-paths %store (list file)) + + ;; Flip a bit in the middle of the stream. + (let* ((index (quotient (bytevector-length dump) 3)) + (byte (bytevector-u8-ref dump index))) + (bytevector-u8-set! dump index (logxor #xff byte))) + + (and (not (file-exists? file)) + (guard (c ((nix-protocol-error? c) + (pk 'c c) + (and (not (zero? (nix-protocol-error-status c))) + (string-contains (nix-protocol-error-message c) + "corrupt")))) + (let* ((source (open-bytevector-input-port dump)) + (imported (import-paths %store source))) + (pk 'corrupt-imported imported) + #f))))) + (test-end "store") -- cgit v1.2.3 From 3f26bfc18a70a65443688d7724e5f97c53855c01 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Dec 2013 22:36:32 +0100 Subject: Factorize package search between 'guix package' and 'guix build'. * guix/scripts/package.scm (newest-available-packages): Remove. (find-best-packages-by-name): Move to... * gnu/packages.scm (find-best-packages-by-name): ... here. (find-newest-available-packages): Memoize. * guix/scripts/build.scm (specification->package): New procedure, formerly called 'find-package' within 'guix-build'. (guix-build): Adjust accordingly. --- gnu/packages.scm | 43 ++++++++++++++++++++++------------- guix/scripts/build.scm | 58 +++++++++++++++++++----------------------------- guix/scripts/package.scm | 15 +------------ 3 files changed, 52 insertions(+), 64 deletions(-) (limited to 'guix') diff --git a/gnu/packages.scm b/gnu/packages.scm index e9f2540b91..8365a00051 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -33,6 +33,7 @@ %bootstrap-binaries-path fold-packages find-packages-by-name + find-best-packages-by-name find-newest-available-packages)) ;;; Commentary: @@ -148,24 +149,36 @@ then only return packages whose version is equal to VERSION." result)) '())) -(define (find-newest-available-packages) - "Return a vhash keyed by package names, and with +(define find-newest-available-packages + (memoize + (lambda () + "Return a vhash keyed by package names, and with associated values of the form (newest-version newest-package ...) where the preferred package is listed first." - ;; FIXME: Currently, the preferred package is whichever one - ;; was found last by 'fold-packages'. Find a better solution. - (fold-packages (lambda (p r) - (let ((name (package-name p)) - (version (package-version p))) - (match (vhash-assoc name r) - ((_ newest-so-far . pkgs) - (case (version-compare version newest-so-far) - ((>) (vhash-cons name `(,version ,p) r)) - ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) - ((<) r))) - (#f (vhash-cons name `(,version ,p) r))))) - vlist-null)) + ;; FIXME: Currently, the preferred package is whichever one + ;; was found last by 'fold-packages'. Find a better solution. + (fold-packages (lambda (p r) + (let ((name (package-name p)) + (version (package-version p))) + (match (vhash-assoc name r) + ((_ newest-so-far . pkgs) + (case (version-compare version newest-so-far) + ((>) (vhash-cons name `(,version ,p) r)) + ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) + ((<) r))) + (#f (vhash-cons name `(,version ,p) r))))) + vlist-null)))) + +(define (find-best-packages-by-name name version) + "If version is #f, return the list of packages named NAME with the highest +version numbers; otherwise, return the list of packages named NAME and at +VERSION." + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (find-newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index dd9a9b8127..1c6dce0539 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -32,8 +32,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) - #:autoload (gnu packages) (find-packages-by-name - find-newest-available-packages) + #:autoload (gnu packages) (find-best-packages-by-name) #:export (guix-build)) (define %store @@ -57,6 +56,27 @@ derivation of a package." ((? procedure? proc) (run-with-store (%store) (proc) #:system system)))) +(define (specification->package spec) + "Return a package matching SPEC. SPEC may be a package name, or a package +name followed by a hyphen and a version number. If the version number is not +present, return the preferred newest version." + (let-values (((name version) + (package-name->name+version spec))) + (match (find-best-packages-by-name name version) + ((p) ; one match + p) + ((p x ...) ; several matches + (warning (_ "ambiguous package specification `~a'~%") spec) + (warning (_ "choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) + p) + (_ ; no matches + (if version + (leave (_ "~A: package not found for version ~a~%") + name version) + (leave (_ "~A: unknown package~%") name)))))) + ;;; ;;; Command-line options. @@ -212,38 +232,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (leave (_ "failed to create GC root `~a': ~a~%") root (strerror (system-error-errno args))))))) - (define newest-available-packages - (memoize find-newest-available-packages)) - - (define (find-best-packages-by-name name version) - (if version - (find-packages-by-name name version) - (match (vhash-assoc name (newest-available-packages)) - ((_ version pkgs ...) pkgs) - (#f '())))) - - (define (find-package request) - ;; Return a package matching REQUEST. REQUEST may be a package - ;; name, or a package name followed by a hyphen and a version - ;; number. If the version number is not present, return the - ;; preferred newest version. - (let-values (((name version) - (package-name->name+version request))) - (match (find-best-packages-by-name name version) - ((p) ; one match - p) - ((p x ...) ; several matches - (warning (_ "ambiguous package specification `~a'~%") request) - (warning (_ "choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) - p) - (_ ; no matches - (if version - (leave (_ "~A: package not found for version ~a~%") - name version) - (leave (_ "~A: unknown package~%") name)))))) - (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. @@ -268,7 +256,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ;; Nothing to do; maybe for --log-file. #f) (('argument . (? string? x)) - (let ((p (find-package x))) + (let ((p (specification->package x))) (if src? (let ((s (package-source p))) (package-source-derivation diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 49fa457a9c..8c197a741e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -292,19 +292,6 @@ return its return value." (format (current-error-port) " interrupted by signal ~a~%" SIGINT) #f)))) -(define newest-available-packages - (memoize find-newest-available-packages)) - -(define (find-best-packages-by-name name version) - "If version is #f, return the list of packages named NAME with the highest -version numbers; otherwise, return the list of packages named NAME and at -VERSION." - (if version - (find-packages-by-name name version) - (match (vhash-assoc name (newest-available-packages)) - ((_ version pkgs ...) pkgs) - (#f '())))) - (define* (specification->package+output spec #:optional (output "out")) "Find the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: @@ -342,7 +329,7 @@ version; if SPEC does not specify an output, return OUTPUT." "Return #t if there's a version of package NAME newer than CURRENT-VERSION, or if the newest available version is equal to CURRENT-VERSION but would have an output path different than CURRENT-PATH." - (match (vhash-assoc name (newest-available-packages)) + (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) (case (version-compare candidate-version current-version) ((>) #t) -- cgit v1.2.3 From 81fa80b2451aa0d1cccc91f8571ecd72c6e479c8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Dec 2013 22:53:58 +0100 Subject: guix build: Improve procedural decomposition. * guix/scripts/build.scm (%store): Remove. (derivation-from-expression): Add 'store' parameter. Adjust caller accordingly. (register-root): New procedure, formerly within 'guix-build'. (options->derivations): New procedure, formerly inline within 'guix-build'. (guix-build): Adjust accordingly. --- guix/scripts/build.scm | 224 +++++++++++++++++++++++++------------------------ 1 file changed, 113 insertions(+), 111 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 1c6dce0539..b3d852e950 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -35,10 +35,7 @@ #:autoload (gnu packages) (find-best-packages-by-name) #:export (guix-build)) -(define %store - (make-parameter #f)) - -(define (derivation-from-expression str package-derivation +(define (derivation-from-expression store str package-derivation system source?) "Read/eval STR and return the corresponding derivation path for SYSTEM. When SOURCE? is true and STR evaluates to a package, return the derivation of @@ -49,12 +46,12 @@ derivation of a package." (if source? (let ((source (package-source p))) (if source - (package-source-derivation (%store) source) + (package-source-derivation store source) (leave (_ "package `~a' has no source~%") (package-name p)))) - (package-derivation (%store) p system))) + (package-derivation store p system))) ((? procedure? proc) - (run-with-store (%store) (proc) #:system system)))) + (run-with-store store (proc) #:system system)))) (define (specification->package spec) "Return a package matching SPEC. SPEC may be a package name, or a package @@ -77,6 +74,30 @@ present, return the preferred newest version." name version) (leave (_ "~A: unknown package~%") name)))))) +(define (register-root store paths root) + "Register ROOT as an indirect GC root for all of PATHS." + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (match paths + ((path) + (symlink path root) + (add-indirect-root store root)) + ((paths ...) + (fold (lambda (path count) + (let ((root (string-append root + "-" + (number->string count)))) + (symlink path root) + (add-indirect-root store root)) + (+ 1 count)) + 0 + paths)))) + (lambda args + (leave (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))))))) + ;;; ;;; Command-line options. @@ -193,6 +214,36 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (alist-cons 'log-file? #t result))))) +(define (options->derivations store opts) + "Given OPTS, the result of 'args-fold', return a list of derivations to +build." + (define package->derivation + (match (assoc-ref opts 'target) + (#f package-derivation) + (triplet + (cut package-cross-derivation <> <> triplet <>)))) + + (define src? (assoc-ref opts 'source?)) + (define sys (assoc-ref opts 'system)) + + (filter-map (match-lambda + (('expression . str) + (derivation-from-expression store str package->derivation + sys src?)) + (('argument . (? derivation-path? drv)) + (call-with-input-file drv read-derivation)) + (('argument . (? store-path?)) + ;; Nothing to do; maybe for --log-file. + #f) + (('argument . (? string? x)) + (let ((p (specification->package x))) + (if src? + (let ((s (package-source p))) + (package-source-derivation store s)) + (package->derivation store p sys)))) + (_ #f)) + opts)) + ;;; ;;; Entry point. @@ -208,114 +259,65 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (alist-cons 'argument arg result)) %default-options)) - (define (register-root paths root) - ;; Register ROOT as an indirect GC root for all of PATHS. - (let* ((root (string-append (canonicalize-path (dirname root)) - "/" root))) - (catch 'system-error - (lambda () - (match paths - ((path) - (symlink path root) - (add-indirect-root (%store) root)) - ((paths ...) - (fold (lambda (path count) - (let ((root (string-append root - "-" - (number->string count)))) - (symlink path root) - (add-indirect-root (%store) root)) - (+ 1 count)) - 0 - paths)))) - (lambda args - (leave (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))))))) - (with-error-handling ;; 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))) - (define package->derivation - (match (assoc-ref opts 'target) - (#f package-derivation) - (triplet - (cut package-cross-derivation <> <> triplet <>)))) - - (parameterize ((%store (open-connection))) - (let* ((src? (assoc-ref opts 'source?)) - (sys (assoc-ref opts 'system)) - (drv (filter-map (match-lambda - (('expression . str) - (derivation-from-expression - str package->derivation sys src?)) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('argument . (? store-path?)) - ;; Nothing to do; maybe for --log-file. - #f) - (('argument . (? string? x)) - (let ((p (specification->package x))) - (if src? - (let ((s (package-source p))) - (package-source-derivation - (%store) s)) - (package->derivation (%store) p sys)))) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) + (let* ((opts (parse-options)) + (store (open-connection)) + (drv (options->derivations store opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) - (unless (assoc-ref opts 'log-file?) - (show-what-to-build (%store) drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?))) + (unless (assoc-ref opts 'log-file?) + (show-what-to-build store drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?))) - ;; TODO: Add more options. - (set-build-options (%store) - #:keep-failed? (assoc-ref opts 'keep-failed?) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:max-silent-time (assoc-ref opts 'max-silent-time) - #:verbosity (assoc-ref opts 'verbosity)) + ;; TODO: Add more options. + (set-build-options store + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:max-silent-time (assoc-ref opts 'max-silent-time) + #:verbosity (assoc-ref opts 'verbosity)) - (cond ((assoc-ref opts 'log-file?) - (for-each (lambda (file) - (let ((log (log-file (%store) file))) - (if log - (format #t "~a~%" log) - (leave (_ "no build log for '~a'~%") - file)))) - (delete-duplicates - (append (map derivation-file-name drv) - (filter-map (match-lambda - (('argument - . (? store-path? file)) - file) - (_ #f)) - opts))))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations (%store) drv) - (for-each (lambda (d) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation->output-path - d out-name))) - (derivation-outputs d)))) - drv) - (for-each (cut register-root <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (cond ((assoc-ref opts 'log-file?) + (for-each (lambda (file) + (let ((log (log-file store file))) + (if log + (format #t "~a~%" log) + (leave (_ "no build log for '~a'~%") + file)))) + (delete-duplicates + (append (map derivation-file-name drv) + (filter-map (match-lambda + (('argument + . (? store-path? file)) + file) + (_ #f)) + opts))))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv) + (for-each (lambda (d) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path + d out-name))) + (derivation-outputs d)))) + drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))) -- cgit v1.2.3 From 760c60d68491bd6803e86e405e765f3337663f17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Dec 2013 01:08:21 +0100 Subject: Add 'guix archive'. * guix/scripts/archive.scm, tests/guix-archive.sh: New files. * Makefile.am (MODULES): Add 'archive.scm'. (SH_TESTS): Add 'guix-archive.sh'. * doc/guix.texi (Invoking guix archive): New section. * guix/scripts/build.scm: Export 'derivation-from-expression'. * guix/scripts/package.scm: Export 'specification->package+output'. --- Makefile.am | 2 + doc/guix.texi | 59 +++++++++++- guix/scripts/archive.scm | 232 +++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/build.scm | 3 +- guix/scripts/package.scm | 5 +- tests/guix-archive.sh | 45 +++++++++ 6 files changed, 342 insertions(+), 4 deletions(-) create mode 100644 guix/scripts/archive.scm create mode 100644 tests/guix-archive.sh (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 4815c55fba..ba54f8c582 100644 --- a/Makefile.am +++ b/Makefile.am @@ -67,6 +67,7 @@ MODULES = \ guix/snix.scm \ guix/scripts/download.scm \ guix/scripts/build.scm \ + guix/scripts/archive.scm \ guix/scripts/import.scm \ guix/scripts/package.scm \ guix/scripts/gc.scm \ @@ -130,6 +131,7 @@ SH_TESTS = \ tests/guix-gc.sh \ tests/guix-hash.sh \ tests/guix-package.sh \ + tests/guix-archive.sh \ tests/guix-authenticate.sh if BUILD_DAEMON diff --git a/doc/guix.texi b/doc/guix.texi index fcffa5a22b..c78e0d0d05 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -407,9 +407,10 @@ management tools it provides. @menu * Features:: How Guix will make your life brighter. * Invoking guix package:: Package installation, removal, etc. -* Packages with Multiple Outputs:: Single source package, multiple outputs. +* Packages with Multiple Outputs:: Single source package, multiple outputs. * Invoking guix gc:: Running the garbage collector. * Invoking guix pull:: Fetching the latest Guix and distribution. +* Invoking guix archive:: Exporting and importing store files. @end menu @node Features @@ -914,6 +915,62 @@ Use the bootstrap Guile to build the latest Guix. This option is only useful to Guix developers. @end table + +@node Invoking guix archive +@section Invoking @command{guix archive} + +The @command{guix archive} command allows users to @dfn{export} files +from the store into a single archive, and to later @dfn{import} them. +In particular, it allows store files to be transferred from one machine +to another machine's store. For example, to transfer the @code{emacs} +package to a machine connected over SSH, one would run: + +@example +guix archive --export emacs | ssh the-machine guix archive --import +@end example + +Archives are stored in the ``Nix archive'' or ``Nar'' format, which is +comparable in spirit to `tar'. When exporting, the daemon digitally +signs the contents of the archive, and that digital signature is +appended. When importing, the daemon verifies the signature and rejects +the import in case of an invalid signature. +@c FIXME: Add xref to daemon doc about signatures. + +The main options are: + +@table @code +@item --export +Export the specified store files or packages (see below.) Write the +resulting archive to the standard output. + +@item --import +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. +@end table + +To export store files as an archive to the standard output, run: + +@example +guix archive --export @var{options} @var{specifications}... +@end example + +@var{specifications} may be either store file names or package +specifications, as for @command{guix package} (@pxref{Invoking guix +package}). For instance, the following command creates an archive +containing the @code{gui} output of the @code{git} package and the main +output of @code{emacs}: + +@example +guix archive --export git:gui /nix/store/...-emacs-24.3 > great.nar +@end example + +If the specified packages are not built yet, @command{guix archive} +automatically builds them. The build process may be controlled with the +same options that can be passed to the @command{guix build} command +(@pxref{Invoking guix build}). + + @c ********************************************************************* @node Programming Interface @chapter Programming Interface diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm new file mode 100644 index 0000000000..df538ed1b7 --- /dev/null +++ b/guix/scripts/archive.scm @@ -0,0 +1,232 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts archive) + #:use-module (guix config) + #:use-module (guix utils) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix ui) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (guix scripts build) + #:use-module (guix scripts package) + #:export (guix-archive)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + +(define (show-help) + (display (_ "Usage: guix archive [OPTION]... PACKAGE... +Export/import one or more packages from/to the store.\n")) + (display (_ " + --export export the specified files/packages to stdout")) + (display (_ " + --import import from the archive passed on stdin")) + (newline) + (display (_ " + -e, --expression=EXPR build the package or derivation EXPR evaluates to")) + (display (_ " + -S, --source build the packages' source derivations")) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (_ " + -n, --dry-run do not build the derivations")) + (display (_ " + --fallback fall back to building when the substituter fails")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) + (display (_ " + --max-silent-time=SECONDS + mark the build as failed after SECONDS of silence")) + (display (_ " + -c, --cores=N allow the use of up to N CPU cores for the build")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix build"))) + + (option '("export") #f #f + (lambda (opt name arg result) + (alist-cons 'export #t result))) + (option '("import") #f #f + (lambda (opt name arg result) + (alist-cons 'import #t result))) + + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '("target") #t #f + (lambda (opt name arg result) + (alist-cons 'target arg + (alist-delete 'target result eq?)))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\c "cores") #t #f + (lambda (opt name arg result) + (let ((c (false-if-exception (string->number arg)))) + (if c + (alist-cons 'cores c result) + (leave (_ "~a: not a number~%") arg))))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("fallback") #f #f + (lambda (opt name arg result) + (alist-cons 'fallback? #t + (alist-delete 'fallback? result)))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) + (option '("max-silent-time") #t #f + (lambda (opt name arg result) + (alist-cons 'max-silent-time (string->number* arg) + result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '("verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))))) + +(define (options->derivations+files store opts) + "Given OPTS, the result of 'args-fold', return a list of derivations to +build and a list of store files to transfer." + (define package->derivation + (match (assoc-ref opts 'target) + (#f package-derivation) + (triplet + (cut package-cross-derivation <> <> triplet <>)))) + + (define src? (assoc-ref opts 'source?)) + (define sys (assoc-ref opts 'system)) + + (fold2 (lambda (arg derivations files) + (match arg + (('expression . str) + (let ((drv (derivation-from-expression store str + package->derivation + sys src?))) + (values (cons drv derivations) + (cons (derivation->output-path drv) files)))) + (('argument . (? store-path? file)) + (values derivations (cons file files))) + (('argument . (? string? spec)) + (let-values (((p output) + (specification->package+output spec))) + (if src? + (let* ((s (package-source p)) + (drv (package-source-derivation store s))) + (values (cons drv derivations) + (cons (derivation->output-path drv) + files))) + (let ((drv (package->derivation store p sys))) + (values (cons drv derivations) + (cons (derivation->output-path drv output) + files)))))) + (_ + (values derivations files)))) + '() + '() + opts)) + + +;;; +;;; Entry point. +;;; + +(define (export-from-store store opts) + "Export the packages or derivations specified in OPTS from STORE. Write the +resulting archive to the standard output port." + (let-values (((drv files) + (options->derivations+files store opts))) + (show-what-to-build store drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) + + (set-build-options store + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:max-silent-time (assoc-ref opts 'max-silent-time)) + + (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"))))) + +(define (guix-archive . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (with-error-handling + ;; 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))) + (else + (leave + (_ "either '--export' or '--import' must be specified")))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index b3d852e950..90187094c1 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -33,7 +33,8 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:autoload (gnu packages) (find-best-packages-by-name) - #:export (guix-build)) + #:export (derivation-from-expression + guix-build)) (define (derivation-from-expression store str package-derivation system source?) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 8c197a741e..7cebf6b4d4 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -41,7 +41,8 @@ #:use-module ((gnu packages base) #:select (guile-final)) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module (guix gnu-maintenance) - #:export (guix-package)) + #:export (specification->package+output + guix-package)) (define %store (make-parameter #f)) @@ -293,7 +294,7 @@ return its return value." #f)))) (define* (specification->package+output spec #:optional (output "out")) - "Find the package and output specified by SPEC, or #f and #f; SPEC may + "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: guile diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh new file mode 100644 index 0000000000..ef04835469 --- /dev/null +++ b/tests/guix-archive.sh @@ -0,0 +1,45 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2013 Ludovic Courtès +# +# This file is part of GNU Guix. +# +# GNU Guix is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# GNU Guix is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Guix. If not, see . + +# +# Test the 'guix archive' command-line utility. +# + +guix archive --version + +archive="t-archive-$$" +archive_alt="t-archive-alt-$$" +rm -f "$archive" "$archive_alt" + +trap 'rm -f "$archive" "$archive_alt"' EXIT + +guix archive --export guile-bootstrap > "$archive" +guix archive --export guile-bootstrap:out > "$archive_alt" +cmp "$archive" "$archive_alt" + +guix archive --export \ + -e '(@ (gnu packages bootstrap) %bootstrap-guile)' > "$archive_alt" +cmp "$archive" "$archive_alt" + +guix archive --export `guix build guile-bootstrap` > "$archive_alt" +cmp "$archive" "$archive_alt" + +guix archive --import < "$archive" 2>&1 | grep "import.*guile-bootstrap" + +if guix archive something-that-does-not-exist +then false; else true; fi -- cgit v1.2.3 From b0a33ac157ce99688b6d668124377fdd81bf413e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Dec 2013 23:32:26 +0100 Subject: pk-crypto: Rename 'gcry-sexp' to 'canonical-sexp'. * guix/pk-crypto.scm: Rename procedures, variables, etc. from 'gcry-sexp' to 'canonical-sexp'. Add comment with references. * guix/scripts/authenticate.scm, tests/pk-crypto.scm: Adjust accordingly. --- guix/pk-crypto.scm | 114 ++++++++++++++++++++++-------------------- guix/scripts/authenticate.scm | 18 +++---- tests/pk-crypto.scm | 46 ++++++++--------- 3 files changed, 91 insertions(+), 87 deletions(-) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index d8fbb6f85b..1676abe642 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -24,14 +24,14 @@ #:use-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) - #:export (gcry-sexp? - string->gcry-sexp - gcry-sexp->string - number->gcry-sexp - gcry-sexp-car - gcry-sexp-cdr - gcry-sexp-nth - gcry-sexp-nth-data + #:export (canonical-sexp? + string->canonical-sexp + canonical-sexp->string + number->canonical-sexp + canonical-sexp-car + canonical-sexp-cdr + canonical-sexp-nth + canonical-sexp-nth-data bytevector->hash-data hash-data->bytevector sign @@ -44,24 +44,28 @@ ;;; ;;; Public key cryptographic routines from GNU Libgcrypt. ;;;; -;;; Libgcrypt uses s-expressions to represent key material, parameters, and -;;; data. We keep it as an opaque object rather than attempting to map them -;;; to Scheme s-expressions because (1) Libgcrypt sexps are stored in secure -;;; memory, and (2) the read syntax is different. +;;; Libgcrypt uses "canonical s-expressions" to represent key material, +;;; parameters, and data. We keep it as an opaque object rather than +;;; attempting to map them to Scheme s-expressions because (1) Libgcrypt sexps +;;; are stored in secure memory, and (2) the read syntax is different. +;;; +;;; Canonical sexps were defined by Rivest et al. in the IETF draft at +;;; for the purposes of SPKI +;;; (see .) ;;; ;;; Code: ;; Libgcrypt "s-expressions". -(define-wrapped-pointer-type - gcry-sexp? - naked-pointer->gcry-sexp - gcry-sexp->pointer +(define-wrapped-pointer-type + canonical-sexp? + naked-pointer->canonical-sexp + canonical-sexp->pointer (lambda (obj port) ;; Don't print OBJ's external representation: we don't want key material ;; to leak in backtraces and such. - (format port "#" + (format port "#" (number->string (object-address obj) 16) - (number->string (pointer-address (gcry-sexp->pointer obj)) + (number->string (pointer-address (canonical-sexp->pointer obj)) 16)))) (define libgcrypt-func @@ -70,22 +74,22 @@ "Return a pointer to symbol FUNC in libgcrypt." (dynamic-func func lib)))) -(define finalize-gcry-sexp! +(define finalize-canonical-sexp! (libgcrypt-func "gcry_sexp_release")) -(define-inlinable (pointer->gcry-sexp ptr) - "Return a that wraps PTR." - (let* ((sexp (naked-pointer->gcry-sexp ptr)) - (ptr* (gcry-sexp->pointer sexp))) - ;; Did we already have a object for PTR? +(define-inlinable (pointer->canonical-sexp ptr) + "Return a that wraps PTR." + (let* ((sexp (naked-pointer->canonical-sexp ptr)) + (ptr* (canonical-sexp->pointer sexp))) + ;; Did we already have a object for PTR? (when (equal? ptr ptr*) ;; No, so we can safely add a finalizer (in Guile 2.0.9 ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the ;; existing one.) - (set-pointer-finalizer! ptr finalize-gcry-sexp!)) + (set-pointer-finalizer! ptr finalize-canonical-sexp!)) sexp)) -(define string->gcry-sexp +(define string->canonical-sexp (let* ((ptr (libgcrypt-func "gcry_sexp_new")) (proc (pointer->procedure int ptr `(* * ,size_t ,int)))) (lambda (str) @@ -93,58 +97,58 @@ (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*)))) (err (proc sexp (string->pointer str) 0 1))) (if (= 0 err) - (pointer->gcry-sexp (dereference-pointer sexp)) + (pointer->canonical-sexp (dereference-pointer sexp)) (throw 'gcry-error err)))))) (define-syntax GCRYSEXP_FMT_ADVANCED (identifier-syntax 3)) -(define gcry-sexp->string +(define canonical-sexp->string (let* ((ptr (libgcrypt-func "gcry_sexp_sprint")) (proc (pointer->procedure size_t ptr `(* ,int * ,size_t)))) (lambda (sexp) "Return a textual representation of SEXP." (let loop ((len 1024)) (let* ((buf (bytevector->pointer (make-bytevector len))) - (size (proc (gcry-sexp->pointer sexp) + (size (proc (canonical-sexp->pointer sexp) GCRYSEXP_FMT_ADVANCED buf len))) (if (zero? size) (loop (* len 2)) (pointer->string buf size "ISO-8859-1"))))))) -(define gcry-sexp-car +(define canonical-sexp-car (let* ((ptr (libgcrypt-func "gcry_sexp_car")) (proc (pointer->procedure '* ptr '(*)))) (lambda (lst) "Return the first element of LST, an sexp, if that element is a list; return #f if LST or its first element is not a list (this is different from the usual Lisp 'car'.)" - (let ((result (proc (gcry-sexp->pointer lst)))) + (let ((result (proc (canonical-sexp->pointer lst)))) (if (null-pointer? result) #f - (pointer->gcry-sexp result)))))) + (pointer->canonical-sexp result)))))) -(define gcry-sexp-cdr +(define canonical-sexp-cdr (let* ((ptr (libgcrypt-func "gcry_sexp_cdr")) (proc (pointer->procedure '* ptr '(*)))) (lambda (lst) "Return the tail of LST, an sexp, or #f if LST is not a list." - (let ((result (proc (gcry-sexp->pointer lst)))) + (let ((result (proc (canonical-sexp->pointer lst)))) (if (null-pointer? result) #f - (pointer->gcry-sexp result)))))) + (pointer->canonical-sexp result)))))) -(define gcry-sexp-nth +(define canonical-sexp-nth (let* ((ptr (libgcrypt-func "gcry_sexp_nth")) (proc (pointer->procedure '* ptr `(* ,int)))) (lambda (lst index) "Return the INDEXth nested element of LST, an s-expression. Return #f if that element does not exist, or if it's an atom. (Note: this is obviously different from Scheme's 'list-ref'.)" - (let ((result (proc (gcry-sexp->pointer lst) index))) + (let ((result (proc (canonical-sexp->pointer lst) index))) (if (null-pointer? result) #f - (pointer->gcry-sexp result)))))) + (pointer->canonical-sexp result)))))) (define (dereference-size_t p) "Return the size_t value pointed to by P." @@ -152,7 +156,7 @@ different from Scheme's 'list-ref'.)" 0 (native-endianness) (sizeof size_t))) -(define gcry-sexp-nth-data +(define canonical-sexp-nth-data (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data")) (proc (pointer->procedure '* ptr `(* ,int *)))) (lambda (lst index) @@ -161,20 +165,20 @@ s-expression. Return #f if that element does not exist, or if it's a list. Note that the result is a Scheme string, but depending on LST, it may need to be interpreted in the sense of a C string---i.e., as a series of octets." (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*)))) - (result (proc (gcry-sexp->pointer lst) index size*))) + (result (proc (canonical-sexp->pointer lst) index size*))) (if (null-pointer? result) #f (pointer->string result (dereference-size_t size*) "ISO-8859-1")))))) -(define (number->gcry-sexp number) +(define (number->canonical-sexp number) "Return an s-expression representing NUMBER." - (string->gcry-sexp (string-append "#" (number->string number 16) "#"))) + (string->canonical-sexp (string-append "#" (number->string number 16) "#"))) (define* (bytevector->hash-data bv #:optional (hash-algo "sha256")) "Given BV, a bytevector containing a hash, return an s-expression suitable for use as the data for 'sign'." - (string->gcry-sexp + (string->canonical-sexp (format #f "(data (flags pkcs1) (hash \"~a\" #~a#))" hash-algo (bytevector->base16-string bv)))) @@ -192,8 +196,8 @@ bytevector) extract from DATA, an sexp as returned by 'bytevector->hash-data'. Return #f if DATA does not conform." (let ((hash (find-sexp-token data 'hash))) (if hash - (let ((algo (gcry-sexp-nth-data hash 1)) - (value (gcry-sexp-nth-data hash 2))) + (let ((algo (canonical-sexp-nth-data hash 1)) + (value (canonical-sexp-nth-data hash 2))) (values (latin1-string->bytevector value) algo)) (values #f #f)))) @@ -205,10 +209,10 @@ Return #f if DATA does not conform." "Sign DATA (an s-expression) with SECRET-KEY (an s-expression whose car is 'private-key'.)" (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc sig (gcry-sexp->pointer data) - (gcry-sexp->pointer secret-key)))) + (err (proc sig (canonical-sexp->pointer data) + (canonical-sexp->pointer secret-key)))) (if (= 0 err) - (pointer->gcry-sexp (dereference-pointer sig)) + (pointer->canonical-sexp (dereference-pointer sig)) (throw 'gry-error err)))))) (define verify @@ -217,9 +221,9 @@ is 'private-key'.)" (lambda (signature data public-key) "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of which are gcrypt s-expressions." - (zero? (proc (gcry-sexp->pointer signature) - (gcry-sexp->pointer data) - (gcry-sexp->pointer public-key)))))) + (zero? (proc (canonical-sexp->pointer signature) + (canonical-sexp->pointer data) + (canonical-sexp->pointer public-key)))))) (define generate-key (let* ((ptr (libgcrypt-func "gcry_pk_genkey")) @@ -228,9 +232,9 @@ which are gcrypt s-expressions." "Return as an s-expression a new key pair for PARAMS. PARAMS must be an s-expression like: (genkey (rsa (nbits 4:2048)))." (let* ((key (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc key (gcry-sexp->pointer params)))) + (err (proc key (canonical-sexp->pointer params)))) (if (zero? err) - (pointer->gcry-sexp (dereference-pointer key)) + (pointer->canonical-sexp (dereference-pointer key)) (throw 'gcry-error err)))))) (define find-sexp-token @@ -240,9 +244,9 @@ s-expression like: (genkey (rsa (nbits 4:2048)))." "Find in SEXP the first element whose 'car' is TOKEN and return it; return #f if not found." (let* ((token (string->pointer (symbol->string token))) - (res (proc (gcry-sexp->pointer sexp) token 0))) + (res (proc (canonical-sexp->pointer sexp) token 0))) (if (null-pointer? res) #f - (pointer->gcry-sexp res)))))) + (pointer->canonical-sexp res)))))) ;;; pk-crypto.scm ends here diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index cbafed79d0..70ba7cb88e 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -33,10 +33,10 @@ ;;; ;;; Code: -(define (read-gcry-sexp file) +(define (read-canonical-sexp file) "Read a gcrypt sexp from FILE and return it." (call-with-input-file file - (compose string->gcry-sexp get-string-all))) + (compose string->canonical-sexp get-string-all))) (define (read-hash-data file) "Read sha256 hash data from FILE and return it as a gcrypt sexp." @@ -56,18 +56,18 @@ (("rsautl" "-sign" "-inkey" key "-in" hash-file) ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes ;; both the hash and the actual signature. - (let* ((secret-key (read-gcry-sexp key)) + (let* ((secret-key (read-canonical-sexp key)) (data (read-hash-data hash-file))) (format #t "(guix-signature ~a (payload ~a))" - (gcry-sexp->string (sign data secret-key)) - (gcry-sexp->string data)) + (canonical-sexp->string (sign data secret-key)) + (canonical-sexp->string data)) #t)) (("rsautl" "-verify" "-inkey" key "-pubin" "-in" signature-file) ;; Read the signature as produced above, check it against KEY, and print ;; the signed data to stdout upon success. - (let* ((public-key (read-gcry-sexp key)) - (sig+data (read-gcry-sexp signature-file)) + (let* ((public-key (read-canonical-sexp key)) + (sig+data (read-canonical-sexp signature-file)) (data (find-sexp-token sig+data 'payload)) (signature (find-sexp-token sig+data 'sig-val))) (if (and data signature) @@ -79,12 +79,12 @@ (begin (format (current-error-port) "error: invalid signature: ~a~%" - (gcry-sexp->string signature)) + (canonical-sexp->string signature)) (exit 1))) (begin (format (current-error-port) "error: corrupt signature data: ~a~%" - (gcry-sexp->string sig+data)) + (canonical-sexp->string sig+data)) (exit 1))))) (("--help") (display (_ "Usage: guix authenticate OPTION... diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index eddd5c4945..85f8f9407e 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -32,7 +32,7 @@ (define %key-pair ;; Key pair that was generated with: - ;; (generate-key (string->gcry-sexp "(genkey (rsa (nbits 4:1024)))")) + ;; (generate-key (string->canonical-sexp "(genkey (rsa (nbits 4:1024)))")) ;; which takes a bit of time. "(key-data (public-key @@ -57,11 +57,11 @@ ;;"#C0FFEE#" "(genkey \n (rsa \n (nbits \"1024\")\n )\n )"))) - (test-equal "string->gcry-sexp->string" + (test-equal "string->canonical-sexp->string" sexps - (let ((sexps (map string->gcry-sexp sexps))) - (and (every gcry-sexp? sexps) - (map (compose string-trim-both gcry-sexp->string) sexps))))) + (let ((sexps (map string->canonical-sexp sexps))) + (and (every canonical-sexp? sexps) + (map (compose string-trim-both canonical-sexp->string) sexps))))) (gc) ; stress test! @@ -75,43 +75,43 @@ sexps) (map (match-lambda ((input token '-> _) - (let ((sexp (find-sexp-token (string->gcry-sexp input) token))) + (let ((sexp (find-sexp-token (string->canonical-sexp input) token))) (and sexp - (string-trim-both (gcry-sexp->string sexp)))))) + (string-trim-both (canonical-sexp->string sexp)))))) sexps))) (gc) -(test-equal "gcry-sexp-car + cdr" +(test-equal "canonical-sexp-car + cdr" '("(b \n (c xyz)\n )") - (let ((lst (string->gcry-sexp "(a (b (c xyz)))"))) + (let ((lst (string->canonical-sexp "(a (b (c xyz)))"))) (map (lambda (sexp) - (and sexp (string-trim-both (gcry-sexp->string sexp)))) + (and sexp (string-trim-both (canonical-sexp->string sexp)))) ;; Note: 'car' returns #f when the first element is an atom. - (list (gcry-sexp-car (gcry-sexp-cdr lst)))))) + (list (canonical-sexp-car (canonical-sexp-cdr lst)))))) (gc) -(test-equal "gcry-sexp-nth" +(test-equal "canonical-sexp-nth" '("(b pqr)" "(c \"456\")" "(d xyz)" #f #f) - (let ((lst (string->gcry-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))"))) - ;; XXX: In Libgcrypt 1.5.3, (gcry-sexp-nth lst 0) returns LST, whereas in + (let ((lst (string->canonical-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))"))) + ;; XXX: In Libgcrypt 1.5.3, (canonical-sexp-nth lst 0) returns LST, whereas in ;; 1.6.0 it returns #f. (map (lambda (sexp) - (and sexp (string-trim-both (gcry-sexp->string sexp)))) + (and sexp (string-trim-both (canonical-sexp->string sexp)))) (unfold (cut > <> 5) - (cut gcry-sexp-nth lst <>) + (cut canonical-sexp-nth lst <>) 1+ 1)))) (gc) -(test-equal "gcry-sexp-nth-data" +(test-equal "canonical-sexp-nth-data" '("Name" "Otto" "Meier" #f #f #f) - (let ((lst (string->gcry-sexp "(Name Otto Meier (address Burgplatz))"))) + (let ((lst (string->canonical-sexp "(Name Otto Meier (address Burgplatz))"))) (unfold (cut > <> 5) - (cut gcry-sexp-nth-data lst <>) + (cut canonical-sexp-nth-data lst <>) 1+ 0))) @@ -120,9 +120,9 @@ ;; XXX: The test below is typically too long as it needs to gather enough entropy. ;; (test-assert "generate-key" -;; (let ((key (generate-key (string->gcry-sexp +;; (let ((key (generate-key (string->canonical-sexp ;; "(genkey (rsa (nbits 3:128)))")))) -;; (and (gcry-sexp? key) +;; (and (canonical-sexp? key) ;; (find-sexp-token key 'key-data) ;; (find-sexp-token key 'public-key) ;; (find-sexp-token key 'private-key)))) @@ -130,13 +130,13 @@ (test-assert "bytevector->hash-data->bytevector" (let* ((bv (sha256 (string->utf8 "Hello, world."))) (data (bytevector->hash-data bv "sha256"))) - (and (gcry-sexp? data) + (and (canonical-sexp? data) (let-values (((value algo) (hash-data->bytevector data))) (and (string=? algo "sha256") (bytevector=? value bv)))))) (test-assert "sign + verify" - (let* ((pair (string->gcry-sexp %key-pair)) + (let* ((pair (string->canonical-sexp %key-pair)) (secret (find-sexp-token pair 'private-key)) (public (find-sexp-token pair 'public-key)) (data (bytevector->hash-data -- cgit v1.2.3 From 6df1fb8991bc7323dd4974a55d37f249a4e9c4a0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Dec 2013 00:42:07 +0100 Subject: authenticate: Store the public key as part of the signature. * guix/scripts/authenticate.scm (signature-sexp): New procedure. (guix-authenticate): Use it to produce the signature. Adjust verification code accordingly. * tests/store.scm ("import corrupt path"): Adjust test accordingly. --- guix/scripts/authenticate.scm | 26 ++++++++++++++++++++------ tests/store.scm | 4 ++-- 2 files changed, 22 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 70ba7cb88e..7e1c2a4671 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -44,6 +44,17 @@ (bv (base16-string->bytevector (string-trim-both hex)))) (bytevector->hash-data bv))) +(define (signature-sexp data secret-key public-key) + "Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that +includes DATA, the actual signature value (with a 'sig-val' tag), and +PUBLIC-KEY (see for examples.)" + (string->canonical-sexp + (format #f + "(signature ~a ~a ~a)" + (canonical-sexp->string data) + (canonical-sexp->string (sign data secret-key)) + (canonical-sexp->string public-key)))) + ;;; ;;; Entry point with 'openssl'-compatible interface. We support this @@ -57,18 +68,21 @@ ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes ;; both the hash and the actual signature. (let* ((secret-key (read-canonical-sexp key)) - (data (read-hash-data hash-file))) - (format #t - "(guix-signature ~a (payload ~a))" - (canonical-sexp->string (sign data secret-key)) - (canonical-sexp->string data)) + (public-key (if (string-suffix? ".sec" key) + (read-canonical-sexp + (string-append (string-drop-right key 4) ".pub")) + (leave (_ "cannot find public key for secret key '~a'") + key))) + (data (read-hash-data hash-file)) + (signature (signature-sexp data secret-key public-key))) + (display (canonical-sexp->string signature)) #t)) (("rsautl" "-verify" "-inkey" key "-pubin" "-in" signature-file) ;; Read the signature as produced above, check it against KEY, and print ;; the signed data to stdout upon success. (let* ((public-key (read-canonical-sexp key)) (sig+data (read-canonical-sexp signature-file)) - (data (find-sexp-token sig+data 'payload)) + (data (find-sexp-token sig+data 'data)) (signature (find-sexp-token sig+data 'sig-val))) (if (and data signature) (if (verify signature data public-key) diff --git a/tests/store.scm b/tests/store.scm index 6834ebc5e9..4bd739e7f6 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -373,8 +373,8 @@ Deriver: ~a~%" (cut export-paths %store (list file) <>)))) (delete-paths %store (list file)) - ;; Flip a bit in the middle of the stream. - (let* ((index (quotient (bytevector-length dump) 3)) + ;; Flip a bit in the stream's payload. + (let* ((index (quotient (bytevector-length dump) 4)) (byte (bytevector-u8-ref dump index))) (bytevector-u8-set! dump index (logxor #xff byte))) -- cgit v1.2.3 From a2cbbb743da26abc3a1bdbcd9af2d07018c2a8a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Dec 2013 15:41:48 +0100 Subject: pk-crypto: 'canonical-sexp-nth-data' returns a symbol for "tokens". * guix/pk-crypto.scm (token-string?): New procedure. (canonical-sexp-nth-data): Return a symbol when the element is a "token", and a bytevector otherwise. (latin1-string->bytevector): Remove. (hash-data->bytevector): Adjust accordingly. * tests/pk-crypto.scm ("canonical-sexp-nth"): Adjust accordingly. Add octet string example. --- guix/pk-crypto.scm | 48 +++++++++++++++++++++++++++++++----------------- tests/pk-crypto.scm | 5 +++-- 2 files changed, 34 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 1676abe642..e5ada6a177 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -156,20 +156,42 @@ different from Scheme's 'list-ref'.)" 0 (native-endianness) (sizeof size_t))) +(define token-string? + (let ((token-cs (char-set-union char-set:digit + char-set:letter + (char-set #\- #\. #\/ #\_ + #\: #\* #\+ #\=)))) + (lambda (str) + "Return #t if STR is a token as per Section 4.3 of +." + (and (not (string-null? str)) + (string-every token-cs str) + (not (char-set-contains? char-set:digit (string-ref str 0))))))) + (define canonical-sexp-nth-data (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data")) (proc (pointer->procedure '* ptr `(* ,int *)))) (lambda (lst index) - "Return as a string the INDEXth data element (atom) of LST, an -s-expression. Return #f if that element does not exist, or if it's a list. -Note that the result is a Scheme string, but depending on LST, it may need to -be interpreted in the sense of a C string---i.e., as a series of octets." + "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other +\"octet string\") the INDEXth data element (atom) of LST, an s-expression. +Return #f if that element does not exist, or if it's a list." (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*)))) (result (proc (canonical-sexp->pointer lst) index size*))) (if (null-pointer? result) #f - (pointer->string result (dereference-size_t size*) - "ISO-8859-1")))))) + (let* ((len (dereference-size_t size*)) + (str (pointer->string result len "ISO-8859-1"))) + ;; The sexp spec speaks of "tokens" and "octet strings". + ;; Sometimes these octet strings are actual strings (text), + ;; sometimes they're bytevectors, and sometimes they're + ;; multi-precision integers (MPIs). Only the application knows. + ;; However, for convenience, we return a symbol when a token is + ;; encountered since tokens are frequent (at least in the 'car' + ;; of each sexp.) + (if (token-string? str) + (string->symbol str) ; an sexp "token" + (bytevector-copy ; application data, textual or binary + (pointer->bytevector result len))))))))) (define (number->canonical-sexp number) "Return an s-expression representing NUMBER." @@ -183,23 +205,15 @@ for use as the data for 'sign'." hash-algo (bytevector->base16-string bv)))) -(define (latin1-string->bytevector str) - "Return a bytevector representing STR." - ;; XXX: In Guile 2.0.9 and later, we would use 'string->bytevector' for - ;; that. - (let ((bytes (map char->integer (string->list str)))) - (u8-list->bytevector bytes))) - (define (hash-data->bytevector data) - "Return two values: the hash algorithm (a string) and the hash value (a -bytevector) extract from DATA, an sexp as returned by 'bytevector->hash-data'. + "Return two values: the hash value (a bytevector), and the hash algorithm (a +string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'. Return #f if DATA does not conform." (let ((hash (find-sexp-token data 'hash))) (if hash (let ((algo (canonical-sexp-nth-data hash 1)) (value (canonical-sexp-nth-data hash 2))) - (values (latin1-string->bytevector value) - algo)) + (values value (symbol->string algo))) (values #f #f)))) (define sign diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 85f8f9407e..8da533f5b2 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -108,8 +108,9 @@ (gc) (test-equal "canonical-sexp-nth-data" - '("Name" "Otto" "Meier" #f #f #f) - (let ((lst (string->canonical-sexp "(Name Otto Meier (address Burgplatz))"))) + `(Name Otto Meier #f ,(base16-string->bytevector "123456") #f) + (let ((lst (string->canonical-sexp + "(Name Otto Meier (address Burgplatz) #123456#)"))) (unfold (cut > <> 5) (cut canonical-sexp-nth-data lst <>) 1+ -- cgit v1.2.3 From 363ae1da82cbb83b57b57f78b716125b79e2ac39 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Dec 2013 15:47:35 +0100 Subject: pk-crypto: Add 'canonical-sexp-length' and related procedures. * guix/pk-crypto.scm (canonical-sexp-length, canonical-sexp-null?, canonical-sexp-list?): New procedures. * tests/pk-crypto.scm ("canonical-sexp-length", "canonical-sexp-list?"): New tests. --- guix/pk-crypto.scm | 20 ++++++++++++++++++++ tests/pk-crypto.scm | 12 ++++++++++++ 2 files changed, 32 insertions(+) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index e5ada6a177..0d1af07313 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -32,6 +32,9 @@ canonical-sexp-cdr canonical-sexp-nth canonical-sexp-nth-data + canonical-sexp-length + canonical-sexp-null? + canonical-sexp-list? bytevector->hash-data hash-data->bytevector sign @@ -156,6 +159,14 @@ different from Scheme's 'list-ref'.)" 0 (native-endianness) (sizeof size_t))) +(define canonical-sexp-length + (let* ((ptr (libgcrypt-func "gcry_sexp_length")) + (proc (pointer->procedure int ptr '(*)))) + (lambda (sexp) + "Return the length of SEXP if it's a list (including the empty list); +return zero if SEXP is an atom." + (proc (canonical-sexp->pointer sexp))))) + (define token-string? (let ((token-cs (char-set-union char-set:digit char-set:letter @@ -263,4 +274,13 @@ return #f if not found." #f (pointer->canonical-sexp res)))))) +(define-inlinable (canonical-sexp-null? sexp) + "Return #t if SEXP is the empty-list sexp." + (null-pointer? (canonical-sexp->pointer sexp))) + +(define (canonical-sexp-list? sexp) + "Return #t if SEXP is a list." + (or (canonical-sexp-null? sexp) + (> (canonical-sexp-length sexp) 0))) + ;;; pk-crypto.scm ends here diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 8da533f5b2..3135d5a60c 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -82,6 +82,18 @@ (gc) +(test-equal "canonical-sexp-length" + '(0 1 2 4 0 0) + (map (compose canonical-sexp-length string->canonical-sexp) + '("()" "(a)" "(a b)" "(a #616263# b #C001#)" "a" "#123456#"))) + +(test-equal "canonical-sexp-list?" + '(#t #f #t #f) + (map (compose canonical-sexp-list? string->canonical-sexp) + '("()" "\"abc\"" "(a b c)" "#123456#"))) + +(gc) + (test-equal "canonical-sexp-car + cdr" '("(b \n (c xyz)\n )") (let ((lst (string->canonical-sexp "(a (b (c xyz)))"))) -- cgit v1.2.3 From 9501d7745eca2c6c5b18f7b573c08398c3ffa4d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Dec 2013 16:16:00 +0100 Subject: pk-crypto: Add canonical-sexp to sexp conversion procedures. * guix/pk-crypto.scm (canonical-sexp-fold, canonical-sexp->sexp, sexp->canonical-sexp): New procedures. * tests/pk-crypto.scm ("canonical-sexp->sexp", "sexp->canonical-sexp->sexp"): New tests. --- guix/pk-crypto.scm | 66 +++++++++++++++++++++++++++++++++++++++++++++++++---- tests/pk-crypto.scm | 46 +++++++++++++++++++++++++++++++++++++ 2 files changed, 108 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 0d1af07313..0e7affcce8 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -40,7 +40,9 @@ sign verify generate-key - find-sexp-token)) + find-sexp-token + canonical-sexp->sexp + sexp->canonical-sexp)) ;;; Commentary: @@ -48,9 +50,13 @@ ;;; Public key cryptographic routines from GNU Libgcrypt. ;;;; ;;; Libgcrypt uses "canonical s-expressions" to represent key material, -;;; parameters, and data. We keep it as an opaque object rather than -;;; attempting to map them to Scheme s-expressions because (1) Libgcrypt sexps -;;; are stored in secure memory, and (2) the read syntax is different. +;;; parameters, and data. We keep it as an opaque object to map them to +;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure +;;; memory, and (2) the read syntax is different. +;;; +;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in +;;; cases where it is safe to move data out of Libgcrypt---e.g., when +;;; processing ACL entries, public keys, etc. ;;; ;;; Canonical sexps were defined by Rivest et al. in the IETF draft at ;;; for the purposes of SPKI @@ -283,4 +289,56 @@ return #f if not found." (or (canonical-sexp-null? sexp) (> (canonical-sexp-length sexp) 0))) +(define (canonical-sexp-fold proc seed sexp) + "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp." + (if (canonical-sexp-list? sexp) + (let ((len (canonical-sexp-length sexp))) + (let loop ((index 0) + (result seed)) + (if (= index len) + result + (loop (+ 1 index) + (proc (or (canonical-sexp-nth sexp index) + (canonical-sexp-nth-data sexp index)) + result))))) + (error "sexp is not a list" sexp))) + +(define (canonical-sexp->sexp sexp) + "Return a Scheme sexp corresponding to SEXP. This is particularly useful to +compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to +use pattern matching." + (if (canonical-sexp-list? sexp) + (reverse + (canonical-sexp-fold (lambda (item result) + (cons (if (canonical-sexp? item) + (canonical-sexp->sexp item) + item) + result)) + '() + sexp)) + (canonical-sexp->string sexp))) ; XXX: not very useful + +(define (sexp->canonical-sexp sexp) + "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by +'canonical-sexp->sexp'." + ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do + ;; much better. + (string->canonical-sexp + (call-with-output-string + (lambda (port) + (define (write item) + (cond ((list? item) + (display "(" port) + (for-each write item) + (display ")" port)) + ((symbol? item) + (format port " ~a" item)) + ((bytevector? item) + (format port " #~a#" + (bytevector->base16-string item))) + (else + (error "unsupported sexp item type" item)))) + + (write sexp))))) + ;;; pk-crypto.scm ends here diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 3135d5a60c..a894a60531 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -163,6 +163,52 @@ (gc) +(test-equal "canonical-sexp->sexp" + `((data + (flags pkcs1) + (hash sha256 + ,(base16-string->bytevector + "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))) + + (public-key + (rsa + (n ,(base16-string->bytevector + (string-downcase + "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45"))) + (e ,(base16-string->bytevector + "010001"))))) + + (list (canonical-sexp->sexp + (string->canonical-sexp + "(data + (flags pkcs1) + (hash \"sha256\" + #2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb#))")) + + (canonical-sexp->sexp + (find-sexp-token (string->canonical-sexp %key-pair) + 'public-key)))) + + +(let ((lst + `((data + (flags pkcs1) + (hash sha256 + ,(base16-string->bytevector + "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))) + + (public-key + (rsa + (n ,(base16-string->bytevector + (string-downcase + "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45"))) + (e ,(base16-string->bytevector + "010001"))))))) + (test-equal "sexp->canonical-sexp->sexp" + lst + (map (compose canonical-sexp->sexp sexp->canonical-sexp) + lst))) + (test-end) -- cgit v1.2.3 From 04d4c8a439c035cf41296eafc23a5dfe196c24db Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2013 15:51:07 +0100 Subject: Move 'with-atomic-file-output' to (guix utils). * guix/scripts/substitute-binary.scm (with-atomic-file-output): Move to... * guix/utils.scm (with-atomic-file-output): ... here. --- .dir-locals.el | 1 + guix/scripts/substitute-binary.scm | 16 ---------------- guix/utils.scm | 16 ++++++++++++++++ 3 files changed, 17 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index bb4e964dd5..87cdaae807 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -20,6 +20,7 @@ (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) (eval . (put 'with-error-handling 'scheme-indent-function 0)) (eval . (put 'with-mutex 'scheme-indent-function 1)) + (eval . (put 'with-atomic-file-output 'scheme-indent-function 1)) (eval . (put 'syntax-parameterize 'scheme-indent-function 1)) (eval . (put 'with-monad 'scheme-indent-function 1)) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 0da29d435b..901b3fb064 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -72,21 +72,6 @@ ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) -(define (with-atomic-file-output file proc) - "Call PROC with an output port for the file that is going to replace FILE. -Upon success, FILE is atomically replaced by what has been written to the -output port, and PROC's result is returned." - (let* ((template (string-append file ".XXXXXX")) - (out (mkstemp! template))) - (with-throw-handler #t - (lambda () - (let ((result (proc out))) - (close out) - (rename-file template file) - result)) - (lambda (key . args) - (false-if-exception (delete-file template)))))) - ;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it. ;; See . (set! regexp-exec @@ -594,7 +579,6 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; Local Variables: -;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; End: diff --git a/guix/utils.scm b/guix/utils.scm index b730340eda..04a74ee29a 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -67,6 +67,7 @@ file-extension file-sans-extension call-with-temporary-output-file + with-atomic-file-output fold2 filtered-port)) @@ -426,6 +427,21 @@ call." (false-if-exception (close out)) (false-if-exception (delete-file template)))))) +(define (with-atomic-file-output file proc) + "Call PROC with an output port for the file that is going to replace FILE. +Upon success, FILE is atomically replaced by what has been written to the +output port, and PROC's result is returned." + (let* ((template (string-append file ".XXXXXX")) + (out (mkstemp! template))) + (with-throw-handler #t + (lambda () + (let ((result (proc out))) + (close out) + (rename-file template file) + result)) + (lambda (key . args) + (false-if-exception (delete-file template)))))) + (define fold2 (case-lambda ((proc seed1 seed2 lst) -- cgit v1.2.3 From 3f40cfdeceab121101fc6aaddc55ccb7a0be3e7f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2013 15:52:50 +0100 Subject: config: Export '%config-directory'. * configure.ac: Define and substitute 'guix_sysconfdir'. * guix/config.scm.in (%config-directory): New variable. --- configure.ac | 4 +++- guix/config.scm.in | 5 +++++ 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/configure.ac b/configure.ac index 07f8539504..e7bc44dca2 100644 --- a/configure.ac +++ b/configure.ac @@ -36,10 +36,12 @@ AC_ARG_ENABLE([daemon], [guix_build_daemon="$enableval"], [guix_build_daemon="yes"]) -# Prepare a version of $localstatedir that does not contain references +# Prepare a version of $localstatedir & co. that does not contain references # to shell variables. guix_localstatedir="`eval echo $localstatedir | sed -e "s|NONE|/usr/local|g"`" +guix_sysconfdir="`eval echo $sysconfdir | sed -e "s|NONE|/usr/local|g"`" AC_SUBST([guix_localstatedir]) +AC_SUBST([guix_sysconfdir]) dnl We require the pkg.m4 set of macros from pkg-config. dnl Make sure it's available. diff --git a/guix/config.scm.in b/guix/config.scm.in index 772ea8c289..4835c6e5d9 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -23,6 +23,7 @@ %guix-home-page-url %store-directory %state-directory + %config-directory %system %libgcrypt %nixpkgs @@ -56,6 +57,10 @@ ;; This must match `NIX_STATE_DIR' as defined in `daemon.am'. "@guix_localstatedir@/nix") +(define %config-directory + ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'. + (or (getenv "NIX_CONF_DIR") "@guix_sysconfdir@/guix")) + (define %system "@guix_system@") -- cgit v1.2.3 From 8b420f74e40a928493ce6afefe2c99144a4ecbb3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2013 15:53:49 +0100 Subject: Add (guix pki). * guix/pki.scm, tests/pki.scm: New files. * Makefile.am (MODULES): Add 'guix/pki.scm'. (SCM_TESTS): Add 'tests/pki.scm'. --- Makefile.am | 2 + guix/pki.scm | 132 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/pki.scm | 51 +++++++++++++++++++++++ 3 files changed, 185 insertions(+) create mode 100644 guix/pki.scm create mode 100644 tests/pki.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index ba54f8c582..6d6aba059b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -31,6 +31,7 @@ MODULES = \ guix/records.scm \ guix/hash.scm \ guix/pk-crypto.scm \ + guix/pki.scm \ guix/utils.scm \ guix/download.scm \ guix/monads.scm \ @@ -111,6 +112,7 @@ SCM_TESTS = \ tests/base32.scm \ tests/hash.scm \ tests/pk-crypto.scm \ + tests/pki.scm \ tests/builders.scm \ tests/derivations.scm \ tests/ui.scm \ diff --git a/guix/pki.scm b/guix/pki.scm new file mode 100644 index 0000000000..1ed84e55f0 --- /dev/null +++ b/guix/pki.scm @@ -0,0 +1,132 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix pki) + #:use-module (guix config) + #:use-module (guix pk-crypto) + #:use-module ((guix utils) #:select (with-atomic-file-output)) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:export (%public-key-file + current-acl + public-keys->acl + acl->public-keys + signature-sexp + authorized-key?)) + +;;; Commentary: +;;; +;;; Public key infrastructure for the authentication and authorization of +;;; archive imports. This is essentially a subset of SPKI for our own +;;; purposes (see and +;;; .) +;;; +;;; Code: + +(define (acl-entry-sexp public-key) + "Return a SPKI-style ACL entry sexp for PUBLIC-KEY, authorizing imports +signed by the corresponding secret key (see the IETF draft at + for the ACL format.)" + ;; Note: We always use PUBLIC-KEY to designate the subject. Someday we may + ;; want to have name certificates and to use subject names instead of + ;; complete keys. + (string->canonical-sexp + (format #f + "(entry ~a (tag (guix import)))" + (canonical-sexp->string public-key)))) + +(define (acl-sexp entries) + "Return an ACL sexp from ENTRIES, a list of 'entry' sexps." + (string->canonical-sexp + (string-append "(acl " + (string-join (map canonical-sexp->string entries)) + ")"))) + +(define (public-keys->acl keys) + "Return an ACL canonical sexp that lists all of KEYS with a '(guix import)' +tag---meaning that all of KEYS are authorized for archive imports. Each +element in KEYS must be a canonical sexp with type 'public-key'." + (acl-sexp (map acl-entry-sexp keys))) + +(define %acl-file + (string-append %config-directory "/acl")) + +(define %public-key-file + (string-append %config-directory "/signing-key.pub")) + +(define (ensure-acl) + "Make sure the ACL file exists, and create an initialized one if needed." + (unless (file-exists? %acl-file) + ;; If there's no public key file, don't attempt to create the ACL. + (when (file-exists? %public-key-file) + (let ((public-key (call-with-input-file %public-key-file + (compose string->canonical-sexp + get-string-all)))) + (with-atomic-file-output %acl-file + (lambda (port) + (display (canonical-sexp->string + (public-keys->acl (list public-key))) + port))))))) + +(define (current-acl) + "Return the current ACL as a canonical sexp." + (ensure-acl) + (if (file-exists? %acl-file) + (call-with-input-file %acl-file + (compose string->canonical-sexp + get-string-all)) + (public-keys->acl '()))) ; the empty ACL + +(define (acl->public-keys acl) + "Return the public keys (as canonical sexps) listed in ACL with the '(guix +import)' tag." + (match (canonical-sexp->sexp acl) + (('acl + ('entry subject-keys + ('tag ('guix 'import))) + ...) + (map sexp->canonical-sexp subject-keys)) + (_ + (error "invalid access-control list" acl)))) + +(define* (authorized-key? key + #:optional (acl (current-acl))) + "Return #t if KEY (a canonical sexp) is an authorized public key for archive +imports according to ACL." + (let ((key (canonical-sexp->sexp key))) + (match (canonical-sexp->sexp acl) + (('acl + ('entry subject-keys + ('tag ('guix 'import))) + ...) + (not (not (member key subject-keys)))) + (_ + (error "invalid access-control list" acl))))) + +(define (signature-sexp data secret-key public-key) + "Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that +includes DATA, the actual signature value (with a 'sig-val' tag), and +PUBLIC-KEY (see for examples.)" + (string->canonical-sexp + (format #f + "(signature ~a ~a ~a)" + (canonical-sexp->string data) + (canonical-sexp->string (sign data secret-key)) + (canonical-sexp->string public-key)))) + +;;; pki.scm ends here diff --git a/tests/pki.scm b/tests/pki.scm new file mode 100644 index 0000000000..04d5a5311b --- /dev/null +++ b/tests/pki.scm @@ -0,0 +1,51 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-pki) + #:use-module (guix pki) + #:use-module (guix pk-crypto) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-64)) + +;; Test the (guix pki) module. + +(define %public-key + (call-with-input-file %public-key-file + (compose string->canonical-sexp + get-string-all))) + +(test-begin "pki") + +(test-assert "current-acl" + (not (not (member (canonical-sexp->sexp %public-key) + (map canonical-sexp->sexp + (acl->public-keys (current-acl))))))) + +(test-assert "authorized-key? public-key current-acl" + (authorized-key? %public-key)) + +(test-assert "authorized-key? public-key empty-acl" + (not (authorized-key? %public-key (public-keys->acl '())))) + +(test-assert "authorized-key? public-key singleton" + (authorized-key? %public-key (public-keys->acl (list %public-key)))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From 96e5085c8113a8ccfdb627b8e2efe30364a86563 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Dec 2013 15:55:38 +0100 Subject: authenticate: Disallow imports signed with unauthorized keys. * guix/scripts/authenticate.scm (signature-sexp): Remove. (guix-authenticate): Upon '-verify', check whether the signature's public key passes 'authorized-key?'. --- guix/scripts/authenticate.scm | 43 ++++++++++++++++++++----------------------- 1 file changed, 20 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 7e1c2a4671..cefa035953 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -20,6 +20,7 @@ #:use-module (guix config) #:use-module (guix utils) #:use-module (guix pk-crypto) + #:use-module (guix pki) #:use-module (guix ui) #:use-module (rnrs io ports) #:use-module (ice-9 match) @@ -44,17 +45,6 @@ (bv (base16-string->bytevector (string-trim-both hex)))) (bytevector->hash-data bv))) -(define (signature-sexp data secret-key public-key) - "Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that -includes DATA, the actual signature value (with a 'sig-val' tag), and -PUBLIC-KEY (see for examples.)" - (string->canonical-sexp - (format #f - "(signature ~a ~a ~a)" - (canonical-sexp->string data) - (canonical-sexp->string (sign data secret-key)) - (canonical-sexp->string public-key)))) - ;;; ;;; Entry point with 'openssl'-compatible interface. We support this @@ -77,23 +67,30 @@ PUBLIC-KEY (see for examples.)" (signature (signature-sexp data secret-key public-key))) (display (canonical-sexp->string signature)) #t)) - (("rsautl" "-verify" "-inkey" key "-pubin" "-in" signature-file) - ;; Read the signature as produced above, check it against KEY, and print - ;; the signed data to stdout upon success. - (let* ((public-key (read-canonical-sexp key)) - (sig+data (read-canonical-sexp signature-file)) + (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) + ;; Read the signature as produced above, check whether its public key is + ;; authorized, and verify the signature, and print the signed data to + ;; stdout upon success. + (let* ((sig+data (read-canonical-sexp signature-file)) + (public-key (find-sexp-token sig+data 'public-key)) (data (find-sexp-token sig+data 'data)) (signature (find-sexp-token sig+data 'sig-val))) (if (and data signature) - (if (verify signature data public-key) - (begin - (display (bytevector->base16-string - (hash-data->bytevector data))) - #t) ; success + (if (authorized-key? public-key) + (if (verify signature data public-key) + (begin + (display (bytevector->base16-string + (hash-data->bytevector data))) + #t) ; success + (begin + (format (current-error-port) + "error: invalid signature: ~a~%" + (canonical-sexp->string signature)) + (exit 1))) (begin (format (current-error-port) - "error: invalid signature: ~a~%" - (canonical-sexp->string signature)) + "error: unauthorized public key: ~a~%" + (canonical-sexp->string public-key)) (exit 1))) (begin (format (current-error-port) -- cgit v1.2.3 From c909dab2697d90a82c388e5efa8dab0001d09938 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Dec 2013 18:23:44 +0100 Subject: authenticate: Consistently use 'leave' for fatal error reporting. * guix/scripts/authenticate.scm (guix-authenticate): Replace all uses of 'format' + 'exit' with 'leave'. --- guix/scripts/authenticate.scm | 26 +++++++++----------------- 1 file changed, 9 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index cefa035953..c7a14f7a8b 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -61,8 +61,9 @@ (public-key (if (string-suffix? ".sec" key) (read-canonical-sexp (string-append (string-drop-right key 4) ".pub")) - (leave (_ "cannot find public key for secret key '~a'") - key))) + (leave + (_ "cannot find public key for secret key '~a'~%") + key))) (data (read-hash-data hash-file)) (signature (signature-sexp data secret-key public-key))) (display (canonical-sexp->string signature)) @@ -82,21 +83,12 @@ (display (bytevector->base16-string (hash-data->bytevector data))) #t) ; success - (begin - (format (current-error-port) - "error: invalid signature: ~a~%" - (canonical-sexp->string signature)) - (exit 1))) - (begin - (format (current-error-port) - "error: unauthorized public key: ~a~%" - (canonical-sexp->string public-key)) - (exit 1))) - (begin - (format (current-error-port) - "error: corrupt signature data: ~a~%" - (canonical-sexp->string sig+data)) - (exit 1))))) + (leave (_ "error: invalid signature: ~a~%") + (canonical-sexp->string signature))) + (leave (_ "error: unauthorized public key: ~a~%") + (canonical-sexp->string public-key))) + (leave (_ "error: corrupt signature data: ~a~%") + (canonical-sexp->string sig+data))))) (("--help") (display (_ "Usage: guix authenticate OPTION... Sign or verify the signature on the given file. This tool is meant to -- cgit v1.2.3 From 36341854dfedc3d173d09e686ffc3e255c102b01 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Dec 2013 22:19:19 +0100 Subject: pk-crypto: Work around Libgcrypt bug . * guix/pk-crypto.scm (canonical-sexp-fold): Call 'nth-data' before 'nth' to work around . * tests/pk-crypto.scm ("https://bugs.g10code.com/gnupg/issue1594"): New test. --- guix/pk-crypto.scm | 7 +++++-- tests/pk-crypto.scm | 12 ++++++++++++ 2 files changed, 17 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 0e7affcce8..cf18faea04 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -298,8 +298,11 @@ return #f if not found." (if (= index len) result (loop (+ 1 index) - (proc (or (canonical-sexp-nth sexp index) - (canonical-sexp-nth-data sexp index)) + ;; XXX: Call 'nth-data' *before* 'nth' to work around + ;; , which + ;; affects 1.6.0 and earlier versions. + (proc (or (canonical-sexp-nth-data sexp index) + (canonical-sexp-nth sexp index)) result))))) (error "sexp is not a list" sexp))) diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index a894a60531..de775d2e19 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -209,6 +209,18 @@ (map (compose canonical-sexp->sexp sexp->canonical-sexp) lst))) +(let ((sexp `(signature + (public-key + (rsa + (n ,(make-bytevector 1024 1)) + (e ,(base16-string->bytevector "010001"))))))) + (test-equal "https://bugs.g10code.com/gnupg/issue1594" + ;; The gcrypt bug above was primarily affecting our uses in + ;; 'canonical-sexp->sexp', typically when applied to a signature sexp (in + ;; 'guix authenticate -verify') with a "big" RSA key, such as 4096 bits. + sexp + (canonical-sexp->sexp (sexp->canonical-sexp sexp)))) + (test-end) -- cgit v1.2.3 From dedb5d947ee2890524a5c6fb1343b3299e7731c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Dec 2013 22:29:12 +0100 Subject: pk-crypto: Fix 'canonical-sexp->sexp' for atoms. * guix/pk-crypto.scm (canonical-sexp->sexp): Add hack to extract an atom's buffer. * tests/pk-crypto.scm ("sexp->canonical-sexp->sexp"): Add sample. --- guix/pk-crypto.scm | 9 ++++++++- tests/pk-crypto.scm | 5 ++++- 2 files changed, 12 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index cf18faea04..d5b3eeb350 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -319,7 +319,14 @@ use pattern matching." result)) '() sexp)) - (canonical-sexp->string sexp))) ; XXX: not very useful + + ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a + ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer. + (let ((sexp (string->canonical-sexp + (string-append "(" (canonical-sexp->string sexp) + ")")))) + (or (canonical-sexp-nth-data sexp 0) + (canonical-sexp-nth sexp 0))))) (define (sexp->canonical-sexp sexp) "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index de775d2e19..6774dd4157 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -203,7 +203,10 @@ (string-downcase "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45"))) (e ,(base16-string->bytevector - "010001"))))))) + "010001")))) + + ,(base16-string->bytevector + "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))) (test-equal "sexp->canonical-sexp->sexp" lst (map (compose canonical-sexp->sexp sexp->canonical-sexp) -- cgit v1.2.3 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'. --- doc/guix.texi | 22 ++++++++++++++ guix/pk-crypto.scm | 18 ++++++++++++ guix/pki.scm | 4 +++ guix/scripts/archive.scm | 74 +++++++++++++++++++++++++++++++++++++++++------- 4 files changed, 108 insertions(+), 10 deletions(-) (limited to 'guix') 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) @@ -52,6 +54,9 @@ Export/import one or more packages from/to the store.\n")) (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 @@ 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~%"))))))))))) -- cgit v1.2.3 From f82cc5fdbe62d835d884f2be2289c95da478da25 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Dec 2013 23:18:52 +0100 Subject: archive: Add '--authorize'. * guix/scripts/archive.scm (authorize-key): New procedure. (guix-archive): Call it when OPTS contains 'authorize-key'. * tests/guix-archive.sh: Add test with invalid public key. * guix/pki.scm: Export '%acl-file'. * doc/guix.texi (Invoking guix archive): Make it clear that '--import' works only with authorized keys. Document '--authorize'. --- doc/guix.texi | 20 ++++++++++++++++++-- guix/pki.scm | 1 + guix/scripts/archive.scm | 28 ++++++++++++++++++++++++++++ tests/guix-archive.sh | 3 +++ 4 files changed, 50 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index ec529346c7..9976024c06 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -942,7 +942,8 @@ Archives are stored in the ``Nix archive'' or ``Nar'' format, which is comparable in spirit to `tar'. When exporting, the daemon digitally signs the contents of the archive, and that digital signature is appended. When importing, the daemon verifies the signature and rejects -the import in case of an invalid signature. +the import in case of an invalid signature or if the signing key is not +authorized. @c FIXME: Add xref to daemon doc about signatures. The main options are: @@ -955,9 +956,11 @@ resulting archive to the standard output. @item --import 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. +signature, or if it is signed by a public key not among the authorized +keys (see @code{--authorize} below.) @item --generate-key[=@var{parameters}] +@cindex signing, archives 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 @@ -970,6 +973,19 @@ 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}). + +@item --authorize +@cindex authorizing, archives +Authorize imports signed by the public key passed on standard input. +The public key must be in ``s-expression advanced format''---i.e., the +same format as the @file{signing-key.pub} file. + +The list of authorized keys is kept in the human-editable file +@file{/etc/guix/acl}. The file contains +@url{http://people.csail.mit.edu/rivest/Sexp.txt, ``advanced-format +s-expressions''} and is structured as an access-control list in the +@url{http://theworld.com/~cme/spki.txt, Simple Public-Key Infrastructure +(SPKI)}. @end table To export store files as an archive to the standard output, run: diff --git a/guix/pki.scm b/guix/pki.scm index 759cd040e9..dc8139fbc9 100644 --- a/guix/pki.scm +++ b/guix/pki.scm @@ -24,6 +24,7 @@ #:use-module (rnrs io ports) #:export (%public-key-file %private-key-file + %acl-file current-acl public-keys->acl acl->public-keys diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index a9e4155393..66000435b4 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -32,6 +32,7 @@ #:use-module (srfi srfi-37) #:use-module (guix scripts build) #:use-module (guix scripts package) + #:use-module (rnrs io ports) #:export (guix-archive)) @@ -111,6 +112,9 @@ Export/import one or more packages from/to the store.\n")) (lambda args (leave (_ "invalid key generation parameters: ~s~%") arg))))) + (option '("authorize") #f #f + (lambda (opt name arg result) + (alist-cons 'authorize #t result))) (option '(#\S "source") #f #f (lambda (opt name arg result) @@ -256,6 +260,28 @@ this may take time...~%")) ;; Make the public key readable by everyone. (chmod %public-key-file #o444))) +(define (authorize-key) + "Authorize imports signed by the public key passed as an advanced sexp on +the input port." + (define (read-key) + (catch 'gcry-error + (lambda () + (string->canonical-sexp (get-string-all (current-input-port)))) + (lambda (key err) + (leave (_ "failed to read public key: ~a: ~a~%") + (error-source err) (error-string err))))) + + (let ((key (read-key)) + (acl (current-acl))) + (unless (eq? 'public-key (canonical-sexp-nth-data key 0)) + (leave (_ "s-expression does not denote a public key~%"))) + + ;; Add KEY to the ACL and write that. + (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) + (with-atomic-file-output %acl-file + (lambda (port) + (display (canonical-sexp->string acl) port)))))) + (define (guix-archive . args) (define (parse-options) ;; Return the alist of option values. @@ -274,6 +300,8 @@ this may take time...~%")) (cond ((assoc-ref opts 'generate-key) => generate-key-pair) + ((assoc-ref opts 'authorize) + (authorize-key)) (else (let ((store (open-connection))) (cond ((assoc-ref opts 'export) diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh index ef04835469..3ac618ae33 100644 --- a/tests/guix-archive.sh +++ b/tests/guix-archive.sh @@ -43,3 +43,6 @@ guix archive --import < "$archive" 2>&1 | grep "import.*guile-bootstrap" if guix archive something-that-does-not-exist then false; else true; fi + +if echo foo | guix archive --authorize +then false; else true; fi -- cgit v1.2.3 From 1a43e4dc572c49e01380c86cdf09934aa0560917 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Jan 2014 22:42:42 +0100 Subject: guix package: Gracefully deal with EPIPE on stdout for --list-*. * guix/scripts/package.scm (leave-on-EPIPE): New macro. (guix-package): Use it for 'list-installed', 'list-available', and '--list-generations'. * tests/guix-package.sh: Add test. --- guix/scripts/package.scm | 68 +++++++++++++++++++++++++++++++----------------- tests/guix-package.sh | 9 ++++++- 2 files changed, 52 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7cebf6b4d4..c12ddcd8c9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013 Mark H Weaver ;;; @@ -293,6 +293,22 @@ return its return value." (format (current-error-port) " interrupted by signal ~a~%" SIGINT) #f)))) +(define-syntax-rule (leave-on-EPIPE exp ...) + "Run EXP... in a context when EPIPE errors are caught and lead to 'exit' +with successful exit code. This is useful when writing to the standard output +may lead to EPIPE, because the standard output is piped through 'head' or +similar." + (catch 'system-error + (lambda () + exp ...) + (lambda args + ;; We really have to exit this brutally, otherwise Guile eventually + ;; attempts to flush all the ports, leading to an uncaught EPIPE down + ;; the path. + (if (= EPIPE (system-error-errno args)) + (primitive-_exit 0) + (apply throw args))))) + (define* (specification->package+output spec #:optional (output "out")) "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: @@ -958,15 +974,17 @@ more information.~%")) profile)) ((string-null? pattern) (let ((numbers (generation-numbers profile))) - (if (equal? numbers '(0)) - (exit 0) - (for-each list-generation numbers)))) + (leave-on-EPIPE + (if (equal? numbers '(0)) + (exit 0) + (for-each list-generation numbers))))) ((matching-generations pattern profile) => (lambda (numbers) (if (null-list? numbers) (exit 1) - (for-each list-generation numbers)))) + (leave-on-EPIPE + (for-each list-generation numbers))))) (else (leave (_ "invalid syntax: ~a~%") pattern))) @@ -976,15 +994,16 @@ more information.~%")) (let* ((regexp (and regexp (make-regexp regexp))) (manifest (profile-manifest profile)) (installed (manifest-entries manifest))) - (for-each (match-lambda - (($ name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - - ;; Show most recently installed packages last. - (reverse installed)) + (leave-on-EPIPE + (for-each (match-lambda + (($ name version output path _) + (when (or (not regexp) + (regexp-exec regexp name)) + (format #t "~a\t~a\t~a\t~a~%" + name (or version "?") output path)))) + + ;; Show most recently installed packages last. + (reverse installed))) #t)) (('list-available regexp) @@ -998,16 +1017,17 @@ more information.~%")) r) (cons p r)))) '()))) - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) - (sort available - (lambda (p1 p2) - (stringstring (package-location p)))) + (sort available + (lambda (p1 p2) + (string +# Copyright © 2012, 2013, 2014 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # This file is part of GNU Guix. @@ -218,3 +218,10 @@ done # Extraneous argument. if guix package install foo-bar; then false; else true; fi + +# Make sure the "broken pipe" doesn't yield an error. +# Note: 'pipefail' is a Bash-specific option. +set -o pipefail || true +guix package -A g | head -1 2> "$HOME/err1" +guix package -I | head -1 2> "$HOME/err2" +test "`cat "$HOME/err1" "$HOME/err2"`" = "" -- cgit v1.2.3 From 425b0bfc2ed60163d1b3dad5c6361dea511ba596 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 5 Jan 2014 22:58:32 +0100 Subject: guix build: Add '--no-build-hook'. * guix/scripts/build.scm (%default-options): Add 'build-hook?' pair. (show-help, %options): Add --no-build-hook. (guix-build): Pass the 'build-hook?' value to 'set-build-options'. * doc/guix.texi (Invoking guix build): Document '--no-build-hook'. --- doc/guix.texi | 8 +++++++- guix/scripts/build.scm | 10 +++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 9976024c06..d5884008f4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10,7 +10,7 @@ @include version.texi @copying -Copyright @copyright{} 2012, 2013 Ludovic Courtès@* +Copyright @copyright{} 2012, 2013, 2014 Ludovic Courtès@* Copyright @copyright{} 2013 Andreas Enge@* Copyright @copyright{} 2013 Nikita Karetnikov @@ -1655,6 +1655,12 @@ packages locally. Do not use substitutes for build products. That is, always build things locally instead of allowing downloads of pre-built binaries. +@item --no-build-hook +Do not attempt to offload builds @i{via} the daemon's ``build hook''. +That is, always build things locally instead of offloading builds to +remote machines. +@c TODO: Add xref to build hook doc. + @item --max-silent-time=@var{seconds} When the build or substitution process remains silent for more than @var{seconds}, terminate it and report a build failure. diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 90187094c1..7cb3710853 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -108,6 +108,7 @@ present, return the preferred newest version." ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -132,6 +133,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) --fallback fall back to building when the substituter fails")) (display (_ " --no-substitutes build instead of resorting to pre-built substitutes")) + (display (_ " + --no-build-hook do not attempt to offload builds via the build hook")) (display (_ " --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) @@ -199,6 +202,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (alist-cons 'substitutes? #f (alist-delete 'substitutes? result)))) + (option '("no-build-hook") #f #f + (lambda (opt name arg result) + (alist-cons 'build-hook? #f + (alist-delete 'build-hook? result)))) (option '("max-silent-time") #t #f (lambda (opt name arg result) (alist-cons 'max-silent-time (string->number* arg) @@ -283,6 +290,7 @@ build." #:build-cores (or (assoc-ref opts 'cores) 0) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) + #:use-build-hook? (assoc-ref opts 'build-hook?) #:max-silent-time (assoc-ref opts 'max-silent-time) #:verbosity (assoc-ref opts 'verbosity)) -- cgit v1.2.3 From 590e4154b683b5efc53269b1c493f48e3d862f48 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 5 Jan 2014 23:40:06 +0100 Subject: archive: Make sure $sysconfdir/guix exists. * guix/pki.scm (ensure-acl): Make sure the directory of %ACL-FILE exists. * guix/scripts/archive.scm (generate-key-pair): Likewise for %PUBLIC-KEY-FILE. --- guix/pki.scm | 4 +++- guix/scripts/archive.scm | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/pki.scm b/guix/pki.scm index dc8139fbc9..5e4dbadd35 100644 --- a/guix/pki.scm +++ b/guix/pki.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix config) #:use-module (guix pk-crypto) #:use-module ((guix utils) #:select (with-atomic-file-output)) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 match) #:use-module (rnrs io ports) #:export (%public-key-file @@ -82,6 +83,7 @@ element in KEYS must be a canonical sexp with type 'public-key'." (let ((public-key (call-with-input-file %public-key-file (compose string->canonical-sexp get-string-all)))) + (mkdir-p (dirname %acl-file)) (with-atomic-file-output %acl-file (lambda (port) (display (canonical-sexp->string diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 66000435b4..3b778d8151 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,7 @@ (define-module (guix scripts archive) #:use-module (guix config) #:use-module (guix utils) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix store) #:use-module (guix packages) #:use-module (guix derivations) @@ -250,6 +251,7 @@ this may take time...~%")) ;; Create the following files as #o400. (umask #o266) + (mkdir-p (dirname %public-key-file)) (with-atomic-file-output %public-key-file (lambda (port) (display (canonical-sexp->string public) port))) -- cgit v1.2.3 From 87236aed77bd57ecd143d84acf864fb112842118 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Jan 2014 22:25:29 +0100 Subject: archive: Add '--missing'. * guix/scripts/archive.scm (show-help, %options): Add '--missing'. (guix-archive)[lines]: New procedure. Use it to honor '--missing'. * tests/guix-archive.sh: Add tests. * doc/guix.texi (Invoking guix archive): Document '--missing'. --- doc/guix.texi | 11 +++++++++++ guix/scripts/archive.scm | 21 +++++++++++++++++++++ tests/guix-archive.sh | 20 +++++++++++++++++++- 3 files changed, 51 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index d5884008f4..93d1c2be3b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -938,6 +938,12 @@ package to a machine connected over SSH, one would run: guix archive --export emacs | ssh the-machine guix archive --import @end example +@noindent +However, note that, in this example, all of @code{emacs} and its +dependencies are transferred, regardless of what is already available in +the target machine's store. The @code{--missing} option can help figure +out which items are missing from the target's store. + Archives are stored in the ``Nix archive'' or ``Nar'' format, which is comparable in spirit to `tar'. When exporting, the daemon digitally signs the contents of the archive, and that digital signature is @@ -959,6 +965,11 @@ therein into the store. Abort if the archive has an invalid digital signature, or if it is signed by a public key not among the authorized keys (see @code{--authorize} below.) +@item --missing +Read a list of store file names from the standard input, one per line, +and write on the standard output the subset of these files missing from +the store. + @item --generate-key[=@var{parameters}] @cindex signing, archives Generate a new key pair for the daemons. This is a prerequisite before diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 3b778d8151..32690c6b45 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -27,6 +27,8 @@ #:use-module (guix pki) #:use-module (guix pk-crypto) #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -55,6 +57,8 @@ Export/import one or more packages from/to the store.\n")) --export export the specified files/packages to stdout")) (display (_ " --import import from the archive passed on stdin")) + (display (_ " + --missing print the files from stdin that are missing")) (newline) (display (_ " --generate-key[=PARAMETERS] @@ -102,6 +106,9 @@ 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 '("missing") #f #f + (lambda (opt name arg result) + (alist-cons 'missing #t result))) (option '("generate-key") #f #t (lambda (opt name arg result) (catch 'gcry-error @@ -294,6 +301,15 @@ the input port." (alist-cons 'argument arg result)) %default-options)) + (define (lines port) + ;; Return lines read from PORT. + (let loop ((line (read-line port)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line port) + (cons line result))))) + (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. @@ -310,6 +326,11 @@ the input port." (export-from-store store opts)) ((assoc-ref opts 'import) (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) (else (leave (_ "either '--export' or '--import' \ diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh index 3ac618ae33..0de7395145 100644 --- a/tests/guix-archive.sh +++ b/tests/guix-archive.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013 Ludovic Courtès +# Copyright © 2013, 2014 Ludovic Courtès # # This file is part of GNU Guix. # @@ -44,5 +44,23 @@ guix archive --import < "$archive" 2>&1 | grep "import.*guile-bootstrap" if guix archive something-that-does-not-exist then false; else true; fi +# This one must not be listed as missing. +guix build guile-bootstrap > "$archive" +guix archive --missing < "$archive" +test "`guix archive --missing < "$archive"`" = "" + +# Two out of three should be listed as missing. +echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" >> "$archive" +echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive" +guix archive --missing < "$archive" > "$archive_alt" +echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" > "$archive" +echo "$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar" >> "$archive" +cmp "$archive" "$archive_alt" + +# This is not a valid store file name, so an error. +echo something invalid > "$archive" +if guix archive --missing < "$archive" +then false; else true; fi + if echo foo | guix archive --authorize then false; else true; fi -- cgit v1.2.3 From 021a201f2967e5a5afdabb03148f225f94c58403 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Jan 2014 19:23:33 +0100 Subject: store: Fix 'log-file' to support uncompressed logs. * guix/store.scm (log-file): Report the file without '.bz2' if it exists. --- guix/store.scm | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 4ceca0daa2..159b5dc396 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -753,12 +753,15 @@ must be an absolute store file name, or a derivation file name." (or (getenv "NIX_STATE_DIR") %state-directory)) (cond ((derivation-path? file) - (let* ((base (basename file)) - (log (string-append (dirname state-dir) ; XXX: ditto - "/log/nix/drvs/" - (string-take base 2) "/" - (string-drop base 2) ".bz2"))) - (and (file-exists? log) log))) + (let* ((base (basename file)) + (log (string-append (dirname state-dir) ; XXX: ditto + "/log/nix/drvs/" + (string-take base 2) "/" + (string-drop base 2))) + (log.bz2 (string-append log ".bz2"))) + (cond ((file-exists? log.bz2) log.bz2) + ((file-exists? log) log) + (else #f)))) (else (match (valid-derivers store file) ((derivers ...) -- cgit v1.2.3 From 80d0447c9556f06decc80a2d43c2fa8402406d91 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Jan 2014 21:12:55 +0100 Subject: config: '%state-directory' always honors $NIX_STATE_DIR. * guix/config.scm.in (%state-directory): Honor $NIX_STATE_DIR. * guix/scripts/package.scm (%profile-directory): Use %state-directory directly. * guix/store.scm (%default-socket-path, log-file): Likewise. --- guix/config.scm.in | 4 ++-- guix/scripts/package.scm | 2 +- guix/store.scm | 8 ++------ 3 files changed, 5 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/config.scm.in b/guix/config.scm.in index 4835c6e5d9..0833faef40 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,7 +55,7 @@ (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `daemon.am'. - "@guix_localstatedir@/nix") + (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/nix")) (define %config-directory ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c12ddcd8c9..04393abc9a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -57,7 +57,7 @@ (cut string-append <> "/.guix-profile"))) (define %profile-directory - (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" + (string-append %state-directory "/profiles/" (or (and=> (getenv "USER") (cut string-append "per-user/" <>)) "default"))) diff --git a/guix/store.scm b/guix/store.scm index 159b5dc396..7715a15644 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -158,8 +158,7 @@ (delete-specific 3)) (define %default-socket-path - (string-append (or (getenv "NIX_STATE_DIR") %state-directory) - "/daemon-socket/socket")) + (string-append %state-directory "/daemon-socket/socket")) (define %daemon-socket-file ;; File name of the socket the daemon listens too. @@ -749,12 +748,9 @@ syntactically valid store path." (define (log-file store file) "Return the build log file for FILE, or #f if none could be found. FILE must be an absolute store file name, or a derivation file name." - (define state-dir ; XXX: factorize - (or (getenv "NIX_STATE_DIR") %state-directory)) - (cond ((derivation-path? file) (let* ((base (basename file)) - (log (string-append (dirname state-dir) ; XXX: ditto + (log (string-append (dirname %state-directory) ; XXX "/log/nix/drvs/" (string-take base 2) "/" (string-drop base 2))) -- cgit v1.2.3 From 1d6816f98ca1746f0b627a6dee9c0adbbf7533c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Jan 2014 21:37:06 +0100 Subject: config: '%store-directory' always honors $NIX_STORE_DIR. * guix/config.scm.in (%store-directory): Honor $NIX_STORE_DIR. * guix/store.scm (%store-prefix): Use %store-directory directly. --- guix/config.scm.in | 3 ++- guix/store.scm | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/config.scm.in b/guix/config.scm.in index 0833faef40..3a5c50e00a 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -51,7 +51,8 @@ "@PACKAGE_URL@") (define %store-directory - "@storedir@") + (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) + "@storedir@")) (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `daemon.am'. diff --git a/guix/store.scm b/guix/store.scm index 7715a15644..1012480b39 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -701,8 +701,7 @@ is true." (define %store-prefix ;; Absolute path to the Nix store. - (make-parameter (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) - %store-directory))) + (make-parameter %store-directory)) (define (store-path? path) "Return #t if PATH is a store path." -- cgit v1.2.3