diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 181 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 32 |
2 files changed, 130 insertions, 83 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a06755dc7a..dd9a9b8127 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -23,6 +23,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix utils) + #:use-module (guix monads) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -38,19 +39,23 @@ (define %store (make-parameter #f)) -(define (derivations-from-package-expressions str package-derivation - system source?) +(define (derivation-from-expression str package-derivation + system source?) "Read/eval STR and return the corresponding derivation path for SYSTEM. -When SOURCE? is true, return the derivations of the package sources; -otherwise, use PACKAGE-DERIVATION to compute the derivation of a package." - (let ((p (read/eval-package-expression str))) - (if source? - (let ((source (package-source p))) - (if source - (package-source-derivation (%store) source) - (leave (_ "package `~a' has no source~%") - (package-name p)))) - (package-derivation (%store) p system)))) +When SOURCE? is true and STR evaluates to a package, return the derivation of +the package source; otherwise, use PACKAGE-DERIVATION to compute the +derivation of a package." + (match (read/eval str) + ((? package? p) + (if source? + (let ((source (package-source p))) + (if source + (package-source-derivation (%store) source) + (leave (_ "package `~a' has no source~%") + (package-name p)))) + (package-derivation (%store) p system))) + ((? procedure? proc) + (run-with-store (%store) (proc) #:system system)))) ;;; @@ -68,7 +73,7 @@ otherwise, use PACKAGE-DERIVATION to compute the derivation of a package." (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")) + -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " -S, --source build the packages' source derivations")) (display (_ " @@ -95,6 +100,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) as a garbage collector root")) (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) + (display (_ " + --log-file return the log file names for the given derivations")) (newline) (display (_ " -h, --help display this help and exit")) @@ -161,7 +168,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (let ((level (string->number arg))) (alist-cons 'verbosity level - (alist-delete 'verbosity result))))))) + (alist-delete 'verbosity result))))) + (option '("log-file") #f #f + (lambda (opt name arg result) + (alist-cons 'log-file? #t result))))) ;;; @@ -235,68 +245,89 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (leave (_ "~A: unknown package~%") name)))))) (with-error-handling - (let ((opts (parse-options))) - (define package->derivation - (match (assoc-ref opts 'target) - (#f package-derivation) - (triplet - (cut package-cross-derivation <> <> triplet <>)))) + ;; 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) - (derivations-from-package-expressions - str package->derivation sys src?)) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('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))) + (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))) - (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?) + #:max-silent-time (assoc-ref opts 'max-silent-time) + #:verbosity (assoc-ref opts 'verbosity)) - (if (assoc-ref opts 'derivations-only?) - (begin - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root <> <>) - (map (compose list derivation-file-name) drv) - roots)) - (or (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 <> <>) + (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)))))))))) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 1afc93bbc9..83e3d25dba 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -123,7 +123,8 @@ again." (lambda () body ...) (lambda args - ;; The SIGALRM triggers EINTR, because of the bug at + ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR + ;; because of the bug at ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>. ;; When that happens, try again. Note: SA_RESTART cannot be ;; used because of <http://bugs.gnu.org/14640>. @@ -162,10 +163,17 @@ provide." (warning (_ "while fetching ~a: server is unresponsive~%") (uri->string uri)) (warning (_ "try `--no-substitutes' if the problem persists~%")) - (when port - (close-port port))) + + ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, + ;; and thus PORT had to be closed and re-opened. This is not the + ;; case afterward. + (unless (or (guile-version>? "2.0.9") + (version>? (version) "2.0.9.39")) + (when port + (close-port port)))) (begin - (set! port (open-socket-for-uri uri #:buffered? buffered?)) + (when (or (not port) (port-closed? port)) + (set! port (open-socket-for-uri uri #:buffered? buffered?))) (http-fetch uri #:text? #f #:port port))))))) (define-record-type <cache> @@ -290,6 +298,12 @@ reading PORT." (time>? (subtract-duration now (make-time time-duration 0 ttl)) (make-time time-monotonic 0 date))) +(define %lookup-threads + ;; Number of threads spawned to perform lookup operations. This means we + ;; can have this many simultaneous HTTP GET requests to the server, which + ;; limits the impact of connection latency. + 20) + (define (lookup-narinfo cache path) "Check locally if we have valid info about PATH, otherwise go to CACHE and check what it has." @@ -489,8 +503,9 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;; Return the subset of PATHS available in CACHE. (let ((substitutable (if cache - (par-map (cut lookup-narinfo cache <>) - paths) + (n-par-map %lookup-threads + (cut lookup-narinfo cache <>) + paths) '()))) (for-each (lambda (narinfo) (when narinfo @@ -501,8 +516,9 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;; Reply info about PATHS if it's in CACHE. (let ((substitutable (if cache - (par-map (cut lookup-narinfo cache <>) - paths) + (n-par-map %lookup-threads + (cut lookup-narinfo cache <>) + paths) '()))) (for-each (lambda (narinfo) (format #t "~a\n~a\n~a\n" |