[jackhill/guix/guix.git] / guix-build.in

#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code

prefix="@prefix@"
datarootdir="@datarootdir@"

GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
export GUILE_LOAD_COMPILED_PATH

main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
         -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Guix.
;;;
;;; Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix-build)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:autoload   (distro) (find-packages-by-name)
  #:export (guix-build))

(define %store
  (make-parameter #f))

(define (derivations-from-package-expressions exp system source?)
  "Eval EXP and return the corresponding derivation path for SYSTEM.
When SOURCE? is true, return the derivations of the package sources."
  (let ((p (eval exp (current-module))))
    (if (package? p)
        (if source?
            (let ((source (package-source p))
                  (loc    (package-location p)))
              (if source
                  (package-source-derivation (%store) source)
                  (leave (_ "~a: error: package `~a' has no source~%")
                         (location->string loc) (package-name p))))
            (package-derivation (%store) p system))
        (leave (_ "expression `~s' does not evaluate to a package~%")
               exp))))

\f
;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  `((system . ,(%current-system))
    (substitutes? . #t)
    (verbosity . 0)))

(define (show-help)
  (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION...
Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
  (display (_ "
  -e, --expression=EXPR  build the package EXPR evaluates to"))
  (display (_ "
  -S, --source           build the packages' source derivations"))
  (display (_ "
  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  (display (_ "
  -d, --derivations      return the derivation paths of the given packages"))
  (display (_ "
  -K, --keep-failed      keep build tree of failed builds"))
  (display (_ "
  -n, --dry-run          do not build the derivations"))
  (display (_ "
      --no-substitutes   build instead of resorting to pre-built substitutes"))
  (display (_ "
  -c, --cores=N          allow the use of up to N CPU cores for the build"))
  (display (_ "
  -r, --root=FILE        make FILE a symlink to the result, and register it
                         as a garbage collector root"))
  (display (_ "
      --verbosity=LEVEL  use the given verbosity LEVEL"))
  (newline)
  (display (_ "
  -h, --help             display this help and exit"))
  (display (_ "
  -V, --version          display version information and exit"))
  (newline)
  (format #t (_ "
Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix-build")))

        (option '(#\S "source") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'source? #t result)))
        (option '(#\s "system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'system arg
                              (alist-delete 'system result eq?))))
        (option '(#\d "derivations") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'derivations-only? #t result)))
        (option '(#\e "expression") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'expression
                              (call-with-input-string arg read)
                              result)))
        (option '(#\K "keep-failed") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'keep-failed? #t result)))
        (option '(#\c "cores") #t #f
                (lambda (opt name arg result)
                  (let ((c (false-if-exception (string->number arg))))
                    (if c
                        (alist-cons 'cores c result)
                        (leave (_ "~a: not a number~%") arg)))))
        (option '(#\n "dry-run") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'dry-run? #t result)))
        (option '("no-substitutes") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'substitutes? #f
                              (alist-delete 'substitutes? result))))
        (option '(#\r "root") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'gc-root arg result)))
        (option '("verbosity") #t #f
                (lambda (opt name arg result)
                  (let ((level (string->number arg)))
                    (alist-cons 'verbosity level
                                (alist-delete 'verbosity result)))))))

\f
;;;
;;; Entry point.
;;;

(define (guix-build . args)
  (define (parse-options)
    ;; Return the alist of option values.
    (args-fold args %options
               (lambda (opt name arg result)
                 (leave (_ "~A: unrecognized option~%") name))
               (lambda (arg result)
                 (alist-cons 'argument arg result))
               %default-options))

  (define (register-root drv root)
    ;; Register ROOT as an indirect GC root for DRV's outputs.
    (let* ((root     (string-append (canonicalize-path (dirname root))
                                    "/" root))
           (drv*     (call-with-input-file drv read-derivation))
           (outputs  (derivation-outputs drv*))
           (outputs* (map (compose derivation-output-path cdr) outputs)))
     (catch 'system-error
       (lambda ()
         (match outputs*
           ((output)
            (symlink output root)
            (add-indirect-root (%store) root))
           ((outputs ...)
            (fold (lambda (output count)
                    (let ((root (string-append root "-" (number->string count))))
                      (symlink output root)
                      (add-indirect-root (%store) root))
                    (+ 1 count))
                  0
                  outputs))))
       (lambda args
         (format (current-error-port)
                 (_ "failed to create GC root `~a': ~a~%")
                 root (strerror (system-error-errno args)))
         (exit 1)))))

  (setlocale LC_ALL "")
  (textdomain "guix")
  (setvbuf (current-output-port) _IOLBF)
  (setvbuf (current-error-port) _IOLBF)

  (with-error-handling
    (let ((opts (parse-options)))
      (parameterize ((%store (open-connection)))
        (let* ((src? (assoc-ref opts 'source?))
               (sys  (assoc-ref opts 'system))
               (drv  (filter-map (match-lambda
                                  (('expression . exp)
                                   (derivations-from-package-expressions exp sys
                                                                         src?))
                                  (('argument . (? derivation-path? drv))
                                   drv)
                                  (('argument . (? string? x))
                                   (match (find-packages-by-name x)
                                     ((p _ ...)
                                      (if src?
                                          (let ((s (package-source p)))
                                            (package-source-derivation (%store) s))
                                          (package-derivation (%store) p sys)))
                                     (_
                                      (leave (_ "~A: unknown package~%") x))))
                                  (_ #f))
                                 opts))
               (req  (append-map (lambda (drv-path)
                                   (let ((d (call-with-input-file drv-path
                                              read-derivation)))
                                     (derivation-prerequisites-to-build (%store) d)))
                                 drv))
               (req* (delete-duplicates
                      (append (remove (compose (cut valid-path? (%store) <>)
                                               derivation-path->output-path)
                                      drv)
                              (map derivation-input-path req)))))
          (if (assoc-ref opts 'dry-run?)
              (format (current-error-port)
                      (N_ "~:[the following derivation would be built:~%~{   ~a~%~}~;~]"
                          "~:[the following derivations would be built:~%~{    ~a~%~}~;~]"
                          (length req*))
                      (null? req*) req*)
              (format (current-error-port)
                      (N_ "~:[the following derivation will be built:~%~{   ~a~%~}~;~]"
                          "~:[the following derivations will be built:~%~{    ~a~%~}~;~]"
                          (length req*))
                      (null? req*) req*))

          ;; TODO: Add more options.
          (set-build-options (%store)
                             #:keep-failed? (assoc-ref opts 'keep-failed?)
                             #:build-cores (or (assoc-ref opts 'cores) 0)
                             #:use-substitutes? (assoc-ref opts 'substitutes?)
                             #:verbosity (assoc-ref opts 'verbosity))

          (if (assoc-ref opts 'derivations-only?)
              (format #t "~{~a~%~}" drv)
              (or (assoc-ref opts 'dry-run?)
                  (and (build-derivations (%store) drv)
                       (for-each (lambda (d)
                                   (let ((drv (call-with-input-file d
                                                read-derivation)))
                                     (format #t "~{~a~%~}"
                                             (map (match-lambda
                                                   ((out-name . out)
                                                    (derivation-path->output-path
                                                     d out-name)))
                                                  (derivation-outputs drv)))))
                                 drv)
                       (let ((roots (filter-map (match-lambda
                                                 (('gc-root . root)
                                                  root)
                                                 (_ #f))
                                                opts)))
                         (when roots
                           (for-each (cut register-root <> <>)
                                     drv roots)
                           #t))))))))))

;; Local Variables:
;; eval: (put 'guard 'scheme-indent-function 1)
;; End:
Commit	Line	Data
14a1c319 LC	1	#!/bin/sh
	2	# aside from this initial boilerplate, this is actually -- scheme -- code
	3
b8605698 LC	4	prefix="@prefix@"
	5	datarootdir="@datarootdir@"
	6
14a1c319 LC	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)
073c34d7	33	#:use-module (guix ui)
14a1c319 LC	34	#:use-module (guix store)
	35	#:use-module (guix derivations)
	36	#:use-module (guix packages)
07783858	37	#:use-module (guix utils)
14a1c319 LC	38	#:use-module (ice-9 format)
	39	#:use-module (ice-9 match)
	40	#:use-module (srfi srfi-1)
	41	#:use-module (srfi srfi-26)
07783858	42	#:use-module (srfi srfi-34)
14a1c319 LC	43	#:use-module (srfi srfi-37)
	44	#:autoload (distro) (find-packages-by-name)
	45	#:export (guix-build))
	46
14a1c319	47	(define %store
c7bdb1b9	48	(make-parameter #f))
14a1c319	49
5cc30616 LC	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."
14a1c319 LC	53	(let ((p (eval exp (current-module))))
14a1c319 LC	54	(if (package? p)
5dba3149	55	(if source?
912209ee LC	56	(let ((source (package-source p))
	57	(loc (package-location p)))
	58	(if source
c7bdb1b9	59	(package-source-derivation (%store) source)
ef1ee6b2 LC	60	(leave (_ "~a: error: package `~a' has no source~%")
ef1ee6b2 LC	61	(location->string loc) (package-name p))))
c7bdb1b9	62	(package-derivation (%store) p system))
912209ee LC	63	(leave (_ "expression `~s' does not evaluate to a package~%")
912209ee LC	64	exp))))
14a1c319 LC	65
	66	\f
	67	;;;
	68	;;; Command-line options.
	69	;;;
	70
	71	(define %default-options
	72	;; Alist of default option values.
692c6c15	73	`((system . ,(%current-system))
07ab4bf1 LC	74	(substitutes? . #t)
07ab4bf1 LC	75	(verbosity . 0)))
14a1c319	76
14a1c319 LC	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 (_ "
5dba3149 LC	83	-S, --source build the packages' source derivations"))
5dba3149 LC	84	(display (_ "
5cc30616 LC	85	-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
5cc30616 LC	86	(display (_ "
609354bf LC	87	-d, --derivations return the derivation paths of the given packages"))
609354bf LC	88	(display (_ "
14a1c319 LC	89	-K, --keep-failed keep build tree of failed builds"))
	90	(display (_ "
	91	-n, --dry-run do not build the derivations"))
1c3972da	92	(display (_ "
692c6c15	93	--no-substitutes build instead of resorting to pre-built substitutes"))
fa14d96e LC	94	(display (_ "
fa14d96e LC	95	-c, --cores=N allow the use of up to N CPU cores for the build"))
34811f02 LC	96	(display (_ "
	97	-r, --root=FILE make FILE a symlink to the result, and register it
	98	as a garbage collector root"))
07ab4bf1 LC	99	(display (_ "
07ab4bf1 LC	100	--verbosity=LEVEL use the given verbosity LEVEL"))
14a1c319 LC	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
cdd5d6f9	118	(show-version-and-exit "guix-build")))
14a1c319	119
5dba3149 LC	120	(option '(#\S "source") #f #f
	121	(lambda (opt name arg result)
	122	(alist-cons 'source? #t result)))
5cc30616 LC	123	(option '(#\s "system") #t #f
	124	(lambda (opt name arg result)
	125	(alist-cons 'system arg
	126	(alist-delete 'system result eq?))))
609354bf LC	127	(option '(#\d "derivations") #f #f
	128	(lambda (opt name arg result)
	129	(alist-cons 'derivations-only? #t result)))
14a1c319 LC	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)))
fa14d96e LC	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)))))
1c3972da LC	144	(option '(#\n "dry-run") #f #f
	145	(lambda (opt name arg result)
	146	(alist-cons 'dry-run? #t result)))
692c6c15	147	(option '("no-substitutes") #f #f
14a1c319	148	(lambda (opt name arg result)
692c6c15	149	(alist-cons 'substitutes? #f
34811f02 LC	150	(alist-delete 'substitutes? result))))
	151	(option '(#\r "root") #t #f
	152	(lambda (opt name arg result)
07ab4bf1 LC	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)))))))
14a1c319 LC	159
	160	\f
	161	;;;
	162	;;; Entry point.
	163	;;;
	164
	165	(define (guix-build . args)
fa14d96e LC	166	(define (parse-options)
	167	;; Return the alist of option values.
	168	(args-fold args %options
	169	(lambda (opt name arg result)
8759a648	170	(leave (_ "~A: unrecognized option~%") name))
fa14d96e LC	171	(lambda (arg result)
	172	(alist-cons 'argument arg result))
	173	%default-options))
	174
34811f02 LC	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)
c7bdb1b9	187	(add-indirect-root (%store) root))
34811f02 LC	188	((outputs ...)
	189	(fold (lambda (output count)
	190	(let ((root (string-append root "-" (number->string count))))
	191	(symlink output root)
c7bdb1b9	192	(add-indirect-root (%store) root))
34811f02 LC	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
fa14d96e LC	202	(setlocale LC_ALL "")
	203	(textdomain "guix")
	204	(setvbuf (current-output-port) _IOLBF)
	205	(setvbuf (current-error-port) _IOLBF)
	206
073c34d7	207	(with-error-handling
c7bdb1b9 LC	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))
07783858	250
c7bdb1b9 LC	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)
07ab4bf1 LC	255	#:use-substitutes? (assoc-ref opts 'substitutes?)
07ab4bf1 LC	256	#:verbosity (assoc-ref opts 'verbosity))
07783858	257
c7bdb1b9 LC	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))))))))))
07783858 LC	281
	282	;; Local Variables:
	283	;; eval: (put 'guard 'scheme-indent-function 1)
	284	;; End: