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