diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 20 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 5 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 58 |
6 files changed, 80 insertions, 20 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 84904e29da..781ffc5f58 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -293,6 +293,11 @@ the input port." (define (guix-archive . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7b7f419f3a..26e9f42774 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -119,7 +119,9 @@ options handled by 'set-build-options-from-command-line', and listed in (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) (display (_ " - -c, --cores=N allow the use of up to N CPU cores for the build"))) + -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"))) (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given @@ -128,6 +130,7 @@ options handled by 'set-build-options-from-command-line', and listed in (set-build-options store #:keep-failed? (assoc-ref opts 'keep-failed?) #: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?) #:use-build-hook? (assoc-ref opts 'build-hook?) @@ -192,7 +195,15 @@ options handled by 'set-build-options-from-command-line', and listed in (let ((c (false-if-exception (string->number arg)))) (if c (apply values (alist-cons 'cores c result) rest) - (leave (_ "~a: not a number~%") arg))))))) + (leave (_ "not a number: '~a' option argument: ~a~%") + name arg))))) + (option '(#\M "max-jobs") #t #f + (lambda (opt name arg result . rest) + (let ((c (false-if-exception (string->number arg)))) + (if c + (apply values (alist-cons 'max-jobs c result) rest) + (leave (_ "not a number: '~a' option argument: ~a~%") + name arg))))))) ;;; @@ -390,6 +401,11 @@ arguments with packages that use the specified source." (define (guix-build . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 81bad963f6..c388b0c52c 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -213,6 +213,12 @@ packages." ;; Entry point. (define (guix-environment . args) (define (parse-options) + ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 3a72053766..21dc66cb75 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -668,6 +668,11 @@ removed from MANIFEST." (define (guix-package . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result arg-handler) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index ddca76d370..9c96411630 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -175,7 +175,7 @@ to the caller without emitting an error message." %fetch-timeout 0) (begin - (warning (_ "while fetching ~a: server is unresponsive~%") + (warning (_ "while fetching ~a: server is somewhat slow~%") (uri->string uri)) (warning (_ "try `--no-substitutes' if the problem persists~%")) @@ -758,6 +758,10 @@ substituter disabled~%") progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) + + ;; Skip a line after what 'progress-proc' printed. + (newline (current-error-port)) + (every (compose zero? cdr waitpid) pids)))) (("--version") (show-version-and-exit "guix substitute-binary")) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 398a5a371b..27404772b7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -131,6 +131,27 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) +(define (install-grub* grub.cfg device target) + "This is a variant of 'install-grub' with error handling, lifted in +%STORE-MONAD" + (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (temp-gc-root (string-append gc-root ".new")) + (delete-file (lift1 delete-file %store-monad)) + (make-symlink (lift2 switch-symlinks %store-monad)) + (rename (lift2 rename-file %store-monad))) + (mbegin %store-monad + ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when + ;; 'install-grub' completes (being a bit paranoid.) + (make-symlink temp-gc-root grub.cfg) + + (munless (false-if-exception (install-grub grub.cfg device target)) + (delete-file temp-gc-root) + (leave (_ "failed to install GRUB on device '~a'~%") device)) + + ;; Register GRUB.CFG as a GC root so that its dependencies (background + ;; image, font, etc.) are not reclaimed. + (rename temp-gc-root gc-root)))) + (define* (install os-drv target #:key (log-port (current-output-port)) grub? grub.cfg device) @@ -151,18 +172,19 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;; Copy items to the new store. (copy-closure to-copy target #:log-port log-port))))) - (mlet* %store-monad ((os-dir -> (derivation->output-path os-drv)) - (% (maybe-copy os-dir))) + (let ((os-dir (derivation->output-path os-drv)) + (format (lift format %store-monad)) + (populate (lift2 populate-root-file-system %store-monad))) - ;; Create a bunch of additional files. - (format log-port "populating '~a'...~%" target) - (populate-root-file-system os-dir target) + (mbegin %store-monad + (maybe-copy os-dir) - (when grub? - (unless (false-if-exception (install-grub grub.cfg device target)) - (leave (_ "failed to install GRUB on device '~a'~%") device))) + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate os-dir target) - (return #t))) + (mwhen grub? + (install-grub* grub.cfg device target))))) ;;; @@ -334,14 +356,11 @@ boot directly to the kernel or to the bootloader." (case action ((reconfigure) - (mlet %store-monad ((% (switch-to-system os))) - (when grub? - (unless (false-if-exception - (install-grub (derivation->output-path grub.cfg) - device "/")) - (leave (_ "failed to install GRUB on device '~a'~%") - device))) - (return #t))) + (mbegin %store-monad + (switch-to-system os) + (mwhen grub? + (install-grub* (derivation->output-path grub.cfg) + device "/")))) ((init) (newline) (format #t (_ "initializing operating system under '~a'...~%") @@ -467,6 +486,11 @@ Build the operating system declared in FILE according to ACTION.\n")) (define (guix-system . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) |