guix/derivations.scm

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