guix/scripts/build.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 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 utils)
  27   #:use-module (guix monads)
  28   #:use-module (guix gexp)
  29   #:autoload   (guix http-client) (http-fetch http-get-error?)
  30   #:use-module (ice-9 format)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 vlist)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-11)
  35   #:use-module (srfi srfi-26)
  36   #:use-module (srfi srfi-34)
  37   #:use-module (srfi srfi-37)
  38   #:autoload   (gnu packages) (specification->package %package-module-path)
  39   #:autoload   (guix download) (download-to-store)
  40   #:export (%standard-build-options
  41             set-build-options-from-command-line
  42             set-build-options-from-command-line*
  43             show-build-options-help
  44
  45             guix-build))
  46
  47 (define %default-log-urls
  48   ;; Default base URLs for build logs.
  49   '("http://hydra.gnu.org/log"))
  50
  51 ;; XXX: The following procedure cannot be in (guix store) because of the
  52 ;; dependency on (guix derivations).
  53 (define* (log-url store file #:key (base-urls %default-log-urls))
  54   "Return a URL under one of the BASE-URLS where a build log for FILE can be
  55 found.  Return #f if no build log was found."
  56   (define (valid-url? url)
  57     ;; Probe URL and return #t if it is accessible.
  58     (guard (c ((http-get-error? c) #f))
  59       (close-port (http-fetch url #:buffered? #f))
  60       #t))
  61
  62   (define (find-url file)
  63     (let ((base (basename file)))
  64       (any (lambda (base-url)
  65              (let ((url (string-append base-url "/" base)))
  66                (and (valid-url? url) url)))
  67            base-urls)))
  68
  69   (cond ((derivation-path? file)
  70          (catch 'system-error
  71            (lambda ()
  72              ;; Usually we'll have more luck with the output file name since
  73              ;; the deriver that was used by the server could be different, so
  74              ;; try one of the output file names.
  75              (let ((drv (call-with-input-file file read-derivation)))
  76                (or (find-url (derivation->output-path drv))
  77                    (find-url file))))
  78            (lambda args
  79              ;; As a last resort, try the .drv.
  80              (if (= ENOENT (system-error-errno args))
  81                  (find-url file)
  82                  (apply throw args)))))
  83         (else
  84          (find-url file))))
  85
  86 (define (register-root store paths root)
  87   "Register ROOT as an indirect GC root for all of PATHS."
  88   (let* ((root (string-append (canonicalize-path (dirname root))
  89                               "/" root)))
  90     (catch 'system-error
  91       (lambda ()
  92         (match paths
  93           ((path)
  94            (symlink path root)
  95            (add-indirect-root store root))
  96           ((paths ...)
  97            (fold (lambda (path count)
  98                    (let ((root (string-append root
  99                                               "-"
 100                                               (number->string count))))
 101                      (symlink path root)
 102                      (add-indirect-root store root))
 103                    (+ 1 count))
 104                  0
 105                  paths))))
 106       (lambda args
 107         (leave (_ "failed to create GC root `~a': ~a~%")
 108                root (strerror (system-error-errno args)))))))
 109
 110 (define (package-with-source store p uri)
 111   "Return a package based on P but with its source taken from URI.  Extract
 112 the new package's version number from URI."
 113   (define (numeric-extension? file-name)
 114     ;; Return true if FILE-NAME ends with digits.
 115     (string-every char-set:hex-digit (file-extension file-name)))
 116
 117   (define (tarball-base-name file-name)
 118     ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar
 119     ;; extensions.
 120     ;; TODO: Factorize.
 121     (cond ((not (file-extension file-name))
 122            file-name)
 123           ((numeric-extension? file-name)
 124            file-name)
 125           ((string=? (file-extension file-name) "tar")
 126            (file-sans-extension file-name))
 127           ((file-extension file-name)
 128            (tarball-base-name (file-sans-extension file-name)))
 129           (else
 130            file-name)))
 131
 132   (let ((base (tarball-base-name (basename uri))))
 133     (let-values (((name version)
 134                   (package-name->name+version base)))
 135       (package (inherit p)
 136                (version (or version (package-version p)))
 137
 138                ;; Use #:recursive? #t to allow for directories.
 139                (source (download-to-store store uri
 140                                           #:recursive? #t))))))
 141
 142 \f
 143 ;;;
 144 ;;; Standard command-line build options.
 145 ;;;
 146
 147 (define (show-build-options-help)
 148   "Display on the current output port help about the standard command-line
 149 options handled by 'set-build-options-from-command-line', and listed in
 150 '%standard-build-options'."
 151   (display (_ "
 152   -L, --load-path=DIR    prepend DIR to the package module search path"))
 153   (display (_ "
 154   -K, --keep-failed      keep build tree of failed builds"))
 155   (display (_ "
 156   -n, --dry-run          do not build the derivations"))
 157   (display (_ "
 158       --fallback         fall back to building when the substituter fails"))
 159   (display (_ "
 160       --no-substitutes   build instead of resorting to pre-built substitutes"))
 161   (display (_ "
 162       --substitute-urls=URLS
 163                          fetch substitute from URLS if they are authorized"))
 164   (display (_ "
 165       --no-build-hook    do not attempt to offload builds via the build hook"))
 166   (display (_ "
 167       --max-silent-time=SECONDS
 168                          mark the build as failed after SECONDS of silence"))
 169   (display (_ "
 170       --timeout=SECONDS  mark the build as failed after SECONDS of activity"))
 171   (display (_ "
 172       --verbosity=LEVEL  use the given verbosity LEVEL"))
 173   (display (_ "
 174   -c, --cores=N          allow the use of up to N CPU cores for the build"))
 175   (display (_ "
 176   -M, --max-jobs=N       allow at most N build jobs")))
 177
 178 (define (set-build-options-from-command-line store opts)
 179   "Given OPTS, an alist as returned by 'args-fold' given
 180 '%standard-build-options', set the corresponding build options on STORE."
 181   ;; TODO: Add more options.
 182   (set-build-options store
 183                      #:keep-failed? (assoc-ref opts 'keep-failed?)
 184                      #:build-cores (or (assoc-ref opts 'cores) 0)
 185                      #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
 186                      #:fallback? (assoc-ref opts 'fallback?)
 187                      #:use-substitutes? (assoc-ref opts 'substitutes?)
 188                      #:substitute-urls (assoc-ref opts 'substitute-urls)
 189                      #:use-build-hook? (assoc-ref opts 'build-hook?)
 190                      #:max-silent-time (assoc-ref opts 'max-silent-time)
 191                      #:timeout (assoc-ref opts 'timeout)
 192                      #:print-build-trace (assoc-ref opts 'print-build-trace?)
 193                      #:verbosity (assoc-ref opts 'verbosity)))
 194
 195 (define set-build-options-from-command-line*
 196   (store-lift set-build-options-from-command-line))
 197
 198 (define %standard-build-options
 199   ;; List of standard command-line options for tools that build something.
 200   (list (option '(#\L "load-path") #t #f
 201                 (lambda (opt name arg result . rest)
 202                   ;; XXX: Imperatively modify the search paths.
 203                   (%package-module-path (cons arg (%package-module-path)))
 204                   (set! %load-path (cons arg %load-path))
 205                   (set! %load-compiled-path (cons arg %load-compiled-path))
 206
 207                   (apply values (cons result rest))))
 208         (option '(#\K "keep-failed") #f #f
 209                 (lambda (opt name arg result . rest)
 210                   (apply values
 211                          (alist-cons 'keep-failed? #t result)
 212                          rest)))
 213         (option '("fallback") #f #f
 214                 (lambda (opt name arg result . rest)
 215                   (apply values
 216                          (alist-cons 'fallback? #t
 217                                      (alist-delete 'fallback? result))
 218                          rest)))
 219         (option '("no-substitutes") #f #f
 220                 (lambda (opt name arg result . rest)
 221                   (apply values
 222                          (alist-cons 'substitutes? #f
 223                                      (alist-delete 'substitutes? result))
 224                          rest)))
 225         (option '("substitute-urls") #t #f
 226                 (lambda (opt name arg result . rest)
 227                   (apply values
 228                          (alist-cons 'substitute-urls
 229                                      (string-tokenize arg)
 230                                      (alist-delete 'substitute-urls result))
 231                          rest)))
 232         (option '("no-build-hook") #f #f
 233                 (lambda (opt name arg result . rest)
 234                   (apply values
 235                          (alist-cons 'build-hook? #f
 236                                      (alist-delete 'build-hook? result))
 237                          rest)))
 238         (option '("max-silent-time") #t #f
 239                 (lambda (opt name arg result . rest)
 240                   (apply values
 241                          (alist-cons 'max-silent-time (string->number* arg)
 242                                      result)
 243                          rest)))
 244         (option '("timeout") #t #f
 245                 (lambda (opt name arg result . rest)
 246                   (apply values
 247                          (alist-cons 'timeout (string->number* arg) result)
 248                          rest)))
 249         (option '("verbosity") #t #f
 250                 (lambda (opt name arg result . rest)
 251                   (let ((level (string->number arg)))
 252                     (apply values
 253                            (alist-cons 'verbosity level
 254                                        (alist-delete 'verbosity result))
 255                            rest))))
 256         (option '(#\c "cores") #t #f
 257                 (lambda (opt name arg result . rest)
 258                   (let ((c (false-if-exception (string->number arg))))
 259                     (if c
 260                         (apply values (alist-cons 'cores c result) rest)
 261                         (leave (_ "not a number: '~a' option argument: ~a~%")
 262                                name arg)))))
 263         (option '(#\M "max-jobs") #t #f
 264                 (lambda (opt name arg result . rest)
 265                   (let ((c (false-if-exception (string->number arg))))
 266                     (if c
 267                         (apply values (alist-cons 'max-jobs c result) rest)
 268                         (leave (_ "not a number: '~a' option argument: ~a~%")
 269                                name arg)))))))
 270
 271 \f
 272 ;;;
 273 ;;; Command-line options.
 274 ;;;
 275
 276 (define %default-options
 277   ;; Alist of default option values.
 278   `((system . ,(%current-system))
 279     (graft? . #t)
 280     (substitutes? . #t)
 281     (build-hook? . #t)
 282     (print-build-trace? . #t)
 283     (max-silent-time . 3600)
 284     (verbosity . 0)))
 285
 286 (define (show-help)
 287   (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION...
 288 Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
 289   (display (_ "
 290   -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
 291   (display (_ "
 292   -f, --file=FILE        build the package or derivation that the code within
 293                          FILE evaluates to"))
 294   (display (_ "
 295   -S, --source           build the packages' source derivations"))
 296   (display (_ "
 297       --sources[=TYPE]   build source derivations; TYPE may optionally be one
 298                          of \"package\", \"all\" (default), or \"transitive\""))
 299   (display (_ "
 300   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
 301   (display (_ "
 302       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
 303   (display (_ "
 304       --with-source=SOURCE
 305                          use SOURCE when building the corresponding package"))
 306   (display (_ "
 307       --no-grafts        do not graft packages"))
 308   (display (_ "
 309   -d, --derivations      return the derivation paths of the given packages"))
 310   (display (_ "
 311   -r, --root=FILE        make FILE a symlink to the result, and register it
 312                          as a garbage collector root"))
 313   (display (_ "
 314       --log-file         return the log file names for the given derivations"))
 315   (newline)
 316   (show-build-options-help)
 317   (newline)
 318   (display (_ "
 319   -h, --help             display this help and exit"))
 320   (display (_ "
 321   -V, --version          display version information and exit"))
 322   (newline)
 323   (show-bug-report-information))
 324
 325 (define %options
 326   ;; Specifications of the command-line options.
 327   (cons* (option '(#\h "help") #f #f
 328                  (lambda args
 329                    (show-help)
 330                    (exit 0)))
 331          (option '(#\V "version") #f #f
 332                  (lambda args
 333                    (show-version-and-exit "guix build")))
 334          (option '(#\S "source") #f #f
 335                  (lambda (opt name arg result)
 336                    (alist-cons 'source #t result)))
 337          (option '("sources") #f #t
 338                  (lambda (opt name arg result)
 339                    (match arg
 340                      ("package"
 341                       (alist-cons 'source #t result))
 342                      ((or "all" #f)
 343                       (alist-cons 'source package-direct-sources result))
 344                      ("transitive"
 345                       (alist-cons 'source package-transitive-sources result))
 346                      (else
 347                       (leave (_ "invalid argument: '~a' option argument: ~a, ~
 348 must be one of 'package', 'all', or 'transitive'~%")
 349                              name arg)))))
 350          (option '(#\s "system") #t #f
 351                  (lambda (opt name arg result)
 352                    (alist-cons 'system arg
 353                                (alist-delete 'system result eq?))))
 354          (option '("target") #t #f
 355                  (lambda (opt name arg result)
 356                    (alist-cons 'target arg
 357                                (alist-delete 'target result eq?))))
 358          (option '(#\d "derivations") #f #f
 359                  (lambda (opt name arg result)
 360                    (alist-cons 'derivations-only? #t result)))
 361          (option '(#\e "expression") #t #f
 362                  (lambda (opt name arg result)
 363                    (alist-cons 'expression arg result)))
 364          (option '(#\f "file") #t #f
 365                  (lambda (opt name arg result)
 366                    (alist-cons 'file arg result)))
 367          (option '(#\n "dry-run") #f #f
 368                  (lambda (opt name arg result)
 369                    (alist-cons 'dry-run? #t result)))
 370          (option '(#\r "root") #t #f
 371                  (lambda (opt name arg result)
 372                    (alist-cons 'gc-root arg result)))
 373          (option '("log-file") #f #f
 374                  (lambda (opt name arg result)
 375                    (alist-cons 'log-file? #t result)))
 376          (option '("with-source") #t #f
 377                  (lambda (opt name arg result)
 378                    (alist-cons 'with-source arg result)))
 379          (option '("no-grafts") #f #f
 380                  (lambda (opt name arg result)
 381                    (alist-cons 'graft? #f
 382                                (alist-delete 'graft? result eq?))))
 383
 384          %standard-build-options))
 385
 386 (define (options->derivations store opts)
 387   "Given OPTS, the result of 'args-fold', return a list of derivations to
 388 build."
 389   (define package->derivation
 390     (match (assoc-ref opts 'target)
 391       (#f package-derivation)
 392       (triplet
 393        (cut package-cross-derivation <> <> triplet <>))))
 394
 395   (define src    (assoc-ref opts 'source))
 396   (define sys    (assoc-ref opts 'system))
 397   (define graft? (assoc-ref opts 'graft?))
 398
 399   (parameterize ((%graft? graft?))
 400     (let ((opts (options/with-source store
 401                                      (options/resolve-packages store opts))))
 402       (concatenate
 403        (filter-map (match-lambda
 404                     (('argument . (? package? p))
 405                      (match src
 406                        (#f
 407                         (list (package->derivation store p sys)))
 408                        (#t
 409                         (let ((s (package-source p)))
 410                           (list (package-source-derivation store s))))
 411                        (proc
 412                         (map (cut package-source-derivation store <>)
 413                              (proc p)))))
 414                     (('argument . (? derivation? drv))
 415                      (list drv))
 416                     (('argument . (? derivation-path? drv))
 417                      (list (call-with-input-file drv read-derivation)))
 418                     (('argument . (? store-path?))
 419                      ;; Nothing to do; maybe for --log-file.
 420                      #f)
 421                     (_ #f))
 422                    opts)))))
 423
 424 (define (options/resolve-packages store opts)
 425   "Return OPTS with package specification strings replaced by actual
 426 packages."
 427   (define system
 428     (or (assoc-ref opts 'system) (%current-system)))
 429
 430   (define (object->argument obj)
 431     (match obj
 432       ((? package? p)
 433        `(argument . ,p))
 434       ((? procedure? proc)
 435        (let ((drv (run-with-store store
 436                     (mbegin %store-monad
 437                       (set-guile-for-build (default-guile))
 438                       (proc))
 439                     #:system system)))
 440          `(argument . ,drv)))
 441       ((? gexp? gexp)
 442        (let ((drv (run-with-store store
 443                     (mbegin %store-monad
 444                       (set-guile-for-build (default-guile))
 445                       (gexp->derivation "gexp" gexp
 446                                         #:system system)))))
 447          `(argument . ,drv)))))
 448
 449   (map (match-lambda
 450         (('argument . (? string? spec))
 451          (if (store-path? spec)
 452              `(argument . ,spec)
 453              `(argument . ,(specification->package spec))))
 454         (('file . file)
 455          (object->argument (load* file (make-user-module '()))))
 456         (('expression . str)
 457          (object->argument (read/eval str)))
 458         (opt opt))
 459        opts))
 460
 461 (define (options/with-source store opts)
 462   "Process with 'with-source' options in OPTS, replacing the relevant package
 463 arguments with packages that use the specified source."
 464   (define new-sources
 465     (filter-map (match-lambda
 466                  (('with-source . uri)
 467                   (cons (package-name->name+version (basename uri))
 468                         uri))
 469                  (_ #f))
 470                 opts))
 471
 472   (let loop ((opts    opts)
 473              (sources new-sources)
 474              (result  '()))
 475     (match opts
 476       (()
 477        (unless (null? sources)
 478          (warning (_ "sources do not match any package:~{ ~a~}~%")
 479                   (match sources
 480                     (((name . uri) ...)
 481                      uri))))
 482        (reverse result))
 483       ((('argument . (? package? p)) tail ...)
 484        (let ((source (assoc-ref sources (package-name p))))
 485          (loop tail
 486                (alist-delete (package-name p) sources)
 487                (alist-cons 'argument
 488                            (if source
 489                                (package-with-source store p source)
 490                                p)
 491                            result))))
 492       ((('with-source . _) tail ...)
 493        (loop tail sources result))
 494       ((head tail ...)
 495        (loop tail sources (cons head result))))))
 496
 497 \f
 498 ;;;
 499 ;;; Entry point.
 500 ;;;
 501
 502 (define (guix-build . args)
 503   (with-error-handling
 504     ;; Ask for absolute file names so that .drv file names passed from the
 505     ;; user to 'read-derivation' are absolute when it returns.
 506     (with-fluids ((%file-port-name-canonicalization 'absolute))
 507       (let* ((opts  (parse-command-line args %options
 508                                         (list %default-options)))
 509              (store (open-connection))
 510              (drv   (options->derivations store opts))
 511              (urls  (map (cut string-append <> "/log")
 512                          (if (assoc-ref opts 'substitutes?)
 513                              (or (assoc-ref opts 'substitute-urls)
 514                                  ;; XXX: This does not necessarily match the
 515                                  ;; daemon's substitute URLs.
 516                                  %default-substitute-urls)
 517                              '())))
 518              (roots (filter-map (match-lambda
 519                                  (('gc-root . root) root)
 520                                  (_ #f))
 521                                 opts)))
 522
 523         (set-build-options-from-command-line store opts)
 524         (unless (assoc-ref opts 'log-file?)
 525           (show-what-to-build store drv
 526                               #:use-substitutes? (assoc-ref opts 'substitutes?)
 527                               #:dry-run? (assoc-ref opts 'dry-run?)))
 528
 529         (cond ((assoc-ref opts 'log-file?)
 530                (for-each (lambda (file)
 531                            (let ((log (or (log-file store file)
 532                                           (log-url store file
 533                                                    #:base-urls urls))))
 534                              (if log
 535                                  (format #t "~a~%" log)
 536                                  (leave (_ "no build log for '~a'~%")
 537                                         file))))
 538                          (delete-duplicates
 539                           (append (map derivation-file-name drv)
 540                                   (filter-map (match-lambda
 541                                                (('argument
 542                                                  . (? store-path? file))
 543                                                 file)
 544                                                (_ #f))
 545                                               opts)))))
 546               ((assoc-ref opts 'derivations-only?)
 547                (format #t "~{~a~%~}" (map derivation-file-name drv))
 548                (for-each (cut register-root store <> <>)
 549                          (map (compose list derivation-file-name) drv)
 550                          roots))
 551               ((not (assoc-ref opts 'dry-run?))
 552                (and (build-derivations store drv)
 553                     (for-each show-derivation-outputs drv)
 554                     (for-each (cut register-root store <> <>)
 555                               (map (lambda (drv)
 556                                      (map cdr
 557                                           (derivation->output-paths drv)))
 558                                    drv)
 559                               roots))))))))