summaryrefslogtreecommitdiff
path: root/guix/scripts/build.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/build.scm')
-rw-r--r--guix/scripts/build.scm293
1 files changed, 146 insertions, 147 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index dd9a9b8127..7cb3710853 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -32,14 +32,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))
+ #:autoload (gnu packages) (find-best-packages-by-name)
+ #:export (derivation-from-expression
+ guix-build))
-(define %store
- (make-parameter #f))
-
-(define (derivation-from-expression str package-derivation
+(define (derivation-from-expression store str package-derivation
system source?)
"Read/eval STR and return the corresponding derivation path for SYSTEM.
When SOURCE? is true and STR evaluates to a package, return the derivation of
@@ -50,12 +47,57 @@ derivation of a package."
(if source?
(let ((source (package-source p)))
(if source
- (package-source-derivation (%store) source)
+ (package-source-derivation store source)
(leave (_ "package `~a' has no source~%")
(package-name p))))
- (package-derivation (%store) p system)))
+ (package-derivation store p system)))
((? procedure? proc)
- (run-with-store (%store) (proc) #:system system))))
+ (run-with-store store (proc) #:system system))))
+
+(define (specification->package spec)
+ "Return a package matching SPEC. SPEC 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 spec)))
+ (match (find-best-packages-by-name name version)
+ ((p) ; one match
+ p)
+ ((p x ...) ; several matches
+ (warning (_ "ambiguous package specification `~a'~%") spec)
+ (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))))))
+
+(define (register-root store 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
+ (leave (_ "failed to create GC root `~a': ~a~%")
+ root (strerror (system-error-errno args)))))))
;;;
@@ -66,6 +108,7 @@ derivation of a package."
;; Alist of default option values.
`((system . ,(%current-system))
(substitutes? . #t)
+ (build-hook? . #t)
(max-silent-time . 3600)
(verbosity . 0)))
@@ -91,6 +134,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(display (_ "
--no-substitutes build instead of resorting to pre-built substitutes"))
(display (_ "
+ --no-build-hook do not attempt to offload builds via the build hook"))
+ (display (_ "
--max-silent-time=SECONDS
mark the build as failed after SECONDS of silence"))
(display (_ "
@@ -157,6 +202,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(lambda (opt name arg result)
(alist-cons 'substitutes? #f
(alist-delete 'substitutes? result))))
+ (option '("no-build-hook") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'build-hook? #f
+ (alist-delete 'build-hook? result))))
(option '("max-silent-time") #t #f
(lambda (opt name arg result)
(alist-cons 'max-silent-time (string->number* arg)
@@ -173,6 +222,36 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(lambda (opt name arg result)
(alist-cons 'log-file? #t result)))))
+(define (options->derivations store opts)
+ "Given OPTS, the result of 'args-fold', return a list of derivations to
+build."
+ (define package->derivation
+ (match (assoc-ref opts 'target)
+ (#f package-derivation)
+ (triplet
+ (cut package-cross-derivation <> <> triplet <>))))
+
+ (define src? (assoc-ref opts 'source?))
+ (define sys (assoc-ref opts 'system))
+
+ (filter-map (match-lambda
+ (('expression . str)
+ (derivation-from-expression store str package->derivation
+ sys src?))
+ (('argument . (? derivation-path? drv))
+ (call-with-input-file drv read-derivation))
+ (('argument . (? store-path?))
+ ;; Nothing to do; maybe for --log-file.
+ #f)
+ (('argument . (? string? x))
+ (let ((p (specification->package x)))
+ (if src?
+ (let ((s (package-source p)))
+ (package-source-derivation store s))
+ (package->derivation store p sys))))
+ (_ #f))
+ opts))
+
;;;
;;; Entry point.
@@ -188,146 +267,66 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(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
- (leave (_ "failed to create GC root `~a': ~a~%")
- root (strerror (system-error-errno args)))))))
-
- (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
- (warning (_ "ambiguous package specification `~a'~%") request)
- (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
;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns.
(with-fluids ((%file-port-name-canonicalization 'absolute))
- (let ((opts (parse-options)))
- (define package->derivation
- (match (assoc-ref opts 'target)
- (#f package-derivation)
- (triplet
- (cut package-cross-derivation <> <> triplet <>))))
-
- (parameterize ((%store (open-connection)))
- (let* ((src? (assoc-ref opts 'source?))
- (sys (assoc-ref opts 'system))
- (drv (filter-map (match-lambda
- (('expression . str)
- (derivation-from-expression
- str package->derivation sys src?))
- (('argument . (? derivation-path? drv))
- (call-with-input-file drv read-derivation))
- (('argument . (? store-path?))
- ;; Nothing to do; maybe for --log-file.
- #f)
- (('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))
- (roots (filter-map (match-lambda
- (('gc-root . root) root)
- (_ #f))
- opts)))
+ (let* ((opts (parse-options))
+ (store (open-connection))
+ (drv (options->derivations store opts))
+ (roots (filter-map (match-lambda
+ (('gc-root . root) root)
+ (_ #f))
+ opts)))
- (unless (assoc-ref opts 'log-file?)
- (show-what-to-build (%store) drv
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:dry-run? (assoc-ref opts 'dry-run?)))
+ (unless (assoc-ref opts 'log-file?)
+ (show-what-to-build store drv
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:dry-run? (assoc-ref opts 'dry-run?)))
- ;; TODO: Add more options.
- (set-build-options (%store)
- #:keep-failed? (assoc-ref opts 'keep-failed?)
- #:build-cores (or (assoc-ref opts 'cores) 0)
- #:fallback? (assoc-ref opts 'fallback?)
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:max-silent-time (assoc-ref opts 'max-silent-time)
- #:verbosity (assoc-ref opts 'verbosity))
+ ;; TODO: Add more options.
+ (set-build-options store
+ #:keep-failed? (assoc-ref opts 'keep-failed?)
+ #:build-cores (or (assoc-ref opts 'cores) 0)
+ #:fallback? (assoc-ref opts 'fallback?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:use-build-hook? (assoc-ref opts 'build-hook?)
+ #:max-silent-time (assoc-ref opts 'max-silent-time)
+ #:verbosity (assoc-ref opts 'verbosity))
- (cond ((assoc-ref opts 'log-file?)
- (for-each (lambda (file)
- (let ((log (log-file (%store) file)))
- (if log
- (format #t "~a~%" log)
- (leave (_ "no build log for '~a'~%")
- file))))
- (delete-duplicates
- (append (map derivation-file-name drv)
- (filter-map (match-lambda
- (('argument
- . (? store-path? file))
- file)
- (_ #f))
- opts)))))
- ((assoc-ref opts 'derivations-only?)
- (format #t "~{~a~%~}" (map derivation-file-name drv))
- (for-each (cut register-root <> <>)
- (map (compose list derivation-file-name) drv)
- roots))
- ((not (assoc-ref opts 'dry-run?))
- (and (build-derivations (%store) drv)
- (for-each (lambda (d)
- (format #t "~{~a~%~}"
- (map (match-lambda
- ((out-name . out)
- (derivation->output-path
- d out-name)))
- (derivation-outputs d))))
- drv)
- (for-each (cut register-root <> <>)
- (map (lambda (drv)
- (map cdr
- (derivation->output-paths drv)))
- drv)
- roots))))))))))
+ (cond ((assoc-ref opts 'log-file?)
+ (for-each (lambda (file)
+ (let ((log (log-file store file)))
+ (if log
+ (format #t "~a~%" log)
+ (leave (_ "no build log for '~a'~%")
+ file))))
+ (delete-duplicates
+ (append (map derivation-file-name drv)
+ (filter-map (match-lambda
+ (('argument
+ . (? store-path? file))
+ file)
+ (_ #f))
+ opts)))))
+ ((assoc-ref opts 'derivations-only?)
+ (format #t "~{~a~%~}" (map derivation-file-name drv))
+ (for-each (cut register-root store <> <>)
+ (map (compose list derivation-file-name) drv)
+ roots))
+ ((not (assoc-ref opts 'dry-run?))
+ (and (build-derivations store drv)
+ (for-each (lambda (d)
+ (format #t "~{~a~%~}"
+ (map (match-lambda
+ ((out-name . out)
+ (derivation->output-path
+ d out-name)))
+ (derivation-outputs d))))
+ drv)
+ (for-each (cut register-root store <> <>)
+ (map (lambda (drv)
+ (map cdr
+ (derivation->output-paths drv)))
+ drv)
+ roots))))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-08-28 05:20:09 +0000