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