;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix store)
#:use-module (guix utils)
#:use-module (guix config)
+ #:use-module (guix combinators)
#:use-module (guix serialization)
#:use-module (guix monads)
#:autoload (guix base32) (bytevector->base32-string)
+ #:autoload (guix build syscalls) (terminal-columns)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 popen)
#:export (%daemon-socket-file
%gc-roots-directory
+ %default-substitute-urls
nix-server?
nix-server-major-version
nix-protocol-error-status
hash-algo
+ build-mode
open-connection
close-connection
with-store
set-build-options
+ set-build-options*
valid-path?
query-path-hash
hash-part->path
add-to-store
build-things
build
+ query-failed-paths
+ clear-failed-paths
add-temp-root
add-indirect-root
add-permanent-root
path-info-nar-size
references
+ references/substitutes
requisites
referrers
optimize-store
+ verify-store
topologically-sorted
valid-derivers
query-derivation-outputs
store-lower
run-with-store
%guile-for-build
+ current-system
+ set-current-system
text-file
interned-file
derivation-path?
store-path-package-name
store-path-hash-part
+ direct-store-path
log-file))
-(define %protocol-version #x10c)
+(define %protocol-version #x10f)
(define %worker-magic-1 #x6e697863) ; "nixc"
(define %worker-magic-2 #x6478696f) ; "dxio"
(query-valid-paths 31)
(query-substitutable-paths 32)
(query-valid-derivers 33)
- (optimize-store 34))
+ (optimize-store 34)
+ (verify-store 35))
(define-enumerate-type hash-algo
;; hash.hh
(sha1 2)
(sha256 3))
+(define-enumerate-type build-mode
+ ;; store-api.hh
+ (normal 0)
+ (repair 1)
+ (check 2))
+
(define-enumerate-type gc-action
;; store-api.hh
(return-live 0)
(define-record-type <path-info>
(path-info deriver hash references registration-time nar-size)
path-info?
- (deriver path-info-deriver)
+ (deriver path-info-deriver) ;string | #f
(hash path-info-hash)
(references path-info-references)
(registration-time path-info-registration-time)
(nar-size path-info-nar-size))
(define (read-path-info p)
- (let ((deriver (read-store-path p))
+ (let ((deriver (match (read-store-path p)
+ ("" #f)
+ (x x)))
(hash (base16-string->bytevector (read-string p)))
(refs (read-store-path-list p))
(registration-time (read-int p))
(path-info deriver hash refs registration-time nar-size)))
(define-syntax write-arg
- (syntax-rules (integer boolean file string string-list string-pairs
+ (syntax-rules (integer boolean string string-list string-pairs
store-path store-path-list base16)
((_ integer arg p)
(write-int arg p))
((_ boolean arg p)
(write-int (if arg 1 0) p))
- ((_ file arg p)
- (write-file arg p))
((_ string arg p)
(write-string arg p))
((_ string-list arg p)
(status nix-protocol-error-status))
(define* (open-connection #:optional (file (%daemon-socket-file))
- #:key (reserve-space? #t))
+ #:key (reserve-space? #t) cpu-affinity)
"Connect to the daemon over the Unix-domain socket at FILE. When
-RESERVE-SPACE? is true, instruct it to reserve a little bit of extra
-space on the file system so that the garbage collector can still
-operate, should the disk become full. Return a server object."
+RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on
+the file system so that the garbage collector can still operate, should the
+disk become full. When CPU-AFFINITY is true, it must be an integer
+corresponding to an OS-level CPU number to which the daemon's worker process
+for this connection will be pinned. Return a server object."
(let ((s (with-fluids ((%default-port-encoding #f))
;; This trick allows use of the `scm_c_read' optimization.
(socket PF_UNIX SOCK_STREAM 0)))
(protocol-major v))
(begin
(write-int %protocol-version s)
- (if (>= (protocol-minor v) 11)
- (write-int (if reserve-space? 1 0) s))
+ (when (>= (protocol-minor v) 14)
+ (write-int (if cpu-affinity 1 0) s)
+ (when cpu-affinity
+ (write-int cpu-affinity s)))
+ (when (>= (protocol-minor v) 11)
+ (write-int (if reserve-space? 1 0) s))
(let ((s (%make-nix-server s
(protocol-major v)
(protocol-minor v)
(status k))))))))
(define %default-substitute-urls
- ;; Default list of substituters.
- '("http://hydra.gnu.org"))
+ ;; Default list of substituters. This is *not* the list baked in
+ ;; 'guix-daemon', but it is used by 'guix-service-type' and and a couple of
+ ;; clients ('guix build --log-file' uses it.)
+ (map (if (false-if-exception (resolve-interface '(gnutls)))
+ (cut string-append "https://" <>)
+ (cut string-append "http://" <>))
+ '("mirror.hydra.gnu.org" "hydra.gnu.org")))
(define* (set-build-options server
#:key keep-failed? keep-going? fallback?
(verbosity 0)
+ rounds ;number of build rounds
(max-build-jobs 1)
timeout
(max-silent-time 3600)
(build-cores (current-processor-count))
(use-substitutes? #t)
- ;; Client-provided substitute URLs. For
- ;; unprivileged clients, these are considered
- ;; "untrusted"; for root, they override the
- ;; daemon's settings.
- (substitute-urls %default-substitute-urls))
+ ;; Client-provided substitute URLs. If it is #f,
+ ;; the daemon's settings are used. Otherwise, it
+ ;; overrides the daemons settings; see 'guix
+ ;; substitute'.
+ (substitute-urls #f)
+
+ ;; Number of columns in the client's terminal.
+ (terminal-columns (terminal-columns))
+
+ ;; Locale of the client.
+ (locale (false-if-exception (setlocale LC_ALL))))
;; Must be called after `open-connection'.
(define socket
(let ((pairs `(,@(if timeout
`(("build-timeout" . ,(number->string timeout)))
'())
- ("substitute-urls" . ,(string-join substitute-urls)))))
+ ,@(if substitute-urls
+ `(("substitute-urls"
+ . ,(string-join substitute-urls)))
+ '())
+ ,@(if rounds
+ `(("build-repeat"
+ . ,(number->string (max 0 (1- rounds)))))
+ '())
+ ,@(if terminal-columns
+ `(("terminal-columns"
+ . ,(number->string terminal-columns)))
+ '())
+ ,@(if locale
+ `(("locale" . ,locale))
+ '()))))
(send (string-pairs pairs))))
(let loop ((done? (process-stderr server)))
(or done? (process-stderr server)))))
(operation (name args ...) docstring return ...)))
(define-operation (valid-path? (string path))
- "Return #t when PATH is a valid store path."
+ "Return #t when PATH designates a valid store item and #f otherwise (an
+invalid item may exist on disk but still be invalid, for instance because it
+is the result of an aborted or failed build.)
+
+A '&nix-protocol-error' condition is raised if PATH is not prefixed by the
+store directory (/gnu/store)."
boolean)
(define-operation (query-path-hash (store-path path))
- "Return the SHA256 hash of PATH as a bytevector."
+ "Return the SHA256 hash of the nar serialization of PATH as a bytevector."
base16)
(define hash-part->path
(hash-set! cache args path)
path))))))
+(define true
+ ;; Define it once and for all since we use it as a default value for
+ ;; 'add-to-store' and want to make sure two default values are 'eq?' for the
+ ;; purposes or memoization.
+ (lambda (file stat)
+ #t))
+
(define add-to-store
;; A memoizing version of `add-to-store'. This is important because
;; `add-to-store' leads to huge data transfers to the server, and
;; because it's often called many times with the very same argument.
- (let ((add-to-store (operation (add-to-store (string basename)
- (boolean fixed?) ; obsolete, must be #t
- (boolean recursive?)
- (string hash-algo)
- (file file-name))
- #f
- store-path)))
- (lambda (server basename recursive? hash-algo file-name)
+ (let ((add-to-store
+ (lambda* (server basename recursive? hash-algo file-name
+ #:key (select? true))
+ ;; We don't use the 'operation' macro so we can pass SELECT? to
+ ;; 'write-file'.
+ (let ((port (nix-server-socket server)))
+ (write-int (operation-id add-to-store) port)
+ (write-string basename port)
+ (write-int 1 port) ;obsolete, must be #t
+ (write-int (if recursive? 1 0) port)
+ (write-string hash-algo port)
+ (write-file file-name port #:select? select?)
+ (let loop ((done? (process-stderr server)))
+ (or done? (loop (process-stderr server))))
+ (read-store-path port)))))
+ (lambda* (server basename recursive? hash-algo file-name
+ #:key (select? true))
"Add the contents of FILE-NAME under BASENAME to the store. When
-RECURSIVE? is true and FILE-NAME designates a directory, the contents of
-FILE-NAME are added recursively; if FILE-NAME designates a flat file and
-RECURSIVE? is true, its contents are added, and its permission bits are
-kept. HASH-ALGO must be a string such as \"sha256\"."
- (let* ((st (stat file-name #f))
- (args `(,st ,basename ,recursive? ,hash-algo))
+RECURSIVE? is false, FILE-NAME must designate a regular file--not a directory
+nor a symlink. When RECURSIVE? is true and FILE-NAME designates a directory,
+the contents of FILE-NAME are added recursively; if FILE-NAME designates a
+flat file and RECURSIVE? is true, its contents are added, and its permission
+bits are kept. HASH-ALGO must be a string such as \"sha256\".
+
+When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry,
+where FILE is the entry's absolute file name and STAT is the result of
+'lstat'; exclude entries for which SELECT? does not return true."
+ (let* ((st (false-if-exception (lstat file-name)))
+ (args `(,st ,basename ,recursive? ,hash-algo ,select?))
(cache (nix-server-add-to-store-cache server)))
(or (and st (hash-ref cache args))
- (let ((path (add-to-store server basename #t recursive?
- hash-algo file-name)))
+ (let ((path (add-to-store server basename recursive?
+ hash-algo file-name
+ #:select? select?)))
(hash-set! cache args path)
path))))))
-(define-operation (build-things (string-list things))
- "Build THINGS, a list of store items which may be either '.drv' files or
+(define build-things
+ (let ((build (operation (build-things (string-list things)
+ (integer mode))
+ "Do it!"
+ boolean))
+ (build/old (operation (build-things (string-list things))
+ "Do it!"
+ boolean)))
+ (lambda* (store things #:optional (mode (build-mode normal)))
+ "Build THINGS, a list of store items which may be either '.drv' files or
outputs, and return when the worker is done building them. Elements of THINGS
that are not derivations can only be substituted and not built locally.
Return #t on success."
- boolean)
+ (if (>= (nix-server-minor-version store) 15)
+ (build store things mode)
+ (if (= mode (build-mode normal))
+ (build/old store things)
+ (raise (condition (&nix-protocol-error
+ (message "unsupported build mode")
+ (status 1)))))))))
(define-operation (add-temp-root (store-path path))
"Make PATH a temporary root for the duration of the current session.
"Return the list of references of PATH."
store-path-list))
-(define* (fold-path store proc seed path
+(define %reference-cache
+ ;; Brute-force cache mapping store items to their list of references.
+ ;; Caching matters because when building a profile in the presence of
+ ;; grafts, we keep calling 'graft-derivation', which in turn calls
+ ;; 'references/substitutes' many times with the same arguments. Ideally we
+ ;; would use a cache associated with the daemon connection instead (XXX).
+ (make-hash-table 100))
+
+(define (references/substitutes store items)
+ "Return the list of list of references of ITEMS; the result has the same
+length as ITEMS. Query substitute information for any item missing from the
+store at once. Raise a '&nix-protocol-error' exception if reference
+information for one of ITEMS is missing."
+ (let* ((local-refs (map (lambda (item)
+ (or (hash-ref %reference-cache item)
+ (guard (c ((nix-protocol-error? c) #f))
+ (references store item))))
+ items))
+ (missing (fold-right (lambda (item local-ref result)
+ (if local-ref
+ result
+ (cons item result)))
+ '()
+ items local-refs))
+
+ ;; Query all the substitutes at once to minimize the cost of
+ ;; launching 'guix substitute' and making HTTP requests.
+ (substs (substitutable-path-info store missing)))
+ (when (< (length substs) (length missing))
+ (raise (condition (&nix-protocol-error
+ (message "cannot determine \
+the list of references")
+ (status 1)))))
+
+ ;; Intersperse SUBSTS and LOCAL-REFS.
+ (let loop ((items items)
+ (local-refs local-refs)
+ (result '()))
+ (match items
+ (()
+ (let ((result (reverse result)))
+ (for-each (cut hash-set! %reference-cache <> <>)
+ items result)
+ result))
+ ((item items ...)
+ (match local-refs
+ ((#f tail ...)
+ (loop items tail
+ (cons (any (lambda (subst)
+ (and (string=? (substitutable-path subst) item)
+ (substitutable-references subst)))
+ substs)
+ result)))
+ ((head tail ...)
+ (loop items tail
+ (cons head result)))))))))
+
+(define* (fold-path store proc seed paths
#:optional (relatives (cut references store <>)))
- "Call PROC for each of the RELATIVES of PATH, exactly once, and return the
+ "Call PROC for each of the RELATIVES of PATHS, exactly once, and return the
result formed from the successive calls to PROC, the first of which is passed
SEED."
- (let loop ((paths (list path))
+ (let loop ((paths paths)
(result seed)
(seen vlist-null))
(match paths
(()
result))))
-(define (requisites store path)
- "Return the requisites of PATH, including PATH---i.e., its closure (all its
-references, recursively)."
- (fold-path store cons '() path))
+(define (requisites store paths)
+ "Return the requisites of PATHS, including PATHS---i.e., their closures (all
+its references, recursively)."
+ (fold-path store cons '() paths))
(define (topologically-sorted store paths)
"Return a list containing PATHS and all their references sorted in
(operation (query-substitutable-path-infos (store-path-list paths))
"Return information about the subset of PATHS that is
substitutable. For each substitutable path, a `substitutable?' object is
-returned."
+returned; thus, the resulting list can be shorter than PATHS. Furthermore,
+that there is no guarantee that the order of the resulting list matches the
+order of PATHS."
substitutable-path-list))
(define-operation (optimize-store)
;; Note: the daemon in Guix <= 0.8.2 does not implement this RPC.
boolean)
+(define verify-store
+ (let ((verify (operation (verify-store (boolean check-contents?)
+ (boolean repair?))
+ "Verify the store."
+ boolean)))
+ (lambda* (store #:key check-contents? repair?)
+ "Verify the integrity of the store and return false if errors remain,
+and true otherwise. When REPAIR? is true, repair any missing or altered store
+items by substituting them (this typically requires root privileges because it
+is not an atomic operation.) When CHECK-CONTENTS? is true, check the contents
+of store items; this can take a lot of time."
+ (not (verify store check-contents? repair?)))))
+
(define (run-gc server action to-delete min-freed)
"Perform the garbage-collector operation ACTION, one of the
`gc-action' values. When ACTION is `delete-specific', the TO-DELETE is
(and (export-path server head port #:sign? sign?)
(loop tail))))))
+(define-operation (query-failed-paths)
+ "Return the list of store items for which a build failure is cached.
+
+The result is always the empty list unless the daemon was started with
+'--cache-failures'."
+ store-path-list)
+
+(define-operation (clear-failed-paths (store-path-list items))
+ "Remove ITEMS from the list of cached build failures.
+
+This makes sense only when the daemon was started with '--cache-failures'."
+ boolean)
+
(define* (register-path path
#:key (references '()) deriver prefix
state-directory)
store)))
(define* (interned-file file #:optional name
- #:key (recursive? #t))
+ #:key (recursive? #t) (select? true))
"Return the name of FILE once interned in the store. Use NAME as its store
name, or the basename of FILE if NAME is omitted.
When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
designates a flat file and RECURSIVE? is true, its contents are added, and its
-permission bits are kept."
+permission bits are kept.
+
+When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry,
+where FILE is the entry's absolute file name and STAT is the result of
+'lstat'; exclude entries for which SELECT? does not return true."
(lambda (store)
(values (add-to-store store (or name (basename file))
- recursive? "sha256" file)
+ recursive? "sha256" file
+ #:select? select?)
store)))
(define build
;; Monadic variant of 'build-things'.
(store-lift build-things))
+(define set-build-options*
+ (store-lift set-build-options))
+
+(define-inlinable (current-system)
+ ;; Consult the %CURRENT-SYSTEM fluid at bind time. This is equivalent to
+ ;; (lift0 %current-system %store-monad), but inlinable, thus avoiding
+ ;; closure allocation in some cases.
+ (lambda (state)
+ (values (%current-system) state)))
+
+(define-inlinable (set-current-system system)
+ ;; Set the %CURRENT-SYSTEM fluid at bind time.
+ (lambda (state)
+ (values (%current-system system) state)))
+
(define %guile-for-build
;; The derivation of the Guile to be used within the build environment,
;; when using 'gexp->derivation' and co.
(system (%current-system)))
"Run MVAL, a monadic value in the store monad, in STORE, an open store
connection, and return the result."
+ ;; Initialize the dynamic bindings here to avoid bad surprises. The
+ ;; difficulty lies in the fact that dynamic bindings are resolved at
+ ;; bind-time and not at call time, which can be disconcerting.
(parameterize ((%guile-for-build guile-for-build)
- (%current-system system))
+ (%current-system system)
+ (%current-target-system #f))
(call-with-values (lambda ()
(run-with-state mval store))
(lambda (result store)
(let ((len (+ 1 (string-length (%store-prefix)))))
(not (string-index (substring path len) #\/)))))
+(define (direct-store-path path)
+ "Return the direct store path part of PATH, stripping components after
+'/gnu/store/xxxx-foo'."
+ (let ((prefix-length (+ (string-length (%store-prefix)) 35)))
+ (if (> (string-length path) prefix-length)
+ (let ((slash (string-index path #\/ prefix-length)))
+ (if slash (string-take path slash) path))
+ path)))
+
(define (derivation-path? path)
"Return #t if PATH is a derivation path."
(and (store-path? path) (string-suffix? ".drv" path)))
HCoop / jackhill / guix / guix.git / blobdiff