diff options
| -rw-r--r-- | guix/nar.scm | 229 | ||||
| -rw-r--r-- | po/Makevars | 13 | ||||
| -rw-r--r-- | po/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/nar.scm | 103 |
4 files changed, 332 insertions, 14 deletions
diff --git a/guix/nar.scm b/guix/nar.scm index ea119a25fe..4bc2deb229 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,23 +19,40 @@ (define-module (guix nar) #:use-module (guix utils) #:use-module (guix serialization) - #:use-module ((guix build utils) #:select (with-directory-excursion)) + #:use-module ((guix build utils) + #:select (delete-file-recursively with-directory-excursion)) + #:use-module (guix store) + #:use-module (guix ui) ; for '_' + #:use-module (guix hash) + #:use-module (guix pki) + #:use-module (guix pk-crypto) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:export (nar-error? + nar-error-port + nar-error-file + nar-read-error? - nar-read-error-file - nar-read-error-port nar-read-error-token + nar-invalid-hash-error? + nar-invalid-hash-error-expected + nar-invalid-hash-error-actual + + nar-signature-error? + nar-signature-error-signature + write-file - restore-file)) + restore-file + + restore-file-set)) ;;; Comment: ;;; @@ -44,15 +61,24 @@ ;;; Code: (define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? - nar-error?) + nar-error? + (file nar-error-file) ; file we were restoring, or #f + (port nar-error-port)) ; port from which we read (define-condition-type &nar-read-error &nar-error nar-read-error? - (port nar-read-error-port) ; port from which we read - (file nar-read-error-file) ; file we were restoring, or #f (token nar-read-error-token)) ; faulty token, or #f +(define-condition-type &nar-signature-error &nar-error + nar-signature-error? + (signature nar-signature-error-signature)) ; faulty signature or #f +(define-condition-type &nar-invalid-hash-error &nar-signature-error + nar-invalid-hash-error? + (expected nar-invalid-hash-error-expected) ; expected hash (a bytevector) + (actual nar-invalid-hash-error-actual)) ; actual hash + + (define (dump in out size) "Copy SIZE bytes from IN to OUT." (define buf-size 65536) @@ -239,4 +265,191 @@ Restore it as FILE." (&message (message "unsupported nar entry type")) (&nar-read-error (port port) (file file) (token x)))))))) + +;;; +;;; Restoring a file set into the store. +;;; + +;; The code below accesses the store directly and is meant to be run from +;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since +;; (1) the locks on the files to be restored as already held, and (2) the +;; $NIX_HELD_LOCKS hackish environment variable cannot be set. +;; +;; So we're really duplicating that functionality of the daemon (well, until +;; most of the daemon is in Scheme :-)). But note that we do use a couple of +;; RPCs for functionality not available otherwise, like 'valid-path?'. + +(define (lock-store-file file) + "Acquire exclusive access to FILE, a store file." + (call-with-output-file (string-append file ".lock") + (cut fcntl-flock <> 'write-lock))) + +(define (unlock-store-file file) + "Release access to FILE." + (call-with-input-file (string-append file ".lock") + (cut fcntl-flock <> 'unlock))) + +(define* (finalize-store-file source target + #:key (references '()) deriver (lock? #t)) + "Rename SOURCE to TARGET and register TARGET as a valid store item, with +REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET +before attempting to register it; otherwise, assume TARGET's locks are already +held." + + ;; XXX: Currently we have to call out to the daemon to check whether TARGET + ;; is valid. + (with-store store + (unless (valid-path? store target) + (when lock? + (lock-store-file target)) + + (unless (valid-path? store target) + ;; If FILE already exists, delete it (it's invalid anyway.) + (when (file-exists? target) + (delete-file-recursively target)) + + ;; Install the new TARGET. + (rename-file source target) + + ;; Register TARGET. As a side effect, it resets the timestamps of all + ;; its files, recursively. However, it doesn't attempt to deduplicate + ;; its files like 'importPaths' does (FIXME). + (register-path target + #:references references + #:deriver deriver)) + + (when lock? + (unlock-store-file target))))) + +(define (temporary-store-directory) + "Return the file name of a temporary directory created in the store that is +protected from garbage collection." + (let* ((template (string-append (%store-prefix) "/guix-XXXXXX")) + (port (mkstemp! template))) + (close-port port) + (with-store store + (add-temp-root store template)) + + ;; There's a small window during which the GC could delete the file. Try + ;; again if that happens. + (if (file-exists? template) + (begin + ;; It's up to the caller to create that file or directory. + (delete-file template) + template) + (temporary-store-directory)))) + +(define* (restore-file-set port + #:key (verify-signature? #t) (lock? #t) + (log-port (current-error-port))) + "Restore the file set read from PORT to the store. The format of the data +on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted +archives with interspersed meta-data joining them together, possibly with a +digital signature at the end. Log progress to LOG-PORT. Return the list of +files restored. + +When LOCK? is #f, assume locks for the files to be restored are already held. +This is the case when the daemon calls a build hook. + +Note that this procedure accesses the store directly, so it's only meant to be +used by the daemon's build hooks since they cannot call back to the daemon +while the locks are held." + (define %export-magic + ;; Number used to identify genuine file set archives. + #x4558494e) + + (define port* + ;; Keep that one around, for error conditions. + port) + + (define (assert-valid-signature signature hash file) + ;; Bail out if SIGNATURE, an sexp, doesn't match HASH, a bytevector + ;; containing the expected hash for FILE. + (let* ((signature (catch 'gcry-error + (lambda () + (string->canonical-sexp signature)) + (lambda (err . _) + (raise (condition + (&message + (message "signature is not a valid \ +s-expression")) + (&nar-signature-error + (file file) + (signature signature) (port port))))))) + (subject (signature-subject signature)) + (data (signature-signed-data signature))) + (if (and data subject) + (if (authorized-key? subject) + (if (equal? (hash-data->bytevector data) hash) + (unless (valid-signature? signature) + (raise (condition + (&message (message "invalid signature")) + (&nar-signature-error + (file file) (signature signature) (port port))))) + (raise (condition (&message (message "invalid hash")) + (&nar-invalid-hash-error + (port port) (file file) + (signature signature) + (expected (hash-data->bytevector data)) + (actual hash))))) + (raise (condition (&message (message "unauthorized public key")) + (&nar-signature-error + (signature signature) (file file) (port port))))) + (raise (condition + (&message (message "corrupt signature data")) + (&nar-signature-error + (signature signature) (file file) (port port))))))) + + (let loop ((n (read-long-long port)) + (files '())) + (case n + ((0) + (reverse files)) + ((1) + (let-values (((port get-hash) + (open-sha256-input-port port))) + (let ((temp (temporary-store-directory))) + (restore-file port temp) + (let ((magic (read-int port))) + (unless (= magic %export-magic) + (raise (condition + (&message (message "corrupt file set archive")) + (&nar-read-error + (port port*) (file #f) (token #f)))))) + + (let ((file (read-store-path port)) + (refs (read-store-path-list port)) + (deriver (read-string port)) + (hash (get-hash)) + (has-sig? (= 1 (read-int port)))) + (format log-port + (_ "importing file or directory '~a'...~%") + file) + + (let ((sig (and has-sig? (read-string port)))) + (when verify-signature? + (if sig + (begin + (assert-valid-signature sig hash file) + (format log-port + (_ "found valid signature for '~a'~%") + file) + (finalize-store-file temp file + #:references refs + #:deriver deriver + #:lock? lock?) + (loop (read-long-long port) + (cons file files))) + (raise (condition + (&message (message "imported file lacks \ +a signature")) + (&nar-signature-error + (port port*) (file file) (signature #f))))))))))) + (else + ;; Neither 0 nor 1. + (raise (condition + (&message (message "invalid inter-file archive mark")) + (&nar-read-error + (port port) (file #f) (token #f)))))))) + ;;; nar.scm ends here diff --git a/po/Makevars b/po/Makevars index 81fd53ef2c..ade615a452 100644 --- a/po/Makevars +++ b/po/Makevars @@ -5,11 +5,14 @@ DOMAIN = $(PACKAGE) subdir = po top_builddir = .. -# These options get passed to xgettext. -XGETTEXT_OPTIONS = \ - --language=Scheme --from-code=UTF-8 \ - --keyword=_ --keyword=N_ \ - --keyword=synopsis --keyword=description +# These options get passed to xgettext. We want to catch standard +# gettext uses, package synopses and descriptions, and SRFI-34 error +# condition messages. +XGETTEXT_OPTIONS = \ + --language=Scheme --from-code=UTF-8 \ + --keyword=_ --keyword=N_ \ + --keyword=synopsis --keyword=description \ + --keyword=message COPYRIGHT_HOLDER = Ludovic Courtès diff --git a/po/POTFILES.in b/po/POTFILES.in index beefdc901b..b329f21e92 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -15,3 +15,4 @@ guix/scripts/authenticate.scm guix/gnu-maintenance.scm guix/ui.scm guix/http-client.scm +guix/nar.scm diff --git a/tests/nar.scm b/tests/nar.scm index 6493d76876..9f21f990c8 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,11 +18,17 @@ (define-module (test-nar) #:use-module (guix nar) + #:use-module (guix store) + #:use-module ((guix hash) #:select (open-sha256-input-port)) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (ice-9 ftw) + #:use-module (ice-9 regex) #:use-module (ice-9 match)) ;; Test the (guix nar) module. @@ -156,6 +162,24 @@ (string-append (dirname (search-path %load-path "pre-inst-env")) "/test-nar-" (number->string (getpid)))) +;; XXX: Factorize. +(define %seed + (seed->random-state (logxor (getpid) (car (gettimeofday))))) + +(define (random-text) + (number->string (random (expt 2 256) %seed) 16)) + +(define-syntax-rule (let/ec k exp...) + ;; This one appeared in Guile 2.0.9, so provide a copy here. + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (let ((k (lambda args + (apply abort-to-prompt tag args)))) + exp...)) + (lambda (_ . args) + (apply values args))))) + (test-begin "nar") @@ -201,6 +225,83 @@ (lambda () (rmdir input))))) +;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn +;; relies on a Guile 2.0.10+ feature. +(test-skip (if (false-if-exception + (open-sha256-input-port (%make-void-port "r"))) + 0 + 3)) + +(test-assert "restore-file-set (signed, valid)" + (with-store store + (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 (restore-file-set source))) + (and (equal? imported files) + (every (lambda (file) + (and (file-exists? file) + (valid-path? store file))) + files) + (equal? texts + (map (lambda (file) + (call-with-input-file file + get-string-all)) + files)))))))) + +(test-assert "restore-file-set (missing signature)" + (let/ec return + (with-store store + (let* ((file (add-text-to-store store "foo" "Hello, world!")) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <> + #:sign? #f)))) + (delete-paths store (list file)) + (and (not (file-exists? file)) + (let ((source (open-bytevector-input-port dump))) + (guard (c ((nar-signature-error? c) + (let ((message (condition-message c)) + (port (nar-error-port c))) + (return + (and (string-match "lacks.*signature" message) + (string=? file (nar-error-file c)) + (eq? source port)))))) + (restore-file-set source)) + #f)))))) + +(test-assert "restore-file-set (corrupt)" + (let/ec return + (with-store store + (let* ((file (add-text-to-store store "foo" + (random-text))) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <>)))) + (delete-paths store (list file)) + + ;; Flip a byte in the file contents. + (let* ((index 120) + (byte (bytevector-u8-ref dump index))) + (bytevector-u8-set! dump index (logxor #xff byte))) + + (and (not (file-exists? file)) + (let ((source (open-bytevector-input-port dump))) + (guard (c ((nar-invalid-hash-error? c) + (let ((message (condition-message c)) + (port (nar-error-port c))) + (return + (and (string-contains message "hash") + (string=? file (nar-error-file c)) + (eq? source port)))))) + (restore-file-set source)) + #f)))))) + (test-end "nar") |