[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
  (open-connection))

(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)))

(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"))
  (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)))))

\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))
           (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?))

      (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 LC	47	(define %store
	48	(open-connection))
	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
	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))))
5cc30616	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 LC	73	`((system . ,(%current-system))
692c6c15 LC	74	(substitutes? . #t)))
14a1c319	75
14a1c319 LC	76	(define (show-help)
	77	(display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION...
	78	Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
	79	(display (_ "
	80	-e, --expression=EXPR build the package EXPR evaluates to"))
	81	(display (_ "
5dba3149 LC	82	-S, --source build the packages' source derivations"))
5dba3149 LC	83	(display (_ "
5cc30616 LC	84	-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
5cc30616 LC	85	(display (_ "
609354bf LC	86	-d, --derivations return the derivation paths of the given packages"))
609354bf LC	87	(display (_ "
14a1c319 LC	88	-K, --keep-failed keep build tree of failed builds"))
	89	(display (_ "
	90	-n, --dry-run do not build the derivations"))
1c3972da	91	(display (_ "
692c6c15	92	--no-substitutes build instead of resorting to pre-built substitutes"))
fa14d96e LC	93	(display (_ "
fa14d96e LC	94	-c, --cores=N allow the use of up to N CPU cores for the build"))
34811f02 LC	95	(display (_ "
	96	-r, --root=FILE make FILE a symlink to the result, and register it
	97	as a garbage collector root"))
14a1c319 LC	98	(newline)
	99	(display (_ "
	100	-h, --help display this help and exit"))
	101	(display (_ "
	102	-V, --version display version information and exit"))
	103	(newline)
	104	(format #t (_ "
	105	Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
	106
	107	(define %options
	108	;; Specifications of the command-line options.
	109	(list (option '(#\h "help") #f #f
	110	(lambda args
	111	(show-help)
	112	(exit 0)))
	113	(option '(#\V "version") #f #f
	114	(lambda args
cdd5d6f9	115	(show-version-and-exit "guix-build")))
14a1c319	116
5dba3149 LC	117	(option '(#\S "source") #f #f
	118	(lambda (opt name arg result)
	119	(alist-cons 'source? #t result)))
5cc30616 LC	120	(option '(#\s "system") #t #f
	121	(lambda (opt name arg result)
	122	(alist-cons 'system arg
	123	(alist-delete 'system result eq?))))
609354bf LC	124	(option '(#\d "derivations") #f #f
	125	(lambda (opt name arg result)
	126	(alist-cons 'derivations-only? #t result)))
14a1c319 LC	127	(option '(#\e "expression") #t #f
	128	(lambda (opt name arg result)
	129	(alist-cons 'expression
	130	(call-with-input-string arg read)
	131	result)))
	132	(option '(#\K "keep-failed") #f #f
	133	(lambda (opt name arg result)
	134	(alist-cons 'keep-failed? #t result)))
fa14d96e LC	135	(option '(#\c "cores") #t #f
	136	(lambda (opt name arg result)
	137	(let ((c (false-if-exception (string->number arg))))
	138	(if c
	139	(alist-cons 'cores c result)
	140	(leave (_ "~a: not a number~%") arg)))))
1c3972da LC	141	(option '(#\n "dry-run") #f #f
	142	(lambda (opt name arg result)
	143	(alist-cons 'dry-run? #t result)))
692c6c15	144	(option '("no-substitutes") #f #f
14a1c319	145	(lambda (opt name arg result)
692c6c15	146	(alist-cons 'substitutes? #f
34811f02 LC	147	(alist-delete 'substitutes? result))))
	148	(option '(#\r "root") #t #f
	149	(lambda (opt name arg result)
	150	(alist-cons 'gc-root arg result)))))
14a1c319 LC	151
	152	\f
	153	;;;
	154	;;; Entry point.
	155	;;;
	156
	157	(define (guix-build . args)
fa14d96e LC	158	(define (parse-options)
	159	;; Return the alist of option values.
	160	(args-fold args %options
	161	(lambda (opt name arg result)
8759a648	162	(leave (_ "~A: unrecognized option~%") name))
fa14d96e LC	163	(lambda (arg result)
	164	(alist-cons 'argument arg result))
	165	%default-options))
	166
34811f02 LC	167	(define (register-root drv root)
	168	;; Register ROOT as an indirect GC root for DRV's outputs.
	169	(let* ((root (string-append (canonicalize-path (dirname root))
	170	"/" root))
	171	(drv* (call-with-input-file drv read-derivation))
	172	(outputs (derivation-outputs drv*))
	173	(outputs* (map (compose derivation-output-path cdr) outputs)))
	174	(catch 'system-error
	175	(lambda ()
	176	(match outputs*
	177	((output)
	178	(symlink output root)
	179	(add-indirect-root %store root))
	180	((outputs ...)
	181	(fold (lambda (output count)
	182	(let ((root (string-append root "-" (number->string count))))
	183	(symlink output root)
	184	(add-indirect-root %store root))
	185	(+ 1 count))
	186	0
	187	outputs))))
	188	(lambda args
	189	(format (current-error-port)
	190	(_ "failed to create GC root `~a': ~a~%")
	191	root (strerror (system-error-errno args)))
	192	(exit 1)))))
	193
fa14d96e LC	194	(setlocale LC_ALL "")
	195	(textdomain "guix")
	196	(setvbuf (current-output-port) _IOLBF)
	197	(setvbuf (current-error-port) _IOLBF)
	198
073c34d7	199	(with-error-handling
07783858 LC	200	(let* ((opts (parse-options))
	201	(src? (assoc-ref opts 'source?))
	202	(sys (assoc-ref opts 'system))
	203	(drv (filter-map (match-lambda
	204	(('expression . exp)
	205	(derivations-from-package-expressions exp sys
	206	src?))
	207	(('argument . (? derivation-path? drv))
	208	drv)
	209	(('argument . (? string? x))
	210	(match (find-packages-by-name x)
	211	((p _ ...)
	212	(if src?
	213	(let ((s (package-source p)))
	214	(package-source-derivation %store s))
	215	(package-derivation %store p sys)))
	216	(_
	217	(leave (_ "~A: unknown package~%") x))))
	218	(_ #f))
	219	opts))
	220	(req (append-map (lambda (drv-path)
	221	(let ((d (call-with-input-file drv-path
609354bf	222	read-derivation)))
07783858 LC	223	(derivation-prerequisites-to-build %store d)))
	224	drv))
	225	(req* (delete-duplicates
	226	(append (remove (compose (cut valid-path? %store <>)
	227	derivation-path->output-path)
	228	drv)
	229	(map derivation-input-path req)))))
	230	(if (assoc-ref opts 'dry-run?)
	231	(format (current-error-port)
	232	(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
	233	"~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
	234	(length req*))
	235	(null? req) req)
	236	(format (current-error-port)
	237	(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
	238	"~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
	239	(length req*))
	240	(null? req) req))
	241
	242	;; TODO: Add more options.
	243	(set-build-options %store
	244	#:keep-failed? (assoc-ref opts 'keep-failed?)
	245	#:build-cores (or (assoc-ref opts 'cores) 0)
	246	#:use-substitutes? (assoc-ref opts 'substitutes?))
	247
	248	(if (assoc-ref opts 'derivations-only?)
	249	(format #t "~{~a~%~}" drv)
	250	(or (assoc-ref opts 'dry-run?)
	251	(and (build-derivations %store drv)
	252	(for-each (lambda (d)
	253	(let ((drv (call-with-input-file d
	254	read-derivation)))
	255	(format #t "~{~a~%~}"
	256	(map (match-lambda
	257	((out-name . out)
	258	(derivation-path->output-path
	259	d out-name)))
	260	(derivation-outputs drv)))))
34811f02 LC	261	drv)
	262	(let ((roots (filter-map (match-lambda
	263	(('gc-root . root)
	264	root)
	265	(_ #f))
	266	opts)))
	267	(when roots
	268	(for-each (cut register-root <> <>)
	269	drv roots)
	270	#t))))))))
07783858 LC	271
	272	;; Local Variables:
	273	;; eval: (put 'guard 'scheme-indent-function 1)
	274	;; End: