guix/derivations.scm

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