guix-build.in

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3
   4 prefix="@prefix@"
   5 datarootdir="@datarootdir@"
   6
   7 GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
   8 export GUILE_LOAD_COMPILED_PATH
   9
  10 main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
  11 exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
  12          -c "(apply $main (cdr (command-line)))" "$@"
  13 !#
  14 ;;; GNU Guix --- Functional package management for GNU
  15 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
  16 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
  17 ;;;
  18 ;;; This file is part of GNU Guix.
  19 ;;;
  20 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  21 ;;; under the terms of the GNU General Public License as published by
  22 ;;; the Free Software Foundation; either version 3 of the License, or (at
  23 ;;; your option) any later version.
  24 ;;;
  25 ;;; GNU Guix is distributed in the hope that it will be useful, but
  26 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  27 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  28 ;;; GNU General Public License for more details.
  29 ;;;
  30 ;;; You should have received a copy of the GNU General Public License
  31 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  32
  33 (define-module (guix-build)
  34   #:use-module (guix ui)
  35   #:use-module (guix store)
  36   #:use-module (guix derivations)
  37   #:use-module (guix packages)
  38   #:use-module (guix utils)
  39   #:use-module (ice-9 format)
  40   #:use-module (ice-9 match)
  41   #:use-module (ice-9 vlist)
  42   #:use-module (srfi srfi-1)
  43   #:use-module (srfi srfi-11)
  44   #:use-module (srfi srfi-26)
  45   #:use-module (srfi srfi-34)
  46   #:use-module (srfi srfi-37)
  47   #:autoload   (gnu packages) (find-packages-by-name
  48                                find-newest-available-packages)
  49   #:export (guix-build))
  50
  51 (define %store
  52   (make-parameter #f))
  53
  54 (define (derivations-from-package-expressions exp system source?)
  55   "Eval EXP and return the corresponding derivation path for SYSTEM.
  56 When SOURCE? is true, return the derivations of the package sources."
  57   (let ((p (eval exp (current-module))))
  58     (if (package? p)
  59         (if source?
  60             (let ((source (package-source p))
  61                   (loc    (package-location p)))
  62               (if source
  63                   (package-source-derivation (%store) source)
  64                   (leave (_ "~a: error: package `~a' has no source~%")
  65                          (location->string loc) (package-name p))))
  66             (package-derivation (%store) p system))
  67         (leave (_ "expression `~s' does not evaluate to a package~%")
  68                exp))))
  69
  70 \f
  71 ;;;
  72 ;;; Command-line options.
  73 ;;;
  74
  75 (define %default-options
  76   ;; Alist of default option values.
  77   `((system . ,(%current-system))
  78     (substitutes? . #t)
  79     (verbosity . 0)))
  80
  81 (define (show-help)
  82   (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION...
  83 Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
  84   (display (_ "
  85   -e, --expression=EXPR  build the package EXPR evaluates to"))
  86   (display (_ "
  87   -S, --source           build the packages' source derivations"))
  88   (display (_ "
  89   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  90   (display (_ "
  91   -d, --derivations      return the derivation paths of the given packages"))
  92   (display (_ "
  93   -K, --keep-failed      keep build tree of failed builds"))
  94   (display (_ "
  95   -n, --dry-run          do not build the derivations"))
  96   (display (_ "
  97       --no-substitutes   build instead of resorting to pre-built substitutes"))
  98   (display (_ "
  99   -c, --cores=N          allow the use of up to N CPU cores for the build"))
 100   (display (_ "
 101   -r, --root=FILE        make FILE a symlink to the result, and register it
 102                          as a garbage collector root"))
 103   (display (_ "
 104       --verbosity=LEVEL  use the given verbosity LEVEL"))
 105   (newline)
 106   (display (_ "
 107   -h, --help             display this help and exit"))
 108   (display (_ "
 109   -V, --version          display version information and exit"))
 110   (newline)
 111   (show-bug-report-information))
 112
 113 (define %options
 114   ;; Specifications of the command-line options.
 115   (list (option '(#\h "help") #f #f
 116                 (lambda args
 117                   (show-help)
 118                   (exit 0)))
 119         (option '(#\V "version") #f #f
 120                 (lambda args
 121                   (show-version-and-exit "guix-build")))
 122
 123         (option '(#\S "source") #f #f
 124                 (lambda (opt name arg result)
 125                   (alist-cons 'source? #t result)))
 126         (option '(#\s "system") #t #f
 127                 (lambda (opt name arg result)
 128                   (alist-cons 'system arg
 129                               (alist-delete 'system result eq?))))
 130         (option '(#\d "derivations") #f #f
 131                 (lambda (opt name arg result)
 132                   (alist-cons 'derivations-only? #t result)))
 133         (option '(#\e "expression") #t #f
 134                 (lambda (opt name arg result)
 135                   (alist-cons 'expression
 136                               (call-with-input-string arg read)
 137                               result)))
 138         (option '(#\K "keep-failed") #f #f
 139                 (lambda (opt name arg result)
 140                   (alist-cons 'keep-failed? #t result)))
 141         (option '(#\c "cores") #t #f
 142                 (lambda (opt name arg result)
 143                   (let ((c (false-if-exception (string->number arg))))
 144                     (if c
 145                         (alist-cons 'cores c result)
 146                         (leave (_ "~a: not a number~%") arg)))))
 147         (option '(#\n "dry-run") #f #f
 148                 (lambda (opt name arg result)
 149                   (alist-cons 'dry-run? #t result)))
 150         (option '("no-substitutes") #f #f
 151                 (lambda (opt name arg result)
 152                   (alist-cons 'substitutes? #f
 153                               (alist-delete 'substitutes? result))))
 154         (option '(#\r "root") #t #f
 155                 (lambda (opt name arg result)
 156                   (alist-cons 'gc-root arg result)))
 157         (option '("verbosity") #t #f
 158                 (lambda (opt name arg result)
 159                   (let ((level (string->number arg)))
 160                     (alist-cons 'verbosity level
 161                                 (alist-delete 'verbosity result)))))))
 162
 163 \f
 164 ;;;
 165 ;;; Entry point.
 166 ;;;
 167
 168 (define (guix-build . args)
 169   (define (parse-options)
 170     ;; Return the alist of option values.
 171     (args-fold args %options
 172                (lambda (opt name arg result)
 173                  (leave (_ "~A: unrecognized option~%") name))
 174                (lambda (arg result)
 175                  (alist-cons 'argument arg result))
 176                %default-options))
 177
 178   (define (register-root paths root)
 179     ;; Register ROOT as an indirect GC root for all of PATHS.
 180     (let* ((root (string-append (canonicalize-path (dirname root))
 181                                 "/" root)))
 182      (catch 'system-error
 183        (lambda ()
 184          (match paths
 185            ((path)
 186             (symlink path root)
 187             (add-indirect-root (%store) root))
 188            ((paths ...)
 189             (fold (lambda (path count)
 190                     (let ((root (string-append root "-" (number->string count))))
 191                       (symlink path root)
 192                       (add-indirect-root (%store) root))
 193                     (+ 1 count))
 194                   0
 195                   paths))))
 196        (lambda args
 197          (format (current-error-port)
 198                  (_ "failed to create GC root `~a': ~a~%")
 199                  root (strerror (system-error-errno args)))
 200          (exit 1)))))
 201
 202   (define newest-available-packages
 203     (memoize find-newest-available-packages))
 204
 205   (define (find-best-packages-by-name name version)
 206     (if version
 207         (find-packages-by-name name version)
 208         (match (vhash-assoc name (newest-available-packages))
 209           ((_ version pkgs ...) pkgs)
 210           (#f '()))))
 211
 212   (define (find-package request)
 213     ;; Return a package matching REQUEST.  REQUEST may be a package
 214     ;; name, or a package name followed by a hyphen and a version
 215     ;; number.  If the version number is not present, return the
 216     ;; preferred newest version.
 217     (let-values (((name version)
 218                   (package-name->name+version request)))
 219       (match (find-best-packages-by-name name version)
 220         ((p)                                      ; one match
 221          p)
 222         ((p x ...)                                ; several matches
 223          (format (current-error-port)
 224                  (_ "warning: ambiguous package specification `~a'~%")
 225                  request)
 226          (format (current-error-port)
 227                  (_ "warning: choosing ~a from ~a~%")
 228                  (package-full-name p)
 229                  (location->string (package-location p)))
 230          p)
 231         (_                                        ; no matches
 232          (if version
 233              (leave (_ "~A: package not found for version ~a~%")
 234                     name version)
 235              (leave (_ "~A: unknown package~%") name))))))
 236
 237   (install-locale)
 238   (textdomain "guix")
 239   (setvbuf (current-output-port) _IOLBF)
 240   (setvbuf (current-error-port) _IOLBF)
 241
 242   (with-error-handling
 243     (let ((opts (parse-options)))
 244       (parameterize ((%store (open-connection)))
 245         (let* ((src? (assoc-ref opts 'source?))
 246                (sys  (assoc-ref opts 'system))
 247                (drv  (filter-map (match-lambda
 248                                   (('expression . exp)
 249                                    (derivations-from-package-expressions exp sys
 250                                                                          src?))
 251                                   (('argument . (? derivation-path? drv))
 252                                    drv)
 253                                   (('argument . (? string? x))
 254                                    (let ((p (find-package x)))
 255                                      (if src?
 256                                          (let ((s (package-source p)))
 257                                            (package-source-derivation
 258                                             (%store) s))
 259                                          (package-derivation (%store) p sys))))
 260                                   (_ #f))
 261                                  opts))
 262                (req  (append-map (lambda (drv-path)
 263                                    (let ((d (call-with-input-file drv-path
 264                                               read-derivation)))
 265                                      (derivation-prerequisites-to-build (%store) d)))
 266                                  drv))
 267                (req* (delete-duplicates
 268                       (append (remove (compose (cut valid-path? (%store) <>)
 269                                                derivation-path->output-path)
 270                                       drv)
 271                               (map derivation-input-path req))))
 272                (roots (filter-map (match-lambda
 273                                    (('gc-root . root) root)
 274                                    (_ #f))
 275                                   opts)))
 276           (if (assoc-ref opts 'dry-run?)
 277               (format (current-error-port)
 278                       (N_ "~:[the following derivation would be built:~%~{   ~a~%~}~;~]"
 279                           "~:[the following derivations would be built:~%~{    ~a~%~}~;~]"
 280                           (length req*))
 281                       (null? req*) req*)
 282               (format (current-error-port)
 283                       (N_ "~:[the following derivation will be built:~%~{   ~a~%~}~;~]"
 284                           "~:[the following derivations will be built:~%~{    ~a~%~}~;~]"
 285                           (length req*))
 286                       (null? req*) req*))
 287
 288           ;; TODO: Add more options.
 289           (set-build-options (%store)
 290                              #:keep-failed? (assoc-ref opts 'keep-failed?)
 291                              #:build-cores (or (assoc-ref opts 'cores) 0)
 292                              #:use-substitutes? (assoc-ref opts 'substitutes?)
 293                              #:verbosity (assoc-ref opts 'verbosity))
 294
 295           (if (assoc-ref opts 'derivations-only?)
 296               (begin
 297                 (format #t "~{~a~%~}" drv)
 298                 (for-each (cut register-root <> <>)
 299                           (map list drv) roots))
 300               (or (assoc-ref opts 'dry-run?)
 301                   (and (build-derivations (%store) drv)
 302                        (for-each (lambda (d)
 303                                    (let ((drv (call-with-input-file d
 304                                                 read-derivation)))
 305                                      (format #t "~{~a~%~}"
 306                                              (map (match-lambda
 307                                                    ((out-name . out)
 308                                                     (derivation-path->output-path
 309                                                      d out-name)))
 310                                                   (derivation-outputs drv)))))
 311                                  drv)
 312                        (for-each (cut register-root <> <>)
 313                                  (map (lambda (drv)
 314                                         (map cdr
 315                                              (derivation-path->output-paths drv)))
 316                                       drv)
 317                                  roots)))))))))