guix/derivations.scm

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