me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2014-01-22 17:09:21 +01:00
parent ce4a482983
commit cd4027fa47
4 changed files with 332 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

229
guix/nar.scm
View File

@ -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

7
po/Makevars
View File

@ -5,11 +5,14 @@ DOMAIN = $(PACKAGE)
subdir = po
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 = \
--language=Scheme --from-code=UTF-8 \
--keyword=_ --keyword=N_ \
--keyword=synopsis --keyword=description
--keyword=synopsis --keyword=description \
--keyword=message
COPYRIGHT_HOLDER = Ludovic Courtès

1
po/POTFILES.in
View File

@ -15,3 +15,4 @@ guix/scripts/authenticate.scm
guix/gnu-maintenance.scm
guix/ui.scm
guix/http-client.scm
guix/nar.scm

103
tests/nar.scm
View File

@ -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")