guix/derivations.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix derivations)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (srfi srfi-9 gnu)
  23   #:use-module (srfi srfi-26)
  24   #:use-module (srfi srfi-34)
  25   #:use-module (srfi srfi-35)
  26   #:use-module (rnrs io ports)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (ice-9 match)
  29   #:use-module (ice-9 rdelim)
  30   #:use-module (ice-9 vlist)
  31   #:use-module (guix store)
  32   #:use-module (guix utils)
  33   #:use-module (guix monads)
  34   #:use-module (guix hash)
  35   #:use-module (guix base32)
  36   #:use-module (guix records)
  37   #:use-module (guix sets)
  38   #:export (<derivation>
  39             derivation?
  40             derivation-outputs
  41             derivation-inputs
  42             derivation-sources
  43             derivation-system
  44             derivation-builder
  45             derivation-builder-arguments
  46             derivation-builder-environment-vars
  47             derivation-file-name
  48             derivation-prerequisites
  49             derivation-prerequisites-to-build
  50
  51             <derivation-output>
  52             derivation-output?
  53             derivation-output-path
  54             derivation-output-hash-algo
  55             derivation-output-hash
  56             derivation-output-recursive?
  57
  58             <derivation-input>
  59             derivation-input?
  60             derivation-input-path
  61             derivation-input-sub-derivations
  62             derivation-input-output-paths
  63             valid-derivation-input?
  64
  65             &derivation-error
  66             derivation-error?
  67             derivation-error-derivation
  68             &derivation-missing-output-error
  69             derivation-missing-output-error?
  70             derivation-missing-output
  71
  72             derivation-name
  73             derivation-output-names
  74             fixed-output-derivation?
  75             offloadable-derivation?
  76             substitutable-derivation?
  77             substitution-oracle
  78             derivation-hash
  79
  80             read-derivation
  81             write-derivation
  82             derivation->output-path
  83             derivation->output-paths
  84             derivation-path->output-path
  85             derivation-path->output-paths
  86             derivation
  87
  88             graft
  89             graft?
  90             graft-origin
  91             graft-replacement
  92             graft-origin-output
  93             graft-replacement-output
  94             graft-derivation
  95
  96             map-derivation
  97
  98             build-derivations
  99             built-derivations
 100
 101             %graft?
 102             set-grafting
 103
 104             build-expression->derivation)
 105
 106   ;; Re-export it from here for backward compatibility.
 107   #:re-export (%guile-for-build))
 108
 109 ;;;
 110 ;;; Error conditions.
 111 ;;;
 112
 113 (define-condition-type &derivation-error &nix-error
 114   derivation-error?
 115   (derivation derivation-error-derivation))
 116
 117 (define-condition-type &derivation-missing-output-error &derivation-error
 118   derivation-missing-output-error?
 119   (output derivation-missing-output))
 120
 121 ;;;
 122 ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
 123 ;;;
 124
 125 (define-record-type <derivation>
 126   (make-derivation outputs inputs sources system builder args env-vars
 127                    file-name)
 128   derivation?
 129   (outputs  derivation-outputs)      ; list of name/<derivation-output> pairs
 130   (inputs   derivation-inputs)       ; list of <derivation-input>
 131   (sources  derivation-sources)      ; list of store paths
 132   (system   derivation-system)       ; string
 133   (builder  derivation-builder)      ; store path
 134   (args     derivation-builder-arguments)         ; list of strings
 135   (env-vars derivation-builder-environment-vars)  ; list of name/value pairs
 136   (file-name derivation-file-name))               ; the .drv file name
 137
 138 (define-record-type <derivation-output>
 139   (make-derivation-output path hash-algo hash recursive?)
 140   derivation-output?
 141   (path       derivation-output-path)             ; store path
 142   (hash-algo  derivation-output-hash-algo)        ; symbol | #f
 143   (hash       derivation-output-hash)             ; bytevector | #f
 144   (recursive? derivation-output-recursive?))      ; Boolean
 145
 146 (define-record-type <derivation-input>
 147   (make-derivation-input path sub-derivations)
 148   derivation-input?
 149   (path            derivation-input-path)             ; store path
 150   (sub-derivations derivation-input-sub-derivations)) ; list of strings
 151
 152 (set-record-type-printer! <derivation>
 153                           (lambda (drv port)
 154                             (format port "#<derivation ~a => ~a ~a>"
 155                                     (derivation-file-name drv)
 156                                     (string-join
 157                                      (map (match-lambda
 158                                            ((_ . output)
 159                                             (derivation-output-path output)))
 160                                           (derivation-outputs drv)))
 161                                     (number->string (object-address drv) 16))))
 162
 163 (define (derivation-name drv)
 164   "Return the base name of DRV."
 165   (let ((base (store-path-package-name (derivation-file-name drv))))
 166     (string-drop-right base 4)))
 167
 168 (define (derivation-output-names drv)
 169   "Return the names of the outputs of DRV."
 170   (match (derivation-outputs drv)
 171     (((names . _) ...)
 172      names)))
 173
 174 (define (fixed-output-derivation? drv)
 175   "Return #t if DRV is a fixed-output derivation, such as the result of a
 176 download with a fixed hash (aka. `fetchurl')."
 177   (match drv
 178     (($ <derivation>
 179         (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
 180      #t)
 181     (_ #f)))
 182
 183 (define (derivation-input-output-paths input)
 184   "Return the list of output paths corresponding to INPUT, a
 185 <derivation-input>."
 186   (match input
 187     (($ <derivation-input> path sub-drvs)
 188      (map (cut derivation-path->output-path path <>)
 189           sub-drvs))))
 190
 191 (define (valid-derivation-input? store input)
 192   "Return true if INPUT is valid--i.e., if all the outputs it requests are in
 193 the store."
 194   (every (cut valid-path? store <>)
 195          (derivation-input-output-paths input)))
 196
 197 (define* (derivation-prerequisites drv #:optional (cut? (const #f)))
 198   "Return the list of derivation-inputs required to build DRV, recursively.
 199
 200 CUT? is a predicate that is passed a derivation-input and returns true to
 201 eliminate the given input and its dependencies from the search.  An example of
 202 search a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
 203 result is the set of prerequisites of DRV not already in valid."
 204   (let loop ((drv       drv)
 205              (result    '())
 206              (input-set (set)))
 207     (let ((inputs (remove (lambda (input)
 208                             (or (set-contains? input-set input)
 209                                 (cut? input)))
 210                           (derivation-inputs drv))))
 211       (fold2 loop
 212              (append inputs result)
 213              (fold set-insert input-set inputs)
 214              (map (lambda (i)
 215                     (call-with-input-file (derivation-input-path i)
 216                       read-derivation))
 217                   inputs)))))
 218
 219 (define (offloadable-derivation? drv)
 220   "Return true if DRV can be offloaded, false otherwise."
 221   (match (assoc "preferLocalBuild"
 222                 (derivation-builder-environment-vars drv))
 223     (("preferLocalBuild" . "1") #f)
 224     (_ #t)))
 225
 226 (define substitutable-derivation?
 227   ;; Return #t if the derivation can be substituted.  Currently the two are
 228   ;; synonymous, see <http://bugs.gnu.org/18747>.
 229   offloadable-derivation?)
 230
 231 (define (derivation-output-paths drv sub-drvs)
 232   "Return the output paths of outputs SUB-DRVS of DRV."
 233   (match drv
 234     (($ <derivation> outputs)
 235      (map (lambda (sub-drv)
 236             (derivation-output-path (assoc-ref outputs sub-drv)))
 237           sub-drvs))))
 238
 239 (define* (substitution-oracle store drv)
 240   "Return a one-argument procedure that, when passed a store file name,
 241 returns #t if it's substitutable and #f otherwise.  The returned procedure
 242 knows about all substitutes for all the derivations listed in DRV; it also
 243 knows about their prerequisites, unless they are themselves substitutable.
 244
 245 Creating a single oracle (thus making a single 'substitutable-paths' call) and
 246 reusing it is much more efficient than calling 'has-substitutes?' or similar
 247 repeatedly, because it avoids the costs associated with launching the
 248 substituter many times."
 249   (define valid?
 250     (cut valid-path? store <>))
 251
 252   (define valid-input?
 253     (cut valid-derivation-input? store <>))
 254
 255   (define (dependencies drv)
 256     ;; Skip prerequisite sub-trees of DRV whose root is valid.  This allows us
 257     ;; to ask the substituter for just as much as needed, instead of asking it
 258     ;; for the whole world, which can be significantly faster when substitute
 259     ;; info is not already in cache.
 260     (append-map derivation-input-output-paths
 261                 (derivation-prerequisites drv valid-input?)))
 262
 263   (let* ((paths (delete-duplicates
 264                  (fold (lambda (drv result)
 265                          (let ((self (match (derivation->output-paths drv)
 266                                        (((names . paths) ...)
 267                                         paths))))
 268                            (if (every valid? self)
 269                                result
 270                                (append (append self (dependencies drv))
 271                                        result))))
 272                        '()
 273                        drv)))
 274          (subst (list->set (substitutable-paths store paths))))
 275     (cut set-contains? subst <>)))
 276
 277 (define* (derivation-prerequisites-to-build store drv
 278                                             #:key
 279                                             (outputs
 280                                              (derivation-output-names drv))
 281                                             (substitutable?
 282                                              (substitution-oracle store
 283                                                                   (list drv))))
 284   "Return two values: the list of derivation-inputs required to build the
 285 OUTPUTS of DRV and not already available in STORE, recursively, and the list
 286 of required store paths that can be substituted.  SUBSTITUTABLE? must be a
 287 one-argument procedure similar to that returned by 'substitution-oracle'."
 288   (define built?
 289     (cut valid-path? store <>))
 290
 291   (define input-built?
 292     (compose (cut any built? <>) derivation-input-output-paths))
 293
 294   (define input-substitutable?
 295     ;; Return true if and only if all of SUB-DRVS are subsitutable.  If at
 296     ;; least one is missing, then everything must be rebuilt.
 297     (compose (cut every substitutable? <>) derivation-input-output-paths))
 298
 299   (define (derivation-built? drv sub-drvs)
 300     (every built? (derivation-output-paths drv sub-drvs)))
 301
 302   (define (derivation-substitutable? drv sub-drvs)
 303     (and (substitutable-derivation? drv)
 304          (every substitutable? (derivation-output-paths drv sub-drvs))))
 305
 306   (let loop ((drv        drv)
 307              (sub-drvs   outputs)
 308              (build      '())
 309              (substitute '()))
 310     (cond ((derivation-built? drv sub-drvs)
 311            (values build substitute))
 312           ((derivation-substitutable? drv sub-drvs)
 313            (values build
 314                    (append (derivation-output-paths drv sub-drvs)
 315                            substitute)))
 316           (else
 317            (let ((build  (if (substitutable-derivation? drv)
 318                              build
 319                              (cons (make-derivation-input
 320                                     (derivation-file-name drv) sub-drvs)
 321                                    build)))
 322                  (inputs (remove (lambda (i)
 323                                    (or (member i build) ; XXX: quadratic
 324                                        (input-built? i)
 325                                        (input-substitutable? i)))
 326                                  (derivation-inputs drv))))
 327              (fold2 loop
 328                     (append inputs build)
 329                     (append (append-map (lambda (input)
 330                                           (if (and (not (input-built? input))
 331                                                    (input-substitutable? input))
 332                                               (derivation-input-output-paths
 333                                                input)
 334                                               '()))
 335                                         (derivation-inputs drv))
 336                             substitute)
 337                     (map (lambda (i)
 338                            (call-with-input-file (derivation-input-path i)
 339                              read-derivation))
 340                          inputs)
 341                     (map derivation-input-sub-derivations inputs)))))))
 342
 343 (define (%read-derivation drv-port)
 344   ;; Actually read derivation from DRV-PORT.
 345
 346   (define comma (string->symbol ","))
 347
 348   (define (ununquote x)
 349     (match x
 350       (('unquote x) (ununquote x))
 351       ((x ...)      (map ununquote x))
 352       (_            x)))
 353
 354   (define (outputs->alist x)
 355     (fold-right (lambda (output result)
 356                   (match output
 357                     ((name path "" "")
 358                      (alist-cons name
 359                                  (make-derivation-output path #f #f #f)
 360                                  result))
 361                     ((name path hash-algo hash)
 362                      ;; fixed-output
 363                      (let* ((rec? (string-prefix? "r:" hash-algo))
 364                             (algo (string->symbol
 365                                    (if rec?
 366                                        (string-drop hash-algo 2)
 367                                        hash-algo)))
 368                             (hash (base16-string->bytevector hash)))
 369                        (alist-cons name
 370                                    (make-derivation-output path algo
 371                                                            hash rec?)
 372                                    result)))))
 373                 '()
 374                 x))
 375
 376   (define (make-input-drvs x)
 377     (fold-right (lambda (input result)
 378                   (match input
 379                     ((path (sub-drvs ...))
 380                      (cons (make-derivation-input path sub-drvs)
 381                            result))))
 382                 '()
 383                 x))
 384
 385   ;; The contents of a derivation are typically ASCII, but choosing
 386   ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
 387   (set-port-encoding! drv-port "UTF-8")
 388
 389   (let loop ((exp    (read drv-port))
 390              (result '()))
 391     (match exp
 392       ((? eof-object?)
 393        (let ((result (reverse result)))
 394          (match result
 395            (('Derive ((outputs ...) (input-drvs ...)
 396                       (input-srcs ...)
 397                       (? string? system)
 398                       (? string? builder)
 399                       ((? string? args) ...)
 400                       ((var value) ...)))
 401             (make-derivation (outputs->alist outputs)
 402                              (make-input-drvs input-drvs)
 403                              input-srcs
 404                              system builder args
 405                              (fold-right alist-cons '() var value)
 406                              (port-filename drv-port)))
 407            (_
 408             (error "failed to parse derivation" drv-port result)))))
 409       ((? (cut eq? <> comma))
 410        (loop (read drv-port) result))
 411       (_
 412        (loop (read drv-port)
 413              (cons (ununquote exp) result))))))
 414
 415 (define read-derivation
 416   (let ((cache (make-weak-value-hash-table 200)))
 417     (lambda (drv-port)
 418       "Read the derivation from DRV-PORT and return the corresponding
 419 <derivation> object."
 420       ;; Memoize that operation because `%read-derivation' is quite expensive,
 421       ;; and because the same argument is read more than 15 times on average
 422       ;; during something like (package-derivation s gdb).
 423       (let ((file (and=> (port-filename drv-port) basename)))
 424         (or (and file (hash-ref cache file))
 425             (let ((drv (%read-derivation drv-port)))
 426               (hash-set! cache file drv)
 427               drv))))))
 428
 429 (define-inlinable (write-sequence lst write-item port)
 430   ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
 431   ;; comma.
 432   (match lst
 433     (()
 434      #t)
 435     ((prefix (... ...) last)
 436      (for-each (lambda (item)
 437                  (write-item item port)
 438                  (display "," port))
 439                prefix)
 440      (write-item last port))))
 441
 442 (define-inlinable (write-list lst write-item port)
 443   ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
 444   ;; element.
 445   (display "[" port)
 446   (write-sequence lst write-item port)
 447   (display "]" port))
 448
 449 (define-inlinable (write-tuple lst write-item port)
 450   ;; Same, but write LST as a tuple.
 451   (display "(" port)
 452   (write-sequence lst write-item port)
 453   (display ")" port))
 454
 455 (define (write-derivation drv port)
 456   "Write the ATerm-like serialization of DRV to PORT.  See Section 2.4 of
 457 Eelco Dolstra's PhD dissertation for an overview of a previous version of
 458 that form."
 459
 460   ;; Make sure we're using the faster implementation.
 461   (define format simple-format)
 462
 463   (define (write-string-list lst)
 464     (write-list lst write port))
 465
 466   (define (coalesce-duplicate-inputs inputs)
 467     ;; Return a list of inputs, such that when INPUTS contains the same DRV
 468     ;; twice, they are coalesced, with their sub-derivations merged.  This is
 469     ;; needed because Nix itself keeps only one of them.
 470     (fold (lambda (input result)
 471             (match input
 472               (($ <derivation-input> path sub-drvs)
 473                ;; XXX: quadratic
 474                (match (find (match-lambda
 475                              (($ <derivation-input> p s)
 476                               (string=? p path)))
 477                             result)
 478                  (#f
 479                   (cons input result))
 480                  ((and dup ($ <derivation-input> _ sub-drvs2))
 481                   ;; Merge DUP with INPUT.
 482                   (let ((sub-drvs (delete-duplicates
 483                                    (append sub-drvs sub-drvs2))))
 484                     (cons (make-derivation-input path sub-drvs)
 485                           (delq dup result))))))))
 486           '()
 487           inputs))
 488
 489   (define (write-output output port)
 490     (match output
 491      ((name . ($ <derivation-output> path hash-algo hash recursive?))
 492       (write-tuple (list name path
 493                          (if hash-algo
 494                              (string-append (if recursive? "r:" "")
 495                                             (symbol->string hash-algo))
 496                              "")
 497                          (or (and=> hash bytevector->base16-string)
 498                              ""))
 499                    write
 500                    port))))
 501
 502   (define (write-input input port)
 503     (match input
 504       (($ <derivation-input> path sub-drvs)
 505        (display "(" port)
 506        (write path port)
 507        (display "," port)
 508        (write-string-list (sort sub-drvs string<?))
 509        (display ")" port))))
 510
 511   (define (write-env-var env-var port)
 512     (match env-var
 513       ((name . value)
 514        (display "(" port)
 515        (write name port)
 516        (display "," port)
 517        (write value port)
 518        (display ")" port))))
 519
 520   ;; Note: lists are sorted alphabetically, to conform with the behavior of
 521   ;; C++ `std::map' in Nix itself.
 522
 523   (match drv
 524     (($ <derivation> outputs inputs sources
 525         system builder args env-vars)
 526      (display "Derive(" port)
 527      (write-list (sort outputs
 528                        (lambda (o1 o2)
 529                          (string<? (car o1) (car o2))))
 530                  write-output
 531                  port)
 532      (display "," port)
 533      (write-list (sort (coalesce-duplicate-inputs inputs)
 534                        (lambda (i1 i2)
 535                          (string<? (derivation-input-path i1)
 536                                    (derivation-input-path i2))))
 537                  write-input
 538                  port)
 539      (display "," port)
 540      (write-string-list (sort sources string<?))
 541      (format port ",~s,~s," system builder)
 542      (write-string-list args)
 543      (display "," port)
 544      (write-list (sort env-vars
 545                        (lambda (e1 e2)
 546                          (string<? (car e1) (car e2))))
 547                  write-env-var
 548                  port)
 549      (display ")" port))))
 550
 551 (define derivation->string
 552   (memoize
 553    (lambda (drv)
 554      "Return the external representation of DRV as a string."
 555      (with-fluids ((%default-port-encoding "UTF-8"))
 556        (call-with-output-string
 557         (cut write-derivation drv <>))))))
 558
 559 (define* (derivation->output-path drv #:optional (output "out"))
 560   "Return the store path of its output OUTPUT.  Raise a
 561 '&derivation-missing-output-error' condition if OUTPUT is not an output of
 562 DRV."
 563   (let ((output* (assoc-ref (derivation-outputs drv) output)))
 564     (if output*
 565         (derivation-output-path output*)
 566         (raise (condition (&derivation-missing-output-error
 567                            (derivation drv)
 568                            (output output)))))))
 569
 570 (define (derivation->output-paths drv)
 571   "Return the list of name/path pairs of the outputs of DRV."
 572   (map (match-lambda
 573         ((name . output)
 574          (cons name (derivation-output-path output))))
 575        (derivation-outputs drv)))
 576
 577 (define derivation-path->output-path
 578   ;; This procedure is called frequently, so memoize it.
 579   (memoize
 580    (lambda* (path #:optional (output "out"))
 581      "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
 582 path of its output OUTPUT."
 583      (derivation->output-path (call-with-input-file path read-derivation)
 584                               output))))
 585
 586 (define (derivation-path->output-paths path)
 587   "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
 588 list of name/path pairs of its outputs."
 589   (derivation->output-paths (call-with-input-file path read-derivation)))
 590
 591 \f
 592 ;;;
 593 ;;; Derivation primitive.
 594 ;;;
 595
 596 (define (compressed-hash bv size)                 ; `compressHash'
 597   "Given the hash stored in BV, return a compressed version thereof that fits
 598 in SIZE bytes."
 599   (define new (make-bytevector size 0))
 600   (define old-size (bytevector-length bv))
 601   (let loop ((i 0))
 602     (if (= i old-size)
 603         new
 604         (let* ((j (modulo i size))
 605                (o (bytevector-u8-ref new j)))
 606           (bytevector-u8-set! new j
 607                               (logxor o (bytevector-u8-ref bv i)))
 608           (loop (+ 1 i))))))
 609
 610 (define derivation-path->base16-hash
 611   (memoize
 612    (lambda (file)
 613      "Return a string containing the base16 representation of the hash of the
 614 derivation at FILE."
 615      (call-with-input-file file
 616        (compose bytevector->base16-string
 617                 derivation-hash
 618                 read-derivation)))))
 619
 620 (define derivation-hash            ; `hashDerivationModulo' in derivations.cc
 621   (memoize
 622    (lambda (drv)
 623     "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
 624     (match drv
 625       (($ <derivation> ((_ . ($ <derivation-output> path
 626                                 (? symbol? hash-algo) (? bytevector? hash)
 627                                 (? boolean? recursive?)))))
 628        ;; A fixed-output derivation.
 629        (sha256
 630         (string->utf8
 631          (string-append "fixed:out:"
 632                         (if recursive? "r:" "")
 633                         (symbol->string hash-algo)
 634                         ":" (bytevector->base16-string hash)
 635                         ":" path))))
 636       (($ <derivation> outputs inputs sources
 637           system builder args env-vars)
 638        ;; A regular derivation: replace the path of each input with that
 639        ;; input's hash; return the hash of serialization of the resulting
 640        ;; derivation.
 641        (let* ((inputs (map (match-lambda
 642                             (($ <derivation-input> path sub-drvs)
 643                              (let ((hash (derivation-path->base16-hash path)))
 644                                (make-derivation-input hash sub-drvs))))
 645                            inputs))
 646               (drv    (make-derivation outputs inputs sources
 647                                        system builder args env-vars
 648                                        #f)))
 649
 650          ;; XXX: At this point this remains faster than `port-sha256', because
 651          ;; the SHA256 port's `write' method gets called for every single
 652          ;; character.
 653          (sha256
 654           (string->utf8 (derivation->string drv)))))))))
 655
 656 (define (store-path type hash name)               ; makeStorePath
 657   "Return the store path for NAME/HASH/TYPE."
 658   (let* ((s (string-append type ":sha256:"
 659                            (bytevector->base16-string hash) ":"
 660                            (%store-prefix) ":" name))
 661          (h (sha256 (string->utf8 s)))
 662          (c (compressed-hash h 20)))
 663     (string-append (%store-prefix) "/"
 664                    (bytevector->nix-base32-string c) "-"
 665                    name)))
 666
 667 (define (output-path output hash name)            ; makeOutputPath
 668   "Return an output path for OUTPUT (the name of the output as a string) of
 669 the derivation called NAME with hash HASH."
 670   (store-path (string-append "output:" output) hash
 671               (if (string=? output "out")
 672                   name
 673                   (string-append name "-" output))))
 674
 675 (define (fixed-output-path output hash-algo hash recursive? name)
 676   "Return an output path for the fixed output OUTPUT defined by HASH of type
 677 HASH-ALGO, of the derivation NAME.  RECURSIVE? has the same meaning as for
 678 'add-to-store'."
 679   (if (and recursive? (eq? hash-algo 'sha256))
 680       (store-path "source" hash name)
 681       (let ((tag (string-append "fixed:" output ":"
 682                                 (if recursive? "r:" "")
 683                                 (symbol->string hash-algo) ":"
 684                                 (bytevector->base16-string hash) ":")))
 685         (store-path (string-append "output:" output)
 686                     (sha256 (string->utf8 tag))
 687                     name))))
 688
 689 (define* (derivation store name builder args
 690                      #:key
 691                      (system (%current-system)) (env-vars '())
 692                      (inputs '()) (outputs '("out"))
 693                      hash hash-algo recursive?
 694                      references-graphs allowed-references
 695                      leaked-env-vars local-build?)
 696   "Build a derivation with the given arguments, and return the resulting
 697 <derivation> object.  When HASH and HASH-ALGO are given, a
 698 fixed-output derivation is created---i.e., one whose result is known in
 699 advance, such as a file download.  If, in addition, RECURSIVE? is true, then
 700 that fixed output may be an executable file or a directory and HASH must be
 701 the hash of an archive containing this output.
 702
 703 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 704 pairs.  In that case, the reference graph of each store path is exported in
 705 the build environment in the corresponding file, in a simple text format.
 706
 707 When ALLOWED-REFERENCES is true, it must be a list of store items or outputs
 708 that the derivation's output may refer to.
 709
 710 When LEAKED-ENV-VARS is true, it must be a list of strings denoting
 711 environment variables that are allowed to \"leak\" from the daemon's
 712 environment to the build environment.  This is only applicable to fixed-output
 713 derivations--i.e., when HASH is true.  The main use is to allow variables such
 714 as \"http_proxy\" to be passed to derivations that download files.
 715
 716 When LOCAL-BUILD? is true, declare that the derivation is not a good candidate
 717 for offloading and should rather be built locally.  This is the case for small
 718 derivations where the costs of data transfers would outweigh the benefits."
 719   (define (add-output-paths drv)
 720     ;; Return DRV with an actual store path for each of its output and the
 721     ;; corresponding environment variable.
 722     (match drv
 723       (($ <derivation> outputs inputs sources
 724           system builder args env-vars)
 725        (let* ((drv-hash (derivation-hash drv))
 726               (outputs  (map (match-lambda
 727                               ((output-name . ($ <derivation-output>
 728                                                  _ algo hash rec?))
 729                                (let ((path (if hash
 730                                                (fixed-output-path output-name
 731                                                                   algo hash
 732                                                                   rec? name)
 733                                                (output-path output-name
 734                                                             drv-hash name))))
 735                                  (cons output-name
 736                                        (make-derivation-output path algo
 737                                                                hash rec?)))))
 738                              outputs)))
 739          (make-derivation outputs inputs sources system builder args
 740                           (map (match-lambda
 741                                 ((name . value)
 742                                  (cons name
 743                                        (or (and=> (assoc-ref outputs name)
 744                                                   derivation-output-path)
 745                                            value))))
 746                                env-vars)
 747                           #f)))))
 748
 749   (define (user+system-env-vars)
 750     ;; Some options are passed to the build daemon via the env. vars of
 751     ;; derivations (urgh!).  We hide that from our API, but here is the place
 752     ;; where we kludgify those options.
 753     (let ((env-vars `(,@(if local-build?
 754                             `(("preferLocalBuild" . "1"))
 755                             '())
 756                       ,@(if allowed-references
 757                             `(("allowedReferences"
 758                                . ,(string-join allowed-references)))
 759                             '())
 760                       ,@(if leaked-env-vars
 761                             `(("impureEnvVars"
 762                                . ,(string-join leaked-env-vars)))
 763                             '())
 764                       ,@env-vars)))
 765       (match references-graphs
 766         (((file . path) ...)
 767          (let ((value (map (cut string-append <> " " <>)
 768                            file path)))
 769            ;; XXX: This all breaks down if an element of FILE or PATH contains
 770            ;; white space.
 771            `(("exportReferencesGraph" . ,(string-join value " "))
 772              ,@env-vars)))
 773         (#f
 774          env-vars))))
 775
 776   (define (env-vars-with-empty-outputs env-vars)
 777     ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
 778     ;; empty string, even outputs that do not appear in ENV-VARS.
 779     (let ((e (map (match-lambda
 780                    ((name . val)
 781                     (if (member name outputs)
 782                         (cons name "")
 783                         (cons name val))))
 784                   env-vars)))
 785       (fold (lambda (output-name env-vars)
 786               (if (assoc output-name env-vars)
 787                   env-vars
 788                   (append env-vars `((,output-name . "")))))
 789             e
 790             outputs)))
 791
 792   (define (set-file-name drv file)
 793     ;; Set FILE as the 'file-name' field of DRV.
 794     (match drv
 795       (($ <derivation> outputs inputs sources system builder
 796           args env-vars)
 797        (make-derivation outputs inputs sources system builder
 798                         args env-vars file))))
 799
 800   (let* ((outputs    (map (lambda (name)
 801                             ;; Return outputs with an empty path.
 802                             (cons name
 803                                   (make-derivation-output "" hash-algo
 804                                                           hash recursive?)))
 805                           outputs))
 806          (inputs     (map (match-lambda
 807                            (((? derivation? drv))
 808                             (make-derivation-input (derivation-file-name drv)
 809                                                    '("out")))
 810                            (((? derivation? drv) sub-drvs ...)
 811                             (make-derivation-input (derivation-file-name drv)
 812                                                    sub-drvs))
 813                            (((? direct-store-path? input))
 814                             (make-derivation-input input '("out")))
 815                            (((? direct-store-path? input) sub-drvs ...)
 816                             (make-derivation-input input sub-drvs))
 817                            ((input . _)
 818                             (let ((path (add-to-store store
 819                                                       (basename input)
 820                                                       #t "sha256" input)))
 821                               (make-derivation-input path '()))))
 822                           (delete-duplicates inputs)))
 823          (env-vars   (env-vars-with-empty-outputs (user+system-env-vars)))
 824          (drv-masked (make-derivation outputs
 825                                       (filter (compose derivation-path?
 826                                                        derivation-input-path)
 827                                               inputs)
 828                                       (filter-map (lambda (i)
 829                                                     (let ((p (derivation-input-path i)))
 830                                                       (and (not (derivation-path? p))
 831                                                            p)))
 832                                                   inputs)
 833                                       system builder args env-vars #f))
 834          (drv        (add-output-paths drv-masked)))
 835
 836     (let ((file (add-text-to-store store (string-append name ".drv")
 837                                    (derivation->string drv)
 838                                    (map derivation-input-path
 839                                         inputs))))
 840       (set-file-name drv file))))
 841
 842 (define* (map-derivation store drv mapping
 843                          #:key (system (%current-system)))
 844   "Given MAPPING, a list of pairs of derivations, return a derivation based on
 845 DRV where all the 'car's of MAPPING have been replaced by its 'cdr's,
 846 recursively."
 847   (define (substitute str initial replacements)
 848     (fold (lambda (path replacement result)
 849             (string-replace-substring result path
 850                                       replacement))
 851           str
 852           initial replacements))
 853
 854   (define (substitute-file file initial replacements)
 855     (define contents
 856       (with-fluids ((%default-port-encoding #f))
 857         (call-with-input-file file get-string-all)))
 858
 859     (let ((updated (substitute contents initial replacements)))
 860       (if (string=? updated contents)
 861           file
 862           ;; XXX: permissions aren't preserved.
 863           (add-text-to-store store (store-path-package-name file)
 864                              updated))))
 865
 866   (define input->output-paths
 867     (match-lambda
 868      (((? derivation? drv))
 869       (list (derivation->output-path drv)))
 870      (((? derivation? drv) sub-drvs ...)
 871       (map (cut derivation->output-path drv <>)
 872            sub-drvs))
 873      ((file)
 874       (list file))))
 875
 876   (let ((mapping (fold (lambda (pair result)
 877                          (match pair
 878                            (((? derivation? orig) . replacement)
 879                             (vhash-cons (derivation-file-name orig)
 880                                         replacement result))
 881                            ((file . replacement)
 882                             (vhash-cons file replacement result))))
 883                        vlist-null
 884                        mapping)))
 885     (define rewritten-input
 886       ;; Rewrite the given input according to MAPPING, and return an input
 887       ;; in the format used in 'derivation' calls.
 888       (memoize
 889        (lambda (input loop)
 890          (match input
 891            (($ <derivation-input> path (sub-drvs ...))
 892             (match (vhash-assoc path mapping)
 893               ((_ . (? derivation? replacement))
 894                (cons replacement sub-drvs))
 895               ((_ . replacement)
 896                (list replacement))
 897               (#f
 898                (let* ((drv (loop (call-with-input-file path read-derivation))))
 899                  (cons drv sub-drvs)))))))))
 900
 901     (let loop ((drv drv))
 902       (let* ((inputs       (map (cut rewritten-input <> loop)
 903                                 (derivation-inputs drv)))
 904              (initial      (append-map derivation-input-output-paths
 905                                        (derivation-inputs drv)))
 906              (replacements (append-map input->output-paths inputs))
 907
 908              ;; Sources typically refer to the output directories of the
 909              ;; original inputs, INITIAL.  Rewrite them by substituting
 910              ;; REPLACEMENTS.
 911              (sources      (map (lambda (source)
 912                                   (match (vhash-assoc source mapping)
 913                                     ((_ . replacement)
 914                                      replacement)
 915                                     (#f
 916                                      (substitute-file source
 917                                                       initial replacements))))
 918                                 (derivation-sources drv)))
 919
 920              ;; Now augment the lists of initials and replacements.
 921              (initial      (append (derivation-sources drv) initial))
 922              (replacements (append sources replacements))
 923              (name         (store-path-package-name
 924                             (string-drop-right (derivation-file-name drv)
 925                                                4))))
 926         (derivation store name
 927                     (substitute (derivation-builder drv)
 928                                 initial replacements)
 929                     (map (cut substitute <> initial replacements)
 930                          (derivation-builder-arguments drv))
 931                     #:system system
 932                     #:env-vars (map (match-lambda
 933                                      ((var . value)
 934                                       `(,var
 935                                         . ,(substitute value initial
 936                                                        replacements))))
 937                                     (derivation-builder-environment-vars drv))
 938                     #:inputs (append (map list sources) inputs)
 939                     #:outputs (derivation-output-names drv)
 940                     #:hash (match (derivation-outputs drv)
 941                              ((($ <derivation-output> _ algo hash))
 942                               hash)
 943                              (_ #f))
 944                     #:hash-algo (match (derivation-outputs drv)
 945                                   ((($ <derivation-output> _ algo hash))
 946                                    algo)
 947                                   (_ #f)))))))
 948
 949 \f
 950 ;;;
 951 ;;; Store compatibility layer.
 952 ;;;
 953
 954 (define (build-derivations store derivations)
 955   "Build DERIVATIONS, a list of <derivation> objects or .drv file names."
 956   (build-things store (map (match-lambda
 957                             ((? string? file) file)
 958                             ((and drv ($ <derivation>))
 959                              (derivation-file-name drv)))
 960                            derivations)))
 961
 962 \f
 963 ;;;
 964 ;;; Guile-based builders.
 965 ;;;
 966
 967 (define (parent-directories file-name)
 968   "Return the list of parent dirs of FILE-NAME, in the order in which an
 969 `mkdir -p' implementation would make them."
 970   (let ((not-slash (char-set-complement (char-set #\/))))
 971     (reverse
 972      (fold (lambda (dir result)
 973              (match result
 974                (()
 975                 (list dir))
 976                ((prev _ ...)
 977                 (cons (string-append prev "/" dir)
 978                       result))))
 979            '()
 980            (remove (cut string=? <> ".")
 981                    (string-tokenize (dirname file-name) not-slash))))))
 982
 983 (define* (imported-files store files              ;deprecated
 984                          #:key (name "file-import")
 985                          (system (%current-system))
 986                          (guile (%guile-for-build)))
 987   "Return a derivation that imports FILES into STORE.  FILES must be a list
 988 of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
 989 system, imported, and appears under FINAL-PATH in the resulting store path."
 990   (let* ((files   (map (match-lambda
 991                         ((final-path . file-name)
 992                          (list final-path
 993                                (add-to-store store (basename final-path) #f
 994                                              "sha256" file-name))))
 995                        files))
 996          (builder
 997           `(begin
 998              (mkdir %output) (chdir %output)
 999              ,@(append-map (match-lambda
1000                             ((final-path store-path)
1001                              (append (match (parent-directories final-path)
1002                                        (() '())
1003                                        ((head ... tail)
1004                                         (append (map (lambda (d)
1005                                                        `(false-if-exception
1006                                                          (mkdir ,d)))
1007                                                      head)
1008                                                 `((or (file-exists? ,tail)
1009                                                       (mkdir ,tail))))))
1010                                      `((symlink ,store-path ,final-path)))))
1011                            files))))
1012     (build-expression->derivation store name builder
1013                                   #:system system
1014                                   #:inputs files
1015                                   #:guile-for-build guile
1016                                   #:local-build? #t)))
1017
1018 (define search-path*
1019   ;; A memoizing version of 'search-path' so 'imported-modules' does not end
1020   ;; up looking for the same files over and over again.
1021   (memoize search-path))
1022
1023 (define* (%imported-modules store modules         ;deprecated
1024                             #:key (name "module-import")
1025                             (system (%current-system))
1026                             (guile (%guile-for-build))
1027                             (module-path %load-path))
1028   "Return a derivation that contains the source files of MODULES, a list of
1029 module names such as `(ice-9 q)'.  All of MODULES must be in the MODULE-PATH
1030 search path."
1031   ;; TODO: Determine the closure of MODULES, build the `.go' files,
1032   ;; canonicalize the source files through read/write, etc.
1033   (let ((files (map (lambda (m)
1034                       (let ((f (string-append
1035                                 (string-join (map symbol->string m) "/")
1036                                 ".scm")))
1037                         (cons f (search-path* module-path f))))
1038                     modules)))
1039     (imported-files store files #:name name #:system system
1040                     #:guile guile)))
1041
1042 (define* (%compiled-modules store modules         ;deprecated
1043                             #:key (name "module-import-compiled")
1044                             (system (%current-system))
1045                             (guile (%guile-for-build))
1046                             (module-path %load-path))
1047   "Return a derivation that builds a tree containing the `.go' files
1048 corresponding to MODULES.  All the MODULES are built in a context where
1049 they can refer to each other."
1050   (let* ((module-drv (%imported-modules store modules
1051                                         #:system system
1052                                         #:guile guile
1053                                         #:module-path module-path))
1054          (module-dir (derivation->output-path module-drv))
1055          (files      (map (lambda (m)
1056                             (let ((f (string-join (map symbol->string m)
1057                                                   "/")))
1058                               (cons (string-append f ".go")
1059                                     (string-append module-dir "/" f ".scm"))))
1060                       modules)))
1061     (define builder
1062       `(begin
1063          (use-modules (system base compile))
1064          (let ((out (assoc-ref %outputs "out")))
1065            (mkdir out)
1066            (chdir out))
1067
1068          (set! %load-path
1069                (cons ,module-dir %load-path))
1070
1071          ,@(map (match-lambda
1072                  ((output . input)
1073                   (let ((make-parent-dirs (map (lambda (dir)
1074                                                  `(unless (file-exists? ,dir)
1075                                                     (mkdir ,dir)))
1076                                                (parent-directories output))))
1077                    `(begin
1078                       ,@make-parent-dirs
1079                       (compile-file ,input
1080                                     #:output-file ,output
1081                                     #:opts %auto-compilation-options)))))
1082                 files)))
1083
1084     (build-expression->derivation store name builder
1085                                   #:inputs `(("modules" ,module-drv))
1086                                   #:system system
1087                                   #:guile-for-build guile
1088                                   #:local-build? #t)))
1089
1090 (define-record-type* <graft> graft make-graft
1091   graft?
1092   (origin             graft-origin)               ;derivation | store item
1093   (origin-output      graft-origin-output         ;string | #f
1094                       (default "out"))
1095   (replacement        graft-replacement)          ;derivation | store item
1096   (replacement-output graft-replacement-output    ;string | #f
1097                       (default "out")))
1098
1099 (define* (graft-derivation store name drv grafts
1100                            #:key (guile (%guile-for-build))
1101                            (system (%current-system)))
1102   "Return a derivation called NAME, based on DRV but with all the GRAFTS
1103 applied."
1104   ;; XXX: Someday rewrite using gexps.
1105   (define mapping
1106     ;; List of store item pairs.
1107     (map (match-lambda
1108           (($ <graft> source source-output target target-output)
1109            (cons (if (derivation? source)
1110                      (derivation->output-path source source-output)
1111                      source)
1112                  (if (derivation? target)
1113                      (derivation->output-path target target-output)
1114                      target))))
1115          grafts))
1116
1117   (define outputs
1118     (match (derivation-outputs drv)
1119       (((names . outputs) ...)
1120        (map derivation-output-path outputs))))
1121
1122   (define output-names
1123     (match (derivation-outputs drv)
1124       (((names . outputs) ...)
1125        names)))
1126
1127   (define build
1128     `(begin
1129        (use-modules (guix build graft)
1130                     (guix build utils)
1131                     (ice-9 match))
1132
1133        (let ((mapping ',mapping))
1134          (for-each (lambda (input output)
1135                      (format #t "grafting '~a' -> '~a'...~%" input output)
1136                      (force-output)
1137                      (rewrite-directory input output
1138                                         `((,input . ,output)
1139                                           ,@mapping)))
1140                    ',outputs
1141                    (match %outputs
1142                      (((names . files) ...)
1143                       files))))))
1144
1145   (define add-label
1146     (cut cons "x" <>))
1147
1148   (match grafts
1149     ((($ <graft> sources source-outputs targets target-outputs) ...)
1150      (let ((sources (zip sources source-outputs))
1151            (targets (zip targets target-outputs)))
1152        (build-expression->derivation store name build
1153                                      #:system system
1154                                      #:guile-for-build guile
1155                                      #:modules '((guix build graft)
1156                                                  (guix build utils))
1157                                      #:inputs `(,@(map (lambda (out)
1158                                                          `("x" ,drv ,out))
1159                                                        output-names)
1160                                                 ,@(append (map add-label sources)
1161                                                           (map add-label targets)))
1162                                      #:outputs output-names
1163                                      #:local-build? #t)))))
1164
1165 (define* (build-expression->derivation store name exp ;deprecated
1166                                        #:key
1167                                        (system (%current-system))
1168                                        (inputs '())
1169                                        (outputs '("out"))
1170                                        hash hash-algo recursive?
1171                                        (env-vars '())
1172                                        (modules '())
1173                                        guile-for-build
1174                                        references-graphs
1175                                        allowed-references
1176                                        local-build?)
1177   "Return a derivation that executes Scheme expression EXP as a builder
1178 for derivation NAME.  INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
1179 tuples; when SUB-DRV is omitted, \"out\" is assumed.  MODULES is a list
1180 of names of Guile modules from the current search path to be copied in
1181 the store, compiled, and made available in the load path during the
1182 execution of EXP.
1183
1184 EXP is evaluated in an environment where %OUTPUT is bound to the main
1185 output path, %OUTPUTS is bound to a list of output/path pairs, and where
1186 %BUILD-INPUTS is bound to an alist of string/output-path pairs made from
1187 INPUTS.  Optionally, ENV-VARS is a list of string pairs specifying the
1188 name and value of environment variables visible to the builder.  The
1189 builder terminates by passing the result of EXP to `exit'; thus, when
1190 EXP returns #f, the build is considered to have failed.
1191
1192 EXP is built using GUILE-FOR-BUILD (a derivation).  When GUILE-FOR-BUILD is
1193 omitted or is #f, the value of the `%guile-for-build' fluid is used instead.
1194
1195 See the `derivation' procedure for the meaning of REFERENCES-GRAPHS,
1196 ALLOWED-REFERENCES, and LOCAL-BUILD?."
1197   (define guile-drv
1198     (or guile-for-build (%guile-for-build)))
1199
1200   (define guile
1201     (string-append (derivation->output-path guile-drv)
1202                    "/bin/guile"))
1203
1204   (define module-form?
1205     (match-lambda
1206      (((or 'define-module 'use-modules) _ ...) #t)
1207      (_ #f)))
1208
1209   (define source-path
1210     ;; When passed an input that is a source, return its path; otherwise
1211     ;; return #f.
1212     (match-lambda
1213      ((_ (? derivation?) _ ...)
1214       #f)
1215      ((_ path _ ...)
1216       (and (not (derivation-path? path))
1217            path))))
1218
1219   (let* ((prologue `(begin
1220                       ,@(match exp
1221                           ((_ ...)
1222                            ;; Module forms must appear at the top-level so
1223                            ;; that any macros they export can be expanded.
1224                            (filter module-form? exp))
1225                           (_ `(,exp)))
1226
1227                       (define %output (getenv "out"))
1228                       (define %outputs
1229                         (map (lambda (o)
1230                                (cons o (getenv o)))
1231                              ',outputs))
1232                       (define %build-inputs
1233                         ',(map (match-lambda
1234                                 ((name drv . rest)
1235                                  (let ((sub (match rest
1236                                               (() "out")
1237                                               ((x) x))))
1238                                    (cons name
1239                                          (cond
1240                                           ((derivation? drv)
1241                                            (derivation->output-path drv sub))
1242                                           ((derivation-path? drv)
1243                                            (derivation-path->output-path drv
1244                                                                          sub))
1245                                           (else drv))))))
1246                                inputs))
1247
1248                       ,@(if (null? modules)
1249                             '()
1250                             ;; Remove our own settings.
1251                             '((unsetenv "GUILE_LOAD_COMPILED_PATH")))
1252
1253                       ;; Guile sets it, but remove it to avoid conflicts when
1254                       ;; building Guile-using packages.
1255                       (unsetenv "LD_LIBRARY_PATH")))
1256          (builder  (add-text-to-store store
1257                                       (string-append name "-guile-builder")
1258
1259                                       ;; Explicitly use UTF-8 for determinism,
1260                                       ;; and also because UTF-8 output is faster.
1261                                       (with-fluids ((%default-port-encoding
1262                                                      "UTF-8"))
1263                                         (call-with-output-string
1264                                          (lambda (port)
1265                                            (write prologue port)
1266                                            (write
1267                                             `(exit
1268                                               ,(match exp
1269                                                  ((_ ...)
1270                                                   (remove module-form? exp))
1271                                                  (_ `(,exp))))
1272                                             port))))
1273
1274                                       ;; The references don't really matter
1275                                       ;; since the builder is always used in
1276                                       ;; conjunction with the drv that needs
1277                                       ;; it.  For clarity, we add references
1278                                       ;; to the subset of INPUTS that are
1279                                       ;; sources, avoiding references to other
1280                                       ;; .drv; otherwise, BUILDER's hash would
1281                                       ;; depend on those, even if they are
1282                                       ;; fixed-output.
1283                                       (filter-map source-path inputs)))
1284
1285          (mod-drv  (and (pair? modules)
1286                         (%imported-modules store modules
1287                                            #:guile guile-drv
1288                                            #:system system)))
1289          (mod-dir  (and mod-drv
1290                         (derivation->output-path mod-drv)))
1291          (go-drv   (and (pair? modules)
1292                         (%compiled-modules store modules
1293                                            #:guile guile-drv
1294                                            #:system system)))
1295          (go-dir   (and go-drv
1296                         (derivation->output-path go-drv))))
1297     (derivation store name guile
1298                 `("--no-auto-compile"
1299                   ,@(if mod-dir `("-L" ,mod-dir) '())
1300                   ,builder)
1301
1302                 #:system system
1303
1304                 #:inputs `((,(or guile-for-build (%guile-for-build)))
1305                            (,builder)
1306                            ,@(map cdr inputs)
1307                            ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
1308
1309                 ;; When MODULES is non-empty, shamelessly clobber
1310                 ;; $GUILE_LOAD_COMPILED_PATH.
1311                 #:env-vars (if go-dir
1312                                `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir)
1313                                  ,@(alist-delete "GUILE_LOAD_COMPILED_PATH"
1314                                                  env-vars))
1315                                env-vars)
1316
1317                 #:hash hash #:hash-algo hash-algo
1318                 #:recursive? recursive?
1319                 #:outputs outputs
1320                 #:references-graphs references-graphs
1321                 #:allowed-references allowed-references
1322                 #:local-build? local-build?)))
1323
1324 \f
1325 ;;;
1326 ;;; Monadic interface.
1327 ;;;
1328
1329 (define built-derivations
1330   (store-lift build-derivations))
1331
1332 ;; The following might feel more at home in (guix packages) but since (guix
1333 ;; gexp), which is a lower level, needs them, we put them here.
1334
1335 (define %graft?
1336   ;; Whether to honor package grafts by default.
1337   (make-parameter #t))
1338
1339 (define (set-grafting enable?)
1340   "This monadic procedure enables grafting when ENABLE? is true, and disables
1341 it otherwise.  It returns the previous setting."
1342   (lambda (store)
1343     (values (%graft? enable?) store)))