mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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.
This commit is contained in:
parent
ce4a482983
commit
cd4027fa47
4 changed files with 332 additions and 14 deletions
229
guix/nar.scm
229
guix/nar.scm
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; 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.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -19,23 +19,40 @@
|
||||||
(define-module (guix nar)
|
(define-module (guix nar)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix serialization)
|
#: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 bytevectors)
|
||||||
#:use-module (rnrs io ports)
|
#:use-module (rnrs io ports)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
#:use-module (ice-9 ftw)
|
#:use-module (ice-9 ftw)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:export (nar-error?
|
#:export (nar-error?
|
||||||
|
nar-error-port
|
||||||
|
nar-error-file
|
||||||
|
|
||||||
nar-read-error?
|
nar-read-error?
|
||||||
nar-read-error-file
|
|
||||||
nar-read-error-port
|
|
||||||
nar-read-error-token
|
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
|
write-file
|
||||||
restore-file))
|
restore-file
|
||||||
|
|
||||||
|
restore-file-set))
|
||||||
|
|
||||||
;;; Comment:
|
;;; Comment:
|
||||||
;;;
|
;;;
|
||||||
|
@ -44,15 +61,24 @@ (define-module (guix nar)
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ?
|
(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
|
(define-condition-type &nar-read-error &nar-error
|
||||||
nar-read-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
|
(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)
|
(define (dump in out size)
|
||||||
"Copy SIZE bytes from IN to OUT."
|
"Copy SIZE bytes from IN to OUT."
|
||||||
(define buf-size 65536)
|
(define buf-size 65536)
|
||||||
|
@ -239,4 +265,191 @@ (define (read-eof-marker)
|
||||||
(&message (message "unsupported nar entry type"))
|
(&message (message "unsupported nar entry type"))
|
||||||
(&nar-read-error (port port) (file file) (token x))))))))
|
(&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
|
;;; nar.scm ends here
|
||||||
|
|
|
@ -5,11 +5,14 @@ DOMAIN = $(PACKAGE)
|
||||||
subdir = po
|
subdir = po
|
||||||
top_builddir = ..
|
top_builddir = ..
|
||||||
|
|
||||||
# These options get passed to xgettext.
|
# 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 = \
|
XGETTEXT_OPTIONS = \
|
||||||
--language=Scheme --from-code=UTF-8 \
|
--language=Scheme --from-code=UTF-8 \
|
||||||
--keyword=_ --keyword=N_ \
|
--keyword=_ --keyword=N_ \
|
||||||
--keyword=synopsis --keyword=description
|
--keyword=synopsis --keyword=description \
|
||||||
|
--keyword=message
|
||||||
|
|
||||||
COPYRIGHT_HOLDER = Ludovic Courtès
|
COPYRIGHT_HOLDER = Ludovic Courtès
|
||||||
|
|
||||||
|
|
|
@ -15,3 +15,4 @@ guix/scripts/authenticate.scm
|
||||||
guix/gnu-maintenance.scm
|
guix/gnu-maintenance.scm
|
||||||
guix/ui.scm
|
guix/ui.scm
|
||||||
guix/http-client.scm
|
guix/http-client.scm
|
||||||
|
guix/nar.scm
|
||||||
|
|
103
tests/nar.scm
103
tests/nar.scm
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; 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.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -18,11 +18,17 @@
|
||||||
|
|
||||||
(define-module (test-nar)
|
(define-module (test-nar)
|
||||||
#:use-module (guix 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 bytevectors)
|
||||||
#:use-module (rnrs io ports)
|
#:use-module (rnrs io ports)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (srfi srfi-34)
|
||||||
|
#:use-module (srfi srfi-35)
|
||||||
#:use-module (srfi srfi-64)
|
#:use-module (srfi srfi-64)
|
||||||
#:use-module (ice-9 ftw)
|
#:use-module (ice-9 ftw)
|
||||||
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (ice-9 match))
|
#:use-module (ice-9 match))
|
||||||
|
|
||||||
;; Test the (guix nar) module.
|
;; Test the (guix nar) module.
|
||||||
|
@ -156,6 +162,24 @@ (define %test-dir
|
||||||
(string-append (dirname (search-path %load-path "pre-inst-env"))
|
(string-append (dirname (search-path %load-path "pre-inst-env"))
|
||||||
"/test-nar-" (number->string (getpid))))
|
"/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")
|
(test-begin "nar")
|
||||||
|
|
||||||
|
@ -201,6 +225,83 @@ (define %test-dir
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(rmdir input)))))
|
(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")
|
(test-end "nar")
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue