[jackhill/guix/guix.git] / guix / scripts / build.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.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 scripts 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 (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:autoload   (gnu packages) (find-packages-by-name
                               find-newest-available-packages)
  #: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)))))

  (define newest-available-packages
    (memoize find-newest-available-packages))

  (define (find-best-packages-by-name name version)
    (if version
        (find-packages-by-name name version)
        (match (vhash-assoc name (newest-available-packages))
          ((_ version pkgs ...) pkgs)
          (#f '()))))

  (define (find-package request)
    ;; Return a package matching REQUEST.  REQUEST may be a package
    ;; name, or a package name followed by a hyphen and a version
    ;; number.  If the version number is not present, return the
    ;; preferred newest version.
    (let-values (((name version)
                  (package-name->name+version request)))
      (match (find-best-packages-by-name name version)
        ((p)                                      ; one match
         p)
        ((p x ...)                                ; several matches
         (format (current-error-port)
                 (_ "warning: ambiguous package specification `~a'~%")
                 request)
         (format (current-error-port)
                 (_ "warning: choosing ~a from ~a~%")
                 (package-full-name p)
                 (location->string (package-location p)))
         p)
        (_                                        ; no matches
         (if version
             (leave (_ "~A: package not found for version ~a~%")
                    name version)
             (leave (_ "~A: unknown package~%") name))))))

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