-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.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 utils)
- #:use-module (guix serialization)
- #:use-module ((guix build utils) #:select (with-directory-excursion))
- #: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 (ice-9 ftw)
- #:use-module (ice-9 match)
- #:export (nar-error?
- nar-read-error?
- nar-read-error-file
- nar-read-error-port
- nar-read-error-token
-
- write-file
- restore-file))
-
-;;; Comment:
-;;;
-;;; Read and write Nix archives, aka. ‘nar’.
-;;;
-;;; Code:
-
-(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ?
- nar-error?)
-
-(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 (dump in out size)
- "Copy SIZE bytes from IN to OUT."
- (define buf-size 65536)
- (define buf (make-bytevector buf-size))
-
- (let loop ((left size))
- (if (<= left 0)
- 0
- (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
- (if (eof-object? read)
- left
- (begin
- (put-bytevector out buf 0 read)
- (loop (- left read))))))))
-
-(define (write-contents file p size)
- "Write SIZE bytes from FILE to output port P."
- (define (call-with-binary-input-file file proc)
- ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
- ;; avoids any initial buffering. Disable file name canonicalization to
- ;; avoid stat'ing like crazy.
- (with-fluids ((%file-port-name-canonicalization #f))
- (let ((port (open-file file "rb")))
- (catch #t (cut proc port)
- (lambda args
- (close-port port)
- (apply throw args))))))
-
- (write-string "contents" p)
- (write-long-long size p)
- (call-with-binary-input-file file
- ;; Use `sendfile' when available (Guile 2.0.8+).
- (if (compile-time-value (defined? 'sendfile))
- (cut sendfile p <> size 0)
- (cut dump <> p size)))
- (write-padding size p))
-
-(define (read-contents in out)
- "Read the contents of a file from the Nar at IN, write it to OUT, and return
-the size in bytes."
- (define executable?
- (match (read-string in)
- ("contents"
- #f)
- ("executable"
- (match (list (read-string in) (read-string in))
- (("" "contents") #t)
- (x (raise
- (condition (&message
- (message "unexpected executable file marker"))
- (&nar-read-error (port in)
- (file #f)
- (token x))))))
- #t)
- (x
- (raise
- (condition (&message (message "unsupported nar file type"))
- (&nar-read-error (port in) (file #f) (token x)))))))
-
- (let ((size (read-long-long in)))
- ;; Note: `sendfile' cannot be used here because of port buffering on IN.
- (dump in out size)
-
- (when executable?
- (chmod out #o755))
- (let ((m (modulo size 8)))
- (unless (zero? m)
- (get-bytevector-n in (- 8 m))))
- size))
-
-(define %archive-version-1
- ;; Magic cookie for Nix archives.
- "nix-archive-1")
-
-(define (write-file file port)
- "Write the contents of FILE to PORT in Nar format, recursing into
-sub-directories of FILE as needed."
- (define p port)
-
- (write-string %archive-version-1 p)
-
- (let dump ((f file))
- (let ((s (lstat f)))
- (write-string "(" p)
- (case (stat:type s)
- ((regular)
- (write-string "type" p)
- (write-string "regular" p)
- (if (not (zero? (logand (stat:mode s) #o100)))
- (begin
- (write-string "executable" p)
- (write-string "" p)))
- (write-contents f p (stat:size s)))
- ((directory)
- (write-string "type" p)
- (write-string "directory" p)
- (let ((entries (remove (cut member <> '("." ".."))
- (scandir f))))
- (for-each (lambda (e)
- (let ((f (string-append f "/" e)))
- (write-string "entry" p)
- (write-string "(" p)
- (write-string "name" p)
- (write-string e p)
- (write-string "node" p)
- (dump f)
- (write-string ")" p)))
- entries)))
- (else
- (raise (condition (&message (message "ENOSYS"))
- (&nar-error)))))
- (write-string ")" p))))
-
-(define (restore-file port file)
- "Read a file (possibly a directory structure) in Nar format from PORT.
-Restore it as FILE."
- (let ((signature (read-string port)))
- (unless (equal? signature %archive-version-1)
- (raise
- (condition (&message (message "invalid nar signature"))
- (&nar-read-error (port port)
- (token signature)
- (file #f))))))
-
- (let restore ((file file))
- (match (list (read-string port) (read-string port) (read-string port))
- (("(" "type" "regular")
- (call-with-output-file file (cut read-contents port <>))
- (match (read-string port)
- (")" #t)
- (x (raise
- (condition
- (&message (message "invalid nar end-of-file marker"))
- (&nar-read-error (port port) (file file) (token x)))))))
- (("(" "type" "directory")
- (let ((dir file))
- (mkdir dir)
- (let loop ((prefix (read-string port)))
- (match prefix
- ("entry"
- (match (list (read-string port)
- (read-string port) (read-string port)
- (read-string port))
- (("(" "name" file "node")
- (restore (string-append dir "/" file))
- (match (read-string port)
- (")" #t)
- (x
- (raise
- (condition
- (&message
- (message "unexpected directory entry termination"))
- (&nar-read-error (port port)
- (file file)
- (token x))))))
- (loop (read-string port)))))
- (")" #t) ; done with DIR
- (x
- (raise
- (condition
- (&message (message "unexpected directory inter-entry marker"))
- (&nar-read-error (port port) (file file) (token x)))))))))
- (x
- (raise
- (condition
- (&message (message "unsupported nar entry type"))
- (&nar-read-error (port port) (file file) (token x))))))))
-
-;;; nar.scm ends here
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 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 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)
+ #: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
+
+
+\f
+;;;
+;;; 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
+held."
+ ;; 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
+ ;; lock.
+ (if (zero? (stat:size (stat port)))
+ 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!
+ (begin
+ (close port)
+ (acquire-lock file)))))
+
+ (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)
+ (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-items db
+ (list (store-info target deriver references))))
+
+ (when lock?
+ (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)
+ (force-output lock)
+ (unlock-file lock))))))
+
+(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."
+ (with-store store
+ (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)
+ (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 of a nar bundle read 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 (\"nar bundle\") 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