diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 58 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 365 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 212 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 60 |
5 files changed, 453 insertions, 245 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 4788468584..8280a821c5 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -64,6 +64,9 @@ Export/import one or more packages from/to the store.\n")) --generate-key[=PARAMETERS] generate a key pair with the given parameters")) (display (_ " + --authorize authorize imports signed by the public key on stdin")) + (newline) + (display (_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " -S, --source build the packages' source derivations")) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 4a00505022..618015e9ba 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -127,6 +127,8 @@ options handled by 'set-build-options-from-command-line', and listed in --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) (display (_ " + --timeout=SECONDS mark the build as failed after SECONDS of activity")) + (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) (display (_ " -c, --cores=N allow the use of up to N CPU cores for the build"))) @@ -142,39 +144,57 @@ options handled by 'set-build-options-from-command-line', and listed in #:use-substitutes? (assoc-ref opts 'substitutes?) #:use-build-hook? (assoc-ref opts 'build-hook?) #:max-silent-time (assoc-ref opts 'max-silent-time) + #:timeout (assoc-ref opts 'timeout) #:verbosity (assoc-ref opts 'verbosity))) (define %standard-build-options ;; List of standard command-line options for tools that build something. (list (option '(#\K "keep-failed") #f #f - (lambda (opt name arg result) - (alist-cons 'keep-failed? #t result))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'keep-failed? #t result) + rest))) (option '("fallback") #f #f - (lambda (opt name arg result) - (alist-cons 'fallback? #t - (alist-delete 'fallback? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'fallback? #t + (alist-delete 'fallback? result)) + rest))) (option '("no-substitutes") #f #f - (lambda (opt name arg result) - (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)) + rest))) (option '("no-build-hook") #f #f - (lambda (opt name arg result) - (alist-cons 'build-hook? #f - (alist-delete 'build-hook? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'build-hook? #f + (alist-delete 'build-hook? result)) + rest))) (option '("max-silent-time") #t #f - (lambda (opt name arg result) - (alist-cons 'max-silent-time (string->number* arg) - result))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'max-silent-time (string->number* arg) + result) + rest))) + (option '("timeout") #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'timeout (string->number* arg) result) + rest))) (option '("verbosity") #t #f - (lambda (opt name arg result) + (lambda (opt name arg result . rest) (let ((level (string->number arg))) - (alist-cons 'verbosity level - (alist-delete 'verbosity result))))) + (apply values + (alist-cons 'verbosity level + (alist-delete 'verbosity result)) + rest)))) (option '(#\c "cores") #t #f - (lambda (opt name arg result) + (lambda (opt name arg result . rest) (let ((c (false-if-exception (string->number arg)))) (if c - (alist-cons 'cores c result) + (apply values (alist-cons 'cores c result) rest) (leave (_ "~a: not a number~%") arg))))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 00a145e5e9..4d2f78f711 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -23,7 +23,7 @@ #:use-module (guix derivations) #:use-module (guix nar) #:use-module (guix utils) - #:use-module ((guix build utils) #:select (which)) + #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -122,38 +122,40 @@ determined." (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -(define (open-ssh-gateway machine) - "Initiate an SSH connection gateway to MACHINE, and return the PID of the -running lsh gateway upon success, or #f on failure." - (catch 'system-error - (lambda () - (let* ((port (open-pipe* OPEN_READ %lsh-command - "-l" (build-machine-user machine) - "-i" (build-machine-private-key machine) - ;; XXX: With lsh 2.1, passing '--write-pid' - ;; last causes the PID not to be printed. - "--write-pid" "--gateway" "--background" "-z" - (build-machine-name machine))) - (line (read-line port)) - (status (close-pipe port))) - (if (zero? status) - (let ((pid (string->number line))) - (if (integer? pid) - pid - (begin - (warning (_ "'~a' did not write its PID on stdout: ~s~%") - %lsh-command line) - #f))) - (begin - (warning (_ "failed to initiate SSH connection to '~a':\ - '~a' exited with ~a~%") - (build-machine-name machine) - %lsh-command - (status:exit-val status)) - #f)))) - (lambda args - (leave (_ "failed to execute '~a': ~a~%") - %lsh-command (strerror (system-error-errno args)))))) +;;; FIXME: The idea was to open the connection to MACHINE once for all, but +;;; lshg is currently non-functional. +;; (define (open-ssh-gateway machine) +;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the +;; running lsh gateway upon success, or #f on failure." +;; (catch 'system-error +;; (lambda () +;; (let* ((port (open-pipe* OPEN_READ %lsh-command +;; "-l" (build-machine-user machine) +;; "-i" (build-machine-private-key machine) +;; ;; XXX: With lsh 2.1, passing '--write-pid' +;; ;; last causes the PID not to be printed. +;; "--write-pid" "--gateway" "--background" "-z" +;; (build-machine-name machine))) +;; (line (read-line port)) +;; (status (close-pipe port))) +;; (if (zero? status) +;; (let ((pid (string->number line))) +;; (if (integer? pid) +;; pid +;; (begin +;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") +;; %lsh-command line) +;; #f))) +;; (begin +;; (warning (_ "failed to initiate SSH connection to '~a':\ +;; '~a' exited with ~a~%") +;; (build-machine-name machine) +;; %lsh-command +;; (status:exit-val status)) +;; #f)))) +;; (lambda args +;; (leave (_ "failed to execute '~a': ~a~%") +;; %lsh-command (strerror (system-error-errno args)))))) (define (remote-pipe machine mode command) "Run COMMAND on MACHINE, assuming an lsh gateway has been set up." @@ -161,6 +163,10 @@ running lsh gateway upon success, or #f on failure." (lambda () (apply open-pipe* mode %lshg-command "-l" (build-machine-user machine) "-z" + + ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. + "-i" (build-machine-private-key machine) + (build-machine-name machine) command)) (lambda args @@ -168,9 +174,89 @@ running lsh gateway upon success, or #f on failure." %lshg-command (strerror (system-error-errno args))) #f))) + +;;; +;;; Synchronization. +;;; + +(define (lock-file file) + "Wait and acquire an exclusive lock on FILE. Return an open port." + (mkdir-p (dirname file)) + (let ((port (open-file file "w0"))) + (fcntl-flock port 'write-lock) + port)) + +(define (unlock-file lock) + "Unlock LOCK." + (fcntl-flock lock 'unlock) + (close-port lock) + #t) + +(define-syntax-rule (with-file-lock file exp ...) + "Wait to acquire a lock on FILE and evaluate EXP in that context." + (let ((port (lock-file file))) + (dynamic-wind + (lambda () + #t) + (lambda () + exp ...) + (lambda () + (unlock-file port))))) + +(define-syntax-rule (with-machine-lock machine hint exp ...) + "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that +context." + (with-file-lock (machine-lock-file machine hint) + exp ...)) + + +(define (machine-slot-file machine slot) + "Return the file name of MACHINE's file for SLOT." + ;; For each machine we have a bunch of files representing each build slot. + ;; When choosing a build machine, we attempt to get an exclusive lock on one + ;; of these; if we fail, that means all the build slots are already taken. + ;; Inspired by Nix's build-remote.pl. + (string-append (string-append %state-directory "/offload/" + (build-machine-name machine) + "/" (number->string slot)))) + +(define (acquire-build-slot machine) + "Attempt to acquire a build slot on MACHINE. Return the port representing +the slot, or #f if none is available. + +This mechanism allows us to set a hard limit on the number of simultaneous +connections allowed to MACHINE." + (mkdir-p (dirname (machine-slot-file machine 0))) + (with-machine-lock machine 'slots + (any (lambda (slot) + (let ((port (open-file (machine-slot-file machine slot) + "w0"))) + (catch 'flock-error + (lambda () + (fcntl-flock port 'write-lock #:wait? #f) + ;; Got it! + (format (current-error-port) + "process ~a acquired build slot '~a'~%" + (getpid) (port-filename port)) + port) + (lambda args + ;; PORT is already locked by another process. + (close-port port) + #f)))) + (iota (build-machine-parallel-builds machine))))) + +(define (release-build-slot slot) + "Release SLOT, a build slot as returned as by 'acquire-build-slot'." + (close-port slot)) + + +;;; +;;; Offloading. +;;; + (define* (offload drv machine #:key print-build-trace? (max-silent-time 3600) - (build-timeout 7200) (log-port (current-output-port))) + build-timeout (log-port (current-output-port))) "Perform DRV on MACHINE, assuming DRV and its prerequisites are available there, and write the build log to LOG-PORT. Return the exit status." (format (current-error-port) "offloading '~a' to '~a'...~%" @@ -181,9 +267,12 @@ there, and write the build log to LOG-PORT. Return the exit status." ;; FIXME: Protect DRV from garbage collection on MACHINE. (let ((pipe (remote-pipe machine OPEN_READ `("guix" "build" - ;; FIXME: more options ,(format #f "--max-silent-time=~a" max-silent-time) + ,@(if build-timeout + (list (format #f "--timeout=~a" + build-timeout)) + '()) ,(derivation-file-name drv))))) (let loop ((line (read-line pipe))) (unless (eof-object? line) @@ -193,6 +282,43 @@ there, and write the build log to LOG-PORT. Return the exit status." (close-pipe pipe))) +(define* (transfer-and-offload drv machine + #:key + (inputs '()) + (outputs '()) + (max-silent-time 3600) + build-timeout + print-build-trace?) + "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of +INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from +MACHINE." + ;; Acquire MACHINE's exclusive lock to serialize file transfers + ;; to/from MACHINE in the presence of several 'offload' hook + ;; instance. + (when (with-machine-lock machine 'bandwidth + (send-files (cons (derivation-file-name drv) inputs) + machine)) + (let ((status (offload drv machine + #:print-build-trace? print-build-trace? + #:max-silent-time max-silent-time + #:build-timeout build-timeout))) + (if (zero? status) + (begin + ;; Likewise (see above.) + (with-machine-lock machine 'bandwidth + (retrieve-files outputs machine)) + (format (current-error-port) + "done with offloaded '~a'~%" + (derivation-file-name drv))) + (begin + (format (current-error-port) + "derivation '~a' offloaded to '~a' failed \ +with exit code ~a~%" + (derivation-file-name drv) + (build-machine-name machine) + (status:exit-val status)) + (primitive-exit (status:exit-val status))))))) + (define (send-files files machine) "Send the subset of FILES that's missing to MACHINE's store. Return #t on success, #f otherwise." @@ -256,6 +382,11 @@ success, #f otherwise." (zero? (close-pipe pipe))))))) + +;;; +;;; Scheduling. +;;; + (define (machine-matches? machine requirements) "Return #t if MACHINE matches REQUIREMENTS." (and (string=? (build-requirements-system requirements) @@ -268,57 +399,124 @@ success, #f otherwise." "Return #t if M1 is faster than M2." (> (build-machine-speed m1) (build-machine-speed m2))) -(define (choose-build-machine requirements machines) - "Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f." - ;; FIXME: Take machine load into account, and/or shuffle MACHINES. - (let ((machines (sort (filter (cut machine-matches? <> requirements) - machines) - machine-faster?))) - (match machines - ((head . _) - head) - (_ #f)))) +(define (machine-load machine) + "Return the load of MACHINE, divided by the number of parallel builds +allowed on MACHINE." + (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) + (line (read-line pipe))) + (close-pipe pipe) + (if (eof-object? line) + 1. + (match (string-tokenize line) + ((one five fifteen . _) + (let* ((raw (string->number five)) + (jobs (build-machine-parallel-builds machine)) + (normalized (/ raw jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ + (normalized: ~s)~%" + (build-machine-name machine) raw normalized) + normalized)) + (_ + 1.))))) + +(define (machine-less-loaded? m1 m2) + "Return #t if the load on M1 is lower than that on M2." + (< (machine-load m1) (machine-load m2))) + +(define (machine-less-loaded-or-faster? m1 m2) + "Return #t if M1 is either less loaded or faster than M2." + (or (machine-less-loaded? m1 m2) + (machine-faster? m1 m2))) + +(define (machine-lock-file machine hint) + "Return the name of MACHINE's lock file for HINT." + (string-append %state-directory "/offload/" + (build-machine-name machine) + "." (symbol->string hint) ".lock")) + +(define (machine-choice-lock-file) + "Return the name of the file used as a lock when choosing a build machine." + (string-append %state-directory "/offload/machine-choice.lock")) + + +(define %slots + ;; List of acquired build slots (open ports). + '()) + +(define (choose-build-machine machines) + "Return the best machine among MACHINES, or #f." + + ;; Proceed like this: + ;; 1. Acquire the global machine-choice lock. + ;; 2. For all MACHINES, attempt to acquire a build slot, and filter out + ;; those machines for which we failed. + ;; 3. Choose the best machine among those that are left. + ;; 4. Release the previously-acquired build slots of the other machines. + ;; 5. Release the global machine-choice lock. + + (with-file-lock (machine-choice-lock-file) + (define machines+slots + (filter-map (lambda (machine) + (let ((slot (acquire-build-slot machine))) + (and slot (list machine slot)))) + machines)) + + (define (undecorate pred) + (match-lambda + ((machine slot) + (and (pred machine) + (list machine slot))))) + + (let ((machines+slots (sort machines+slots + (undecorate machine-less-loaded-or-faster?)))) + (match machines+slots + (((best slot) (others slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; Return the best machine unless it's already overloaded. + (if (< (machine-load best) 2.) + (begin + ;; Prevent SLOT from being GC'd. + (set! %slots (cons slot %slots)) + best) + (begin + (release-build-slot slot) + #f))) + (() #f))))) (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) - (build-timeout 7200)) + build-timeout) "Process a request to build DRV." - (let* ((local? (and wants-local? (string=? system (%current-system)))) - (reqs (build-requirements - (system system) - (features features))) - (machine (choose-build-machine reqs (build-machines)))) - (if machine - (match (open-ssh-gateway machine) - ((? integer? pid) - (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) - (outputs (string-tokenize (read-line)))) - (when (send-files (cons (derivation-file-name drv) inputs) - machine) - (let ((status (offload drv machine - #:print-build-trace? print-build-trace? - #:max-silent-time max-silent-time - #:build-timeout build-timeout))) - (kill pid SIGTERM) - (if (zero? status) - (begin - (retrieve-files outputs machine) - (format (current-error-port) - "done with offloaded '~a'~%" - (derivation-file-name drv))) - (begin - (format (current-error-port) - "derivation '~a' offloaded to '~a' failed \ -with exit code ~a~%" - (derivation-file-name drv) - (build-machine-name machine) - (status:exit-val status)) - (primitive-exit (status:exit-val status)))))))) - (#f - (display "# decline\n"))) - (display "# decline\n")))) + (let* ((local? (and wants-local? (string=? system (%current-system)))) + (reqs (build-requirements + (system system) + (features features))) + (candidates (filter (cut machine-matches? <> reqs) + (build-machines)))) + (match candidates + (() + ;; We'll never be able to match REQS. + (display "# decline\n")) + ((_ ...) + (let ((machine (choose-build-machine candidates))) + (if machine + (begin + ;; Offload DRV to MACHINE. + (display "# accept\n") + (let ((inputs (string-tokenize (read-line))) + (outputs (string-tokenize (read-line)))) + (transfer-and-offload drv machine + #:inputs inputs + #:outputs outputs + #:max-silent-time max-silent-time + #:build-timeout build-timeout + #:print-build-trace? print-build-trace?))) + + ;; Not now, all the machines are busy. + (display "# postpone\n"))))))) (define-syntax-rule (with-nar-error-handling body ...) "Execute BODY with any &nar-error suitably reported to the user." @@ -388,4 +586,9 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) (x (leave (_ "invalid arguments: ~{~s ~}~%") x)))) +;;; Local Variables: +;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) +;;; eval: (put 'with-file-lock 'scheme-indent-function 1) +;;; End: + ;;; offload.scm ends here diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d41a83de8a..6069b203de 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -26,6 +26,7 @@ #:use-module (guix profiles) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix scripts build) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module ((guix ftp-client) #:select (ftp-open)) #:use-module (ice-9 format) @@ -460,6 +461,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." ;; Alist of default option values. `((profile . ,%current-profile) (max-silent-time . 3600) + (verbosity . 0) (substitutes? . #t))) (define (show-help) @@ -484,18 +486,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " -d, --delete-generations[=PATTERN] delete generations matching PATTERN")) - (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) - (display (_ " - -n, --dry-run show what would be done without actually doing it")) - (display (_ " - --fallback fall back to building when the substituter fails")) - (display (_ " - --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " - --max-silent-time=SECONDS - mark the build as failed after SECONDS of silence")) + (newline) (display (_ " --bootstrap use the bootstrap Guile to build the profile")) (display (_ " @@ -510,6 +503,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -A, --list-available[=REGEXP] list available packages matching REGEXP")) (newline) + (show-build-options-help) + (newline) (display (_ " -h, --help display this help and exit")) (display (_ " @@ -519,107 +514,94 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define %options ;; Specification 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 package"))) - - (option '(#\i "install") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (if arg - (alist-cons 'install arg result) - result) - arg-handler)))) - (option '(#\e "install-from-expression") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'install (read/eval-package-expression arg) - result) - #f))) - (option '(#\r "remove") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (if arg - (alist-cons 'remove arg result) - result) - arg-handler)))) - (option '(#\u "upgrade") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (alist-cons 'upgrade arg - ;; Delete any prior "upgrade all" - ;; command, or else "--upgrade gcc" - ;; would upgrade everything. - (delete '(upgrade . #f) result)) - arg-handler)))) - (option '("roll-back") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'roll-back? #t result) - #f))) - (option '(#\l "list-generations") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-generations ,(or arg "")) - result) - #f))) - (option '(#\d "delete-generations") #f #t - (lambda (opt name arg result arg-handler) - (values (alist-cons 'delete-generations (or arg "") - result) - #f))) - (option '("search-paths") #f #f - (lambda (opt name arg result arg-handler) - (values (cons `(query search-paths) result) - #f))) - (option '(#\p "profile") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'profile arg - (alist-delete 'profile result)) - #f))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'dry-run? #t result) - #f))) - (option '("fallback") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'fallback? #t - (alist-delete 'fallback? result)) - #f))) - (option '("no-substitutes") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)) - #f))) - (option '("max-silent-time") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'max-silent-time (string->number* arg) - result) - #f))) - (option '("bootstrap") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'bootstrap? #t result) - #f))) - (option '("verbose") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'verbose? #t result) - #f))) - (option '(#\s "search") #t #f - (lambda (opt name arg result arg-handler) - (values (cons `(query search ,(or arg "")) - result) - #f))) - (option '(#\I "list-installed") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-installed ,(or arg "")) - result) - #f))) - (option '(#\A "list-available") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-available ,(or arg "")) - result) - #f))))) + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix package"))) + + (option '(#\i "install") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (if arg + (alist-cons 'install arg result) + result) + arg-handler)))) + (option '(#\e "install-from-expression") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'install (read/eval-package-expression arg) + result) + #f))) + (option '(#\r "remove") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (if arg + (alist-cons 'remove arg result) + result) + arg-handler)))) + (option '(#\u "upgrade") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (alist-cons 'upgrade arg + ;; Delete any prior "upgrade all" + ;; command, or else "--upgrade gcc" + ;; would upgrade everything. + (delete '(upgrade . #f) result)) + arg-handler)))) + (option '("roll-back") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'roll-back? #t result) + #f))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-generations ,(or arg "")) + result) + #f))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result arg-handler) + (values (alist-cons 'delete-generations (or arg "") + result) + #f))) + (option '("search-paths") #f #f + (lambda (opt name arg result arg-handler) + (values (cons `(query search-paths) result) + #f))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'profile arg + (alist-delete 'profile result)) + #f))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'dry-run? #t result) + #f))) + (option '("bootstrap") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'bootstrap? #t result) + #f))) + (option '("verbose") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'verbose? #t result) + #f))) + (option '(#\s "search") #t #f + (lambda (opt name arg result arg-handler) + (values (cons `(query search ,(or arg "")) + result) + #f))) + (option '(#\I "list-installed") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-installed ,(or arg "")) + result) + #f))) + (option '(#\A "list-available") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-available ,(or arg "")) + result) + #f))) + + %standard-build-options)) (define (options->installable opts manifest) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', @@ -1052,13 +1034,7 @@ more information.~%")) (or (process-query opts) (with-error-handling (parameterize ((%store (open-connection))) - (set-build-options (%store) - #:print-build-trace #f - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:max-silent-time - (assoc-ref opts 'max-silent-time)) + (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation (%store) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 3aaa1c4284..54f4aaa6c0 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -38,6 +38,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (web uri) #:use-module (guix http-client) #:export (guix-substitute-binary)) @@ -133,33 +134,38 @@ provide." (if buffered? "rb" "r0b")))) (values port (stat:size (stat port))))) ((http) - ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So - ;; honor TIMEOUT? to disable the timeout when fetching a nar. - ;; - ;; Test this with: - ;; sudo tc qdisc add dev eth0 root netem delay 1500ms - ;; and then cancel with: - ;; sudo tc qdisc del dev eth0 root - (let ((port #f)) - (with-timeout (if (or timeout? (guile-version>? "2.0.5")) - %fetch-timeout - 0) - (begin - (warning (_ "while fetching ~a: server is unresponsive~%") - (uri->string uri)) - (warning (_ "try `--no-substitutes' if the problem persists~%")) - - ;; 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 - (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri #:buffered? buffered?))) - (http-fetch uri #:text? #f #:port port))))))) + (guard (c ((http-get-error? c) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)))) + ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So + ;; honor TIMEOUT? to disable the timeout when fetching a nar. + ;; + ;; Test this with: + ;; sudo tc qdisc add dev eth0 root netem delay 1500ms + ;; and then cancel with: + ;; sudo tc qdisc del dev eth0 root + (let ((port #f)) + (with-timeout (if (or timeout? (guile-version>? "2.0.5")) + %fetch-timeout + 0) + (begin + (warning (_ "while fetching ~a: server is unresponsive~%") + (uri->string uri)) + (warning (_ "try `--no-substitutes' if the problem persists~%")) + + ;; 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 + (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> (%make-cache url store-directory wants-mass-query?) |