guix/derivations.scm

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