aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-01-22 17:09:21 +0100
committerLudovic Courtès <ludo@gnu.org>2014-01-24 00:01:50 +0100
commitcd4027fa478e20b59e798dd163a54e7ff9c42c98 (patch)
tree5e8345f9800d039432fb98560ebd66a46d9eb024
parentce4a482983abaf7090d098cdda973139cefb56b7 (diff)
downloadguix-cd4027fa478e20b59e798dd163a54e7ff9c42c98.tar
guix-cd4027fa478e20b59e798dd163a54e7ff9c42c98.tar.gz
nar: Add 'restore-file-set', for use by build hooks.
* guix/nar.scm (&nar-invalid-hash-error, &nar-signature-error): New condition types. (&nar-error): Add 'file' and 'port' fields. (&nar-read-error): Remove 'port' and 'file' fields. (lock-store-file, unlock-store-file, finalize-store-file, temporary-store-directory, restore-file-set): New procedures. * tests/nar.scm (%seed): New variable. (random-text): New procedure. ("restore-file-set (signed, valid)", "restore-file-set (missing signature)", "restore-file-set (corrupt)"): New tests. * po/Makevars (XGETTEXT_OPTIONS): Add '--keyword=message'.nar fixes * po/POTFILES.in: Add guix/nar.scm.
-rw-r--r--guix/nar.scm229
-rw-r--r--po/Makevars13
-rw-r--r--po/POTFILES.in1
-rw-r--r--tests/nar.scm103
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")