diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/scripts/package.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 28 | ||||
| -rw-r--r-- | guix/ui.scm | 103 |
3 files changed, 116 insertions, 29 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 06ee441799..9da6b9ec1e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -886,14 +886,16 @@ more information.~%")) (alist-delete 'delete-generations opts))) (_ #f)) opts)) - ((and (assoc-ref opts 'manifest) - (not dry-run?)) - (let* ((file-name (assoc-ref opts 'manifest)) + ((assoc-ref opts 'manifest) + (let* ((file-name (assoc-ref opts 'manifest)) (user-module (make-user-module '((guix profiles) (gnu)))) - (manifest (load* file-name user-module))) - (format #t (_ "installing new manifest from ~a with ~d entries.~%") - file-name (length (manifest-entries manifest))) + (manifest (load* file-name user-module))) + (if (assoc-ref opts 'dry-run?) + (format #t (_ "would install new manifest from '~a' with ~d entries~%") + file-name (length (manifest-entries manifest))) + (format #t (_ "installing new manifest from '~a' with ~d entries~%") + file-name (length (manifest-entries manifest)))) (build-and-use-profile manifest))) (else (let* ((manifest (profile-manifest profile)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1feb821389..b6d7d0d045 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -128,8 +128,9 @@ TARGET, and register them." (define* (install os-drv target #:key (log-port (current-output-port)) grub? grub.cfg device) - "Copy the output of OS-DRV and its dependencies to directory TARGET. TARGET -must be an absolute directory name since that's what 'guix-register' expects. + "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to +directory TARGET. TARGET must be an absolute directory name since that's what +'guix-register' expects. When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (define (maybe-copy to-copy) @@ -160,7 +161,9 @@ the ownership of '~a' may be incorrect!~%") (populate (lift2 populate-root-file-system %store-monad))) (mbegin %store-monad - (maybe-copy os-dir) + ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's + ;; background image and so on. + (maybe-copy grub.cfg) ;; Create a bunch of additional files. (format log-port "populating '~a'...~%" target) @@ -284,10 +287,6 @@ it atomically, and then run OS's activation script." ((disk-image) (system-disk-image os #:disk-image-size image-size)))) -(define (grub.cfg os) - "Return the GRUB configuration file for OS." - (operating-system-grub.cfg os (previous-grub-entries))) - (define* (maybe-build drvs #:key dry-run? use-substitutes?) "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is @@ -317,7 +316,10 @@ boot directly to the kernel or to the bootloader." #:full-boot? full-boot? #:mappings mappings)) (grub (package->derivation grub)) - (grub.cfg (grub.cfg os)) + (grub.cfg (operating-system-grub.cfg os + (if (eq? 'init action) + '() + (previous-grub-entries)))) (drvs -> (if (and grub? (memq action '(init reconfigure))) (list sys grub grub.cfg) (list sys))) @@ -381,6 +383,9 @@ Build the operating system declared in FILE according to ACTION.\n")) (show-build-options-help) (display (_ " + --on-error=STRATEGY + apply STRATEGY when an error occurs while reading FILE")) + (display (_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (_ " --no-grub for 'init', do not install GRUB")) @@ -420,6 +425,10 @@ Build the operating system declared in FILE according to ACTION.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) + (option '("on-error") #t #f + (lambda (opt name arg result) + (alist-cons 'on-error (string->symbol arg) + result))) (option '("image-size") #t #f (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) @@ -512,7 +521,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (action (assoc-ref opts 'action)) (system (assoc-ref opts 'system)) (os (if file - (read-operating-system file) + (load* file %user-module + #:on-error (assoc-ref opts 'on-error)) (leave (_ "no configuration file specified~%")))) (dry? (assoc-ref opts 'dry-run?)) diff --git a/guix/ui.scm b/guix/ui.scm index 9bab7c51dd..7490de080c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -35,6 +35,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-31) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) @@ -42,6 +43,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 regex) + #:autoload (system repl repl) (start-repl) + #:autoload (system repl debug) (make-debug stack->vector) #:replace (symlink) #:export (_ N_ @@ -50,7 +53,6 @@ leave make-user-module load* - report-load-error warn-about-load-error show-version-and-exit show-bug-report-information @@ -145,35 +147,91 @@ messages." modules) module)) -(define (load* file user-module) +(define* (load* file user-module + #:key (on-error 'nothing-special)) "Load the user provided Scheme source code FILE." + (define (frame-with-source frame) + ;; Walk from FRAME upwards until source location information is found. + (let loop ((frame frame) + (previous frame)) + (if (not frame) + previous + (if (frame-source frame) + frame + (loop (frame-previous frame) frame))))) + + (define (error-string frame args) + (call-with-output-string + (lambda (port) + (apply display-error frame port (cdr args))))) + + (define tag + (make-prompt-tag "user-code")) + (catch #t (lambda () + ;; XXX: Force a recompilation to avoid ABI issues. (set! %fresh-auto-compile #t) + (set! %load-should-auto-compile #t) (save-module-excursion (lambda () (set-current-module user-module) - (primitive-load file)))) - (lambda args - (report-load-error file args)))) -(define (report-load-error file args) - "Report the failure to load FILE, a user-provided Scheme file, and exit. + ;; Hide the "auto-compiling" messages. + (parameterize ((current-warning-port (%make-void-port "w"))) + (call-with-prompt tag + (lambda () + ;; Give 'load' an absolute file name so that it doesn't try to + ;; search for FILE in %LOAD-PATH. Note: use 'load', not + ;; 'primitive-load', so that FILE is compiled, which then allows us + ;; to provide better error reporting with source line numbers. + (load (canonicalize-path file))) + (const #f)))))) + (lambda _ + ;; XXX: Errors are reported from the pre-unwind handler below, but + ;; calling 'exit' from there has no effect, so we call it here. + (exit 1)) + (rec (handle-error . args) + ;; Capture the stack up to this procedure call, excluded, and pass + ;; the faulty stack frame to 'report-load-error'. + (let* ((stack (make-stack #t handle-error tag)) + (depth (stack-length stack)) + (last (and (> depth 0) (stack-ref stack 0))) + (frame (frame-with-source + (if (> depth 1) + (stack-ref stack 1) ;skip the 'throw' frame + last)))) + + (report-load-error file args frame) + + (case on-error + ((debug) + (newline) + (display (_ "entering debugger; type ',bt' for a backtrace\n")) + (start-repl #:debug (make-debug (stack->vector stack) 0 + (error-string frame args) + #f))) + ((backtrace) + (newline (current-error-port)) + (display-backtrace stack (current-error-port))) + (else + #t)))))) + +(define* (report-load-error file args #:optional frame) + "Report the failure to load FILE, a user-provided Scheme file. ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . _) (let ((err (system-error-errno args))) - (leave (_ "failed to load '~a': ~a~%") file (strerror err)))) + (report-error (_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) (format (current-error-port) (_ "~a: error: ~a~%") - (location->string loc) message) - (exit 1))) + (location->string loc) message))) ((error args ...) (report-error (_ "failed to load '~a':~%") file) - (apply display-error #f (current-error-port) args) - (exit 1)))) + (apply display-error frame (current-error-port) args)))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ "Report the failure to load FILE, a user-provided Scheme file, without @@ -243,8 +301,25 @@ General help using GNU software: <http://www.gnu.org/gethelp/>")) ;; information is missing as of Guile 2.0.11, making the exception ;; uninformative.) (apply throw key proc "~A: ~S" - (append args (list link)) - errno)))))) + (list (strerror (car errno)) link) + (list errno))))))) + +(set! copy-file + ;; Note: here we use 'set!', not #:replace, because UIs typically use + ;; 'copy-recursively', which doesn't use (guix ui). + (let ((real-copy-file (@ (guile) copy-file))) + (lambda (source target) + "This is a 'copy-file' replacement that provides proper error reporting." + (catch 'system-error + (lambda () + (real-copy-file source target)) + (lambda (key proc fmt args errno) + ;; Augment the FMT and ARGS with information about TARGET (this + ;; information is missing as of Guile 2.0.11, making the exception + ;; uninformative.) + (apply throw key proc "~A: ~S" + (list (strerror (car errno)) target) + (list errno))))))) (define (string->number* str) "Like `string->number', but error out with an error message on failure." |