1afe1985f5
* guix/store/database.scm (%default-database-file): New variable. (path-id): Export. * guix/nar.scm (finalize-store-file): Use 'with-database' instead of 'with-store', and use 'path-id' instead of 'valid-path?'.
278 lines
11 KiB
Scheme
278 lines
11 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
|
||
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
|
||
;;;
|
||
;;; 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 ui) ; for '_'
|
||
#: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)
|
||
#:export (nar-invalid-hash-error?
|
||
nar-invalid-hash-error-expected
|
||
nar-invalid-hash-error-actual
|
||
|
||
nar-signature-error?
|
||
nar-signature-error-signature
|
||
|
||
restore-file-set))
|
||
|
||
;;; Comment:
|
||
;;;
|
||
;;; Read and write Nix archives, aka. ‘nar’.
|
||
;;;
|
||
;;; Code:
|
||
|
||
(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
|
||
|
||
|
||
|
||
;;;
|
||
;;; 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."
|
||
(with-database %default-database-file db
|
||
(unless (path-id db target)
|
||
(when lock?
|
||
(lock-store-file target))
|
||
|
||
(unless (path-id db 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, and runs a deduplication pass.
|
||
(register-path target
|
||
#:references references
|
||
#:deriver deriver))
|
||
|
||
(when lock?
|
||
(unlock-store-file target)))))
|
||
|
||
(define (temporary-store-file)
|
||
"Return the file name of a temporary file created in the store."
|
||
(let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
|
||
(port (mkstemp! template)))
|
||
(close-port port)
|
||
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)))
|
||
(with-store store
|
||
;; 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)
|
||
(begin
|
||
(delete-file name)
|
||
body ...)
|
||
(loop (temporary-store-file))))))
|
||
|
||
(define* (restore-one-item port
|
||
#:key acl (verify-signature? #t) (lock? #t)
|
||
(log-port (current-error-port)))
|
||
"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 ()
|
||
(string->canonical-sexp signature))
|
||
(lambda (key proc err)
|
||
(raise (condition
|
||
(&message
|
||
(message "signature is not a valid \
|
||
s-expression"))
|
||
(&nar-signature-error
|
||
(file file)
|
||
(signature signature) (port port))))))))
|
||
(signature-case (signature hash (current-acl))
|
||
(valid-signature #t)
|
||
(invalid-signature
|
||
(raise (condition
|
||
(&message (message "invalid signature"))
|
||
(&nar-signature-error
|
||
(file file) (signature signature) (port port)))))
|
||
(hash-mismatch
|
||
(raise (condition (&message (message "invalid hash"))
|
||
(&nar-invalid-hash-error
|
||
(port port) (file file)
|
||
(signature signature)
|
||
(expected (hash-data->bytevector
|
||
(signature-signed-data signature)))
|
||
(actual hash)))))
|
||
(unauthorized-key
|
||
(raise (condition (&message (message "unauthorized public key"))
|
||
(&nar-signature-error
|
||
(signature signature) (file file) (port port)))))
|
||
(corrupt-signature
|
||
(raise (condition
|
||
(&message (message "corrupt signature data"))
|
||
(&nar-signature-error
|
||
(signature signature) (file file) (port port))))))))
|
||
|
||
(define %export-magic
|
||
;; Number used to identify genuine file set archives.
|
||
#x4558494e)
|
||
|
||
(define port*
|
||
;; Keep that one around, for error conditions.
|
||
port)
|
||
|
||
(let-values (((port get-hash)
|
||
(open-sha256-input-port port)))
|
||
(with-temporary-store-file temp
|
||
(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
|
||
(G_ "importing file or directory '~a'...~%")
|
||
file)
|
||
|
||
;; 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))))
|
||
(when verify-signature?
|
||
(if sig
|
||
(begin
|
||
(assert-valid-signature sig hash file)
|
||
(format log-port
|
||
(G_ "found valid signature for '~a'~%")
|
||
file)
|
||
(finalize-store-file temp file
|
||
#:references refs
|
||
#:deriver deriver
|
||
#:lock? lock?))
|
||
(raise (condition
|
||
(&message (message "imported file lacks \
|
||
a signature"))
|
||
(&nar-signature-error
|
||
(port port*) (file file) (signature #f))))))
|
||
file)))))
|
||
|
||
(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 acl
|
||
(current-acl))
|
||
|
||
(let loop ((n (read-long-long port))
|
||
(files '()))
|
||
(case n
|
||
((0)
|
||
(reverse files))
|
||
((1)
|
||
(let ((file
|
||
(restore-one-item port
|
||
#:acl acl #:verify-signature? verify-signature?
|
||
#:lock? lock? #:log-port log-port)))
|
||
(loop (read-long-long port)
|
||
(cons file files))))
|
||
(else
|
||
;; Neither 0 nor 1.
|
||
(raise (condition
|
||
(&message (message "invalid inter-file archive mark"))
|
||
(&nar-read-error
|
||
(port port) (file #f) (token #f))))))))
|
||
|
||
;;; Local Variables:
|
||
;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
|
||
;;; End:
|
||
|
||
;;; nar.scm ends here
|