[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)))" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU 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   (gnu packages) (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)
  (show-bug-report-information))

(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 paths root)
    ;; Register ROOT as an indirect GC root for all of PATHS.
    (let* ((root (string-append (canonicalize-path (dirname root))
                                "/" root)))
     (catch 'system-error
       (lambda ()
         (match paths
           ((path)
            (symlink path root)
            (add-indirect-root (%store) root))
           ((paths ...)
            (fold (lambda (path count)
                    (let ((root (string-append root "-" (number->string count))))
                      (symlink path root)
                      (add-indirect-root (%store) root))
                    (+ 1 count))
                  0
                  paths))))
       (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))))
               (roots (filter-map (match-lambda
                                   (('gc-root . root) root)
                                   (_ #f))
                                  opts)))
          (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?)
              (begin
                (format #t "~{~a~%~}" drv)
                (for-each (cut register-root <> <>)
                          (map list drv) roots))
              (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)
                       (for-each (cut register-root <> <>)
                                 (map (lambda (drv)
                                        (map cdr
                                             (derivation-path->output-paths drv)))
                                      drv)
                                 roots)))))))))

;; 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	!#
233e7676 LC	14	;;; GNU Guix --- Functional package management for GNU
233e7676 LC	15	;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
14a1c319	16	;;;
233e7676	17	;;; This file is part of GNU Guix.
14a1c319	18	;;;
233e7676	19	;;; GNU Guix is free software; you can redistribute it and/or modify it
14a1c319 LC	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	;;;
233e7676	24	;;; GNU Guix is distributed in the hope that it will be useful, but
14a1c319 LC	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
233e7676	30	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
14a1c319 LC	31
14a1c319 LC	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	43	#:use-module (srfi srfi-37)
59a43334	44	#:autoload (gnu packages) (find-packages-by-name)
14a1c319 LC	45	#:export (guix-build))
14a1c319 LC	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)
3441e164	107	(show-bug-report-information))
14a1c319 LC	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
cdd5d6f9	117	(show-version-and-exit "guix-build")))
14a1c319	118
5dba3149 LC	119	(option '(#\S "source") #f #f
	120	(lambda (opt name arg result)
	121	(alist-cons 'source? #t result)))
5cc30616 LC	122	(option '(#\s "system") #t #f
	123	(lambda (opt name arg result)
	124	(alist-cons 'system arg
	125	(alist-delete 'system result eq?))))
609354bf LC	126	(option '(#\d "derivations") #f #f
	127	(lambda (opt name arg result)
	128	(alist-cons 'derivations-only? #t result)))
14a1c319 LC	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)))
fa14d96e LC	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)))))
1c3972da LC	143	(option '(#\n "dry-run") #f #f
	144	(lambda (opt name arg result)
	145	(alist-cons 'dry-run? #t result)))
692c6c15	146	(option '("no-substitutes") #f #f
14a1c319	147	(lambda (opt name arg result)
692c6c15	148	(alist-cons 'substitutes? #f
34811f02 LC	149	(alist-delete 'substitutes? result))))
	150	(option '(#\r "root") #t #f
	151	(lambda (opt name arg result)
07ab4bf1 LC	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)))))))
14a1c319 LC	158
	159	\f
	160	;;;
	161	;;; Entry point.
	162	;;;
	163
	164	(define (guix-build . args)
fa14d96e LC	165	(define (parse-options)
	166	;; Return the alist of option values.
	167	(args-fold args %options
	168	(lambda (opt name arg result)
8759a648	169	(leave (_ "~A: unrecognized option~%") name))
fa14d96e LC	170	(lambda (arg result)
	171	(alist-cons 'argument arg result))
	172	%default-options))
	173
2646c55b LC	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)))
34811f02 LC	178	(catch 'system-error
34811f02 LC	179	(lambda ()
2646c55b LC	180	(match paths
	181	((path)
	182	(symlink path root)
c7bdb1b9	183	(add-indirect-root (%store) root))
2646c55b LC	184	((paths ...)
2646c55b LC	185	(fold (lambda (path count)
34811f02	186	(let ((root (string-append root "-" (number->string count))))
2646c55b	187	(symlink path root)
c7bdb1b9	188	(add-indirect-root (%store) root))
34811f02 LC	189	(+ 1 count))
34811f02 LC	190	0
2646c55b	191	paths))))
34811f02 LC	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
fa14d96e LC	198	(setlocale LC_ALL "")
	199	(textdomain "guix")
	200	(setvbuf (current-output-port) _IOLBF)
	201	(setvbuf (current-error-port) _IOLBF)
	202
073c34d7	203	(with-error-handling
c7bdb1b9 LC	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)
2646c55b LC	234	(map derivation-input-path req))))
	235	(roots (filter-map (match-lambda
	236	(('gc-root . root) root)
	237	(_ #f))
	238	opts)))
c7bdb1b9 LC	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	258	(if (assoc-ref opts 'derivations-only?)
2646c55b LC	259	(begin
	260	(format #t "~{~a~%~}" drv)
	261	(for-each (cut register-root <> <>)
	262	(map list drv) roots))
c7bdb1b9 LC	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)
2646c55b LC	275	(for-each (cut register-root <> <>)
	276	(map (lambda (drv)
	277	(map cdr
	278	(derivation-path->output-paths drv)))
	279	drv)
	280	roots)))))))))
07783858 LC	281
	282	;; Local Variables:
	283	;; eval: (put 'guard 'scheme-indent-function 1)
	284	;; End: