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.scm271
1 files changed, 160 insertions, 111 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index a357cf8aa4..8ecd9560ed 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -171,6 +171,8 @@ options handled by 'set-build-options-from-command-line', and listed in
(display (_ "
--verbosity=LEVEL use the given verbosity LEVEL"))
(display (_ "
+ --rounds=N build N times in a row to detect non-determinism"))
+ (display (_ "
-c, --cores=N allow the use of up to N CPU cores for the build"))
(display (_ "
-M, --max-jobs=N allow at most N build jobs")))
@@ -181,12 +183,12 @@ options handled by 'set-build-options-from-command-line', and listed in
;; TODO: Add more options.
(set-build-options store
#:keep-failed? (assoc-ref opts 'keep-failed?)
+ #:rounds (assoc-ref opts 'rounds)
#:build-cores (or (assoc-ref opts 'cores) 0)
#:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
- #:substitute-urls (or (assoc-ref opts 'substitute-urls)
- %default-substitute-urls)
+ #:substitute-urls (assoc-ref opts 'substitute-urls)
#:use-build-hook? (assoc-ref opts 'build-hook?)
#:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout)
@@ -211,6 +213,12 @@ options handled by 'set-build-options-from-command-line', and listed in
(apply values
(alist-cons 'keep-failed? #t result)
rest)))
+ (option '("rounds") #t #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons 'rounds (string->number* arg)
+ result)
+ rest)))
(option '("fallback") #f #f
(lambda (opt name arg result . rest)
(apply values
@@ -277,6 +285,7 @@ options handled by 'set-build-options-from-command-line', and listed in
(define %default-options
;; Alist of default option values.
`((system . ,(%current-system))
+ (build-mode . ,(build-mode normal))
(graft? . #t)
(substitutes? . #t)
(build-hook? . #t)
@@ -290,6 +299,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(display (_ "
-e, --expression=EXPR build the package or derivation EXPR evaluates to"))
(display (_ "
+ -f, --file=FILE build the package or derivation that the code within
+ FILE evaluates to"))
+ (display (_ "
-S, --source build the packages' source derivations"))
(display (_ "
--sources[=TYPE] build source derivations; TYPE may optionally be one
@@ -306,6 +318,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(display (_ "
-d, --derivations return the derivation paths of the given packages"))
(display (_ "
+ --check rebuild items to check for non-determinism issues"))
+ (display (_ "
-r, --root=FILE make FILE a symlink to the result, and register it
as a garbage collector root"))
(display (_ "
@@ -345,6 +359,12 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(leave (_ "invalid argument: '~a' option argument: ~a, ~
must be one of 'package', 'all', or 'transitive'~%")
name arg)))))
+ (option '("check") #f #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons 'build-mode (build-mode check)
+ result)
+ rest)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
@@ -359,6 +379,9 @@ must be one of 'package', 'all', or 'transitive'~%")
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
(alist-cons 'expression arg result)))
+ (option '(#\f "file") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'file arg result)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t result)))
@@ -378,9 +401,40 @@ must be one of 'package', 'all', or 'transitive'~%")
%standard-build-options))
+(define (options->things-to-build opts)
+ "Read the arguments from OPTS and return a list of high-level objects to
+build---packages, gexps, derivations, and so on."
+ (define ensure-list
+ (match-lambda
+ ((x ...) x)
+ (x (list x))))
+
+ (append-map (match-lambda
+ (('argument . (? string? spec))
+ (cond ((derivation-path? spec)
+ (list (call-with-input-file spec read-derivation)))
+ ((store-path? spec)
+ ;; Nothing to do; maybe for --log-file.
+ '())
+ (else
+ (list (specification->package spec)))))
+ (('file . file)
+ (ensure-list (load* file (make-user-module '()))))
+ (('expression . str)
+ (ensure-list (read/eval str)))
+ (('argument . (? derivation? drv))
+ drv)
+ (('argument . (? derivation-path? drv))
+ (list ))
+ (_ '()))
+ opts))
+
(define (options->derivations store opts)
"Given OPTS, the result of 'args-fold', return a list of derivations to
build."
+ (define transform
+ (options->transformation opts))
+
(define package->derivation
(match (assoc-ref opts 'target)
(#f package-derivation)
@@ -388,101 +442,99 @@ build."
(cut package-cross-derivation <> <> triplet <>))))
(define src (assoc-ref opts 'source))
- (define sys (assoc-ref opts 'system))
+ (define system (assoc-ref opts 'system))
(define graft? (assoc-ref opts 'graft?))
(parameterize ((%graft? graft?))
- (let ((opts (options/with-source store
- (options/resolve-packages store opts))))
- (concatenate
- (filter-map (match-lambda
- (('argument . (? package? p))
- (match src
- (#f
- (list (package->derivation store p sys)))
- (#t
- (let ((s (package-source p)))
- (list (package-source-derivation store s))))
- (proc
- (map (cut package-source-derivation store <>)
- (proc p)))))
- (('argument . (? derivation? drv))
- (list drv))
- (('argument . (? derivation-path? drv))
- (list (call-with-input-file drv read-derivation)))
- (('argument . (? store-path?))
- ;; Nothing to do; maybe for --log-file.
- #f)
- (_ #f))
- opts)))))
-
-(define (options/resolve-packages store opts)
- "Return OPTS with package specification strings replaced by actual
-packages."
- (define system
- (or (assoc-ref opts 'system) (%current-system)))
-
- (map (match-lambda
- (('argument . (? string? spec))
- (if (store-path? spec)
- `(argument . ,spec)
- `(argument . ,(specification->package spec))))
- (('expression . str)
- (match (read/eval str)
- ((? package? p)
- `(argument . ,p))
- ((? procedure? proc)
- (let ((drv (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (proc))
- #:system system)))
- `(argument . ,drv)))
- ((? gexp? gexp)
- (let ((drv (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (gexp->derivation "gexp" gexp
- #:system system)))))
- `(argument . ,drv)))))
- (opt opt))
- opts))
-
-(define (options/with-source store opts)
- "Process with 'with-source' options in OPTS, replacing the relevant package
-arguments with packages that use the specified source."
+ (append-map (match-lambda
+ ((? package? p)
+ (match src
+ (#f
+ (list (package->derivation store p system)))
+ (#t
+ (let ((s (package-source p)))
+ (list (package-source-derivation store s))))
+ (proc
+ (map (cut package-source-derivation store <>)
+ (proc p)))))
+ ((? derivation? drv)
+ (list drv))
+ ((? procedure? proc)
+ (list (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (proc))
+ #:system system)))
+ ((? gexp? gexp)
+ (list (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (gexp->derivation "gexp" gexp
+ #:system system))))))
+ (transform store (options->things-to-build opts)))))
+
+(define (transform-package-source sources)
+ "Return a transformation procedure that uses replaces package sources with
+the matching URIs given in SOURCES."
(define new-sources
- (filter-map (match-lambda
- (('with-source . uri)
- (cons (package-name->name+version (basename uri))
- uri))
- (_ #f))
- opts))
-
- (let loop ((opts opts)
- (sources new-sources)
- (result '()))
- (match opts
- (()
- (unless (null? sources)
- (warning (_ "sources do not match any package:~{ ~a~}~%")
- (match sources
- (((name . uri) ...)
- uri))))
- (reverse result))
- ((('argument . (? package? p)) tail ...)
- (let ((source (assoc-ref sources (package-name p))))
- (loop tail
- (alist-delete (package-name p) sources)
- (alist-cons 'argument
- (if source
- (package-with-source store p source)
- p)
- result))))
- ((('with-source . _) tail ...)
- (loop tail sources result))
- ((head tail ...)
- (loop tail sources (cons head result))))))
+ (map (lambda (uri)
+ (cons (package-name->name+version (basename uri))
+ uri))
+ sources))
+
+ (lambda (store packages)
+ (let loop ((packages packages)
+ (sources new-sources)
+ (result '()))
+ (match packages
+ (()
+ (unless (null? sources)
+ (warning (_ "sources do not match any package:~{ ~a~}~%")
+ (match sources
+ (((name . uri) ...)
+ uri))))
+ (reverse result))
+ (((? package? p) tail ...)
+ (let ((source (assoc-ref sources (package-name p))))
+ (loop tail
+ (alist-delete (package-name p) sources)
+ (cons (if source
+ (package-with-source store p source)
+ p)
+ result))))
+ ((thing tail ...)
+ (loop tail sources result))))))
+
+(define %transformations
+ ;; Transformations that can be applied to things to build. The car is the
+ ;; key used in the option alist, and the cdr is the transformation
+ ;; procedure; it is called with two arguments: the store, and a list of
+ ;; things to build.
+ `((with-source . ,transform-package-source)))
+
+(define (options->transformation opts)
+ "Return a procedure that, when passed a list of things to build (packages,
+derivations, etc.), applies the transformations specified by OPTS."
+ (apply compose
+ (map (match-lambda
+ ((key . transform)
+ (let ((args (filter-map (match-lambda
+ ((k . arg)
+ (and (eq? k key) arg)))
+ opts)))
+ (if (null? args)
+ (lambda (store things) things)
+ (transform args)))))
+ %transformations)))
+
+(define (show-build-log store file urls)
+ "Show the build log for FILE, falling back to remote logs from URLS if
+needed."
+ (let ((log (or (log-file store file)
+ (log-url store file #:base-urls urls))))
+ (if log
+ (format #t "~a~%" log)
+ (leave (_ "no build log for '~a'~%") file))))
;;;
@@ -497,47 +549,44 @@ arguments with packages that use the specified source."
(let* ((opts (parse-command-line args %options
(list %default-options)))
(store (open-connection))
+ (mode (assoc-ref opts 'build-mode))
(drv (options->derivations store opts))
(urls (map (cut string-append <> "/log")
(if (assoc-ref opts 'substitutes?)
(or (assoc-ref opts 'substitute-urls)
+ ;; XXX: This does not necessarily match the
+ ;; daemon's substitute URLs.
%default-substitute-urls)
'())))
+ (items (filter-map (match-lambda
+ (('argument . (? store-path? file))
+ file)
+ (_ #f))
+ opts))
(roots (filter-map (match-lambda
- (('gc-root . root) root)
- (_ #f))
+ (('gc-root . root) root)
+ (_ #f))
opts)))
(set-build-options-from-command-line store 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?)))
+ #:dry-run? (assoc-ref opts 'dry-run?)
+ #:mode mode))
(cond ((assoc-ref opts 'log-file?)
- (for-each (lambda (file)
- (let ((log (or (log-file store file)
- (log-url store file
- #:base-urls urls))))
- (if log
- (format #t "~a~%" log)
- (leave (_ "no build log for '~a'~%")
- file))))
+ (for-each (cut show-build-log store <> urls)
(delete-duplicates
(append (map derivation-file-name drv)
- (filter-map (match-lambda
- (('argument
- . (? store-path? file))
- file)
- (_ #f))
- opts)))))
+ items))))
((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)
+ (and (build-derivations store drv mode)
(for-each show-derivation-outputs drv)
(for-each (cut register-root store <> <>)
(map (lambda (drv)
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-09 14:14:01 +0000