guix/store/build-derivations.scm: new module.

* guix/build/store-copy.scm
  (<store-info>): export so that (match x ($ <store-info> ...) ...) will
  work.

* guix/store/build-derivations.scm: new module (note: WIP).
  (get-output-specs, builtin-download, add-to-trie, make-search-trie,
   remove-from-trie!, scanning-wrapper-port, scan-for-references,
   ensure-input-outputs-exist, build-derivation): new procedures.
  (builtins): new variable.
  (<trie-node>): new record types.

* Makefile.am: add guix/store/build-derivations.scm to STORE_MODULES.

Makefile.am

@@ -39,7 +39,8 @@ do_subst = $(SED)					\
   -e 's,[@]GUILE[@],$(GUILE),g'				\
   -e 's,[@]guilemoduledir[@],$(guilemoduledir),g'	\
   -e 's,[@]guileobjectdir[@],$(guileobjectdir),g'	\
-  -e 's,[@]localedir[@],$(localedir),g'
+  -e 's,[@]localedir[@],$(localedir),g' 		\
+  -e 's,[@]Libexecdir[@],$(libexecdir),g'
 
 scripts/guix: scripts/guix.in Makefile
 	$(AM_V_at)rm -f $@ $@-t
@@ -47,6 +48,9 @@ scripts/guix: scripts/guix.in Makefile
 	$(AM_V_GEN)$(do_subst) < "$(srcdir)/$@.in" > "$@-t"
 	$(AM_V_at)chmod a+x,a-w "$@-t" && mv -f "$@-t" "$@"
 
+guix/config.scm: guix/config.scm.in
+	$(AM_V_GEN)$(do_subst) < "$@.in" > "$@"
+
 nodist_noinst_SCRIPTS =				\
   pre-inst-env					\
   test-env
@@ -307,7 +311,9 @@ endif BUILD_DAEMON_OFFLOAD
 STORE_MODULES =					\
   guix/store/database.scm			\
   guix/store/deduplication.scm			\
-  guix/store/roots.scm
+  guix/store/roots.scm				\
+  guix/store/environment.scm			\
+  guix/store/build-derivations.scm
 
 MODULES += $(STORE_MODULES)
 

configure.ac

@@ -61,6 +61,17 @@ AC_ARG_WITH([selinux-policy-dir],
   [selinux_policydir='${datadir}/selinux/'])
 AC_SUBST([selinux_policydir])
 
+AC_ARG_WITH(impersonate-linux-2.6-default,
+  AC_HELP_STRING([--with-impersonate-linux-2.6-default],
+    [Whether builds should should impersonate linux 2.6 by default]),
+  [if test "x$withval" = "xyes"; then
+    impersonate_linux26="#t";
+   else
+    impersonate_linux26="#f";
+  fi],
+  [impersonate_linux26="#f"])
+AC_SUBST(impersonate_linux26)
+
 dnl Better be verbose.
 AC_MSG_CHECKING([for the store directory])
 AC_MSG_RESULT([$storedir])
@@ -306,7 +317,7 @@ AC_CONFIG_FILES([Makefile
                  po/guix/Makefile.in
                  po/packages/Makefile.in
                  etc/guix-daemon.cil
-                 guix/config.scm])
+                 guix/config.scm.in])
 
 AC_CONFIG_FILES([test-env:build-aux/test-env.in], [chmod +x test-env])
 AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],

gnu/build/linux-container.scm

@@ -99,7 +99,14 @@ for the process."
 
   ;; The container's file system is completely ephemeral, sans directories
   ;; bind-mounted from the host.
-  (mount "none" root "tmpfs")
+  ;; Make this private in the container namespace so everything mounted under
+  ;; it is local to this namespace.
+  (mount "none" "/" "none" (logior MS_REC MS_PRIVATE))
+  (let ((current-perms (stat:perms (stat root))))
+    (mount "none" root "tmpfs" 0 (string-append "mode="
+                                                (number->string current-perms
+                                                                8))))
+
 
   ;; A proc mount requires a new pid namespace.
   (when mount-/proc?

guix/build/store-copy.scm

@@ -27,7 +27,8 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 vlist)
-  #:export (store-info?
+  #:export (<store-info>
+            store-info?
             store-info
             store-info-item
             store-info-deriver

guix/build/syscalls.scm

@@ -45,6 +45,8 @@
             MS_MOVE
             MS_STRICTATIME
             MS_LAZYTIME
+            MS_PRIVATE
+            MS_REC
             MNT_FORCE
             MNT_DETACH
             MNT_EXPIRE
@@ -112,6 +114,7 @@
             configure-network-interface
             add-network-route/gateway
             delete-network-route
+            initialize-loopback
 
             interface?
             interface-name
@@ -159,7 +162,12 @@
             utmpx-address
             login-type
             utmpx-entries
-            (read-utmpx-from-port . read-utmpx)))
+            (read-utmpx-from-port . read-utmpx)
+            personality
+            ADDR_NO_RANDOMIZE
+            setdomainname
+            UNAME26
+            PER_LINUX32))
 
 ;;; Commentary:
 ;;;
@@ -452,6 +460,8 @@ the returned procedure is called."
 (define MS_NOATIME         1024)
 (define MS_BIND            4096)
 (define MS_MOVE            8192)
+(define MS_REC            16384)
+(define MS_PRIVATE       262144)
 (define MS_STRICTATIME 16777216)
 (define MS_LAZYTIME    33554432)
 
@@ -505,6 +515,27 @@ constants from <sys/mount.h>."
       (when update-mtab?
         (remove-from-mtab target)))))
 
+(define (octal-escaped str)
+  "Convert a string that may contain octal-escaped characters of the form \\ooo
+to a string with the corresponding code points."
+    ;; I'm using "octet" here like I would normally use "digit".
+  (define (octal-triplet->char octet1 octet2 octet3)
+   (integer->char (string->number (string octet1 octet2 octet3)
+                                   8)))
+
+  (let next-char ((result-list '())
+                  (to-convert (string->list str)))
+    (match to-convert
+      ((#\\ octet1 octet2 octet3 . others)
+       (next-char (cons (octal-triplet->char octet1 octet2 octet3)
+                        result-list)
+                  others))
+      ((char . others)
+       (next-char (cons char result-list)
+                  others))
+      (()
+       (list->string (reverse! result-list))))))
+
 (define (mount-points)
   "Return the mounts points for currently mounted file systems."
   (call-with-input-file "/proc/mounts"
@@ -515,7 +546,7 @@ constants from <sys/mount.h>."
               (reverse result)
               (match (string-tokenize line)
                 ((source mount-point _ ...)
-                 (loop (cons mount-point result))))))))))
+                 (loop (cons (octal-escaped mount-point) result))))))))))
 
 (define swapon
   (let ((proc (syscall->procedure int "swapon" (list '* int))))
@@ -1554,6 +1585,16 @@ is true, it must be a socket address to use as the network mask."
       (lambda ()
         (close-port sock)))))
 
+(define (initialize-loopback)
+  (let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_IP)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (set-network-interface-flags sock "lo"
+                                     (logior IFF_UP IFF_LOOPBACK IFF_RUNNING)))
+      (lambda ()
+        (close sock)))))
+
 
 ;;;
 ;;; Network routes.
@@ -2070,4 +2111,31 @@ entry."
     ((? bytevector? bv)
      (read-utmpx bv))))
 
-;;; syscalls.scm ends here
+;; TODO: verify these constants are correct on platforms other than x86-64
+(define ADDR_NO_RANDOMIZE #x0040000)
+(define UNAME26           #x0020000)
+(define PER_LINUX32          #x0008)
+
+(define personality
+  (let ((proc (syscall->procedure int "personality" `(,unsigned-long))))
+    (lambda (persona)
+      (let-values (((ret err) (proc persona)))
+        (if (= -1 ret)
+            (throw 'system-error "personality" "~A"
+                   (list (strerror err))
+                   (list err))
+            ret)))))
+
+(define setdomainname
+  (let ((proc (syscall->procedure int "setdomainname" (list '* int))))
+    (lambda (domain-name)
+      (let-values (((ret err) (proc (string->pointer/utf-8 domain-name)
+                                    (bytevector-length (string->utf8
+                                                        domain-name)))))
+        (if (= -1 ret)
+            (throw 'system-error "setdomainname" "~A"
+                   (list (strerror err))
+                   (list err))
+            ret)))))
+
+;;; syscalls.scm ends here 

guix/config.scm.in.in

@@ -26,6 +26,8 @@
             %storedir
             %localstatedir
             %sysconfdir
+            %temp-directory
+            %libexecdir
 
             %store-directory
             %state-directory
@@ -37,7 +39,8 @@
             %liblz
             %gzip
             %bzip2
-            %xz))
+            %xz
+            %impersonate-linux-2.6?))
 
 ;;; Commentary:
 ;;;
@@ -64,9 +67,20 @@
 (define %localstatedir
   "@guix_localstatedir@")
 
+(define %temp-directory
+  (or (getenv "TMPDIR")
+      "/tmp"))
+
+(define %impersonate-linux-2.6?
+  (make-parameter @impersonate_linux26@))
+
 (define %sysconfdir
   "@guix_sysconfdir@")
 
+(define %libexecdir
+  (or (getenv "NIX_LIBEXEC_DIR")
+      "@Libexecdir@/guix"))
+
 (define %store-directory
   (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
       %storedir))

guix/derivations.scm

@@ -43,64 +43,15 @@
   #:use-module (guix base32)
   #:use-module (guix records)
   #:use-module (guix sets)
-  #:export (<derivation>
-            derivation?
-            derivation-outputs
-            derivation-inputs
-            derivation-sources
-            derivation-system
-            derivation-builder
-            derivation-builder-arguments
-            derivation-builder-environment-vars
-            derivation-file-name
-            derivation-prerequisites
-            derivation-build-plan
-            derivation-prerequisites-to-build     ;deprecated
-
-            <derivation-output>
-            derivation-output?
-            derivation-output-path
-            derivation-output-hash-algo
-            derivation-output-hash
-            derivation-output-recursive?
-
-            <derivation-input>
-            derivation-input?
-            derivation-input
-            derivation-input-path
-            derivation-input-derivation
-            derivation-input-sub-derivations
-            derivation-input-output-paths
-            derivation-input-output-path
+  #:use-module (guix store derivations)
+  #:export (derivation-build-plan
+	    derivation-prerequisites-to-build     ;deprecated
             valid-derivation-input?
 
-            &derivation-error
-            derivation-error?
-            derivation-error-derivation
-            &derivation-missing-output-error
-            derivation-missing-output-error?
-            derivation-missing-output
-
-            derivation-name
-            derivation-output-names
-            fixed-output-derivation?
-            offloadable-derivation?
-            substitutable-derivation?
-            derivation-input-fold
             substitution-oracle
-            derivation-hash
-            derivation-properties
 
-            read-derivation
-            read-derivation-from-file
-            write-derivation
-            derivation->output-path
-            derivation->output-paths
-            derivation-path->output-path
-            derivation-path->output-paths
             derivation
             raw-derivation
-            invalidate-derivation-caches!
 
             map-derivation
 
@@ -116,119 +67,66 @@
             build-expression->derivation)
 
   ;; Re-export it from here for backward compatibility.
-  #:re-export (%guile-for-build))
+  #:re-export (%guile-for-build
 
-;;;
-;;; Error conditions.
-;;;
+               &derivation-error
+               derivation-error?
+               derivation-error-derivation
 
-(define-condition-type &derivation-error &store-error
-  derivation-error?
-  (derivation derivation-error-derivation))
+               &derivation-missing-output-error
+               derivation-missing-output-error?
+               derivation-missing-output
 
-(define-condition-type &derivation-missing-output-error &derivation-error
-  derivation-missing-output-error?
-  (output derivation-missing-output))
+               <derivation>
+               derivation?
+               derivation-outputs
+               derivation-inputs
+               derivation-sources
+               derivation-system
+               derivation-builder
+               derivation-builder-arguments
+               derivation-builder-environment-vars
+               derivation-file-name
 
-;;;
-;;; Nix derivations, as implemented in Nix's `derivations.cc'.
-;;;
+               <derivation-output>
+               derivation-output?
+               derivation-output-path
+               derivation-output-hash-algo
+               derivation-output-hash
+               derivation-output-recursive?
+	       derivation-output-names
 
-(define-immutable-record-type <derivation>
-  (make-derivation outputs inputs sources system builder args env-vars
-                   file-name)
-  derivation?
-  (outputs  derivation-outputs)      ; list of name/<derivation-output> pairs
-  (inputs   derivation-inputs)       ; list of <derivation-input>
-  (sources  derivation-sources)      ; list of store paths
-  (system   derivation-system)       ; string
-  (builder  derivation-builder)      ; store path
-  (args     derivation-builder-arguments)         ; list of strings
-  (env-vars derivation-builder-environment-vars)  ; list of name/value pairs
-  (file-name derivation-file-name))               ; the .drv file name
+               <derivation-input>
+               derivation-input?
+	       derivation-input-derivation
+               derivation-input-sub-derivations
+	       derivation-input-path
+	       derivation-input
 
-(define-immutable-record-type <derivation-output>
-  (make-derivation-output path hash-algo hash recursive?)
-  derivation-output?
-  (path       derivation-output-path)             ; store path
-  (hash-algo  derivation-output-hash-algo)        ; symbol | #f
-  (hash       derivation-output-hash)             ; bytevector | #f
-  (recursive? derivation-output-recursive?))      ; Boolean
+               derivation-name
+               derivation-output-names
+               derivation-hash
+               derivation-properties
+               fixed-output-derivation?
+               offloadable-derivation?
+               substitutable-derivation?
 
-(define-immutable-record-type <derivation-input>
-  (make-derivation-input drv sub-derivations)
-  derivation-input?
-  (drv             derivation-input-derivation)       ; <derivation>
-  (sub-derivations derivation-input-sub-derivations)) ; list of strings
+               derivation-input<?
+	       derivation-input-output-path
+               derivation-input-output-paths
+               derivation-input-fold
+               derivation->output-path
+               derivation->output-paths
+               derivation-path->output-path
+               derivation-path->output-paths
 
+               derivation-prerequisites
 
-(define (derivation-input-path input)
-  "Return the file name of the derivation INPUT refers to."
-  (derivation-file-name (derivation-input-derivation input)))
+               read-derivation
+               read-derivation-from-file
+               write-derivation
+               invalidate-derivation-caches!))
 
-(define* (derivation-input drv #:optional
-                           (outputs (derivation-output-names drv)))
-  "Return a <derivation-input> for the OUTPUTS of DRV."
-  ;; This is a public interface meant to be more convenient than
-  ;; 'make-derivation-input' and giving us more control.
-  (make-derivation-input drv outputs))
-
-(define (derivation-input-key input)
-  "Return an object for which 'equal?' and 'hash' are constant-time, and which
-can thus be used as a key for INPUT in lookup tables."
-  (cons (derivation-input-path input)
-        (derivation-input-sub-derivations input)))
-
-(set-record-type-printer! <derivation>
-                          (lambda (drv port)
-                            (format port "#<derivation ~a => ~a ~a>"
-                                    (derivation-file-name drv)
-                                    (string-join
-                                     (map (match-lambda
-                                           ((_ . output)
-                                            (derivation-output-path output)))
-                                          (derivation-outputs drv)))
-                                    (number->string (object-address drv) 16))))
-
-(define (derivation-name drv)
-  "Return the base name of DRV."
-  (let ((base (store-path-package-name (derivation-file-name drv))))
-    (string-drop-right base 4)))
-
-(define (derivation-output-names drv)
-  "Return the names of the outputs of DRV."
-  (match (derivation-outputs drv)
-    (((names . _) ...)
-     names)))
-
-(define (fixed-output-derivation? drv)
-  "Return #t if DRV is a fixed-output derivation, such as the result of a
-download with a fixed hash (aka. `fetchurl')."
-  (match drv
-    (($ <derivation>
-        (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
-     #t)
-    (_ #f)))
-
-(define (derivation-input<? input1 input2)
-  "Compare INPUT1 and INPUT2, two <derivation-input>."
-  (string<? (derivation-input-path input1)
-            (derivation-input-path input2)))
-
-(define (derivation-input-output-paths input)
-  "Return the list of output paths corresponding to INPUT, a
-<derivation-input>."
-  (match input
-    (($ <derivation-input> drv sub-drvs)
-     (map (cut derivation->output-path drv <>)
-          sub-drvs))))
-
-(define (derivation-input-output-path input)
-  "Return the output file name of INPUT.  If INPUT has more than one outputs,
-an error is raised."
-  (match input
-    (($ <derivation-input> drv (output))
-     (derivation->output-path drv output))))
 
 (define (valid-derivation-input? store input)
   "Return true if INPUT is valid--i.e., if all the outputs it requests are in
@@ -236,104 +134,6 @@ the store."
   (every (cut valid-path? store <>)
          (derivation-input-output-paths input)))
 
-(define (coalesce-duplicate-inputs inputs)
-  "Return a list of inputs, such that when INPUTS contains the same DRV twice,
-they are coalesced, with their sub-derivations merged.  This is needed because
-Nix itself keeps only one of them."
-  (define (find pred lst)                         ;inlinable copy of 'find'
-    (let loop ((lst lst))
-      (match lst
-        (() #f)
-        ((head . tail)
-         (if (pred head) head (loop tail))))))
-
-  (fold (lambda (input result)
-          (match input
-            (($ <derivation-input> (= derivation-file-name path) sub-drvs)
-             ;; XXX: quadratic
-             (match (find (match-lambda
-                            (($ <derivation-input> (= derivation-file-name p)
-                                                   s)
-                             (string=? p path)))
-                          result)
-               (#f
-                (cons input result))
-               ((and dup ($ <derivation-input> drv sub-drvs2))
-                ;; Merge DUP with INPUT.
-                (let ((sub-drvs (delete-duplicates
-                                 (append sub-drvs sub-drvs2))))
-                  (cons (make-derivation-input drv (sort sub-drvs string<?))
-                        (delq dup result))))))))
-        '()
-        inputs))
-
-(define* (derivation-prerequisites drv #:optional (cut? (const #f)))
-  "Return the list of derivation-inputs required to build DRV, recursively.
-
-CUT? is a predicate that is passed a derivation-input and returns true to
-eliminate the given input and its dependencies from the search.  An example of
-such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
-result is the set of prerequisites of DRV not already in valid."
-  (let loop ((drv       drv)
-             (result    '())
-             (input-set (set)))
-    (let ((inputs (remove (lambda (input)
-                            (or (set-contains? input-set
-                                               (derivation-input-key input))
-                                (cut? input)))
-                          (derivation-inputs drv))))
-      (fold2 loop
-             (append inputs result)
-             (fold set-insert input-set
-                   (map derivation-input-key inputs))
-             (map derivation-input-derivation inputs)))))
-
-(define (offloadable-derivation? drv)
-  "Return true if DRV can be offloaded, false otherwise."
-  (match (assoc "preferLocalBuild"
-                (derivation-builder-environment-vars drv))
-    (("preferLocalBuild" . "1") #f)
-    (_ #t)))
-
-(define (substitutable-derivation? drv)
-  "Return #t if DRV can be substituted."
-  (match (assoc "allowSubstitutes"
-                (derivation-builder-environment-vars drv))
-    (("allowSubstitutes" . value)
-     (string=? value "1"))
-    (_ #t)))
-
-(define (derivation-output-paths drv sub-drvs)
-  "Return the output paths of outputs SUB-DRVS of DRV."
-  (match drv
-    (($ <derivation> outputs)
-     (map (lambda (sub-drv)
-            (derivation-output-path (assoc-ref outputs sub-drv)))
-          sub-drvs))))
-
-(define* (derivation-input-fold proc seed inputs
-                                #:key (cut? (const #f)))
-  "Perform a breadth-first traversal of INPUTS, calling PROC on each input
-with the current result, starting from SEED.  Skip recursion on inputs that
-match CUT?."
-  (let loop ((inputs inputs)
-             (result seed)
-             (visited (set)))
-    (match inputs
-      (()
-       result)
-      ((input rest ...)
-       (let ((key (derivation-input-key input)))
-         (cond ((set-contains? visited key)
-                (loop rest result visited))
-               ((cut? input)
-                (loop rest result (set-insert key visited)))
-               (else
-                (let ((drv (derivation-input-derivation input)))
-                  (loop (append (derivation-inputs drv) rest)
-                        (proc input result)
-                        (set-insert key visited))))))))))
-
 (define* (substitution-oracle store inputs-or-drv
                               #:key (mode (build-mode normal)))
   "Return a one-argument procedure that, when passed a store file name,
@@ -456,287 +256,13 @@ by 'substitution-oracle'."
                        (list (derivation-input drv)) rest)))
     (values (map derivation-input build) download)))
 
-(define* (read-derivation drv-port
-                          #:optional (read-derivation-from-file
-                                      read-derivation-from-file))
-  "Read the derivation from DRV-PORT and return the corresponding <derivation>
-object.  Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs
-of the derivation being parsed.
 
-Most of the time you'll want to use 'read-derivation-from-file', which caches
-things as appropriate and is thus more efficient."
-
-  (define comma (string->symbol ","))
-
-  (define (ununquote x)
-    (match x
-      (('unquote x) (ununquote x))
-      ((x ...)      (map ununquote x))
-      (_            x)))
-
-  (define (outputs->alist x)
-    (fold-right (lambda (output result)
-                  (match output
-                    ((name path "" "")
-                     (alist-cons name
-                                 (make-derivation-output path #f #f #f)
-                                 result))
-                    ((name path hash-algo hash)
-                     ;; fixed-output
-                     (let* ((rec? (string-prefix? "r:" hash-algo))
-                            (algo (string->symbol
-                                   (if rec?
-                                       (string-drop hash-algo 2)
-                                       hash-algo)))
-                            (hash (base16-string->bytevector hash)))
-                       (alist-cons name
-                                   (make-derivation-output path algo
-                                                           hash rec?)
-                                   result)))))
-                '()
-                x))
-
-  (define (make-input-drvs x)
-    (fold-right (lambda (input result)
-                  (match input
-                    ((path (sub-drvs ...))
-                     (let ((drv (read-derivation-from-file path)))
-                       (cons (make-derivation-input drv sub-drvs)
-                             result)))))
-                '()
-                x))
-
-  ;; The contents of a derivation are typically ASCII, but choosing
-  ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
-  (set-port-encoding! drv-port "UTF-8")
-
-  (let loop ((exp    (read drv-port))
-             (result '()))
-    (match exp
-      ((? eof-object?)
-       (let ((result (reverse result)))
-         (match result
-           (('Derive ((outputs ...) (input-drvs ...)
-                      (input-srcs ...)
-                      (? string? system)
-                      (? string? builder)
-                      ((? string? args) ...)
-                      ((var value) ...)))
-            (make-derivation (outputs->alist outputs)
-                             (make-input-drvs input-drvs)
-                             input-srcs
-                             system builder args
-                             (fold-right alist-cons '() var value)
-                             (port-filename drv-port)))
-           (_
-            (error "failed to parse derivation" drv-port result)))))
-      ((? (cut eq? <> comma))
-       (loop (read drv-port) result))
-      (_
-       (loop (read drv-port)
-             (cons (ununquote exp) result))))))
-
-(define %derivation-cache
-  ;; Maps derivation file names to <derivation> objects.
-  ;; XXX: This is redundant with 'atts-cache' in the store.
-  (make-weak-value-hash-table 200))
-
-(define (read-derivation-from-file file)
-  "Read the derivation in FILE, a '.drv' file, and return the corresponding
-<derivation> object."
-  ;; Memoize that operation because 'read-derivation' is quite expensive,
-  ;; and because the same argument is read more than 15 times on average
-  ;; during something like (package-derivation s gdb).
-  (or (and file (hash-ref %derivation-cache file))
-      (let ((drv (call-with-input-file file read-derivation)))
-        (hash-set! %derivation-cache file drv)
-        drv)))
-
-(define-inlinable (write-sequence lst write-item port)
-  ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
-  ;; comma.
-  (match lst
-    (()
-     #t)
-    ((prefix (... ...) last)
-     (for-each (lambda (item)
-                 (write-item item port)
-                 (display "," port))
-               prefix)
-     (write-item last port))))
-
-(define-inlinable (write-list lst write-item port)
-  ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
-  ;; element.
-  (display "[" port)
-  (write-sequence lst write-item port)
-  (display "]" port))
-
-(define-inlinable (write-tuple lst write-item port)
-  ;; Same, but write LST as a tuple.
-  (display "(" port)
-  (write-sequence lst write-item port)
-  (display ")" port))
-
-(define (write-derivation drv port)
-  "Write the ATerm-like serialization of DRV to PORT.  See Section 2.4 of
-Eelco Dolstra's PhD dissertation for an overview of a previous version of
-that form."
-
-  ;; Make sure we're using the faster implementation.
-  (define format simple-format)
-
-  (define (write-string-list lst)
-    (write-list lst write port))
-
-  (define (write-output output port)
-    (match output
-     ((name . ($ <derivation-output> path hash-algo hash recursive?))
-      (write-tuple (list name path
-                         (if hash-algo
-                             (string-append (if recursive? "r:" "")
-                                            (symbol->string hash-algo))
-                             "")
-                         (or (and=> hash bytevector->base16-string)
-                             ""))
-                   write
-                   port))))
-
-  (define (write-input input port)
-    (match input
-      (($ <derivation-input> obj sub-drvs)
-       (display "(\"" port)
-
-       ;; 'derivation/masked-inputs' produces objects that contain a string
-       ;; instead of a <derivation>, so we need to account for that.
-       (display (if (derivation? obj)
-                    (derivation-file-name obj)
-                    obj)
-                port)
-       (display "\"," port)
-       (write-string-list sub-drvs)
-       (display ")" port))))
-
-  (define (write-env-var env-var port)
-    (match env-var
-      ((name . value)
-       (display "(" port)
-       (write name port)
-       (display "," port)
-       (write value port)
-       (display ")" port))))
-
-  ;; Assume all the lists we are writing are already sorted.
-  (match drv
-    (($ <derivation> outputs inputs sources
-        system builder args env-vars)
-     (display "Derive(" port)
-     (write-list outputs write-output port)
-     (display "," port)
-     (write-list inputs write-input port)
-     (display "," port)
-     (write-string-list sources)
-     (simple-format port ",\"~a\",\"~a\"," system builder)
-     (write-string-list args)
-     (display "," port)
-     (write-list env-vars write-env-var port)
-     (display ")" port))))
-
-(define derivation->bytevector
-  (lambda (drv)
-    "Return the external representation of DRV as a UTF-8-encoded string."
-    (with-fluids ((%default-port-encoding "UTF-8"))
-      (call-with-values open-bytevector-output-port
-        (lambda (port get-bytevector)
-          (write-derivation drv port)
-          (get-bytevector))))))
-
-(define* (derivation->output-path drv #:optional (output "out"))
-  "Return the store path of its output OUTPUT.  Raise a
-'&derivation-missing-output-error' condition if OUTPUT is not an output of
-DRV."
-  (let ((output* (assoc-ref (derivation-outputs drv) output)))
-    (if output*
-        (derivation-output-path output*)
-        (raise (condition (&derivation-missing-output-error
-                           (derivation drv)
-                           (output output)))))))
-
-(define (derivation->output-paths drv)
-  "Return the list of name/path pairs of the outputs of DRV."
-  (map (match-lambda
-        ((name . output)
-         (cons name (derivation-output-path output))))
-       (derivation-outputs drv)))
-
-(define derivation-path->output-path
-  ;; This procedure is called frequently, so memoize it.
-  (let ((memoized (mlambda (path output)
-                    (derivation->output-path (read-derivation-from-file path)
-                                             output))))
-    (lambda* (path #:optional (output "out"))
-      "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
-path of its output OUTPUT."
-      (memoized path output))))
-
-(define (derivation-path->output-paths path)
-  "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
-list of name/path pairs of its outputs."
-  (derivation->output-paths (read-derivation-from-file path)))
 
 
 ;;;
 ;;; Derivation primitive.
 ;;;
 
-(define derivation-base16-hash
-  (mlambdaq (drv)
-    "Return a string containing the base16 representation of the hash of DRV."
-    (bytevector->base16-string (derivation-hash drv))))
-
-(define (derivation/masked-inputs drv)
-  "Assuming DRV is a regular derivation (not fixed-output), replace the file
-name of each input with that input's hash."
-  (match drv
-    (($ <derivation> outputs inputs sources
-                     system builder args env-vars)
-     (let ((inputs (map (match-lambda
-                          (($ <derivation-input> drv sub-drvs)
-                           (let ((hash (derivation-base16-hash drv)))
-                             (make-derivation-input hash sub-drvs))))
-                        inputs)))
-       (make-derivation outputs
-                        (sort (delete-duplicates inputs)
-                              (lambda (drv1 drv2)
-                                (string<? (derivation-input-derivation drv1)
-                                          (derivation-input-derivation drv2))))
-                        sources
-                        system builder args env-vars
-                        #f)))))
-
-(define derivation-hash            ; `hashDerivationModulo' in derivations.cc
-  (lambda (drv)
-    "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
-    (match drv
-      (($ <derivation> ((_ . ($ <derivation-output> path
-                                                    (? symbol? hash-algo) (? bytevector? hash)
-                                                    (? boolean? recursive?)))))
-       ;; A fixed-output derivation.
-       (sha256
-        (string->utf8
-         (string-append "fixed:out:"
-                        (if recursive? "r:" "")
-                        (symbol->string hash-algo)
-                        ":" (bytevector->base16-string hash)
-                        ":" path))))
-      (_
-
-       ;; XXX: At this point this remains faster than `port-sha256', because
-       ;; the SHA256 port's `write' method gets called for every single
-       ;; character.
-       (sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
-
-
 (define (warn-about-derivation-deprecation name)
   ;; TRANSLATORS: 'derivation' must not be translated; it refers to the
   ;; 'derivation' procedure.
@@ -935,25 +461,6 @@ derivation.  It is kept as-is, uninterpreted, in the derivation."
             (hash-set! %derivation-cache file drv*)
             drv*)))))
 
-(define (invalidate-derivation-caches!)
-  "Invalidate internal derivation caches.  This is mostly useful for
-long-running processes that know what they're doing.  Use with care!"
-  ;; Typically this is meant to be used by Cuirass and Hydra, which can clear
-  ;; caches when they start evaluating packages for another architecture.
-  (invalidate-memoization! derivation-base16-hash)
-
-  ;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>.
-  ;; (hash-clear! %derivation-cache)
-  )
-
-(define derivation-properties
-  (mlambdaq (drv)
-    "Return the property alist associated with DRV."
-    (match (assoc "guix properties"
-                  (derivation-builder-environment-vars drv))
-      ((_ . str) (call-with-input-string str read))
-      (#f        '()))))
-
 (define* (map-derivation store drv mapping
                          #:key (system (%current-system)))
   "Given MAPPING, a list of pairs of derivations, return a derivation based on

guix/store.scm

@@ -20,6 +20,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix store)
+  #:use-module (guix store files)
   #:use-module (guix utils)
   #:use-module (guix config)
   #:use-module (guix deprecation)
@@ -69,7 +70,6 @@
             current-store-protocol-version        ;for internal use
             mcached
 
-            &store-error store-error?
             &store-connection-error store-connection-error?
             store-connection-error-file
             store-connection-error-code
@@ -170,19 +170,20 @@
             interned-file
             interned-file-tree
 
-            %store-prefix
-            store-path
-            output-path
-            fixed-output-path
-            store-path?
-            direct-store-path?
-            derivation-path?
-            store-path-base
-            store-path-package-name
-            store-path-hash-part
-            direct-store-path
-            derivation-log-file
-            log-file))
+            log-file)
+  #:re-export (&store-error store-error?
+               %store-prefix
+               store-path
+               output-path
+               fixed-output-path
+               store-path?
+               direct-store-path?
+               derivation-path?
+	       store-path-base
+               store-path-package-name
+               store-path-hash-part
+               direct-store-path
+               derivation-log-file))
 
 (define %protocol-version #x163)
 
@@ -396,9 +397,6 @@
 (define-deprecated/alias nix-server-socket store-connection-socket)
 
 
-(define-condition-type &store-error &error
-  store-error?)
-
 (define-condition-type &store-connection-error &store-error
   store-connection-error?
   (file   store-connection-error-file)
@@ -1982,131 +1980,7 @@ connection, and return the result."
         result))))
 
 
-;;;
-;;; Store paths.
-;;;
-
-(define %store-prefix
-  ;; Absolute path to the Nix store.
-  (make-parameter %store-directory))
-
-(define (compressed-hash bv size)                 ; `compressHash'
-  "Given the hash stored in BV, return a compressed version thereof that fits
-in SIZE bytes."
-  (define new (make-bytevector size 0))
-  (define old-size (bytevector-length bv))
-  (let loop ((i 0))
-    (if (= i old-size)
-        new
-        (let* ((j (modulo i size))
-               (o (bytevector-u8-ref new j)))
-          (bytevector-u8-set! new j
-                              (logxor o (bytevector-u8-ref bv i)))
-          (loop (+ 1 i))))))
-
-(define (store-path type hash name)               ; makeStorePath
-  "Return the store path for NAME/HASH/TYPE."
-  (let* ((s (string-append type ":sha256:"
-                           (bytevector->base16-string hash) ":"
-                           (%store-prefix) ":" name))
-         (h (sha256 (string->utf8 s)))
-         (c (compressed-hash h 20)))
-    (string-append (%store-prefix) "/"
-                   (bytevector->nix-base32-string c) "-"
-                   name)))
-
-(define (output-path output hash name)            ; makeOutputPath
-  "Return an output path for OUTPUT (the name of the output as a string) of
-the derivation called NAME with hash HASH."
-  (store-path (string-append "output:" output) hash
-              (if (string=? output "out")
-                  name
-                  (string-append name "-" output))))
-
-(define* (fixed-output-path name hash
-                            #:key
-                            (output "out")
-                            (hash-algo 'sha256)
-                            (recursive? #t))
-  "Return an output path for the fixed output OUTPUT defined by HASH of type
-HASH-ALGO, of the derivation NAME.  RECURSIVE? has the same meaning as for
-'add-to-store'."
-  (if (and recursive? (eq? hash-algo 'sha256))
-      (store-path "source" hash name)
-      (let ((tag (string-append "fixed:" output ":"
-                                (if recursive? "r:" "")
-                                (symbol->string hash-algo) ":"
-                                (bytevector->base16-string hash) ":")))
-        (store-path (string-append "output:" output)
-                    (sha256 (string->utf8 tag))
-                    name))))
-
-(define (store-path? path)
-  "Return #t if PATH is a store path."
-  ;; This is a lightweight check, compared to using a regexp, but this has to
-  ;; be fast as it's called often in `derivation', for instance.
-  ;; `isStorePath' in Nix does something similar.
-  (string-prefix? (%store-prefix) path))
-
-(define (direct-store-path? path)
-  "Return #t if PATH is a store path, and not a sub-directory of a store path.
-This predicate is sometimes needed because files *under* a store path are not
-valid inputs."
-  (and (store-path? path)
-       (not (string=? path (%store-prefix)))
-       (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)))
-
-(define (store-path-base path)
-  "Return the base path of a path in the store."
-  (and (string-prefix? (%store-prefix) path)
-       (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
-         (and (> (string-length base) 33)
-              (not (string-index base #\/))
-              base))))
-
-(define (store-path-package-name path)
-  "Return the package name part of PATH, a file name in the store."
-  (let ((base (store-path-base path)))
-    (string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen
-
-(define (store-path-hash-part path)
-  "Return the hash part of PATH as a base32 string, or #f if PATH is not a
-syntactically valid store path."
-  (let* ((base (store-path-base path))
-         (hash (string-take base 32)))
-    (and (string-every %nix-base32-charset hash)
-         hash)))
-
-(define (derivation-log-file drv)
-  "Return the build log file for DRV, a derivation file name, or #f if it
-could not be found."
-  (let* ((base    (basename drv))
-         (log     (string-append (or (getenv "GUIX_LOG_DIRECTORY")
-                                     (string-append %localstatedir "/log/guix"))
-                                 "/drvs/"
-                                 (string-take base 2) "/"
-                                 (string-drop base 2)))
-         (log.gz  (string-append log ".gz"))
-         (log.bz2 (string-append log ".bz2")))
-    (cond ((file-exists? log.gz) log.gz)
-          ((file-exists? log.bz2) log.bz2)
-          ((file-exists? log) log)
-          (else #f))))
-
+;; Uses VALID-DERIVERS, so can't go in (guix store files)
 (define (log-file store file)
   "Return the build log file for FILE, or #f if none could be found.  FILE
 must be an absolute store file name, or a derivation file name."

guix/store/build-derivations.scm

@@ -0,0 +1,474 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.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/>.
+
+;;; For building derivations.
+
+(define-module (guix store build-derivations)
+  #:use-module (guix store derivations)
+  #:use-module (guix store files)
+  #:use-module (guix store database)
+  #:use-module (guix config)
+  #:use-module (guix build syscalls)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 popen)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-11)
+  #:use-module (gcrypt hash)
+  #:use-module (guix serialization)
+  #:use-module (guix base16)
+  #:use-module (guix sets)
+  #:use-module ((guix build utils) #:select (delete-file-recursively
+                                             mkdir-p
+                                             copy-recursively))
+  #:use-module (guix build store-copy)
+  #:use-module (gnu system file-systems)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 q)
+  #:use-module (srfi srfi-43)
+  #:use-module (rnrs bytevectors)
+  #:use-module (guix store environment)
+  #:export (builder+environment+inputs
+            build-derivation))
+
+(define (output-paths drv)
+  "Return all store output paths produced by DRV."
+  (match (derivation-outputs drv)
+    (((outid . ($ <derivation-output> output-path)) ...)
+     output-path)))
+
+(define (get-output-specs drv possible-references)
+  "Return a list of <store-info> objects, one for each output of DRV."
+  (map (match-lambda
+         ((outid . ($ <derivation-output> output-path))
+          (let ((references
+                 (scan-for-references output-path
+                                      ;; outputs can reference
+                                      ;; themselves or other outputs of
+                                      ;; the same derivation.
+                                      (append (output-paths drv)
+                                              possible-references))))
+            (store-info output-path (derivation-file-name drv) references))))
+       (derivation-outputs drv)))
+
+(define (builtin-download drv outputs)
+  "Download DRV outputs OUTPUTS into the store."
+  (setenv "NIX_STORE" %store-directory)
+  ;; XXX: Set _NIX_OPTIONS once client settings are known
+  (execl (string-append %libexecdir "/download")
+         "download"
+         (derivation-file-name drv)
+         ;; We assume this has only a single output
+         (derivation-output-path (cdr (first outputs)))))
+
+;; if a derivation builder name is in here, it is a builtin. For normal
+;; behavior, make sure everything starts with "builtin:". Also, the procedures
+;; stored in here should take two arguments, the derivation and the list of
+;; (output-name . <derivation-output>)s to be built.
+
+(define builtins
+  (let ((builtins-table (make-hash-table 10)))
+    (hash-set! builtins-table
+               "builtin:download"
+               builtin-download)
+    builtins-table))
+
+(define %keep-build-dir? #t)
+
+;; XXX: make this configurable.
+(define %build-group
+  (make-parameter (false-if-exception (getgrnam "guixbuild"))))
+
+(define (get-build-user)
+  ;; XXX: user namespace to make build-user work instead of having to be root?
+  (or (and=> (%build-group)
+             ;; XXX: Acquire a user via lock files once those are properly
+             ;; implemented. For now, avoid conflict with the existing daemon
+             ;; where possible by picking a build user from the end (last)
+             ;; instead of the front.
+             ;; So in the future, replace LAST with ACQUIRE-BUILD-USER
+             (compose passwd:uid getpwnam last group:mem))
+      (getuid)))
+
+(define (get-build-group)
+  (or (and (zero? (getuid))
+           (group:gid %build-group))
+      (getgid)))
+
+(define-record-type <trie-node>
+  (make-trie-node table string-exists?)
+  trie-node?
+  ;; TODO implement skip values. Probably not as big a speed gain as you think
+  ;; it is, since this is I/O-bound.
+  ;; (skip-value node-skip-value set-skip-value!)
+  (table node-table set-node-table!)
+  ;; Technically speaking, it's possible for both CAT and CATTLE to be in a
+  ;; trie at once. Of course, for our purposes, this is
+  (string-exists? node-string-exists? set-string-exists?!))
+
+(define* (add-to-trie trie string #:optional (new-tables-size 2))
+  "Adds STR to TRIE."
+  (let ((str (string->utf8 string)))
+    (let next-node ((position 0)
+                    (current-node trie))
+      (if (= position (bytevector-length str))
+          ;; this is it. This is where we need to register that this string is
+          ;; present.
+          (set-string-exists?! current-node #t)
+          (let* ((current-table (node-table current-node))
+                 (node (hash-ref current-table
+                                 (bytevector-u8-ref str position))))
+            (if node
+                (next-node (1+ position)
+                           node)
+                (let ((new-node (make-trie-node (make-hash-table new-tables-size)
+                                                #f)))
+                  (hash-set! current-table
+                             (bytevector-u8-ref str position)
+                             new-node)
+                  (next-node (1+ position)
+                             new-node))))))))
+
+(define (make-search-trie strings)
+  ;; TODO: make the first few trie levels non-sparse tables to avoid hashing
+  ;; overhead.
+  (let ((root (make-trie-node (make-hash-table) #f)))
+    (for-each (cut add-to-trie root <>)
+              strings)
+    root))
+
+
+(define (remove-from-trie! trie sequence)
+  "Removes SEQUENCE from TRIE. This means that any nodes that are only in the
+path of SEQUENCE are removed. It's an error to use this with a sequence not
+already in TRIE."
+  ;; Hm. Looks like we'll have to recurse all the way down, find where it
+  ;; ends, then stop at the first thing on the way back up that has anything
+  ;; with the same prefix. Or I could do this the right way with an explicit
+  ;; stack. Hm...
+
+  (define (node-stack)
+    (let next ((nodes '())
+               (i 0)
+               (current-node trie))
+      (if (= (bytevector-length sequence) i)
+          (begin
+            ;; it's possible that even though this is the last node of this
+            ;; sequence it can't be deleted. So mark it as not denoting a
+            ;; string.
+            (set-string-exists?! current-node #f)
+            (cons current-node nodes))
+          (let ((next-node (hash-ref (node-table current-node)
+                                     (bytevector-u8-ref sequence i))))
+            (next (cons current-node nodes)
+                  (1+ i)
+                  next-node)))))
+
+  (let maybe-delete ((visited-nodes (node-stack))
+                     (i (1- (bytevector-length sequence))))
+    (match visited-nodes
+      ((current parent others ...)
+       (when (zero? (hash-count (const #t)
+                                (node-table current)))
+
+         (hash-remove! (node-table parent)
+                       (bytevector-u8-ref sequence i))
+         (maybe-delete (cdr visited-nodes)
+                       (1- i))))
+      ((current)
+       #f))))
+
+(define (scanning-wrapper-port output-port paths)
+  "Creates a wrapper port which passes through bytes to OUTPUT-PORT and
+returns it as well as a procedure which, when called, returns a list of all
+references out of the possibilities enumerated in PATHS that were
+detected. PATHS must not be empty."
+  ;; Not sure if I should be using custom ports or soft ports...
+  (let* ((strings (map store-path-hash-part paths))
+         (string->path (fold (lambda (current prev)
+                               (vhash-cons (store-path-hash-part current)
+                                           current
+                                           prev))
+                             vlist-null
+                             paths))
+         (lookback-size (apply max (map (compose bytevector-length string->utf8)
+                                        strings)))
+         (smallest-length (apply min (map (compose bytevector-length
+                                                   string->utf8)
+                                          strings)))
+         (lookback-buffer (make-bytevector lookback-size))
+         (search-trie (make-search-trie strings))
+         (buffer-pos 0)
+         (references '()))
+
+    (values
+     (make-custom-binary-output-port
+      "scanning-wrapper"
+      ;; write
+      (lambda (bytes offset count)
+        (define (in-lookback? n)
+          (< n buffer-pos))
+        ;; the "virtual" stuff provides a convenient interface that makes it
+        ;; look like we magically remember the end of the previous buffer.
+        (define (virtual-ref n)
+          (if (in-lookback? n)
+              (bytevector-u8-ref lookback-buffer n)
+              (bytevector-u8-ref bytes (+ (- n buffer-pos)
+                                          offset))))
+
+
+        (let ((total-length (+ buffer-pos count)))
+
+          (define (virtual-copy! start end target)
+            (let* ((copy-size (- end start)))
+              (let copy-next ((i 0))
+                (unless (= i copy-size)
+                  (bytevector-u8-set! target
+                                      i
+                                      (virtual-ref (+ start i)))
+                  (copy-next (1+ i))))
+              target))
+
+          ;; the gritty reality of that magic
+          (define (remember-end)
+            (let* ((copy-amount (min total-length
+                                     lookback-size))
+                   (start (- total-length copy-amount))
+                   (end total-length))
+              (virtual-copy! start end lookback-buffer)
+              (set! buffer-pos copy-amount)))
+
+          (define (attempt-match n trie)
+            (let test-position ((i n)
+                                (current-node trie))
+              (if (node-string-exists? current-node)
+                  ;; MATCH
+                  (virtual-copy! n i (make-bytevector (- i n)))
+                  (if (>= i total-length)
+                      #f
+                      (let ((next-node (hash-ref (node-table current-node)
+                                                 (virtual-ref i))))
+                        (if next-node
+                            (test-position (1+ i)
+                                           next-node)
+                            #f))))))
+
+
+
+          (define (scan)
+            (let next-char ((i 0))
+              (when (< i (- total-length smallest-length))
+                (let ((match-result (attempt-match i search-trie)))
+                  (if match-result
+                      (begin
+                        (set! references
+                          (let ((str-result
+                                 (cdr (vhash-assoc (utf8->string match-result)
+                                                   string->path))))
+                            (format #t "Found reference to: ~a~%" str-result)
+                            (cons str-result
+                                  references)))
+                        ;; We're not interested in multiple references, it'd
+                        ;; just slow us down.
+                        (remove-from-trie! search-trie match-result)
+                        (next-char (+ i (bytevector-length match-result))))
+                      (next-char (1+ i)))))))
+          (format #t "Scanning chunk of ~a bytes~%" count)
+          (scan)
+          (remember-end)
+          (put-bytevector output-port bytes offset count)
+          count))
+      #f ;; get-position
+      #f ;; set-position
+      (lambda ()
+        (close-port output-port)))
+     (lambda ()
+       references))))
+
+
+;; There are two main approaches we can use here: we can look for the entire
+;; store path of the form "/gnu/store/hashpart-name", which will yield no
+;; false positives and likely be faster due to being more quickly able to rule
+;; out sequences, and we can look for just hashpart, which will be faster to
+;; lookup and may both increase false positives and decrease false negatives
+;; as stuff that gets split up will likely still have the hash part all
+;; together, but adds a chance that 32 random base-32 characters could cause a
+;; false positive, but the chances of that are extremely slim, and an
+;; adversary couldn't really use that.
+(define (scan-for-references file possibilities)
+  "Scans for literal references in FILE as long as they happen to be in
+POSSIBILITIES. Returns the list of references found, the sha256 hash of the
+nar, and the length of the nar."
+  (let*-values (((scanning-port get-references)
+                 (scanning-wrapper-port (%make-void-port "w") possibilities)))
+    (write-file file scanning-port)
+    (force-output scanning-port)
+    (get-references)))
+
+(define (copy-outputs drv environment)
+  "Copy output paths produced in ENVIRONMENT from building DRV to the store if
+a fake store was used."
+  (let ((store-dir (assoc-ref (environment-temp-dirs environment)
+                              'store-directory)))
+    (when store-dir
+      (for-each
+       (match-lambda
+         ((outid . ($ <derivation-output> output-path))
+          (copy-recursively
+           (string-append store-dir "/" (basename output-path)) output-path)))
+       (derivation-outputs drv)))))
+
+(define (topologically-sorted store-infos)
+  "Returns STORE-INFOS in topological order or throws CYCLE-DETECTED if no
+such order exists."
+  (define path->store-info
+    (let loop ((infos store-infos)
+               (mapping vlist-null))
+      (match infos
+        ((($ <store-info> item deriver references) . tail)
+         (loop tail (vhash-cons item (car infos) mapping)))
+        (()
+         (lambda (path)
+           (let ((pair (vhash-assoc path mapping)))
+             (and pair
+                  (cdr pair))))))))
+
+  (define (references-of store-info)
+    ;; We need to pretend that self-references don't exist...
+    (fold (lambda (current prev)
+            (let ((info (path->store-info current)))
+              (or (and (not (equal? info store-info))
+                       info
+                       (cons info prev))
+                  prev)))
+          '()
+          (store-info-references store-info)))
+
+  (reverse
+   (let visit ((infos store-infos)
+               (visited (set))
+               (dependents (set))
+               (result '()))
+     (match infos
+       ((head . tail)
+        (if (set-contains? visited head)
+            (if (set-contains? dependents head)
+                (throw 'cycle-detected head)
+                (visit tail visited dependents result))
+            (call-with-values
+                (lambda ()
+                  (visit (references-of head)
+                         (set-insert head visited)
+                         (set-insert head dependents)
+                         result))
+              (lambda (result visited)
+                (visit tail
+                       visited
+                       dependents
+                       (cons head result))))))
+       (()
+        (values result visited))))))
+
+(define (run-builder builder drv environment store-inputs)
+  "Run the builder BUILDER for DRV in ENVIRONMENT, wait for it to finish, and
+return the list of <store-info>s corresponding to its outputs."
+  (match (status:exit-val (call-with-values
+                              (lambda ()
+                                (run-standard environment builder))
+                            wait-for-build))
+    (0
+     ;; XXX: check that the output paths were produced.
+     (copy-outputs drv environment)
+     (delete-environment environment)
+     (get-output-specs drv store-inputs))
+    (exit-value
+     (format #t "Builder exited with status ~A~%" exit-value)
+     (if %keep-build-dir?
+         (format #t "Note: keeping build directories: ~A~%"
+                 (match (environment-temp-dirs environment)
+                   (((sym . dir) ...)
+                    dir)))
+         (delete-environment environment))
+     #f)))
+
+(define* (builder+environment+inputs drv #:optional (chroot? #t))
+  "Return a thunk that performs the build action, the environment it should be
+run in, and the store inputs of that environment."
+  (let*-values (((builtin) (hash-ref builtins (derivation-builder drv)))
+                ((environment store-inputs)
+                 ((if builtin
+                      builtin-builder-environment
+                      (if chroot?
+                          chroot-build-environment
+                          nonchroot-build-environment))
+                  drv #:gid (get-build-group) #:uid (get-build-user)))
+                ((builder) (or
+                            (and builtin (lambda ()
+                                           (builtin drv (derivation-outputs
+                                                         drv))))
+                            (lambda ()
+                              (let ((prog (derivation-builder drv))
+                                    (args (derivation-builder-arguments drv)))
+                                (apply execl prog prog args))))))
+    (values builder environment store-inputs)))
+
+;; Note: used for testing mostly, daemon should be starting builds directly
+;; and not just waiting for them to finish sequentially...
+(define (%build-derivation drv)
+  "Given a <derivation> DRV, build the derivation unconditionally even if its
+outputs already exist."
+  ;; Make sure store permissions and ownership are intact (test-env creates a
+  ;; store with wrong permissions, for example).
+  (when (and (zero? (getuid)) %build-group)
+    (chown %store-directory 0 %build-group))
+  (chmod %store-directory #o1775)
+  ;; Inputs need to exist regardless of how we're getting the outputs of this
+  ;; derivation.
+  (ensure-input-outputs-exist (derivation-inputs drv))
+  (format #t "Starting build of derivation ~a~%~%" drv)
+  (let*-values (((builder environment store-inputs)
+                 (builder+environment+inputs drv (zero? (getuid))))
+                ((output-specs)
+                 (run-builder builder drv environment store-inputs)))
+    (if output-specs
+        (register-items (topologically-sorted output-specs))
+        (throw 'derivation-build-failed drv))))
+
+(define (ensure-input-outputs-exist inputs)
+  "Call %build-derivation as necessary, recursively, to make the necessary
+outputs of INPUTS exist."
+  (for-each
+   (lambda (input)
+     (let ((input-drv-path (derivation-input-path input)))
+       (unless (outputs-exist? input-drv-path
+                               (derivation-input-sub-derivations input))
+         (%build-derivation (read-derivation-from-file input-drv-path)))))
+   inputs))
+
+(define* (build-derivation drv
+                           #:optional (outputs (derivation-output-names drv)))
+  "Given a <derivation> DRV with desired outputs OUTPUTS, build DRV if the
+outputs don't already exist."
+  (unless (outputs-exist? (derivation-file-name drv)
+                          outputs)
+    (%build-derivation drv)))

guix/store/database.scm

@@ -21,6 +21,8 @@
   #:use-module (sqlite3)
   #:use-module (guix config)
   #:use-module (guix serialization)
+  #:use-module (guix store derivations)
+  #:use-module (guix store files)
   #:use-module (guix store deduplication)
   #:use-module (guix base16)
   #:use-module (guix progress)
@@ -34,6 +36,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:use-module (system foreign)
   #:export (sql-schema
             %default-database-file
@@ -42,8 +45,12 @@
             sqlite-register
             register-path
             register-items
+            registered-derivation-outputs
             %epoch
-            reset-timestamps))
+            reset-timestamps
+            outputs-exist?
+            file-closure
+            all-transitive-inputs))
 
 ;;; Code for working with the store database directly.
 
@@ -282,6 +289,26 @@ be used internally by the daemon's build hook."
   ;; When it all began.
   (make-time time-utc 0 1))
 
+(define derivation-outputs-sql "SELECT id, path FROM DerivationOutputs WHERE
+drv in (SELECT id from ValidPaths where path = :drv)")
+
+(define (registered-derivation-outputs db drv)
+  "Get the list of (id, output-path) pairs registered for DRV."
+  (let ((stmt (sqlite-prepare db derivation-outputs-sql #:cache? #t)))
+    (sqlite-bind-arguments stmt #:drv drv)
+    (let ((result (sqlite-fold (lambda (current prev)
+                                 (match current
+                                   (#(id path)
+                                    (cons (cons id path)
+                                          prev))))
+                               '() stmt)))
+      (sqlite-finalize stmt)
+      result)))
+
+(define register-output-sql
+  "INSERT OR REPLACE INTO DerivationOutputs (drv, id, path) SELECT id, :outid,
+:outpath FROM ValidPaths WHERE path = :drvpath;")
+
 (define* (register-items items
                          #:key prefix state-directory
                          (deduplicate? #t)
@@ -330,6 +357,21 @@ Write a progress report to LOG-PORT."
     (define real-file-name
       (string-append store-dir "/" (basename (store-info-item item))))
 
+    (define (register-derivation-outputs drv)
+      "Register all output paths of DRV as being produced by it (note that
+this doesn't mean 'already produced by it', but rather just 'associated with
+it')."
+      (let ((stmt (sqlite-prepare db register-output-sql #:cache? #t)))
+        (for-each (match-lambda
+                    ((outid . ($ <derivation-output> path))
+                     (sqlite-bind-arguments stmt
+                                            #:drvpath (derivation-file-name
+                                                       drv)
+                                            #:outid outid
+                                            #:outpath path)
+                     (sqlite-fold noop #f stmt)))
+                  (derivation-outputs drv))
+        (sqlite-finalize stmt)))
 
     ;; When TO-REGISTER is already registered, skip it.  This makes a
     ;; significant differences when 'register-closures' is called
@@ -345,6 +387,9 @@ Write a progress report to LOG-PORT."
                                                (bytevector->base16-string hash))
                          #:nar-size nar-size
                          #:time registration-time)
+        (when (derivation-path? real-file-name)
+          (register-derivation-outputs (read-derivation-from-file
+                                        real-file-name)))
         (when deduplicate?
           (deduplicate real-file-name hash #:store store-dir)))))
 
@@ -362,3 +407,76 @@ Write a progress report to LOG-PORT."
                               (register db item)
                               (report))
                             items)))))))))
+
+(define output-path-id-sql
+  "SELECT id FROM ValidPaths WHERE path IN (SELECT path FROM DerivationOutputs
+WHERE DerivationOutputs.id = :id AND drv IN (SELECT id FROM ValidPaths WHERE
+path = :drvpath))")
+
+(define* (outputs-exist? drv-path outputs
+                         #:optional (database %default-database-file))
+  "Determine whether all output labels in OUTPUTS exist as built outputs of
+DRV-PATH."
+  (with-database database db
+    (let ((stmt (sqlite-prepare db output-path-id-sql)))
+      (sqlite-bind-arguments stmt #:drvpath drv-path)
+      (let ((result (every (lambda (out-id)
+                             (sqlite-reset stmt)
+                             (sqlite-bind-arguments stmt #:id out-id)
+                             (sqlite-step stmt))
+                           outputs)))
+        (sqlite-finalize stmt)
+        result))))
+
+(define references-sql
+  "SELECT path FROM ValidPaths WHERE id IN (SELECT reference FROM Refs WHERE
+referrer IN (SELECT id FROM ValidPaths WHERE path = :path))")
+
+(define* (file-closure path #:key
+                       (database %default-database-file)
+                       (list-so-far vlist-null))
+  "Return a vlist containing the store paths referenced by PATH, the store
+paths referenced by those paths, and so on."
+  (with-database database db
+    (let ((get-references (sqlite-prepare db references-sql)))
+      ;; to make it possible to go depth-first we need to get all the
+      ;; references of an item first or we'll have re-entrancy issues with
+      ;; the get-references statement.
+      (define (references-of path)
+        ;; There are no problems with resetting an already-reset
+        ;; statement.
+        (sqlite-reset get-references)
+        (sqlite-bind-arguments get-references #:path path)
+        (sqlite-fold (lambda (row prev)
+                       (cons (vector-ref row 0) prev))
+                     '()
+                     get-references))
+
+      (let ((result
+             (let %file-closure ((path path)
+                                 (references-vlist list-so-far))
+               (if (vhash-assoc path references-vlist)
+                   references-vlist
+                   (fold %file-closure
+                         (vhash-cons path #t references-vlist)
+                         (references-of path))))))
+        (sqlite-finalize get-references)
+        result))))
+
+(define (all-input-output-paths drv)
+  "Return a list containing the output paths this derivation's inputs need to
+provide."
+  (apply append (map derivation-input-output-paths
+                     (derivation-inputs drv))))
+
+(define (all-transitive-inputs drv)
+  "Produce a list of all inputs and all of their references."
+  (let ((input-paths (all-input-output-paths drv)))
+    (vhash-fold (lambda (key val prev)
+                  (cons key prev))
+                '()
+                (fold (lambda (input list-so-far)
+                        (file-closure input #:list-so-far list-so-far))
+                      vlist-null
+                      `(,@(derivation-sources drv)
+                        ,@input-paths)))))

guix/store/derivations.scm

@@ -0,0 +1,611 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.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 store derivations)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (gcrypt hash)
+  #:use-module (guix base16)
+  #:use-module (guix combinators)
+  #:use-module (guix memoization)
+  #:use-module (guix sets)
+  #:use-module (guix store files)
+  #:export (&derivation-error
+            derivation-error?
+            derivation-error-derivation
+
+            &derivation-missing-output-error
+            derivation-missing-output-error?
+            derivation-missing-output
+
+            <derivation>
+            make-derivation
+            derivation?
+            derivation-outputs
+            derivation-inputs
+            derivation-sources
+            derivation-system
+            derivation-builder
+            derivation-builder-arguments
+            derivation-builder-environment-vars
+            derivation-file-name
+
+            <derivation-output>
+            make-derivation-output
+            derivation-output?
+            derivation-output-path
+            derivation-output-hash-algo
+            derivation-output-hash
+            derivation-output-recursive?
+            derivation-output-names
+
+            <derivation-input>
+            make-derivation-input
+            derivation-input?
+            derivation-input-derivation
+            derivation-input-sub-derivations
+            derivation-input-path
+            derivation-input
+            derivation-input-key
+            coalesce-duplicate-inputs
+
+            derivation-name
+            derivation-base16-hash
+            derivation-output-names
+            derivation-hash
+            derivation-properties
+            fixed-output-derivation?
+            offloadable-derivation?
+            substitutable-derivation?
+
+            derivation-input<?
+            derivation-input-output-path
+            derivation-input-output-paths
+            derivation-output-paths
+            derivation-input-fold
+            derivation->output-path
+            derivation->output-paths
+            derivation-path->output-path
+            derivation-path->output-paths
+
+            derivation-prerequisites
+
+            derivation/masked-inputs
+            read-derivation
+            read-derivation-from-file
+            derivation->bytevector
+            %derivation-cache
+            write-derivation
+            invalidate-derivation-caches!))
+
+;;;
+;;; Nix derivations, as implemented in Nix's `derivations.cc'.
+;;;
+
+(define-immutable-record-type <derivation>
+  (make-derivation outputs inputs sources system builder args env-vars
+                   file-name)
+  derivation?
+  (outputs  derivation-outputs)      ; list of name/<derivation-output> pairs
+  (inputs   derivation-inputs)       ; list of <derivation-input>
+  (sources  derivation-sources)      ; list of store paths
+  (system   derivation-system)       ; string
+  (builder  derivation-builder)      ; store path
+  (args     derivation-builder-arguments)         ; list of strings
+  (env-vars derivation-builder-environment-vars)  ; list of name/value pairs
+  (file-name derivation-file-name))               ; the .drv file name
+
+(define-immutable-record-type <derivation-output>
+  (make-derivation-output path hash-algo hash recursive?)
+  derivation-output?
+  (path       derivation-output-path)             ; store path
+  (hash-algo  derivation-output-hash-algo)        ; symbol | #f
+  (hash       derivation-output-hash)             ; bytevector | #f
+  (recursive? derivation-output-recursive?))      ; Boolean
+
+(define-immutable-record-type <derivation-input>
+  (make-derivation-input drv sub-derivations)
+  derivation-input?
+  (drv             derivation-input-derivation)       ; <derivation>
+  (sub-derivations derivation-input-sub-derivations)) ; list of strings
+
+
+(define (derivation-input-path input)
+  "Return the file name of the derivation INPUT refers to."
+  (derivation-file-name (derivation-input-derivation input)))
+
+(define* (derivation-input drv #:optional
+                           (outputs (derivation-output-names drv)))
+  "Return a <derivation-input> for the OUTPUTS of DRV."
+  ;; This is a public interface meant to be more convenient than
+  ;; 'make-derivation-input' and giving us more control.
+  (make-derivation-input drv outputs))
+
+(define (derivation-input-key input)
+  "Return an object for which 'equal?' and 'hash' are constant-time, and which
+can thus be used as a key for INPUT in lookup tables."
+  (cons (derivation-input-path input)
+        (derivation-input-sub-derivations input)))
+
+(set-record-type-printer! <derivation>
+                          (lambda (drv port)
+                            (format port "#<derivation ~a => ~a ~a>"
+                                    (derivation-file-name drv)
+                                    (string-join
+                                     (map (match-lambda
+                                           ((_ . output)
+                                            (derivation-output-path output)))
+                                          (derivation-outputs drv)))
+                                    (number->string (object-address drv)
+                                                    16))))
+
+;;;
+;;; Error conditions.
+;;;
+
+(define-condition-type &derivation-error &store-error
+  derivation-error?
+  (derivation derivation-error-derivation))
+
+(define-condition-type &derivation-missing-output-error &derivation-error
+  derivation-missing-output-error?
+  (output derivation-missing-output))
+
+
+(define (derivation-name drv)
+  "Return the base name of DRV."
+  (let ((base (store-path-package-name (derivation-file-name drv))))
+    (string-drop-right base 4)))
+
+(define (derivation-output-names drv)
+  "Return the names of the outputs of DRV."
+  (match (derivation-outputs drv)
+    (((names . _) ...)
+     names)))
+
+(define (fixed-output-derivation? drv)
+  "Return #t if DRV is a fixed-output derivation, such as the result of a
+download with a fixed hash (aka. `fetchurl')."
+  (match drv
+    (($ <derivation>
+        (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
+     #t)
+    (_ #f)))
+
+(define (derivation-input<? input1 input2)
+  "Compare INPUT1 and INPUT2, two <derivation-input>."
+  (string<? (derivation-input-path input1)
+            (derivation-input-path input2)))
+
+(define (coalesce-duplicate-inputs inputs)
+  "Return a list of inputs, such that when INPUTS contains the same DRV twice,
+they are coalesced, with their sub-derivations merged.  This is needed because
+Nix itself keeps only one of them."
+  (define (find pred lst)                         ;inlinable copy of 'find'
+    (let loop ((lst lst))
+      (match lst
+        (() #f)
+        ((head . tail)
+         (if (pred head) head (loop tail))))))
+
+  (fold (lambda (input result)
+          (match input
+            (($ <derivation-input> (= derivation-file-name path) sub-drvs)
+             ;; XXX: quadratic
+             (match (find (match-lambda
+                            (($ <derivation-input> (= derivation-file-name p)
+                                                   s)
+                             (string=? p path)))
+                          result)
+               (#f
+                (cons input result))
+               ((and dup ($ <derivation-input> drv sub-drvs2))
+                ;; Merge DUP with INPUT.
+                (let ((sub-drvs (delete-duplicates
+                                 (append sub-drvs sub-drvs2))))
+                  (cons (make-derivation-input drv (sort sub-drvs string<?))
+                        (delq dup result))))))))
+        '()
+        inputs))
+
+(define* (derivation-prerequisites drv #:optional (cut? (const #f)))
+  "Return the list of derivation-inputs required to build DRV, recursively.
+
+CUT? is a predicate that is passed a derivation-input and returns true to
+eliminate the given input and its dependencies from the search.  An example of
+such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
+result is the set of prerequisites of DRV not already in valid."
+  (let loop ((drv       drv)
+             (result    '())
+             (input-set (set)))
+    (let ((inputs (remove (lambda (input)
+                            (or (set-contains? input-set
+                                               (derivation-input-key input))
+                                (cut? input)))
+                          (derivation-inputs drv))))
+      (fold2 loop
+             (append inputs result)
+             (fold set-insert input-set
+                   (map derivation-input-key inputs))
+             (map derivation-input-derivation inputs)))))
+
+(define (offloadable-derivation? drv)
+  "Return true if DRV can be offloaded, false otherwise."
+  (match (assoc "preferLocalBuild"
+                (derivation-builder-environment-vars drv))
+    (("preferLocalBuild" . "1") #f)
+    (_ #t)))
+
+(define (substitutable-derivation? drv)
+  "Return #t if DRV can be substituted."
+  (match (assoc "allowSubstitutes"
+                (derivation-builder-environment-vars drv))
+    (("allowSubstitutes" . value)
+     (string=? value "1"))
+    (_ #t)))
+
+(define (derivation-output-paths drv sub-drvs)
+  "Return the output paths of outputs SUB-DRVS of DRV."
+  (match drv
+    (($ <derivation> outputs)
+     (map (lambda (sub-drv)
+            (derivation-output-path (assoc-ref outputs sub-drv)))
+          sub-drvs))))
+
+(define* (derivation-input-fold proc seed inputs
+                                #:key (cut? (const #f)))
+  "Perform a breadth-first traversal of INPUTS, calling PROC on each input
+with the current result, starting from SEED.  Skip recursion on inputs that
+match CUT?."
+  (let loop ((inputs inputs)
+             (result seed)
+             (visited (set)))
+    (match inputs
+      (()
+       result)
+      ((input rest ...)
+       (let ((key (derivation-input-key input)))
+         (cond ((set-contains? visited key)
+                (loop rest result visited))
+               ((cut? input)
+                (loop rest result (set-insert key visited)))
+               (else
+                (let ((drv (derivation-input-derivation input)))
+                  (loop (append (derivation-inputs drv) rest)
+                        (proc input result)
+                        (set-insert key visited))))))))))
+
+(define derivation-base16-hash
+  (mlambdaq (drv)
+    "Return a string containing the base16 representation of the hash of DRV."
+    (bytevector->base16-string (derivation-hash drv))))
+
+(define (derivation/masked-inputs drv)
+  "Assuming DRV is a regular derivation (not fixed-output), replace the file
+name of each input with that input's hash."
+  (match drv
+    (($ <derivation> outputs inputs sources
+                     system builder args env-vars)
+     (let ((inputs (map (match-lambda
+                          (($ <derivation-input> drv sub-drvs)
+                           (let ((hash (derivation-base16-hash drv)))
+                             (make-derivation-input hash sub-drvs))))
+                        inputs)))
+       (make-derivation outputs
+                        (sort (delete-duplicates inputs)
+                              (lambda (drv1 drv2)
+                                (string<? (derivation-input-derivation drv1)
+                                          (derivation-input-derivation drv2))))
+                        sources
+                        system builder args env-vars
+                        #f)))))
+
+(define derivation-hash            ; `hashDerivationModulo' in derivations.cc
+  (lambda (drv)
+    "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
+    (match drv
+      (($ <derivation> ((_ . ($ <derivation-output> path
+                                                    (? symbol? hash-algo) (? bytevector? hash)
+                                                    (? boolean? recursive?)))))
+       ;; A fixed-output derivation.
+       (sha256
+        (string->utf8
+         (string-append "fixed:out:"
+                        (if recursive? "r:" "")
+                        (symbol->string hash-algo)
+                        ":" (bytevector->base16-string hash)
+                        ":" path))))
+      (_
+
+       ;; XXX: At this point this remains faster than `port-sha256', because
+       ;; the SHA256 port's `write' method gets called for every single
+       ;; character.
+       (sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
+
+(define (invalidate-derivation-caches!)
+  "Invalidate internal derivation caches.  This is mostly useful for
+long-running processes that know what they're doing.  Use with care!"
+  ;; Typically this is meant to be used by Cuirass and Hydra, which can clear
+  ;; caches when they start evaluating packages for another architecture.
+  (invalidate-memoization! derivation->bytevector)
+
+  ;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>.
+  ;; (hash-clear! %derivation-cache)
+  )
+
+(define derivation-properties
+  (mlambdaq (drv)
+    "Return the property alist associated with DRV."
+    (match (assoc "guix properties"
+                  (derivation-builder-environment-vars drv))
+      ((_ . str) (call-with-input-string str read))
+      (#f        '()))))
+
+(define (derivation-input-output-path input)
+  "Return the output file name of INPUT.  If INPUT has more than one outputs,
+an error is raised."
+  (match input
+    (($ <derivation-input> drv (output))
+     (derivation->output-path drv output))))
+
+(define (derivation-input-output-paths input)
+  "Return the list of output paths corresponding to INPUT, a
+<derivation-input>."
+  (match input
+    (($ <derivation-input> drv sub-drvs)
+     (map (cut derivation->output-path drv <>)
+          sub-drvs))))
+
+(define* (derivation->output-path drv #:optional (output "out"))
+  "Return the store path of its output OUTPUT.  Raise a
+'&derivation-missing-output-error' condition if OUTPUT is not an output of
+DRV."
+  (let ((output* (assoc-ref (derivation-outputs drv) output)))
+    (if output*
+        (derivation-output-path output*)
+        (raise (condition (&derivation-missing-output-error
+                           (derivation drv)
+                           (output output)))))))
+
+(define (derivation->output-paths drv)
+  "Return the list of name/path pairs of the outputs of DRV."
+  (map (match-lambda
+        ((name . output)
+         (cons name (derivation-output-path output))))
+       (derivation-outputs drv)))
+
+(define derivation-path->output-path
+  ;; This procedure is called frequently, so memoize it.
+  (let ((memoized (mlambda (path output)
+                    (derivation->output-path (read-derivation-from-file path)
+                                             output))))
+    (lambda* (path #:optional (output "out"))
+      "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
+path of its output OUTPUT."
+      (memoized path output))))
+
+(define (derivation-path->output-paths path)
+  "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
+list of name/path pairs of its outputs."
+  (derivation->output-paths (read-derivation-from-file path)))
+
+
+(define* (read-derivation drv-port
+                          #:optional (read-derivation-from-file
+                                      read-derivation-from-file))
+  "Read the derivation from DRV-PORT and return the corresponding <derivation>
+object.  Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs
+of the derivation being parsed.
+
+Most of the time you'll want to use 'read-derivation-from-file', which caches
+things as appropriate and is thus more efficient."
+
+  (define comma (string->symbol ","))
+
+  (define (ununquote x)
+    (match x
+      (('unquote x) (ununquote x))
+      ((x ...)      (map ununquote x))
+      (_            x)))
+
+  (define (outputs->alist x)
+    (fold-right (lambda (output result)
+                  (match output
+                    ((name path "" "")
+                     (alist-cons name
+                                 (make-derivation-output path #f #f #f)
+                                 result))
+                    ((name path hash-algo hash)
+                     ;; fixed-output
+                     (let* ((rec? (string-prefix? "r:" hash-algo))
+                            (algo (string->symbol
+                                   (if rec?
+                                       (string-drop hash-algo 2)
+                                       hash-algo)))
+                            (hash (base16-string->bytevector hash)))
+                       (alist-cons name
+                                   (make-derivation-output path algo
+                                                           hash rec?)
+                                   result)))))
+                '()
+                x))
+
+  (define (make-input-drvs x)
+    (fold-right (lambda (input result)
+                  (match input
+                    ((path (sub-drvs ...))
+                     (let ((drv (read-derivation-from-file path)))
+                       (cons (make-derivation-input drv sub-drvs)
+                             result)))))
+                '()
+                x))
+
+  ;; The contents of a derivation are typically ASCII, but choosing
+  ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
+  (set-port-encoding! drv-port "UTF-8")
+
+  (let loop ((exp    (read drv-port))
+             (result '()))
+    (match exp
+      ((? eof-object?)
+       (let ((result (reverse result)))
+         (match result
+           (('Derive ((outputs ...) (input-drvs ...)
+                      (input-srcs ...)
+                      (? string? system)
+                      (? string? builder)
+                      ((? string? args) ...)
+                      ((var value) ...)))
+            (make-derivation (outputs->alist outputs)
+                             (make-input-drvs input-drvs)
+                             input-srcs
+                             system builder args
+                             (fold-right alist-cons '() var value)
+                             (port-filename drv-port)))
+           (_
+            (error "failed to parse derivation" drv-port result)))))
+      ((? (cut eq? <> comma))
+       (loop (read drv-port) result))
+      (_
+       (loop (read drv-port)
+             (cons (ununquote exp) result))))))
+
+(define %derivation-cache
+  ;; Maps derivation file names to <derivation> objects.
+  ;; XXX: This is redundant with 'atts-cache' in the store.
+  (make-weak-value-hash-table 200))
+
+(define (read-derivation-from-file file)
+  "Read the derivation in FILE, a '.drv' file, and return the corresponding
+<derivation> object."
+  ;; Memoize that operation because 'read-derivation' is quite expensive,
+  ;; and because the same argument is read more than 15 times on average
+  ;; during something like (package-derivation s gdb).
+  (or (and file (hash-ref %derivation-cache file))
+      (let ((drv (call-with-input-file file read-derivation)))
+        (hash-set! %derivation-cache file drv)
+        drv)))
+
+(define-inlinable (write-sequence lst write-item port)
+  ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
+  ;; comma.
+  (match lst
+    (()
+     #t)
+    ((prefix (... ...) last)
+     (for-each (lambda (item)
+                 (write-item item port)
+                 (display "," port))
+               prefix)
+     (write-item last port))))
+
+(define-inlinable (write-list lst write-item port)
+  ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
+  ;; element.
+  (display "[" port)
+  (write-sequence lst write-item port)
+  (display "]" port))
+
+(define-inlinable (write-tuple lst write-item port)
+  ;; Same, but write LST as a tuple.
+  (display "(" port)
+  (write-sequence lst write-item port)
+  (display ")" port))
+
+(define (write-derivation drv port)
+  "Write the ATerm-like serialization of DRV to PORT.  See Section 2.4 of
+Eelco Dolstra's PhD dissertation for an overview of a previous version of
+that form."
+
+  ;; Make sure we're using the faster implementation.
+  (define format simple-format)
+
+  (define (write-string-list lst)
+    (write-list lst write port))
+
+  (define (write-output output port)
+    (match output
+     ((name . ($ <derivation-output> path hash-algo hash recursive?))
+      (write-tuple (list name path
+                         (if hash-algo
+                             (string-append (if recursive? "r:" "")
+                                            (symbol->string hash-algo))
+                             "")
+                         (or (and=> hash bytevector->base16-string)
+                             ""))
+                   write
+                   port))))
+
+  (define (write-input input port)
+    (match input
+      (($ <derivation-input> obj sub-drvs)
+       (display "(\"" port)
+
+       ;; 'derivation/masked-inputs' produces objects that contain a string
+       ;; instead of a <derivation>, so we need to account for that.
+       (display (if (derivation? obj)
+                    (derivation-file-name obj)
+                    obj)
+                port)
+       (display "\"," port)
+       (write-string-list sub-drvs)
+       (display ")" port))))
+
+  (define (write-env-var env-var port)
+    (match env-var
+      ((name . value)
+       (display "(" port)
+       (write name port)
+       (display "," port)
+       (write value port)
+       (display ")" port))))
+
+  ;; Assume all the lists we are writing are already sorted.
+  (match drv
+    (($ <derivation> outputs inputs sources
+        system builder args env-vars)
+     (display "Derive(" port)
+     (write-list outputs write-output port)
+     (display "," port)
+     (write-list inputs write-input port)
+     (display "," port)
+     (write-string-list sources)
+     (simple-format port ",\"~a\",\"~a\"," system builder)
+     (write-string-list args)
+     (display "," port)
+     (write-list env-vars write-env-var port)
+     (display ")" port))))
+
+(define derivation->bytevector
+  (mlambda (drv)
+    "Return the external representation of DRV as a UTF-8-encoded string."
+    (with-fluids ((%default-port-encoding "UTF-8"))
+      (call-with-values open-bytevector-output-port
+        (lambda (port get-bytevector)
+          (write-derivation drv port)
+          (get-bytevector))))))

guix/store/environment.scm

@@ -0,0 +1,492 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.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/>.
+
+;;; Code for setting up environments, especially build environments.  Builds
+;;; on top of (gnu build linux-container).
+
+(define-module (guix store environment)
+  #:use-module (guix records)
+  #:use-module (guix config)
+  #:use-module (gnu build linux-container)
+  #:use-module (gnu system file-systems)
+  #:use-module ((guix build utils) #:select (delete-file-recursively
+                                             mkdir-p
+                                             copy-recursively))
+  #:use-module (guix derivations)
+  #:use-module (guix store)
+  #:use-module (guix build syscalls)
+  #:use-module (guix store database)
+  #:use-module (guix store files)
+  #:use-module (gcrypt hash)
+  #:use-module (guix base32)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-98)
+
+  #:export (<environment>
+            environment
+            environment-namespaces
+            environment-variables
+            environment-temp-dirs
+            environment-filesystems
+            environment-new-session?
+            environment-new-pgroup?
+            environment-setup-i/o-proc
+            environment-preserved-fds
+            environment-chroot
+            environment-personality
+            environment-user
+            environment-group
+            environment-hostname
+            environment-domainname
+            build-environment-vars
+            delete-environment
+            run-in-environment
+            bind-mount
+            standard-i/o-setup
+            %standard-preserved-fds
+            nonchroot-build-environment
+            chroot-build-environment
+            builtin-builder-environment
+            run-standard
+            run-standard-build
+            wait-for-build))
+
+(define %standard-preserved-fds '(0 1 2))
+
+(define-record-type* <environment> environment
+  ;; The defaults are set to be as close to the "current environment" as
+  ;; possible.
+  make-environment
+  environment?
+  (namespaces environment-namespaces (default '())) ; list of symbols
+  ; list of (key . val) pairs
+  (variables environment-variables (default (get-environment-variables)))
+  ; list of (symbol . filename) pairs.
+  (temp-dirs environment-temp-dirs (default '()))
+  ;; list of <file-system> objects. Only used when MNT is in NAMESPACES.
+  (filesystems environment-filesystems (default '()))
+  ; boolean (implies NEW-PGROUP?)
+  (new-session? environment-new-session? (default #f))
+  (new-pgroup? environment-new-pgroup? (default #f)) ; boolean
+  (setup-i/o environment-setup-i/o-proc) ; a thunk or #f
+  ; #f or list of integers (in case of #f, all are preserved)
+  (preserved-fds environment-preserved-fds (default #f))
+  ;; either the chroot directory or #f, must not be #f if MNT is in
+  ;; NAMESPACES! Will be recursively deleted when the environment is
+  ;; destroyed. Ignored if MNT is not in NAMESPACES.
+  (chroot environment-chroot (default #f))
+  (initial-directory environment-initial-directory (default #f)) ; string or #f
+  (personality environment-personality (default #f)) ; integer or #f
+  ;; These are currently naively handled in the case of user namespaces.
+  (user environment-user (default #f))             ; integer or #f
+  (group environment-group (default #f))           ; integer or #f
+  (hostname environment-hostname (default #f))         ; string or #f
+  (domainname environment-domainname (default #f)))    ; string or #f
+
+(define (delete-environment env)
+  "Delete all temporary directories used in ENV."
+  (for-each (match-lambda
+              ((id . filename)
+               (delete-file-recursively filename)))
+            (environment-temp-dirs env))
+  (when (environment-chroot env)
+    (delete-file-recursively (environment-chroot env))))
+
+(define (format-file file-name . args)
+  (call-with-output-file file-name
+    (lambda (port)
+      (apply simple-format port args))))
+
+(define* (mkdir-p* dir #:optional permissions)
+  (mkdir-p dir)
+  (when permissions
+    (chmod dir permissions)))
+
+(define (add-core-files environment fixed-output?)
+  "Populate container with miscellaneous files and directories that shouldn't
+be bind-mounted."
+  (let ((uid (environment-user environment))
+        (gid (environment-group environment)))
+    (mkdir-p* "/tmp" #o1777)
+    (mkdir-p* "/etc")
+
+    (unless (or (file-exists? "/etc/passwd")
+                (file-exists? "/etc/group"))
+      (format-file "/etc/passwd"
+                   (string-append "nixbld:x:~a:~a:Nix build user:/:/noshell~%"
+                                  "nobody:x:65534:65534:Nobody:/:/noshell~%")
+                   uid gid)
+      (format-file "/etc/group" "nixbld:!:~a:~%" gid))
+
+    (unless (or fixed-output? (file-exists? "/etc/hosts"))
+      (format-file "/etc/hosts" "127.0.0.1 localhost~%"))
+    (when (file-exists? "/dev/pts/ptmx")
+      (chmod "/dev/pts/ptmx" #o0666))))
+
+(define (run-in-environment env thunk . i/o-args)
+  "Run THUNK in ENV with I/O-ARGS passed to the SETUP-I/O procedure of
+ENV.  Return the pid of the process THUNK is run in."
+  (match env
+    (($ <environment> namespaces variables temp-dirs
+                      filesystems new-session? new-pgroup? setup-i/o
+                      preserved-fds chroot current-directory new-personality
+                      user group hostname domainname)
+     (when (and new-session? (not new-pgroup?))
+       (throw 'invalid-environment "NEW-SESSION? implies NEW-PGROUP?."))
+     (let ((fixed-output? (not (memq 'net namespaces))))
+       (run-container chroot filesystems namespaces (and user (1+ user))
+                      (lambda ()
+                        (when hostname (sethostname hostname))
+                        (when domainname (setdomainname domainname))
+                        ;; setsid / setpgrp as necessary
+                        (if new-session?
+                            (setsid)
+                            (when new-pgroup?
+                              (setpgid 0 0)))
+                        (when chroot
+                          (add-core-files env fixed-output?))
+                        ;; set environment variables
+                        (when variables
+                          (environ (map (match-lambda
+                                          ((key . val)
+                                           (string-append key "=" val)))
+                                        variables)))
+                        (when setup-i/o (apply setup-i/o i/o-args))
+                        ;; set UID and GID
+                        (when current-directory (chdir current-directory))
+                        (when group (setgid group))
+                        (when user (setuid user))
+                        ;; Close unpreserved fds
+                        (when preserved-fds
+                          (let close-next ((n 0))
+                            (when (< n 20) ;; XXX: don't hardcode.
+                              (unless (memq n preserved-fds)
+                                (false-if-exception (close-fdes n)))
+                              (close-next (1+ n)))))
+
+                        ;; enact personality
+                        (when new-personality (personality new-personality))
+                        (thunk)))))))
+
+(define (bind-mount src dest)
+  "Return a <file-system> denoting the bind-mounting of SRC to DEST. Note that
+if this is part of a chroot <environment>, DEST will be the name *inside of*
+the chroot, i.e.
+
+(bind-mount \"/foo/x\" \"/bar/x\")
+
+in an environment with chroot \"/chrootdir\" will bind-mount \"/foo/x\" to
+\"/chrootdir/bar/x\"."
+  (file-system
+    (device src)
+    (mount-point dest)
+    (type "none")
+    (flags '(bind-mount))
+    (check? #f)))
+
+(define input->mount
+  (match-lambda
+    ((source . dest)
+     (bind-mount source dest))
+    (source
+     (bind-mount source source))))
+
+(define (default-files drv)
+  "Return a list of the files to be bind-mounted that aren't store items or
+already added by call-with-container."
+  `(,@(if (file-exists? "/dev/kvm")
+          '("/dev/kvm")
+          '())
+    ,@(if (fixed-output-derivation? drv)
+          '("/etc/resolv.conf"
+            "/etc/nsswitch.conf"
+            "/etc/services"
+            "/etc/hosts")
+          '())))
+
+(define (build-environment-vars drv build-dir)
+  "Return an alist of environment variable / value pairs for every environment
+variable that should be set during the build execution."
+  (let ((leaked-vars (and
+                      (fixed-output-derivation? drv)
+                      (let ((leak-string
+                             (assoc-ref (derivation-builder-environment-vars drv)
+                                        "impureEnvVars")))
+                        (and leak-string
+                             (string-tokenize leak-string
+                                              (char-set-complement
+                                               (char-set #\space))))))))
+    (append `(("PATH"             .  "/path-not-set")
+              ("HOME"             .  "/homeless-shelter")
+              ("NIX_STORE"        .  ,%store-directory)
+              ;; XXX: make this configurable
+              ("NIX_BUILD_CORES"  .  "0")
+              ("NIX_BUILD_TOP"    .  ,build-dir)
+              ("TMPDIR"           .  ,build-dir)
+              ("TEMPDIR"          .  ,build-dir)
+              ("TMP"              .  ,build-dir)
+              ("TEMP"             .  ,build-dir)
+              ("PWD"              .  ,build-dir))
+            (if (fixed-output-derivation? drv)
+                (cons '("NIX_OUTPUT_CHECKED" . "1")
+                      (if leaked-vars
+                          ;; leaked vars might be #f
+                          (filter cdr
+                                  (map (lambda (leaked-var)
+                                         (cons leaked-var (getenv leaked-var)))
+                                       leaked-vars))
+                          '()))
+                '())
+            (derivation-builder-environment-vars drv))))
+
+(define* (temp-directory name #:optional permissions user group
+                         #:key (tmpdir %temp-directory))
+  "Create a temporary directory under TMPDIR with permissions PERMISSIONS if
+specified, otherwise default permissions as specified by umask, and belonging
+to user USER and group GROUP (defaulting to current user if not specified or
+#f).  Return the full filename of the form <tmpdir>/<name>-<number>."
+  (let try-again ((attempt-number 0))
+    (catch 'system-error
+      (lambda ()
+        (let ((attempt-name (string-append tmpdir "/" name "-"
+                                           (number->string
+                                            attempt-number 10))))
+          (mkdir attempt-name permissions)
+          (when permissions
+            ;; the only guarantee we get from mkdir is that the actual
+            ;; permissions are no more permissive than what we specified. In
+            ;; the event we want to be more permissive than the umask, though,
+            ;; this is necessary.
+            (chmod attempt-name permissions))
+          ;; -1 means "unchanged"
+          (chown attempt-name (or user -1) (or group -1))
+          attempt-name))
+      (lambda args
+        (if (= (system-error-errno args) EEXIST)
+            (try-again (+ attempt-number 1))
+            (apply throw args))))))
+
+(define (special-filesystems input-paths)
+  "Return whatever new filesystems need to be created in the container, which
+depends on whether they're already set to be bind-mounted.  INPUT-PATHS must
+be a list of paths or pairs of paths."
+  ;; procfs and devpts are already taken care of by run-container
+  `(,@(if (file-exists? "/dev/shm")
+          (list (file-system
+                  (device "none")
+                  (mount-point "/dev/shm")
+                  (type "tmpfs")
+                  (check? #f)))
+          '())))
+
+(define (standard-i/o-setup output-port)
+  "Redirect output and error streams to OUTPUT-FD, get input from /dev/null."
+  (define output-fd (port->fdes output-port))
+  (define stdout (fdopen 1 "w"))
+  ;; Useful in case an error happens between here and an exec and it needs to
+  ;; get reported.
+  (set-current-output-port stdout)
+  (set-current-error-port stdout)
+  (dup2 output-fd 1)
+  (dup2 output-fd 2)
+  (call-with-input-file "/dev/null"
+    (lambda (null-port)
+      (dup2 (port->fdes null-port) 0)))
+  (sigaction SIGPIPE SIG_DFL))
+
+
+
+(define (derivation-tempname drv)
+  (string-append "guix-build-"
+                 (store-path-package-name (derivation-file-name drv))))
+
+;; We might want to add to this sometime.
+(define %default-chroot-dirs
+  '())
+
+(define (default-personality drv)
+  (let ((current-personality (personality #xffffffff)))
+    (logior current-personality ADDR_NO_RANDOMIZE
+            (match (cons %system (derivation-system drv))
+              ((or ("x86_64-linux" . "i686-linux")
+                   ("aarch64-linux" . "armhf-linux"))
+               PER_LINUX32)
+              (_ 0))
+            (match (cons (derivation-system drv) (%impersonate-linux-2.6?))
+              (((or "x86_64-linux" "i686-linux") . #t)
+               UNAME26)
+              (_ 0)))))
+
+(define* (make-build-directory drv #:optional uid gid)
+  (let ((build-directory (temp-directory (derivation-tempname drv) #o0700
+                                         uid gid)))
+    ;; XXX: Honor exportReferencesGraph here...
+    build-directory))
+
+(define* (nonchroot-build-environment drv #:key gid uid)
+  "Create and return an <environment> for building DRV outside of a chroot, as
+well as the store inputs the build requires."
+  (let* ((fixed-output? (fixed-output-derivation? drv))
+         (build-directory (make-build-directory drv)))
+    (values
+     (environment
+      (temp-dirs `((build-directory . ,build-directory)))
+      (initial-directory build-directory)
+      (new-session? #t)
+      (new-pgroup? #t)
+      (variables (build-environment-vars drv build-directory))
+      (preserved-fds %standard-preserved-fds)
+      (setup-i/o standard-i/o-setup)
+      (personality (default-personality drv))
+      (user uid)
+      (group gid))
+     (all-transitive-inputs drv))))
+
+
+(define* (builtin-builder-environment drv #:key gid uid)
+  "Create and return an <environment> for builtin builders, as well as the
+store inputs the build requires."
+  ;; It's just the same as non-chroot-build-environment, but without any
+  ;; environment variables being changed.
+  (let*-values (((env inputs) (nonchroot-build-environment drv
+                                                           #:gid gid
+                                                           #:uid uid)))
+    (values
+     (environment (inherit env)
+                  (variables (get-environment-variables)))
+     inputs)))
+
+(define* (chroot-build-environment drv #:key gid uid
+                                   (extra-chroot-dirs '())
+                                   build-chroot-dirs )
+  "Create an <environment> for building DRV with standard in-chroot
+settings (as used by nix daemon).  Return said environment as well as the
+store paths that are included in it (useful for reference scanning)."
+  (let* ((tempname (derivation-tempname drv))
+         (store-directory (temp-directory (string-append tempname ".store")
+                                          #o1775 0 gid))
+         (build-directory (make-build-directory drv uid gid))
+         (inside-build-dir (string-append %temp-directory "/" tempname "-0"))
+         (fixed-output? (fixed-output-derivation? drv))
+         (store-inputs (all-transitive-inputs drv))
+         (input-paths (append store-inputs
+                              (default-files drv)
+                              (or build-chroot-dirs
+                                  %default-chroot-dirs)
+                              extra-chroot-dirs)))
+    (values
+     (environment
+      (namespaces `(mnt pid ipc uts ,@(if fixed-output? '() '(net))))
+      (filesystems
+       (cons* (bind-mount build-directory inside-build-dir)
+              (bind-mount store-directory %store-directory)
+              (append (special-filesystems input-paths)
+                      (map input->mount input-paths))))
+      (temp-dirs `((store-directory . ,store-directory)
+                   (build-directory . ,build-directory)))
+      (initial-directory inside-build-dir)
+      (new-session? #t)
+      (new-pgroup? #t)
+      (setup-i/o (lambda (output-fd)
+                   (unless fixed-output?
+                     (initialize-loopback))
+                   (standard-i/o-setup output-fd)))
+      (variables (build-environment-vars drv inside-build-dir))
+      (preserved-fds %standard-preserved-fds)
+      (chroot (temp-directory (string-append tempname ".chroot") #o750 0 gid))
+      (user uid)
+      (group gid)
+      (personality (default-personality drv))
+      (hostname "localhost")
+      (domainname "(none)"))
+     store-inputs)))
+
+(define (redirected-path drv output)
+  (let* ((original (derivation-output-path (assoc-ref (derivation-outputs drv)
+                                                      output)))
+         (hash
+          (bytevector->nix-base32-string
+           (compressed-hash (sha256 (string-append "rewrite:"
+                                                   (derivation-file-name drv)
+                                                   ":"
+                                                   original))
+                            20))))
+    (string-append (%store-prefix) "/" hash "-"
+                   (store-path-package-name original))))
+
+(define (redirect-outputs env drv output-names)
+  "Create a new <environment> based on ENV but modified so that for each
+output-name in OUTPUT-NAMES, the environment variable corresponding to that
+output is set to a newly-generated output path."
+  (environment (inherit env)
+   (variables (append (map (lambda (output)
+                             (cons output (redirected-path drv output)))
+                           output-names)
+                      (remove (lambda (var)
+                                (member (car var) output-names))
+                              (environment-variables env))))))
+
+(define (run-standard environment thunk)
+  "Run THUNK in ENVIRONMENT.  Return the PID it is being run in and the read
+end of the pipe its i/o has been set up with."
+  (match (pipe)
+    ((read . write)
+     (let ((pid (run-in-environment environment
+                                    (lambda ()
+                                      (catch #t
+                                        (lambda ()
+                                          (thunk)
+                                          (primitive-exit 0))
+                                        (lambda args
+                                          (format #t "Error: ~A~%" args)
+                                          (primitive-exit 1))))
+                                    write)))
+       (close-fdes (port->fdes write))
+       (values pid read)))))
+
+(define (run-standard-build drv environment)
+  "Run the builder of DRV in ENVIRONMENT.  Return the PID it is being run in
+and the read end of the pipe its i/o has been set up with."
+  (run-standard environment
+                (lambda ()
+                  (let ((prog (derivation-builder drv))
+                        (args (derivation-builder-arguments drv)))
+                    (apply execl prog prog args)))))
+
+(define* (dump-port port #:optional (target-port (current-output-port)))
+  (if (port-eof? port)
+      (force-output target-port)
+      (begin
+        (put-bytevector target-port (get-bytevector-some port))
+        (dump-port port target-port))))
+
+(define (wait-for-build pid read-port)
+  "Dump all input from READ-PORT to (current-output-port), then wait for PID
+to terminate."
+  (dump-port read-port)
+  (close-fdes (port->fdes read-port))
+  ;; Should we wait specifically for PID to die, or just for any state change?
+  (cdr (waitpid pid)))
+
+
+

guix/store/files.scm

@@ -0,0 +1,176 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.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 store files)
+  #:use-module (ice-9 regex)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-35)
+  #:use-module (gcrypt hash)
+  #:use-module (guix base32)
+  #:use-module (guix base16)
+  #:use-module (guix config)
+  #:use-module (guix memoization)
+  #:export (&store-error
+            store-error?
+            %store-prefix
+            store-path
+            output-path
+            fixed-output-path
+            store-path?
+            direct-store-path?
+            derivation-path?
+            store-path-base
+            store-path-package-name
+            store-path-hash-part
+            direct-store-path
+            derivation-log-file
+            log-file
+            compressed-hash))
+
+(define-condition-type &store-error &error
+  store-error?)
+
+;;;
+;;; Store paths.
+;;;
+
+(define %store-prefix
+  ;; Absolute path to the Nix store.
+  (make-parameter %store-directory))
+
+(define (compressed-hash bv size)                 ; `compressHash'
+  "Given the hash stored in BV, return a compressed version thereof that fits
+in SIZE bytes."
+  (define new (make-bytevector size 0))
+  (define old-size (bytevector-length bv))
+  (let loop ((i 0))
+    (if (= i old-size)
+        new
+        (let* ((j (modulo i size))
+               (o (bytevector-u8-ref new j)))
+          (bytevector-u8-set! new j
+                              (logxor o (bytevector-u8-ref bv i)))
+          (loop (+ 1 i))))))
+
+(define (store-path type hash name)               ; makeStorePath
+  "Return the store path for NAME/HASH/TYPE."
+  (let* ((s (string-append type ":sha256:"
+                           (bytevector->base16-string hash) ":"
+                           (%store-prefix) ":" name))
+         (h (sha256 (string->utf8 s)))
+         (c (compressed-hash h 20)))
+    (string-append (%store-prefix) "/"
+                   (bytevector->nix-base32-string c) "-"
+                   name)))
+
+(define (output-path output hash name)            ; makeOutputPath
+  "Return an output path for OUTPUT (the name of the output as a string) of
+the derivation called NAME with hash HASH."
+  (store-path (string-append "output:" output) hash
+              (if (string=? output "out")
+                  name
+                  (string-append name "-" output))))
+
+(define* (fixed-output-path name hash
+                            #:key
+                            (output "out")
+                            (hash-algo 'sha256)
+                            (recursive? #t))
+  "Return an output path for the fixed output OUTPUT defined by HASH of type
+HASH-ALGO, of the derivation NAME.  RECURSIVE? has the same meaning as for
+'add-to-store'."
+  (if (and recursive? (eq? hash-algo 'sha256))
+      (store-path "source" hash name)
+      (let ((tag (string-append "fixed:" output ":"
+                                (if recursive? "r:" "")
+                                (symbol->string hash-algo) ":"
+                                (bytevector->base16-string hash) ":")))
+        (store-path (string-append "output:" output)
+                    (sha256 (string->utf8 tag))
+                    name))))
+
+(define (store-path? path)
+  "Return #t if PATH is a store path."
+  ;; This is a lightweight check, compared to using a regexp, but this has to
+  ;; be fast as it's called often in `derivation', for instance.
+  ;; `isStorePath' in Nix does something similar.
+  (string-prefix? (%store-prefix) path))
+
+(define (direct-store-path? path)
+  "Return #t if PATH is a store path, and not a sub-directory of a store path.
+This predicate is sometimes needed because files *under* a store path are not
+valid inputs."
+  (and (store-path? path)
+       (not (string=? path (%store-prefix)))
+       (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)))
+
+(define (store-path-base path)
+  "Return the base path of a path in the store."
+  (and (string-prefix? (%store-prefix) path)
+       (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
+         (and (> (string-length base) 33)
+              (not (string-index base #\/))
+              base))))
+
+(define (store-path-package-name path)
+  "Return the package name part of PATH, a file name in the store."
+  (let ((base (store-path-base path)))
+    (string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen
+
+(define (store-path-hash-part path)
+  "Return the hash part of PATH as a base32 string, or #f if PATH is not a
+syntactically valid store path."
+  (let* ((base (store-path-base path))
+         (hash (string-take base 32)))
+    (and (string-every %nix-base32-charset hash)
+         hash)))
+
+(define (derivation-log-file drv)
+  "Return the build log file for DRV, a derivation file name, or #f if it
+could not be found."
+  (let* ((base    (basename drv))
+         (log     (string-append (or (getenv "GUIX_LOG_DIRECTORY")
+                                     (string-append %localstatedir "/log/guix"))
+                                 "/drvs/"
+                                 (string-take base 2) "/"
+                                 (string-drop base 2)))
+         (log.gz  (string-append log ".gz"))
+         (log.bz2 (string-append log ".bz2")))
+    (cond ((file-exists? log.gz) log.gz)
+          ((file-exists? log.bz2) log.bz2)
+          ((file-exists? log) log)
+          (else #f))))
+
+

tests/store-database.scm

@@ -20,6 +20,7 @@
   #:use-module (guix tests)
   #:use-module (guix store)
   #:use-module (guix store database)
+  #:use-module (guix derivations)
   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64))
@@ -44,14 +45,41 @@
           (drv (string-append file ".drv")))
       (call-with-output-file file
         (cut display "This is a fake store item.\n" <>))
+      (when (valid-path? %store drv)
+        (delete-paths %store (list drv)))
+      (call-with-output-file drv
+        (lambda (port)
+          ;; XXX: we should really go from derivation to output path as is
+          ;; usual, currently any verification done on this derivation will
+          ;; cause an error.
+          (write-derivation ((@@ (guix derivations) make-derivation)
+                             ;; outputs
+                             (list (cons "out"
+                                         ((@@ (guix derivations)
+                                              make-derivation-output)
+                                          file
+                                          #f
+                                          #f
+                                          #f)))
+                             ;; inputs sources system builder args
+                             '() '() "" "" '()
+                             ;; env-vars filename
+                             '() drv)
+                            port)))
+      (register-path drv)
       (register-path file
                      #:references (list ref)
                      #:deriver drv)
 
       (and (valid-path? %store file)
            (equal? (references %store file) (list ref))
-           (null? (valid-derivers %store file))
+           ;; We expect the derivation outputs to be automatically
+           ;; registered.
+           (not (null? (valid-derivers %store file)))
            (null? (referrers %store file))
+           (equal? (with-database %default-database-file db
+                     (registered-derivation-outputs db drv))
+                   `(("out" . ,file)))
            (list (stat:mtime (lstat file))
                  (stat:mtime (lstat ref)))))))