guix/scripts/build.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 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-module (guix utils)
  29
  30   ;; Use the procedure that destructures "NAME-VERSION" forms.
  31   #:use-module ((guix build utils)
  32                 #:select ((package-name->name+version
  33                            . hyphen-package-name->name+version)))
  34
  35   #:use-module (guix monads)
  36   #:use-module (guix gexp)
  37   #:autoload   (guix http-client) (http-fetch http-get-error?)
  38   #:use-module (ice-9 format)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 vlist)
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-11)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-37)
  46   #:autoload   (gnu packages) (specification->package %package-module-path)
  47   #:autoload   (guix download) (download-to-store)
  48   #:autoload   (guix git-download) (git-reference?)
  49   #:autoload   (guix git) (git-checkout?)
  50   #:use-module ((guix status) #:select (with-status-verbosity))
  51   #:use-module ((guix progress) #:select (current-terminal-columns))
  52   #:use-module ((guix build syscalls) #:select (terminal-columns))
  53   #:export (%standard-build-options
  54             set-build-options-from-command-line
  55             set-build-options-from-command-line*
  56             show-build-options-help
  57
  58             %transformation-options
  59             options->transformation
  60             show-transformation-options-help
  61
  62             guix-build
  63             register-root
  64             register-root*))
  65
  66 (define %default-log-urls
  67   ;; Default base URLs for build logs.
  68   '("http://ci.guix.info/log"))
  69
  70 ;; XXX: The following procedure cannot be in (guix store) because of the
  71 ;; dependency on (guix derivations).
  72 (define* (log-url store file #:key (base-urls %default-log-urls))
  73   "Return a URL under one of the BASE-URLS where a build log for FILE can be
  74 found.  Return #f if no build log was found."
  75   (define (valid-url? url)
  76     ;; Probe URL and return #t if it is accessible.
  77     (catch #t
  78       (lambda ()
  79         (guard (c ((http-get-error? c) #f))
  80           (close-port (http-fetch url #:buffered? #f))
  81           #t))
  82       (match-lambda*
  83         (('getaddrinfo-error . _)
  84          #f)
  85         (('tls-certificate-error args ...)
  86          (report-error (G_ "cannot access build log at '~a':~%") url)
  87          (print-exception (current-error-port) #f
  88                           'tls-certificate-error args)
  89          (exit 1))
  90         ((key . args)
  91          (apply throw key args)))))
  92
  93   (define (find-url file)
  94     (let ((base (basename file)))
  95       (any (lambda (base-url)
  96              (let ((url (string-append base-url "/" base)))
  97                (and (valid-url? url) url)))
  98            base-urls)))
  99
 100   (cond ((derivation-path? file)
 101          (catch 'system-error
 102            (lambda ()
 103              ;; Usually we'll have more luck with the output file name since
 104              ;; the deriver that was used by the server could be different, so
 105              ;; try one of the output file names.
 106              (let ((drv (read-derivation-from-file file)))
 107                (or (find-url (derivation->output-path drv))
 108                    (find-url file))))
 109            (lambda args
 110              ;; As a last resort, try the .drv.
 111              (if (= ENOENT (system-error-errno args))
 112                  (find-url file)
 113                  (apply throw args)))))
 114         (else
 115          (find-url file))))
 116
 117 (define (register-root store paths root)
 118   "Register ROOT as an indirect GC root for all of PATHS."
 119   (let* ((root (if (string-prefix? "/" root)
 120                    root
 121                    (string-append (canonicalize-path (dirname root))
 122                                   "/" (basename root)))))
 123     (catch 'system-error
 124       (lambda ()
 125         (match paths
 126           ((path)
 127            (symlink path root)
 128            (add-indirect-root store root))
 129           ((paths ...)
 130            (fold (lambda (path count)
 131                    (let ((root (string-append root
 132                                               "-"
 133                                               (number->string count))))
 134                      (symlink path root)
 135                      (add-indirect-root store root))
 136                    (+ 1 count))
 137                  0
 138                  paths))))
 139       (lambda args
 140         (leave (G_ "failed to create GC root `~a': ~a~%")
 141                root (strerror (system-error-errno args)))))))
 142
 143 (define register-root*
 144   (store-lift register-root))
 145
 146 (define (numeric-extension? file-name)
 147   "Return true if FILE-NAME ends with digits."
 148   (string-every char-set:hex-digit (file-extension file-name)))
 149
 150 (define (tarball-base-name file-name)
 151   "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
 152 extensions."
 153   ;; TODO: Factorize.
 154   (cond ((not (file-extension file-name))
 155          file-name)
 156         ((numeric-extension? file-name)
 157          file-name)
 158         ((string=? (file-extension file-name) "tar")
 159          (file-sans-extension file-name))
 160         ((file-extension file-name)
 161          =>
 162          (match-lambda
 163            ("scm" file-name)
 164            (else  (tarball-base-name (file-sans-extension file-name)))))
 165         (else
 166          file-name)))
 167
 168 (define* (package-with-source store p uri #:optional version)
 169   "Return a package based on P but with its source taken from URI.  Extract
 170 the new package's version number from URI."
 171   (let ((base (tarball-base-name (basename uri))))
 172     (let-values (((_ version*)
 173                   (hyphen-package-name->name+version base)))
 174       (package (inherit p)
 175                (version (or version version*
 176                             (package-version p)))
 177
 178                ;; Use #:recursive? #t to allow for directories.
 179                (source (download-to-store store uri
 180                                           #:recursive? #t))
 181
 182                ;; Override the replacement, otherwise '--with-source' would
 183                ;; have no effect.
 184                (replacement #f)))))
 185
 186 \f
 187 ;;;
 188 ;;; Transformations.
 189 ;;;
 190
 191 (define (transform-package-source sources)
 192   "Return a transformation procedure that replaces package sources with the
 193 matching URIs given in SOURCES."
 194   (define new-sources
 195     (map (lambda (uri)
 196            (match (string-index uri #\=)
 197              (#f
 198               ;; Determine the package name and version from URI.
 199               (call-with-values
 200                   (lambda ()
 201                     (hyphen-package-name->name+version
 202                      (tarball-base-name (basename uri))))
 203                 (lambda (name version)
 204                   (list name version uri))))
 205              (index
 206               ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
 207               (call-with-values
 208                   (lambda ()
 209                     (package-name->name+version (string-take uri index)))
 210                 (lambda (name version)
 211                   (list name version
 212                         (string-drop uri (+ 1 index))))))))
 213          sources))
 214
 215   (lambda (store obj)
 216     (let loop ((sources  new-sources)
 217                (result   '()))
 218       (match obj
 219         ((? package? p)
 220          (match (assoc-ref sources (package-name p))
 221            ((version source)
 222             (package-with-source store p source version))
 223            (#f
 224             p)))
 225         (_
 226          obj)))))
 227
 228 (define (evaluate-replacement-specs specs proc)
 229   "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
 230 of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
 231 PROC is called with the package to be replaced and its replacement according
 232 to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
 233 package it refers to could not be found."
 234   (define not-equal
 235     (char-set-complement (char-set #\=)))
 236
 237   (map (lambda (spec)
 238          (match (string-tokenize spec not-equal)
 239            ((spec new)
 240             (cons spec
 241                   (let ((new (specification->package new)))
 242                     (lambda (old)
 243                       (proc old new)))))
 244            (x
 245             (leave (G_ "invalid replacement specification: ~s~%") spec))))
 246        specs))
 247
 248 (define (transform-package-inputs replacement-specs)
 249   "Return a procedure that, when passed a package, replaces its direct
 250 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 251 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
 252 called \"guile\" must be replaced with a dependency on a version 2.1 of
 253 \"guile\"."
 254   (let* ((replacements (evaluate-replacement-specs replacement-specs
 255                                                    (lambda (old new)
 256                                                      new)))
 257          (rewrite      (package-input-rewriting/spec replacements)))
 258     (lambda (store obj)
 259       (if (package? obj)
 260           (rewrite obj)
 261           obj))))
 262
 263 (define (transform-package-inputs/graft replacement-specs)
 264   "Return a procedure that, when passed a package, replaces its direct
 265 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 266 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
 267 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
 268   (define (set-replacement old new)
 269     (package (inherit old) (replacement new)))
 270
 271   (let* ((replacements (evaluate-replacement-specs replacement-specs
 272                                                    set-replacement))
 273          (rewrite      (package-input-rewriting/spec replacements)))
 274     (lambda (store obj)
 275       (if (package? obj)
 276           (rewrite obj)
 277           obj))))
 278
 279 (define %not-equal
 280   (char-set-complement (char-set #\=)))
 281
 282 (define (package-git-url package)
 283   "Return the URL of the Git repository for package, or raise an error if
 284 the source of PACKAGE is not fetched from a Git repository."
 285   (let ((source (package-source package)))
 286     (cond ((and (origin? source)
 287                 (git-reference? (origin-uri source)))
 288            (git-reference-url (origin-uri source)))
 289           ((git-checkout? source)
 290            (git-checkout-url source))
 291           (else
 292            (leave (G_ "the source of ~a is not a Git reference~%")
 293                   (package-full-name package))))))
 294
 295 (define (evaluate-git-replacement-specs specs proc)
 296   "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
 297 of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
 298 replacement package.  Raise an error if an element of SPECS uses invalid
 299 syntax, or if a package it refers to could not be found."
 300   (map (lambda (spec)
 301          (match (string-tokenize spec %not-equal)
 302            ((spec branch-or-commit)
 303             (define (replace old)
 304               (let* ((source (package-source old))
 305                      (url    (package-git-url old)))
 306                 (proc old url branch-or-commit)))
 307
 308             (cons spec replace))
 309            (x
 310             (leave (G_ "invalid replacement specification: ~s~%") spec))))
 311        specs))
 312
 313 (define (transform-package-source-branch replacement-specs)
 314   "Return a procedure that, when passed a package, replaces its direct
 315 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 316 strings like \"guile-next=stable-3.0\" meaning that packages are built using
 317 'guile-next' from the latest commit on its 'stable-3.0' branch."
 318   (define (replace old url branch)
 319     (package
 320       (inherit old)
 321       (version (string-append "git." (string-map (match-lambda
 322                                                    (#\/ #\-)
 323                                                    (chr chr))
 324                                                  branch)))
 325       (source (git-checkout (url url) (branch branch)
 326                             (recursive? #t)))))
 327
 328   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 329                                                        replace))
 330          (rewrite      (package-input-rewriting/spec replacements)))
 331     (lambda (store obj)
 332       (if (package? obj)
 333           (rewrite obj)
 334           obj))))
 335
 336 (define (transform-package-source-commit replacement-specs)
 337   "Return a procedure that, when passed a package, replaces its direct
 338 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 339 strings like \"guile-next=cabba9e\" meaning that packages are built using
 340 'guile-next' from commit 'cabba9e'."
 341   (define (replace old url commit)
 342     (package
 343       (inherit old)
 344       (version (string-append "git."
 345                               (if (< (string-length commit) 7)
 346                                   commit
 347                                   (string-take commit 7))))
 348       (source (git-checkout (url url) (commit commit)
 349                             (recursive? #t)))))
 350
 351   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
 352                                                        replace))
 353          (rewrite      (package-input-rewriting/spec replacements)))
 354     (lambda (store obj)
 355       (if (package? obj)
 356           (rewrite obj)
 357           obj))))
 358
 359 (define (transform-package-source-git-url replacement-specs)
 360   "Return a procedure that, when passed a package, replaces its dependencies
 361 according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
 362 \"guile-json=https://gitthing.com/…\" meaning that packages are built using
 363 a checkout of the Git repository at the given URL."
 364   (define replacements
 365     (map (lambda (spec)
 366            (match (string-tokenize spec %not-equal)
 367              ((spec url)
 368               (cons spec
 369                     (lambda (old)
 370                       (package
 371                         (inherit old)
 372                         (source (git-checkout (url url)
 373                                               (recursive? #t)))))))))
 374          replacement-specs))
 375
 376   (define rewrite
 377     (package-input-rewriting/spec replacements))
 378
 379   (lambda (store obj)
 380     (if (package? obj)
 381         (rewrite obj)
 382         obj)))
 383
 384 (define %transformations
 385   ;; Transformations that can be applied to things to build.  The car is the
 386   ;; key used in the option alist, and the cdr is the transformation
 387   ;; procedure; it is called with two arguments: the store, and a list of
 388   ;; things to build.
 389   `((with-source . ,transform-package-source)
 390     (with-input  . ,transform-package-inputs)
 391     (with-graft  . ,transform-package-inputs/graft)
 392     (with-branch . ,transform-package-source-branch)
 393     (with-commit . ,transform-package-source-commit)
 394     (with-git-url . ,transform-package-source-git-url)))
 395
 396 (define %transformation-options
 397   ;; The command-line interface to the above transformations.
 398   (let ((parser (lambda (symbol)
 399                   (lambda (opt name arg result . rest)
 400                     (apply values
 401                            (alist-cons symbol arg result)
 402                            rest)))))
 403     (list (option '("with-source") #t #f
 404                   (parser 'with-source))
 405           (option '("with-input") #t #f
 406                   (parser 'with-input))
 407           (option '("with-graft") #t #f
 408                   (parser 'with-graft))
 409           (option '("with-branch") #t #f
 410                   (parser 'with-branch))
 411           (option '("with-commit") #t #f
 412                   (parser 'with-commit))
 413           (option '("with-git-url") #t #f
 414                   (parser 'with-git-url)))))
 415
 416 (define (show-transformation-options-help)
 417   (display (G_ "
 418       --with-source=SOURCE
 419                          use SOURCE when building the corresponding package"))
 420   (display (G_ "
 421       --with-input=PACKAGE=REPLACEMENT
 422                          replace dependency PACKAGE by REPLACEMENT"))
 423   (display (G_ "
 424       --with-graft=PACKAGE=REPLACEMENT
 425                          graft REPLACEMENT on packages that refer to PACKAGE"))
 426   (display (G_ "
 427       --with-branch=PACKAGE=BRANCH
 428                          build PACKAGE from the latest commit of BRANCH"))
 429   (display (G_ "
 430       --with-commit=PACKAGE=COMMIT
 431                          build PACKAGE from COMMIT"))
 432   (display (G_ "
 433       --with-git-url=PACKAGE=URL
 434                          build PACKAGE from the repository at URL")))
 435
 436
 437 (define (options->transformation opts)
 438   "Return a procedure that, when passed an object to build (package,
 439 derivation, etc.), applies the transformations specified by OPTS."
 440   (define applicable
 441     ;; List of applicable transformations as symbol/procedure pairs in the
 442     ;; order in which they appear on the command line.
 443     (filter-map (match-lambda
 444                   ((key . value)
 445                    (match (any (match-lambda
 446                                  ((k . proc)
 447                                   (and (eq? k key) proc)))
 448                                %transformations)
 449                      (#f
 450                       #f)
 451                      (transform
 452                       ;; XXX: We used to pass TRANSFORM a list of several
 453                       ;; arguments, but we now pass only one, assuming that
 454                       ;; transform composes well.
 455                       (cons key (transform (list value)))))))
 456                 (reverse opts)))
 457
 458   (lambda (store obj)
 459     (fold (match-lambda*
 460             (((name . transform) obj)
 461              (let ((new (transform store obj)))
 462                (when (eq? new obj)
 463                  (warning (G_ "transformation '~a' had no effect on ~a~%")
 464                           name
 465                           (if (package? obj)
 466                               (package-full-name obj)
 467                               obj)))
 468                new)))
 469           obj
 470           applicable)))
 471
 472 \f
 473 ;;;
 474 ;;; Standard command-line build options.
 475 ;;;
 476
 477 (define (show-build-options-help)
 478   "Display on the current output port help about the standard command-line
 479 options handled by 'set-build-options-from-command-line', and listed in
 480 '%standard-build-options'."
 481   (display (G_ "
 482   -L, --load-path=DIR    prepend DIR to the package module search path"))
 483   (display (G_ "
 484   -K, --keep-failed      keep build tree of failed builds"))
 485   (display (G_ "
 486   -k, --keep-going       keep going when some of the derivations fail"))
 487   (display (G_ "
 488   -n, --dry-run          do not build the derivations"))
 489   (display (G_ "
 490       --fallback         fall back to building when the substituter fails"))
 491   (display (G_ "
 492       --no-substitutes   build instead of resorting to pre-built substitutes"))
 493   (display (G_ "
 494       --substitute-urls=URLS
 495                          fetch substitute from URLS if they are authorized"))
 496   (display (G_ "
 497       --no-grafts        do not graft packages"))
 498   (display (G_ "
 499       --no-build-hook    do not attempt to offload builds via the build hook"))
 500   (display (G_ "
 501       --max-silent-time=SECONDS
 502                          mark the build as failed after SECONDS of silence"))
 503   (display (G_ "
 504       --timeout=SECONDS  mark the build as failed after SECONDS of activity"))
 505   (display (G_ "
 506       --rounds=N         build N times in a row to detect non-determinism"))
 507   (display (G_ "
 508   -c, --cores=N          allow the use of up to N CPU cores for the build"))
 509   (display (G_ "
 510   -M, --max-jobs=N       allow at most N build jobs"))
 511   (display (G_ "
 512       --debug=LEVEL      produce debugging output at LEVEL")))
 513
 514 (define (set-build-options-from-command-line store opts)
 515   "Given OPTS, an alist as returned by 'args-fold' given
 516 '%standard-build-options', set the corresponding build options on STORE."
 517   ;; TODO: Add more options.
 518   (set-build-options store
 519                      #:keep-failed? (assoc-ref opts 'keep-failed?)
 520                      #:keep-going? (assoc-ref opts 'keep-going?)
 521                      #:rounds (assoc-ref opts 'rounds)
 522                      #:build-cores (assoc-ref opts 'cores)
 523                      #:max-build-jobs (assoc-ref opts 'max-jobs)
 524                      #:fallback? (assoc-ref opts 'fallback?)
 525                      #:use-substitutes? (assoc-ref opts 'substitutes?)
 526                      #:substitute-urls (assoc-ref opts 'substitute-urls)
 527                      #:use-build-hook? (assoc-ref opts 'build-hook?)
 528                      #:max-silent-time (assoc-ref opts 'max-silent-time)
 529                      #:timeout (assoc-ref opts 'timeout)
 530                      #:print-build-trace (assoc-ref opts 'print-build-trace?)
 531                      #:print-extended-build-trace?
 532                      (assoc-ref opts 'print-extended-build-trace?)
 533                      #:multiplexed-build-output?
 534                      (assoc-ref opts 'multiplexed-build-output?)
 535                      #:verbosity (assoc-ref opts 'debug)))
 536
 537 (define set-build-options-from-command-line*
 538   (store-lift set-build-options-from-command-line))
 539
 540 (define %standard-build-options
 541   ;; List of standard command-line options for tools that build something.
 542   (list (option '(#\L "load-path") #t #f
 543                 (lambda (opt name arg result . rest)
 544                   ;; XXX: Imperatively modify the search paths.
 545                   (%package-module-path (cons arg (%package-module-path)))
 546                   (%patch-path (cons arg (%patch-path)))
 547                   (set! %load-path (cons arg %load-path))
 548                   (set! %load-compiled-path (cons arg %load-compiled-path))
 549
 550                   (apply values (cons result rest))))
 551         (option '(#\K "keep-failed") #f #f
 552                 (lambda (opt name arg result . rest)
 553                   (apply values
 554                          (alist-cons 'keep-failed? #t result)
 555                          rest)))
 556         (option '(#\k "keep-going") #f #f
 557                 (lambda (opt name arg result . rest)
 558                   (apply values
 559                          (alist-cons 'keep-going? #t result)
 560                          rest)))
 561         (option '("rounds") #t #f
 562                 (lambda (opt name arg result . rest)
 563                   (apply values
 564                          (alist-cons 'rounds (string->number* arg)
 565                                      result)
 566                          rest)))
 567         (option '("fallback") #f #f
 568                 (lambda (opt name arg result . rest)
 569                   (apply values
 570                          (alist-cons 'fallback? #t
 571                                      (alist-delete 'fallback? result))
 572                          rest)))
 573         (option '("no-substitutes") #f #f
 574                 (lambda (opt name arg result . rest)
 575                   (apply values
 576                          (alist-cons 'substitutes? #f
 577                                      (alist-delete 'substitutes? result))
 578                          rest)))
 579         (option '("substitute-urls") #t #f
 580                 (lambda (opt name arg result . rest)
 581                   (apply values
 582                          (alist-cons 'substitute-urls
 583                                      (string-tokenize arg)
 584                                      (alist-delete 'substitute-urls result))
 585                          rest)))
 586         (option '("no-grafts") #f #f
 587                 (lambda (opt name arg result . rest)
 588                   (apply values
 589                          (alist-cons 'graft? #f
 590                                      (alist-delete 'graft? result eq?))
 591                          rest)))
 592         (option '("no-build-hook") #f #f
 593                 (lambda (opt name arg result . rest)
 594                   (apply values
 595                          (alist-cons 'build-hook? #f
 596                                      (alist-delete 'build-hook? result))
 597                          rest)))
 598         (option '("max-silent-time") #t #f
 599                 (lambda (opt name arg result . rest)
 600                   (apply values
 601                          (alist-cons 'max-silent-time (string->number* arg)
 602                                      result)
 603                          rest)))
 604         (option '("timeout") #t #f
 605                 (lambda (opt name arg result . rest)
 606                   (apply values
 607                          (alist-cons 'timeout (string->number* arg) result)
 608                          rest)))
 609         (option '("debug") #t #f
 610                 (lambda (opt name arg result . rest)
 611                   (let ((level (string->number* arg)))
 612                     (apply values
 613                            (alist-cons 'debug level
 614                                        (alist-delete 'debug result))
 615                            rest))))
 616         (option '(#\c "cores") #t #f
 617                 (lambda (opt name arg result . rest)
 618                   (let ((c (false-if-exception (string->number arg))))
 619                     (if c
 620                         (apply values (alist-cons 'cores c result) rest)
 621                         (leave (G_ "not a number: '~a' option argument: ~a~%")
 622                                name arg)))))
 623         (option '(#\M "max-jobs") #t #f
 624                 (lambda (opt name arg result . rest)
 625                   (let ((c (false-if-exception (string->number arg))))
 626                     (if c
 627                         (apply values (alist-cons 'max-jobs c result) rest)
 628                         (leave (G_ "not a number: '~a' option argument: ~a~%")
 629                                name arg)))))))
 630
 631 \f
 632 ;;;
 633 ;;; Command-line options.
 634 ;;;
 635
 636 (define %default-options
 637   ;; Alist of default option values.
 638   `((build-mode . ,(build-mode normal))
 639     (graft? . #t)
 640     (substitutes? . #t)
 641     (build-hook? . #t)
 642     (print-build-trace? . #t)
 643     (print-extended-build-trace? . #t)
 644     (multiplexed-build-output? . #t)
 645     (verbosity . 2)
 646     (debug . 0)))
 647
 648 (define (show-help)
 649   (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION...
 650 Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
 651   (display (G_ "
 652   -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
 653   (display (G_ "
 654   -f, --file=FILE        build the package or derivation that the code within
 655                          FILE evaluates to"))
 656   (display (G_ "
 657   -S, --source           build the packages' source derivations"))
 658   (display (G_ "
 659       --sources[=TYPE]   build source derivations; TYPE may optionally be one
 660                          of \"package\", \"all\" (default), or \"transitive\""))
 661   (display (G_ "
 662   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
 663   (display (G_ "
 664       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
 665   (display (G_ "
 666   -d, --derivations      return the derivation paths of the given packages"))
 667   (display (G_ "
 668       --check            rebuild items to check for non-determinism issues"))
 669   (display (G_ "
 670       --repair           repair the specified items"))
 671   (display (G_ "
 672   -r, --root=FILE        make FILE a symlink to the result, and register it
 673                          as a garbage collector root"))
 674   (display (G_ "
 675   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 676   (display (G_ "
 677   -q, --quiet            do not show the build log"))
 678   (display (G_ "
 679       --log-file         return the log file names for the given derivations"))
 680   (newline)
 681   (show-build-options-help)
 682   (newline)
 683   (show-transformation-options-help)
 684   (newline)
 685   (display (G_ "
 686   -h, --help             display this help and exit"))
 687   (display (G_ "
 688   -V, --version          display version information and exit"))
 689   (newline)
 690   (show-bug-report-information))
 691
 692 (define %options
 693   ;; Specifications of the command-line options.
 694   (cons* (option '(#\h "help") #f #f
 695                  (lambda args
 696                    (show-help)
 697                    (exit 0)))
 698          (option '(#\V "version") #f #f
 699                  (lambda args
 700                    (show-version-and-exit "guix build")))
 701          (option '(#\S "source") #f #f
 702                  (lambda (opt name arg result)
 703                    (alist-cons 'source #t result)))
 704          (option '("sources") #f #t
 705                  (lambda (opt name arg result)
 706                    (match arg
 707                      ("package"
 708                       (alist-cons 'source #t result))
 709                      ((or "all" #f)
 710                       (alist-cons 'source package-direct-sources result))
 711                      ("transitive"
 712                       (alist-cons 'source package-transitive-sources result))
 713                      (else
 714                       (leave (G_ "invalid argument: '~a' option argument: ~a, ~
 715 must be one of 'package', 'all', or 'transitive'~%")
 716                              name arg)))))
 717          (option '("check") #f #f
 718                  (lambda (opt name arg result . rest)
 719                    (apply values
 720                           (alist-cons 'build-mode (build-mode check)
 721                                       result)
 722                           rest)))
 723          (option '("repair") #f #f
 724                  (lambda (opt name arg result . rest)
 725                    (apply values
 726                           (alist-cons 'build-mode (build-mode repair)
 727                                       result)
 728                           rest)))
 729          (option '(#\s "system") #t #f
 730                  (lambda (opt name arg result)
 731                    (alist-cons 'system arg result)))
 732          (option '("target") #t #f
 733                  (lambda (opt name arg result)
 734                    (alist-cons 'target arg
 735                                (alist-delete 'target result eq?))))
 736          (option '(#\d "derivations") #f #f
 737                  (lambda (opt name arg result)
 738                    (alist-cons 'derivations-only? #t result)))
 739          (option '(#\e "expression") #t #f
 740                  (lambda (opt name arg result)
 741                    (alist-cons 'expression arg result)))
 742          (option '(#\f "file") #t #f
 743                  (lambda (opt name arg result)
 744                    (alist-cons 'file arg result)))
 745          (option '(#\n "dry-run") #f #f
 746                  (lambda (opt name arg result)
 747                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 748          (option '(#\r "root") #t #f
 749                  (lambda (opt name arg result)
 750                    (alist-cons 'gc-root arg result)))
 751          (option '(#\v "verbosity") #t #f
 752                  (lambda (opt name arg result)
 753                    (let ((level (string->number* arg)))
 754                      (alist-cons 'verbosity level
 755                                  (alist-delete 'verbosity result)))))
 756          (option '(#\q "quiet") #f #f
 757                  (lambda (opt name arg result)
 758                    (alist-cons 'verbosity 0
 759                                (alist-delete 'verbosity result))))
 760          (option '("log-file") #f #f
 761                  (lambda (opt name arg result)
 762                    (alist-cons 'log-file? #t result)))
 763
 764          (append %transformation-options
 765                  %standard-build-options)))
 766
 767 (define (options->things-to-build opts)
 768   "Read the arguments from OPTS and return a list of high-level objects to
 769 build---packages, gexps, derivations, and so on."
 770   (define (validate-type x)
 771     (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x))
 772       (leave (G_ "~s: not something we can build~%") x)))
 773
 774   (define (ensure-list x)
 775     (let ((lst (match x
 776                  ((x ...) x)
 777                  (x       (list x)))))
 778       (for-each validate-type lst)
 779       lst))
 780
 781   (append-map (match-lambda
 782                 (('argument . (? string? spec))
 783                  (cond ((derivation-path? spec)
 784                         (list (read-derivation-from-file spec)))
 785                        ((store-path? spec)
 786                         ;; Nothing to do; maybe for --log-file.
 787                         '())
 788                        (else
 789                         (list (specification->package spec)))))
 790                 (('file . file)
 791                  (ensure-list (load* file (make-user-module '()))))
 792                 (('expression . str)
 793                  (ensure-list (read/eval str)))
 794                 (('argument . (? derivation? drv))
 795                  drv)
 796                 (_ '()))
 797               opts))
 798
 799 (define (options->derivations store opts)
 800   "Given OPTS, the result of 'args-fold', return a list of derivations to
 801 build."
 802   (define transform
 803     (options->transformation opts))
 804
 805   (define package->derivation
 806     (match (assoc-ref opts 'target)
 807       (#f package-derivation)
 808       (triplet
 809        (cut package-cross-derivation <> <> triplet <>))))
 810
 811   (define src    (assoc-ref opts 'source))
 812   (define graft? (assoc-ref opts 'graft?))
 813   (define systems
 814     (match (filter-map (match-lambda
 815                          (('system . system) system)
 816                          (_ #f))
 817                        opts)
 818       (()      (list (%current-system)))
 819       (systems systems)))
 820
 821   (define things-to-build
 822     (map (cut transform store <>)
 823          (options->things-to-build opts)))
 824
 825   (define (compute-derivation obj system)
 826     ;; Compute the derivation of OBJ for SYSTEM.
 827     (match obj
 828       ((? package? p)
 829        (let ((p (or (and graft? (package-replacement p)) p)))
 830          (match src
 831            (#f
 832             (list (package->derivation store p system)))
 833            (#t
 834             (match (package-source p)
 835               (#f
 836                (format (current-error-port)
 837                        (G_ "~a: warning: \
 838 package '~a' has no source~%")
 839                        (location->string (package-location p))
 840                        (package-name p))
 841                '())
 842               (s
 843                (list (package-source-derivation store s)))))
 844            (proc
 845             (map (cut package-source-derivation store <>)
 846                  (proc p))))))
 847       ((? derivation? drv)
 848        (list drv))
 849       ((? procedure? proc)
 850        (list (run-with-store store
 851                (mbegin %store-monad
 852                  (set-guile-for-build (default-guile))
 853                  (proc))
 854                #:system system)))
 855       ((? file-like? obj)
 856        (list (run-with-store store
 857                (lower-object obj system
 858                              #:target (assoc-ref opts 'target))
 859                #:system system)))
 860       ((? gexp? gexp)
 861        (list (run-with-store store
 862                (mbegin %store-monad
 863                  (set-guile-for-build (default-guile))
 864                  (gexp->derivation "gexp" gexp
 865                                    #:system system))
 866                #:system system)))))
 867
 868   ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
 869   ;; of user packages.  Since 'guix build' is the primary tool for people
 870   ;; testing new packages, report such errors gracefully.
 871   (with-unbound-variable-handling
 872    (parameterize ((%graft? graft?))
 873      (append-map (lambda (system)
 874                    (append-map (cut compute-derivation <> system)
 875                                things-to-build))
 876                  systems))))
 877
 878 (define (show-build-log store file urls)
 879   "Show the build log for FILE, falling back to remote logs from URLS if
 880 needed."
 881   (let ((log (or (log-file store file)
 882                  (log-url store file #:base-urls urls))))
 883     (if log
 884         (format #t "~a~%" log)
 885         (leave (G_ "no build log for '~a'~%") file))))
 886
 887 \f
 888 ;;;
 889 ;;; Entry point.
 890 ;;;
 891
 892 (define (guix-build . args)
 893   (define opts
 894     (parse-command-line args %options
 895                         (list %default-options)))
 896
 897   (with-error-handling
 898     ;; Ask for absolute file names so that .drv file names passed from the
 899     ;; user to 'read-derivation' are absolute when it returns.
 900     (with-fluids ((%file-port-name-canonicalization 'absolute))
 901       (with-status-verbosity (assoc-ref opts 'verbosity)
 902         (with-store store
 903           ;; Set the build options before we do anything else.
 904           (set-build-options-from-command-line store opts)
 905
 906           (parameterize ((current-terminal-columns (terminal-columns)))
 907             (let* ((mode  (assoc-ref opts 'build-mode))
 908                    (drv   (options->derivations store opts))
 909                    (urls  (map (cut string-append <> "/log")
 910                                (if (assoc-ref opts 'substitutes?)
 911                                    (or (assoc-ref opts 'substitute-urls)
 912                                        ;; XXX: This does not necessarily match the
 913                                        ;; daemon's substitute URLs.
 914                                        %default-substitute-urls)
 915                                    '())))
 916                    (items (filter-map (match-lambda
 917                                         (('argument . (? store-path? file))
 918                                          file)
 919                                         (_ #f))
 920                                       opts))
 921                    (roots (filter-map (match-lambda
 922                                         (('gc-root . root) root)
 923                                         (_ #f))
 924                                       opts)))
 925
 926               (unless (or (assoc-ref opts 'log-file?)
 927                           (assoc-ref opts 'derivations-only?))
 928                 (show-what-to-build store drv
 929                                     #:use-substitutes?
 930                                     (assoc-ref opts 'substitutes?)
 931                                     #:dry-run? (assoc-ref opts 'dry-run?)
 932                                     #:mode mode))
 933
 934               (cond ((assoc-ref opts 'log-file?)
 935                      (for-each (cut show-build-log store <> urls)
 936                                (delete-duplicates
 937                                 (append (map derivation-file-name drv)
 938                                         items))))
 939                     ((assoc-ref opts 'derivations-only?)
 940                      (format #t "~{~a~%~}" (map derivation-file-name drv))
 941                      (for-each (cut register-root store <> <>)
 942                                (map (compose list derivation-file-name) drv)
 943                                roots))
 944                     ((not (assoc-ref opts 'dry-run?))
 945                      (and (build-derivations store drv mode)
 946                           (for-each show-derivation-outputs drv)
 947                           (for-each (cut register-root store <> <>)
 948                                     (map (lambda (drv)
 949                                            (map cdr
 950                                                 (derivation->output-paths drv)))
 951                                          drv)
 952                                     roots)))))))))))