;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; 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.
;;; 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 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 ui) ; for '_'
- #:use-module (guix hash)
+ #: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 (guix pk-crypto)
- #:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
+ #: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)
- #: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-token
-
- nar-invalid-hash-error?
+ #:export (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-set))
;;; Comment:
;;;
;;; Code:
-(define-condition-type &nar-error &error ; XXX: inherit from &nix-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?
- (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
(expected nar-invalid-hash-error-expected) ; expected hash (a bytevector)
(actual nar-invalid-hash-error-actual)) ; actual hash
-\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")))
- (dynamic-wind
- (const #t)
- (cut proc port)
- (lambda ()
- (close-port port))))))
-
- (write-string "contents" p)
- (write-long-long size p)
- (call-with-binary-input-file file
- ;; Use `sendfile' when available (Guile 2.0.8+).
- (if (and (compile-time-value (defined? 'sendfile))
- (file-port? p))
- (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
- ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories
- ;; unconditionally, including "." and "..", regardless of the
- ;; 'select?' predicate passed to it, so we have to filter
- ;; those out externally.
- (filter (negate (cut member <> '("." "..")))
- ;; 'scandir' defaults to 'string-locale<?' to sort
- ;; files, but this happens to be case-insensitive (at
- ;; least in 'en_US' locale on libc 2.18.) Conversely,
- ;; we want files to be sorted in a case-sensitive
- ;; fashion.
- (scandir f (const #t) string<?))))
- (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)))
- ((symlink)
- (write-string "type" p)
- (write-string "symlink" p)
- (write-string "target" p)
- (write-string (readlink f) p))
- (else
- (raise (condition (&message (message "unsupported file type"))
- (&nar-error (file f) (port port))))))
- (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))
- (define (read-eof-marker)
- (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)))))))
-
- (match (list (read-string port) (read-string port) (read-string port))
- (("(" "type" "regular")
- (call-with-output-file file (cut read-contents port <>))
- (read-eof-marker))
- (("(" "type" "symlink")
- (match (list (read-string port) (read-string port))
- (("target" target)
- (symlink target file)
- (read-eof-marker))
- (x (raise
- (condition
- (&message (message "invalid symlink tokens"))
- (&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))))))))
\f
;;;
;; 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)))))
+ ;; 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."
(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
+ (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.)
(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."
+ "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
(let ((signature (catch 'gcry-error
(lambda ()
(string->canonical-sexp signature))
- (lambda (err . _)
+ (lambda (key proc err)
(raise (condition
(&message
(message "signature is not a valid \
(hash (get-hash))
(has-sig? (= 1 (read-int port))))
(format log-port
- (_ "importing file or directory '~a'...~%")
+ (G_ "importing file or directory '~a'...~%")
file)
- (let ((sig (and has-sig? (read-string port))))
+ ;; 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
- (_ "found valid signature for '~a'~%")
+ (G_ "found valid signature for '~a'~%")
file)
(finalize-store-file temp file
#:references refs
(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.
+ "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.
HCoop / jackhill / guix / guix.git / blobdiff