diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/environment.scm | 28 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 132 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 11 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 13 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 3 |
5 files changed, 126 insertions, 61 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 5965e3426e..86e1eb115f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -162,6 +162,8 @@ COMMAND or an interactive shell in that environment.\n")) (newline) (show-build-options-help) (newline) + (show-transformation-options-help) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -261,7 +263,9 @@ COMMAND or an interactive shell in that environment.\n")) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) - %standard-build-options)) + + (append %transformation-options + %standard-build-options))) (define (pick-all alist key) "Return a list of values in ALIST associated with KEY." @@ -274,7 +278,7 @@ COMMAND or an interactive shell in that environment.\n")) (_ memo))) '() alist)) -(define (options/resolve-packages opts) +(define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by manifest entries for the corresponding packages." (define (manifest-entry=? e1 e2) @@ -282,15 +286,21 @@ for the corresponding packages." (string=? (manifest-entry-output e1) (manifest-entry-output e2)))) + (define transform + (cut (options->transformation opts) store <>)) + + (define* (package->manifest-entry* package #:optional (output "out")) + (package->manifest-entry (transform package) output)) + (define (packages->outputs packages mode) (match packages ((? package? package) (if (eq? mode 'ad-hoc-package) - (list (package->manifest-entry package)) + (list (package->manifest-entry* package)) (package-environment-inputs package))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) - (list (package->manifest-entry package output)) + (list (package->manifest-entry* package output)) (package-environment-inputs package))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -301,7 +311,7 @@ for the corresponding packages." (('package 'ad-hoc-package (? string? spec)) (let-values (((package output) (specification->package+output spec))) - (list (package->manifest-entry package output)))) + (list (package->manifest-entry* package output)))) (('package 'package (? string? spec)) (package-environment-inputs (specification->package+output spec))) @@ -364,8 +374,8 @@ requisite store items i.e. the union closure of all the inputs." ((? direct-store-path? path) (list path))))) - (mlet %store-monad ((reqs (sequence %store-monad - (map input->requisites inputs)))) + (mlet %store-monad ((reqs (mapm %store-monad + input->requisites inputs))) (return (delete-duplicates (concatenate reqs))))) (define (status->exit-code status) @@ -654,7 +664,6 @@ message if any test fails." ;; within the container. '("/bin/sh") (list %default-shell)))) - (manifest (options/resolve-packages opts)) (mappings (pick-all opts 'file-system-mapping))) (when container? (assert-container-features)) @@ -666,6 +675,9 @@ message if any test fails." (with-store store (with-status-report print-build-event + (define manifest + (options/resolve-packages store opts)) + (set-build-options-from-command-line store opts) ;; Use the bootstrap Guile when requested. diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index ee5857e16b..1e0ea1c4c6 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -321,6 +321,13 @@ hook." (set-port-revealed! port 1) port)) +(define (node-free-disk-space node) + "Return the free disk space, in bytes, in NODE's store." + (node-eval node + `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))))) + (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -360,9 +367,19 @@ MACHINE." (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100))) + (let* ((space (false-if-exception + (node-free-disk-space (make-node session))))) + + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (if (and space (< space (* 10 (expt 2 20)))) + (begin + (format (current-error-port) + (G_ "build failure may have been caused by lack \ +of free disk space on '~a'~%") + (build-machine-name machine)) + (primitive-exit 1)) + (primitive-exit 100))))) (parameterize ((current-build-output-port (build-log-port))) (build-derivations store (list drv)))) @@ -392,33 +409,37 @@ MACHINE." (build-requirements-features requirements) (build-machine-features machine)))) -(define (machine-load machine) - "Return the load of MACHINE, divided by the number of parallel builds -allowed on MACHINE. Return +∞ if MACHINE is unreachable." - ;; Note: This procedure is costly since it creates a new SSH session. - (match (false-if-exception (open-ssh-session machine)) - ((? session? session) - (let* ((pipe (open-remote-pipe* session OPEN_READ - "cat" "/proc/loadavg")) - (line (read-line pipe))) - (close-port pipe) - (disconnect! session) - - (if (eof-object? line) - +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded - (match (string-tokenize line) - ((one five fifteen . x) - (let* ((raw (string->number one)) - (jobs (build-machine-parallel-builds machine)) - (normalized (/ raw jobs))) - (format (current-error-port) "load on machine '~a' is ~s\ +(define %minimum-disk-space + ;; Minimum disk space required on the build machine for a build to be + ;; offloaded. This keeps us from offloading to machines that are bound to + ;; run out of disk space. + (* 100 (expt 2 20))) ;100 MiB + +(define (node-load node) + "Return the load on NODE. Return +∞ if NODE is misbehaving." + (let ((line (node-eval node + '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string))))) + (if (eof-object? line) + +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded + (match (string-tokenize line) + ((one five fifteen . x) + (string->number one)) + (x + +inf.0))))) + +(define (normalized-load machine load) + "Divide LOAD by the number of parallel builds of MACHINE." + (if (rational? load) + (let* ((jobs (build-machine-parallel-builds machine)) + (normalized (/ load jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ (normalized: ~s)~%" - (build-machine-name machine) raw normalized) - normalized)) - (x - +inf.0))))) ;something's fishy about MACHINE, so avoid it - (x - +inf.0))) ;failed to connect to MACHINE, so avoid it + (build-machine-name machine) load normalized) + normalized) + load)) (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." @@ -484,21 +505,32 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (match machines+slots (((best slot) others ...) ;; Return the best machine unless it's already overloaded. - ;; Note: We call 'machine-load' only as a last resort because it is + ;; Note: We call 'node-load' only as a last resort because it is ;; too costly to call it once for every machine. - (if (< (machine-load best) 2.) - (match others - (((machines slots) ...) - ;; Release slots from the uninteresting machines. - (for-each release-build-slot slots) - - ;; The caller must keep SLOT to protect it from GC and to - ;; eventually release it. - (values best slot))) - (begin - ;; BEST is overloaded, so try the next one. - (release-build-slot slot) - (loop others)))) + (let* ((session (false-if-exception (open-ssh-session best))) + (node (and session (make-node session))) + (load (and node (normalized-load best (node-load node)))) + (space (and node (node-free-disk-space node)))) + (when session (disconnect! session)) + (if (and node (< load 2.) (>= space %minimum-disk-space)) + (match others + (((machines slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; The caller must keep SLOT to protect it from GC and to + ;; eventually release it. + (values best slot))) + (begin + ;; BEST is unsuitable, so try the next one. + (when (and space (< space %minimum-disk-space)) + (format (current-error-port) + "skipping machine '~a' because it is low \ +on disk space (~,2f MiB free)~%" + (build-machine-name best) + (/ space (expt 2 20) 1.))) + (release-build-slot slot) + (loop others))))) (() (values #f #f)))))) @@ -689,16 +721,20 @@ machine." (info (G_ "getting status of ~a build machines defined in '~a'...~%") (length machines) machine-file) (for-each (lambda (machine) - (let* ((node (make-node (open-ssh-session machine))) - (uts (node-eval node '(uname)))) + (let* ((session (open-ssh-session machine)) + (node (make-node session)) + (uts (node-eval node '(uname))) + (load (node-load node)) + (free (node-free-disk-space node))) + (disconnect! session) (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ - host name: ~a~% normalized load: ~a~%" + host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" (build-machine-name machine) (utsname:sysname uts) (utsname:release uts) (utsname:machine uts) (utsname:nodename uts) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (machine-load machine))))) + load + (/ free (expt 2 20) 1.)))) machines))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c5326b33da..a236f3e45c 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -537,14 +537,19 @@ requested using POOL." (not-found request)))) (define* (render-nar/cached store cache request store-item - #:key (compression %no-compression)) + #:key ttl (compression %no-compression)) "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE, -return it; otherwise, return 404." +return it; otherwise, return 404. When TTL is true, use it as the +'Cache-Control' expiration time." (let ((cached (nar-cache-file cache store-item #:compression compression))) (if (file-exists? cached) (values `((content-type . (application/octet-stream (charset . "ISO-8859-1"))) + ,@(if ttl + `((cache-control (max-age . ,ttl))) + '()) + ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; <http://bugs.gnu.org/21093>. @@ -819,6 +824,7 @@ blocking." %default-gzip-compression)))) (if cache (render-nar/cached store cache request store-item + #:ttl narinfo-ttl #:compression compression) (render-nar store request store-item #:compression compression))) @@ -829,6 +835,7 @@ blocking." (if (nar-path? components) (if cache (render-nar/cached store cache request store-item + #:ttl narinfo-ttl #:compression %no-compression) (render-nar store request store-item #:compression %no-compression)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index d6dc9b6448..53b1777241 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -392,12 +392,21 @@ No authentication and authorization checks are performed here!" (define (narinfo-sha256 narinfo) "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a 'Signature' field." + (define %mandatory-fields + ;; List of fields that must be signed. If they are not signed, the + ;; narinfo is considered unsigned. + '("StorePath" "NarHash" "References")) + (let ((contents (narinfo-contents narinfo))) (match (string-contains contents "Signature:") (#f #f) (index - (let ((above-signature (string-take contents index))) - (sha256 (string->utf8 above-signature))))))) + (let* ((above-signature (string-take contents index)) + (signed-fields (match (call-with-input-string above-signature + fields->alist) + (((fields . values) ...) fields)))) + (and (every (cut member <> signed-fields) %mandatory-fields) + (sha256 (string->utf8 above-signature)))))))) (define* (valid-narinfo? narinfo #:optional (acl (current-acl)) #:key verbose?) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8eb32c62bc..6cda3ccbd6 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -993,7 +993,8 @@ Some ACTIONS support additional ARGS.\n")) instead of reading FILE, when applicable")) (display (G_ " --on-error=STRATEGY - apply STRATEGY when an error occurs while reading FILE")) + apply STRATEGY (one of nothing-special, backtrace, + or debug) when an error occurs while reading FILE")) (display (G_ " --file-system-type=TYPE for 'disk-image', produce a root file system of TYPE |