| 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 | ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- |
| 15 | ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> |
| 16 | ;;; |
| 17 | ;;; This file is part of Guix. |
| 18 | ;;; |
| 19 | ;;; 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 | ;;; 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 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 | (format #t (_ " |
| 108 | Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@")) |
| 109 | |
| 110 | (define %options |
| 111 | ;; Specifications of the command-line options. |
| 112 | (list (option '(#\h "help") #f #f |
| 113 | (lambda args |
| 114 | (show-help) |
| 115 | (exit 0))) |
| 116 | (option '(#\V "version") #f #f |
| 117 | (lambda args |
| 118 | (show-version-and-exit "guix-build"))) |
| 119 | |
| 120 | (option '(#\S "source") #f #f |
| 121 | (lambda (opt name arg result) |
| 122 | (alist-cons 'source? #t result))) |
| 123 | (option '(#\s "system") #t #f |
| 124 | (lambda (opt name arg result) |
| 125 | (alist-cons 'system arg |
| 126 | (alist-delete 'system result eq?)))) |
| 127 | (option '(#\d "derivations") #f #f |
| 128 | (lambda (opt name arg result) |
| 129 | (alist-cons 'derivations-only? #t result))) |
| 130 | (option '(#\e "expression") #t #f |
| 131 | (lambda (opt name arg result) |
| 132 | (alist-cons 'expression |
| 133 | (call-with-input-string arg read) |
| 134 | result))) |
| 135 | (option '(#\K "keep-failed") #f #f |
| 136 | (lambda (opt name arg result) |
| 137 | (alist-cons 'keep-failed? #t result))) |
| 138 | (option '(#\c "cores") #t #f |
| 139 | (lambda (opt name arg result) |
| 140 | (let ((c (false-if-exception (string->number arg)))) |
| 141 | (if c |
| 142 | (alist-cons 'cores c result) |
| 143 | (leave (_ "~a: not a number~%") arg))))) |
| 144 | (option '(#\n "dry-run") #f #f |
| 145 | (lambda (opt name arg result) |
| 146 | (alist-cons 'dry-run? #t result))) |
| 147 | (option '("no-substitutes") #f #f |
| 148 | (lambda (opt name arg result) |
| 149 | (alist-cons 'substitutes? #f |
| 150 | (alist-delete 'substitutes? result)))) |
| 151 | (option '(#\r "root") #t #f |
| 152 | (lambda (opt name arg result) |
| 153 | (alist-cons 'gc-root arg result))) |
| 154 | (option '("verbosity") #t #f |
| 155 | (lambda (opt name arg result) |
| 156 | (let ((level (string->number arg))) |
| 157 | (alist-cons 'verbosity level |
| 158 | (alist-delete 'verbosity result))))))) |
| 159 | |
| 160 | \f |
| 161 | ;;; |
| 162 | ;;; Entry point. |
| 163 | ;;; |
| 164 | |
| 165 | (define (guix-build . args) |
| 166 | (define (parse-options) |
| 167 | ;; Return the alist of option values. |
| 168 | (args-fold args %options |
| 169 | (lambda (opt name arg result) |
| 170 | (leave (_ "~A: unrecognized option~%") name)) |
| 171 | (lambda (arg result) |
| 172 | (alist-cons 'argument arg result)) |
| 173 | %default-options)) |
| 174 | |
| 175 | (define (register-root drv root) |
| 176 | ;; Register ROOT as an indirect GC root for DRV's outputs. |
| 177 | (let* ((root (string-append (canonicalize-path (dirname root)) |
| 178 | "/" root)) |
| 179 | (drv* (call-with-input-file drv read-derivation)) |
| 180 | (outputs (derivation-outputs drv*)) |
| 181 | (outputs* (map (compose derivation-output-path cdr) outputs))) |
| 182 | (catch 'system-error |
| 183 | (lambda () |
| 184 | (match outputs* |
| 185 | ((output) |
| 186 | (symlink output root) |
| 187 | (add-indirect-root (%store) root)) |
| 188 | ((outputs ...) |
| 189 | (fold (lambda (output count) |
| 190 | (let ((root (string-append root "-" (number->string count)))) |
| 191 | (symlink output root) |
| 192 | (add-indirect-root (%store) root)) |
| 193 | (+ 1 count)) |
| 194 | 0 |
| 195 | outputs)))) |
| 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 | (setlocale LC_ALL "") |
| 203 | (textdomain "guix") |
| 204 | (setvbuf (current-output-port) _IOLBF) |
| 205 | (setvbuf (current-error-port) _IOLBF) |
| 206 | |
| 207 | (with-error-handling |
| 208 | (let ((opts (parse-options))) |
| 209 | (parameterize ((%store (open-connection))) |
| 210 | (let* ((src? (assoc-ref opts 'source?)) |
| 211 | (sys (assoc-ref opts 'system)) |
| 212 | (drv (filter-map (match-lambda |
| 213 | (('expression . exp) |
| 214 | (derivations-from-package-expressions exp sys |
| 215 | src?)) |
| 216 | (('argument . (? derivation-path? drv)) |
| 217 | drv) |
| 218 | (('argument . (? string? x)) |
| 219 | (match (find-packages-by-name x) |
| 220 | ((p _ ...) |
| 221 | (if src? |
| 222 | (let ((s (package-source p))) |
| 223 | (package-source-derivation (%store) s)) |
| 224 | (package-derivation (%store) p sys))) |
| 225 | (_ |
| 226 | (leave (_ "~A: unknown package~%") x)))) |
| 227 | (_ #f)) |
| 228 | opts)) |
| 229 | (req (append-map (lambda (drv-path) |
| 230 | (let ((d (call-with-input-file drv-path |
| 231 | read-derivation))) |
| 232 | (derivation-prerequisites-to-build (%store) d))) |
| 233 | drv)) |
| 234 | (req* (delete-duplicates |
| 235 | (append (remove (compose (cut valid-path? (%store) <>) |
| 236 | derivation-path->output-path) |
| 237 | drv) |
| 238 | (map derivation-input-path req))))) |
| 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 | (format #t "~{~a~%~}" drv) |
| 260 | (or (assoc-ref opts 'dry-run?) |
| 261 | (and (build-derivations (%store) drv) |
| 262 | (for-each (lambda (d) |
| 263 | (let ((drv (call-with-input-file d |
| 264 | read-derivation))) |
| 265 | (format #t "~{~a~%~}" |
| 266 | (map (match-lambda |
| 267 | ((out-name . out) |
| 268 | (derivation-path->output-path |
| 269 | d out-name))) |
| 270 | (derivation-outputs drv))))) |
| 271 | drv) |
| 272 | (let ((roots (filter-map (match-lambda |
| 273 | (('gc-root . root) |
| 274 | root) |
| 275 | (_ #f)) |
| 276 | opts))) |
| 277 | (when roots |
| 278 | (for-each (cut register-root <> <>) |
| 279 | drv roots) |
| 280 | #t)))))))))) |
| 281 | |
| 282 | ;; Local Variables: |
| 283 | ;; eval: (put 'guard 'scheme-indent-function 1) |
| 284 | ;; End: |