guix/scripts/build.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts build)
  21   #:use-module (guix ui)
  22   #:use-module (guix scripts)
  23   #:use-module (guix store)
  24   #:use-module (guix derivations)
  25   #:use-module (guix packages)
  26   #:use-module (guix grafts)
  27
  28   ;; Use the procedure that destructures "NAME-VERSION" forms.
  29   #:use-module ((guix utils) #:hide (package-name->name+version))
  30   #:use-module ((guix build utils) #:select (package-name->name+version))
  31
  32   #:use-module (guix monads)
  33   #:use-module (guix gexp)
  34   #:autoload   (guix http-client) (http-fetch http-get-error?)
  35   #:use-module (ice-9 format)
  36   #:use-module (ice-9 match)
  37   #:use-module (ice-9 vlist)
  38   #:use-module (srfi srfi-1)
  39   #:use-module (srfi srfi-11)
  40   #:use-module (srfi srfi-26)
  41   #:use-module (srfi srfi-34)
  42   #:use-module (srfi srfi-37)
  43   #:autoload   (gnu packages) (specification->package %package-module-path)
  44   #:autoload   (guix download) (download-to-store)
  45   #:export (%standard-build-options
  46             set-build-options-from-command-line
  47             set-build-options-from-command-line*
  48             show-build-options-help
  49
  50             %transformation-options
  51             options->transformation
  52             show-transformation-options-help
  53
  54             guix-build
  55             register-root
  56             register-root*))
  57
  58 (define %default-log-urls
  59   ;; Default base URLs for build logs.
  60   '("http://hydra.gnu.org/log"))
  61
  62 ;; XXX: The following procedure cannot be in (guix store) because of the
  63 ;; dependency on (guix derivations).
  64 (define* (log-url store file #:key (base-urls %default-log-urls))
  65   "Return a URL under one of the BASE-URLS where a build log for FILE can be
  66 found.  Return #f if no build log was found."
  67   (define (valid-url? url)
  68     ;; Probe URL and return #t if it is accessible.
  69     (catch 'getaddrinfo-error
  70       (lambda ()
  71         (guard (c ((http-get-error? c) #f))
  72           (close-port (http-fetch url #:buffered? #f))
  73           #t))
  74       (lambda _
  75         #f)))
  76
  77   (define (find-url file)
  78     (let ((base (basename file)))
  79       (any (lambda (base-url)
  80              (let ((url (string-append base-url "/" base)))
  81                (and (valid-url? url) url)))
  82            base-urls)))
  83
  84   (cond ((derivation-path? file)
  85          (catch 'system-error
  86            (lambda ()
  87              ;; Usually we'll have more luck with the output file name since
  88              ;; the deriver that was used by the server could be different, so
  89              ;; try one of the output file names.
  90              (let ((drv (call-with-input-file file read-derivation)))
  91                (or (find-url (derivation->output-path drv))
  92                    (find-url file))))
  93            (lambda args
  94              ;; As a last resort, try the .drv.
  95              (if (= ENOENT (system-error-errno args))
  96                  (find-url file)
  97                  (apply throw args)))))
  98         (else
  99          (find-url file))))
 100
 101 (define (register-root store paths root)
 102   "Register ROOT as an indirect GC root for all of PATHS."
 103   (let* ((root (if (string-prefix? "/" root)
 104                    root
 105                    (string-append (canonicalize-path (dirname root))
 106                                   "/" root))))
 107     (catch 'system-error
 108       (lambda ()
 109         (match paths
 110           ((path)
 111            (symlink path root)
 112            (add-indirect-root store root))
 113           ((paths ...)
 114            (fold (lambda (path count)
 115                    (let ((root (string-append root
 116                                               "-"
 117                                               (number->string count))))
 118                      (symlink path root)
 119                      (add-indirect-root store root))
 120                    (+ 1 count))
 121                  0
 122                  paths))))
 123       (lambda args
 124         (leave (G_ "failed to create GC root `~a': ~a~%")
 125                root (strerror (system-error-errno args)))))))
 126
 127 (define register-root*
 128   (store-lift register-root))
 129
 130 (define (package-with-source store p uri)
 131   "Return a package based on P but with its source taken from URI.  Extract
 132 the new package's version number from URI."
 133   (define (numeric-extension? file-name)
 134     ;; Return true if FILE-NAME ends with digits.
 135     (string-every char-set:hex-digit (file-extension file-name)))
 136
 137   (define (tarball-base-name file-name)
 138     ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar
 139     ;; extensions.
 140     ;; TODO: Factorize.
 141     (cond ((not (file-extension file-name))
 142            file-name)
 143           ((numeric-extension? file-name)
 144            file-name)
 145           ((string=? (file-extension file-name) "tar")
 146            (file-sans-extension file-name))
 147           ((file-extension file-name)
 148            (tarball-base-name (file-sans-extension file-name)))
 149           (else
 150            file-name)))
 151
 152   (let ((base (tarball-base-name (basename uri))))
 153     (let-values (((name version)
 154                   (package-name->name+version base)))
 155       (package (inherit p)
 156                (version (or version (package-version p)))
 157
 158                ;; Use #:recursive? #t to allow for directories.
 159                (source (download-to-store store uri
 160                                           #:recursive? #t))
 161
 162                ;; Override the replacement, otherwise '--with-source' would
 163                ;; have no effect.
 164                (replacement #f)))))
 165
 166 \f
 167 ;;;
 168 ;;; Transformations.
 169 ;;;
 170
 171 (define (transform-package-source sources)
 172   "Return a transformation procedure that replaces package sources with the
 173 matching URIs given in SOURCES."
 174   (define new-sources
 175     (map (lambda (uri)
 176            (cons (package-name->name+version (basename uri))
 177                  uri))
 178          sources))
 179
 180   (lambda (store obj)
 181     (let loop ((sources  new-sources)
 182                (result   '()))
 183       (match obj
 184         ((? package? p)
 185          (let ((source (assoc-ref sources (package-name p))))
 186            (if source
 187                (package-with-source store p source)
 188                p)))
 189         (_
 190          obj)))))
 191
 192 (define (evaluate-replacement-specs specs proc)
 193   "Parse SPECS, a list of strings like \"guile=guile@2.1\", and invoke PROC on
 194 each package pair specified by SPECS.  Return the resulting list.  Raise an
 195 error if an element of SPECS uses invalid syntax, or if a package it refers to
 196 could not be found."
 197   (define not-equal
 198     (char-set-complement (char-set #\=)))
 199
 200   (map (lambda (spec)
 201          (match (string-tokenize spec not-equal)
 202            ((old new)
 203             (proc (specification->package old)
 204                   (specification->package new)))
 205            (x
 206             (leave (G_ "invalid replacement specification: ~s~%") spec))))
 207        specs))
 208
 209 (define (transform-package-inputs replacement-specs)
 210   "Return a procedure that, when passed a package, replaces its direct
 211 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 212 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
 213 called \"guile\" must be replaced with a dependency on a version 2.1 of
 214 \"guile\"."
 215   (let* ((replacements (evaluate-replacement-specs replacement-specs cons))
 216          (rewrite      (package-input-rewriting replacements)))
 217     (lambda (store obj)
 218       (if (package? obj)
 219           (rewrite obj)
 220           obj))))
 221
 222 (define (transform-package-inputs/graft replacement-specs)
 223   "Return a procedure that, when passed a package, replaces its direct
 224 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 225 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
 226 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
 227   (define (replacement-pair old new)
 228     (cons old
 229           (package (inherit old) (replacement new))))
 230
 231   (let* ((replacements (evaluate-replacement-specs replacement-specs
 232                                                    replacement-pair))
 233          (rewrite      (package-input-rewriting replacements)))
 234     (lambda (store obj)
 235       (if (package? obj)
 236           (rewrite obj)
 237           obj))))
 238
 239 (define %transformations
 240   ;; Transformations that can be applied to things to build.  The car is the
 241   ;; key used in the option alist, and the cdr is the transformation
 242   ;; procedure; it is called with two arguments: the store, and a list of
 243   ;; things to build.
 244   `((with-source . ,transform-package-source)
 245     (with-input  . ,transform-package-inputs)
 246     (with-graft  . ,transform-package-inputs/graft)))
 247
 248 (define %transformation-options
 249   ;; The command-line interface to the above transformations.
 250   (let ((parser (lambda (symbol)
 251                   (lambda (opt name arg result . rest)
 252                     (apply values
 253                            (alist-cons symbol arg result)
 254                            rest)))))
 255     (list (option '("with-source") #t #f
 256                   (parser 'with-source))
 257           (option '("with-input") #t #f
 258                   (parser 'with-input))
 259           (option '("with-graft") #t #f
 260                   (parser 'with-graft)))))
 261
 262 (define (show-transformation-options-help)
 263   (display (G_ "
 264       --with-source=SOURCE
 265                          use SOURCE when building the corresponding package"))
 266   (display (G_ "
 267       --with-input=PACKAGE=REPLACEMENT
 268                          replace dependency PACKAGE by REPLACEMENT"))
 269   (display (G_ "
 270       --with-graft=PACKAGE=REPLACEMENT
 271                          graft REPLACEMENT on packages that refer to PACKAGE")))
 272
 273
 274 (define (options->transformation opts)
 275   "Return a procedure that, when passed an object to build (package,
 276 derivation, etc.), applies the transformations specified by OPTS."
 277   (define applicable
 278     ;; List of applicable transformations as symbol/procedure pairs.
 279     (filter-map (match-lambda
 280                   ((key . transform)
 281                    (match (filter-map (match-lambda
 282                                         ((k . arg)
 283                                          (and (eq? k key) arg)))
 284                                       opts)
 285                      (()   #f)
 286                      (args (cons key (transform args))))))
 287                 %transformations))
 288
 289   (lambda (store obj)
 290     (fold (match-lambda*
 291             (((name . transform) obj)
 292              (let ((new (transform store obj)))
 293                (when (eq? new obj)
 294                  (warning (G_ "transformation '~a' had no effect on ~a~%")
 295                           name
 296                           (if (package? obj)
 297                               (package-full-name obj)
 298                               obj)))
 299                new)))
 300           obj
 301           applicable)))
 302
 303 \f
 304 ;;;
 305 ;;; Standard command-line build options.
 306 ;;;
 307
 308 (define (show-build-options-help)
 309   "Display on the current output port help about the standard command-line
 310 options handled by 'set-build-options-from-command-line', and listed in
 311 '%standard-build-options'."
 312   (display (G_ "
 313   -L, --load-path=DIR    prepend DIR to the package module search path"))
 314   (display (G_ "
 315   -K, --keep-failed      keep build tree of failed builds"))
 316   (display (G_ "
 317   -k, --keep-going       keep going when some of the derivations fail"))
 318   (display (G_ "
 319   -n, --dry-run          do not build the derivations"))
 320   (display (G_ "
 321       --fallback         fall back to building when the substituter fails"))
 322   (display (G_ "
 323       --no-substitutes   build instead of resorting to pre-built substitutes"))
 324   (display (G_ "
 325       --substitute-urls=URLS
 326                          fetch substitute from URLS if they are authorized"))
 327   (display (G_ "
 328       --no-grafts        do not graft packages"))
 329   (display (G_ "
 330       --no-build-hook    do not attempt to offload builds via the build hook"))
 331   (display (G_ "
 332       --max-silent-time=SECONDS
 333                          mark the build as failed after SECONDS of silence"))
 334   (display (G_ "
 335       --timeout=SECONDS  mark the build as failed after SECONDS of activity"))
 336   (display (G_ "
 337       --verbosity=LEVEL  use the given verbosity LEVEL"))
 338   (display (G_ "
 339       --rounds=N         build N times in a row to detect non-determinism"))
 340   (display (G_ "
 341   -c, --cores=N          allow the use of up to N CPU cores for the build"))
 342   (display (G_ "
 343   -M, --max-jobs=N       allow at most N build jobs")))
 344
 345 (define (set-build-options-from-command-line store opts)
 346   "Given OPTS, an alist as returned by 'args-fold' given
 347 '%standard-build-options', set the corresponding build options on STORE."
 348   ;; TODO: Add more options.
 349   (set-build-options store
 350                      #:keep-failed? (assoc-ref opts 'keep-failed?)
 351                      #:keep-going? (assoc-ref opts 'keep-going?)
 352                      #:rounds (assoc-ref opts 'rounds)
 353                      #:build-cores (assoc-ref opts 'cores)
 354                      #:max-build-jobs (assoc-ref opts 'max-jobs)
 355                      #:fallback? (assoc-ref opts 'fallback?)
 356                      #:use-substitutes? (assoc-ref opts 'substitutes?)
 357                      #:substitute-urls (assoc-ref opts 'substitute-urls)
 358                      #:use-build-hook? (assoc-ref opts 'build-hook?)
 359                      #:max-silent-time (assoc-ref opts 'max-silent-time)
 360                      #:timeout (assoc-ref opts 'timeout)
 361                      #:print-build-trace (assoc-ref opts 'print-build-trace?)
 362                      #:verbosity (assoc-ref opts 'verbosity)))
 363
 364 (define set-build-options-from-command-line*
 365   (store-lift set-build-options-from-command-line))
 366
 367 (define %standard-build-options
 368   ;; List of standard command-line options for tools that build something.
 369   (list (option '(#\L "load-path") #t #f
 370                 (lambda (opt name arg result . rest)
 371                   ;; XXX: Imperatively modify the search paths.
 372                   (%package-module-path (cons arg (%package-module-path)))
 373                   (%patch-path (cons arg (%patch-path)))
 374                   (set! %load-path (cons arg %load-path))
 375                   (set! %load-compiled-path (cons arg %load-compiled-path))
 376
 377                   (apply values (cons result rest))))
 378         (option '(#\K "keep-failed") #f #f
 379                 (lambda (opt name arg result . rest)
 380                   (apply values
 381                          (alist-cons 'keep-failed? #t result)
 382                          rest)))
 383         (option '(#\k "keep-going") #f #f
 384                 (lambda (opt name arg result . rest)
 385                   (apply values
 386                          (alist-cons 'keep-going? #t result)
 387                          rest)))
 388         (option '("rounds") #t #f
 389                 (lambda (opt name arg result . rest)
 390                   (apply values
 391                          (alist-cons 'rounds (string->number* arg)
 392                                      result)
 393                          rest)))
 394         (option '("fallback") #f #f
 395                 (lambda (opt name arg result . rest)
 396                   (apply values
 397                          (alist-cons 'fallback? #t
 398                                      (alist-delete 'fallback? result))
 399                          rest)))
 400         (option '("no-substitutes") #f #f
 401                 (lambda (opt name arg result . rest)
 402                   (apply values
 403                          (alist-cons 'substitutes? #f
 404                                      (alist-delete 'substitutes? result))
 405                          rest)))
 406         (option '("substitute-urls") #t #f
 407                 (lambda (opt name arg result . rest)
 408                   (apply values
 409                          (alist-cons 'substitute-urls
 410                                      (string-tokenize arg)
 411                                      (alist-delete 'substitute-urls result))
 412                          rest)))
 413         (option '("no-grafts") #f #f
 414                 (lambda (opt name arg result . rest)
 415                   (apply values
 416                          (alist-cons 'graft? #f
 417                                      (alist-delete 'graft? result eq?))
 418                          rest)))
 419         (option '("no-build-hook") #f #f
 420                 (lambda (opt name arg result . rest)
 421                   (apply values
 422                          (alist-cons 'build-hook? #f
 423                                      (alist-delete 'build-hook? result))
 424                          rest)))
 425         (option '("max-silent-time") #t #f
 426                 (lambda (opt name arg result . rest)
 427                   (apply values
 428                          (alist-cons 'max-silent-time (string->number* arg)
 429                                      result)
 430                          rest)))
 431         (option '("timeout") #t #f
 432                 (lambda (opt name arg result . rest)
 433                   (apply values
 434                          (alist-cons 'timeout (string->number* arg) result)
 435                          rest)))
 436         (option '("verbosity") #t #f
 437                 (lambda (opt name arg result . rest)
 438                   (let ((level (string->number arg)))
 439                     (apply values
 440                            (alist-cons 'verbosity level
 441                                        (alist-delete 'verbosity result))
 442                            rest))))
 443         (option '(#\c "cores") #t #f
 444                 (lambda (opt name arg result . rest)
 445                   (let ((c (false-if-exception (string->number arg))))
 446                     (if c
 447                         (apply values (alist-cons 'cores c result) rest)
 448                         (leave (G_ "not a number: '~a' option argument: ~a~%")
 449                                name arg)))))
 450         (option '(#\M "max-jobs") #t #f
 451                 (lambda (opt name arg result . rest)
 452                   (let ((c (false-if-exception (string->number arg))))
 453                     (if c
 454                         (apply values (alist-cons 'max-jobs c result) rest)
 455                         (leave (G_ "not a number: '~a' option argument: ~a~%")
 456                                name arg)))))))
 457
 458 \f
 459 ;;;
 460 ;;; Command-line options.
 461 ;;;
 462
 463 (define %default-options
 464   ;; Alist of default option values.
 465   `((system . ,(%current-system))
 466     (build-mode . ,(build-mode normal))
 467     (graft? . #t)
 468     (substitutes? . #t)
 469     (build-hook? . #t)
 470     (print-build-trace? . #t)
 471     (verbosity . 0)))
 472
 473 (define (show-help)
 474   (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION...
 475 Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
 476   (display (G_ "
 477   -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
 478   (display (G_ "
 479   -f, --file=FILE        build the package or derivation that the code within
 480                          FILE evaluates to"))
 481   (display (G_ "
 482   -S, --source           build the packages' source derivations"))
 483   (display (G_ "
 484       --sources[=TYPE]   build source derivations; TYPE may optionally be one
 485                          of \"package\", \"all\" (default), or \"transitive\""))
 486   (display (G_ "
 487   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
 488   (display (G_ "
 489       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
 490   (display (G_ "
 491   -d, --derivations      return the derivation paths of the given packages"))
 492   (display (G_ "
 493       --check            rebuild items to check for non-determinism issues"))
 494   (display (G_ "
 495       --repair           repair the specified items"))
 496   (display (G_ "
 497   -r, --root=FILE        make FILE a symlink to the result, and register it
 498                          as a garbage collector root"))
 499   (display (G_ "
 500   -q, --quiet            do not show the build log"))
 501   (display (G_ "
 502       --log-file         return the log file names for the given derivations"))
 503   (newline)
 504   (show-build-options-help)
 505   (newline)
 506   (show-transformation-options-help)
 507   (newline)
 508   (display (G_ "
 509   -h, --help             display this help and exit"))
 510   (display (G_ "
 511   -V, --version          display version information and exit"))
 512   (newline)
 513   (show-bug-report-information))
 514
 515 (define %options
 516   ;; Specifications of the command-line options.
 517   (cons* (option '(#\h "help") #f #f
 518                  (lambda args
 519                    (show-help)
 520                    (exit 0)))
 521          (option '(#\V "version") #f #f
 522                  (lambda args
 523                    (show-version-and-exit "guix build")))
 524          (option '(#\S "source") #f #f
 525                  (lambda (opt name arg result)
 526                    (alist-cons 'source #t result)))
 527          (option '("sources") #f #t
 528                  (lambda (opt name arg result)
 529                    (match arg
 530                      ("package"
 531                       (alist-cons 'source #t result))
 532                      ((or "all" #f)
 533                       (alist-cons 'source package-direct-sources result))
 534                      ("transitive"
 535                       (alist-cons 'source package-transitive-sources result))
 536                      (else
 537                       (leave (G_ "invalid argument: '~a' option argument: ~a, ~
 538 must be one of 'package', 'all', or 'transitive'~%")
 539                              name arg)))))
 540          (option '("check") #f #f
 541                  (lambda (opt name arg result . rest)
 542                    (apply values
 543                           (alist-cons 'build-mode (build-mode check)
 544                                       result)
 545                           rest)))
 546          (option '("repair") #f #f
 547                  (lambda (opt name arg result . rest)
 548                    (apply values
 549                           (alist-cons 'build-mode (build-mode repair)
 550                                       result)
 551                           rest)))
 552          (option '(#\s "system") #t #f
 553                  (lambda (opt name arg result)
 554                    (alist-cons 'system arg
 555                                (alist-delete 'system result eq?))))
 556          (option '("target") #t #f
 557                  (lambda (opt name arg result)
 558                    (alist-cons 'target arg
 559                                (alist-delete 'target result eq?))))
 560          (option '(#\d "derivations") #f #f
 561                  (lambda (opt name arg result)
 562                    (alist-cons 'derivations-only? #t result)))
 563          (option '(#\e "expression") #t #f
 564                  (lambda (opt name arg result)
 565                    (alist-cons 'expression arg result)))
 566          (option '(#\f "file") #t #f
 567                  (lambda (opt name arg result)
 568                    (alist-cons 'file arg result)))
 569          (option '(#\n "dry-run") #f #f
 570                  (lambda (opt name arg result)
 571                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 572          (option '(#\r "root") #t #f
 573                  (lambda (opt name arg result)
 574                    (alist-cons 'gc-root arg result)))
 575          (option '(#\q "quiet") #f #f
 576                  (lambda (opt name arg result)
 577                    (alist-cons 'quiet? #t result)))
 578          (option '("log-file") #f #f
 579                  (lambda (opt name arg result)
 580                    (alist-cons 'log-file? #t result)))
 581
 582          (append %transformation-options
 583                  %standard-build-options)))
 584
 585 (define (options->things-to-build opts)
 586   "Read the arguments from OPTS and return a list of high-level objects to
 587 build---packages, gexps, derivations, and so on."
 588   (define (validate-type x)
 589     (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
 590       (leave (G_ "~s: not something we can build~%") x)))
 591
 592   (define (ensure-list x)
 593     (let ((lst (match x
 594                  ((x ...) x)
 595                  (x       (list x)))))
 596       (for-each validate-type lst)
 597       lst))
 598
 599   (append-map (match-lambda
 600                 (('argument . (? string? spec))
 601                  (cond ((derivation-path? spec)
 602                         (list (call-with-input-file spec read-derivation)))
 603                        ((store-path? spec)
 604                         ;; Nothing to do; maybe for --log-file.
 605                         '())
 606                        (else
 607                         (list (specification->package spec)))))
 608                 (('file . file)
 609                  (ensure-list (load* file (make-user-module '()))))
 610                 (('expression . str)
 611                  (ensure-list (read/eval str)))
 612                 (('argument . (? derivation? drv))
 613                  drv)
 614                 (_ '()))
 615               opts))
 616
 617 (define (options->derivations store opts)
 618   "Given OPTS, the result of 'args-fold', return a list of derivations to
 619 build."
 620   (define transform
 621     (options->transformation opts))
 622
 623   (define package->derivation
 624     (match (assoc-ref opts 'target)
 625       (#f package-derivation)
 626       (triplet
 627        (cut package-cross-derivation <> <> triplet <>))))
 628
 629   (define src    (assoc-ref opts 'source))
 630   (define system (assoc-ref opts 'system))
 631   (define graft? (assoc-ref opts 'graft?))
 632
 633   (parameterize ((%graft? graft?))
 634     (append-map (match-lambda
 635                   ((? package? p)
 636                    (let ((p (or (and graft? (package-replacement p)) p)))
 637                      (match src
 638                        (#f
 639                         (list (package->derivation store p system)))
 640                        (#t
 641                         (match (package-source p)
 642                           (#f
 643                            (format (current-error-port)
 644                                    (G_ "~a: warning: \
 645 package '~a' has no source~%")
 646                                    (location->string (package-location p))
 647                                    (package-name p))
 648                            '())
 649                           (s
 650                            (list (package-source-derivation store s)))))
 651                        (proc
 652                         (map (cut package-source-derivation store <>)
 653                              (proc p))))))
 654                   ((? derivation? drv)
 655                    (list drv))
 656                   ((? procedure? proc)
 657                    (list (run-with-store store
 658                            (mbegin %store-monad
 659                              (set-guile-for-build (default-guile))
 660                              (proc))
 661                            #:system system)))
 662                   ((? gexp? gexp)
 663                    (list (run-with-store store
 664                            (mbegin %store-monad
 665                              (set-guile-for-build (default-guile))
 666                              (gexp->derivation "gexp" gexp
 667                                                #:system system))))))
 668                 (map (cut transform store <>)
 669                      (options->things-to-build opts)))))
 670
 671 (define (show-build-log store file urls)
 672   "Show the build log for FILE, falling back to remote logs from URLS if
 673 needed."
 674   (let ((log (or (log-file store file)
 675                  (log-url store file #:base-urls urls))))
 676     (if log
 677         (format #t "~a~%" log)
 678         (leave (G_ "no build log for '~a'~%") file))))
 679
 680 \f
 681 ;;;
 682 ;;; Entry point.
 683 ;;;
 684
 685 (define (guix-build . args)
 686   (define opts
 687     (parse-command-line args %options
 688                         (list %default-options)))
 689
 690   (define quiet?
 691     (assoc-ref opts 'quiet?))
 692
 693   (with-error-handling
 694     ;; Ask for absolute file names so that .drv file names passed from the
 695     ;; user to 'read-derivation' are absolute when it returns.
 696     (with-fluids ((%file-port-name-canonicalization 'absolute))
 697       (with-store store
 698         ;; Set the build options before we do anything else.
 699         (set-build-options-from-command-line store opts)
 700
 701         (parameterize ((current-build-output-port (if quiet?
 702                                                       (%make-void-port "w")
 703                                                       (current-error-port))))
 704           (let* ((mode  (assoc-ref opts 'build-mode))
 705                  (drv   (options->derivations store opts))
 706                  (urls  (map (cut string-append <> "/log")
 707                              (if (assoc-ref opts 'substitutes?)
 708                                  (or (assoc-ref opts 'substitute-urls)
 709                                      ;; XXX: This does not necessarily match the
 710                                      ;; daemon's substitute URLs.
 711                                      %default-substitute-urls)
 712                                  '())))
 713                  (items (filter-map (match-lambda
 714                                       (('argument . (? store-path? file))
 715                                        file)
 716                                       (_ #f))
 717                                     opts))
 718                  (roots (filter-map (match-lambda
 719                                       (('gc-root . root) root)
 720                                       (_ #f))
 721                                     opts)))
 722
 723             (unless (or (assoc-ref opts 'log-file?)
 724                         (assoc-ref opts 'derivations-only?))
 725               (show-what-to-build store drv
 726                                   #:use-substitutes?
 727                                   (assoc-ref opts 'substitutes?)
 728                                   #:dry-run? (assoc-ref opts 'dry-run?)
 729                                   #:mode mode))
 730
 731             (cond ((assoc-ref opts 'log-file?)
 732                    (for-each (cut show-build-log store <> urls)
 733                              (delete-duplicates
 734                               (append (map derivation-file-name drv)
 735                                       items))))
 736                   ((assoc-ref opts 'derivations-only?)
 737                    (format #t "~{~a~%~}" (map derivation-file-name drv))
 738                    (for-each (cut register-root store <> <>)
 739                              (map (compose list derivation-file-name) drv)
 740                              roots))
 741                   ((not (assoc-ref opts 'dry-run?))
 742                    (and (build-derivations store drv mode)
 743                         (for-each show-derivation-outputs drv)
 744                         (for-each (cut register-root store <> <>)
 745                                   (map (lambda (drv)
 746                                          (map cdr
 747                                               (derivation->output-paths drv)))
 748                                        drv)
 749                                   roots))))))))))