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.

4 files changed, 332 insertions, 14 deletions

diff --git a/guix/nar.scm b/guix/nar.scm
index ea119a25fe1..4bc2deb2299 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 81fd53ef2cb..ade615a4523 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 beefdc901b8..b329f21e927 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 6493d76876f..9f21f990c82 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")