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