;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <firstname.lastname@example.org>
;;; Copyright © 2014 Mark H Weaver <email@example.com>
;;; This file is part of GNU Guix.
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix nar)
#:use-module (guix serialization)
#:use-module (guix build syscalls)
#:use-module ((guix build utils)
#:select (delete-file-recursively with-directory-excursion))
;; XXX: Eventually we should use (guix store database) exclusively, and not
;; (guix store) since this is "daemon-side" code.
#:use-module (guix store)
#:use-module (guix store database)
#:use-module ((guix build store-copy) #:select (store-info))
#:use-module (guix i18n)
#:use-module (gcrypt hash)
#:use-module (guix pki)
#:use-module (gcrypt pk-crypto)
#: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)
;;; Read and write Nix archives, aka. ‘nar’.
(define-condition-type &nar-signature-error &nar-error
(signature nar-signature-error-signature)) ; faulty signature or #f
(define-condition-type &nar-invalid-hash-error &nar-signature-error
(expected nar-invalid-hash-error-expected) ; expected hash (a bytevector)
(actual nar-invalid-hash-error-actual)) ; actual hash
;;; 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* (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
;; TODO: make this reusable
(define (acquire-lock file)
(let ((port (lock-file file)))
;; There is an inherent race condition between opening the lock file and
;; attempting to acquire the lock on it, and because we like deleting
;; these lock files when we release them, only the first successful
;; acquisition on a given lock file matters. To make it easier to tell
;; when an acquisition is and isn't the first, the first to acquire it
;; writes a deletion token (arbitrary character) prior to releasing the
(if (zero? (stat:size (stat port)))
;; if FILE is non-empty, that's because it contains the deletion
;; token, so we aren't the first to acquire it. So try again!
(with-database %default-database-file db
(unless (path-id db target)
(let ((lock (and lock?
(acquire-lock (string-append target ".lock")))))
(unless (path-id db target)
;; If FILE already exists, delete it (it's invalid anyway.)
(when (file-exists? target)
;; Install the new TARGET.
(rename-file source target)
;; Register TARGET. As a side effect, it resets the timestamps of all
;; its files, recursively, and runs a deduplication pass.
(list (store-info target deriver references))))
(delete-file (string-append target ".lock"))
;; Write the deletion token to inform anyone who acquires the lock
;; on this particular file next that they aren't the first to
;; acquire it, so they should retry.
(display "d" lock)
"Return the file name of a temporary file created in the store."
(let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
(port (mkstemp! template)))
(define-syntax-rule (with-temporary-store-file name body ...)
"Evaluate BODY with NAME bound to the file name of a temporary store item
protected from GC."
(let loop ((name (temporary-store-file)))
;; Add NAME to the current process' roots. (Opening this connection to
;; the daemon allows us to reuse its code that deals with the
;; per-process roots file.)
(add-temp-root store name)
;; There's a window during which GC could delete NAME. Try again when
;; that happens.
(if (file-exists? name)
(define* (restore-one-item port
#:key acl (verify-signature? #t) (lock? #t)
"Restore one store item from PORT; return its file name on success."
(define (assert-valid-signature signature hash file)
;; Bail out if SIGNATURE, which must be a string as produced by
;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
;; the expected hash for FILE.
(let ((signature (catch 'gcry-error
(lambda (key proc err)
(message "signature is not a valid \
(signature signature) (port port))))))))
(signature-case (signature hash (current-acl))
(&message (message "invalid signature"))
(file file) (signature signature) (port port)))))
(raise (condition (&message (message "invalid hash"))
(port port) (file file)
(raise (condition (&message (message "unauthorized public key"))
(signature signature) (file file) (port port)))))
(&message (message "corrupt signature data"))
(signature signature) (file file) (port port))))))))
;; Number used to identify genuine file set archives.
;; Keep that one around, for error conditions.
(let-values (((port get-hash)
(restore-file port temp)
(let ((magic (read-int port)))
(unless (= magic %export-magic)
(&message (message "corrupt file set archive"))
(port port*) (file #f) (token #f))))))
(let ((file (read-store-path port))
(refs (read-store-path-list port))
(deriver (read-string port))
(has-sig? (= 1 (read-int port))))
(G_ "importing file or directory '~a'...~%")
;; The signature may contain characters that are meant to be
;; interpreted as bytes in a 'char *', so read them as a ISO-8859-1.
(let ((sig (and has-sig? (read-latin1-string port))))
(assert-valid-signature sig hash file)
(G_ "found valid signature for '~a'~%")
(finalize-store-file temp file
(&message (message "imported file lacks \
(port port*) (file file) (signature #f))))))
(define* (restore-file-set port
#:key (verify-signature? #t) (lock? #t)
"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
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."
(let loop ((n (read-long-long port))
#:acl acl #:verify-signature? verify-signature?
#:lock? lock? #:log-port log-port)))
(loop (read-long-long port)
(cons file files))))
;; Neither 0 nor 1.
(&message (message "invalid inter-file archive mark"))
(port port) (file #f) (token #f))))))))
;;; Local Variables:
;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
;;; nar.scm ends here