From 7ea1432e22b42969ff0d078e68f5cb55a75b1aca Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 18 May 2015 07:49:44 -0400 Subject: ui: Factorize user-provided Scheme file loading. * guix/ui.scm (make-user-module, load*): New procedures. * guix/scripts/system.scm (%user-module): Define in terms of 'make-user-module'. (read-operating-system): Define in terms of load*'. --- guix/scripts/system.scm | 22 ++++------------------ 1 file changed, 4 insertions(+), 18 deletions(-) (limited to 'guix/scripts/system.scm') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1838e8945..459b2da0c 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -48,28 +48,14 @@ (define %user-module ;; Module in which the machine description file is loaded. - (let ((module (make-fresh-user-module))) - (for-each (lambda (iface) - (module-use! module (resolve-interface iface))) - '((gnu system) - (gnu services) - (gnu system shadow))) - module)) + (make-user-module '((gnu system) + (gnu services) + (gnu system shadow)))) (define (read-operating-system file) "Read the operating-system declaration from FILE and return it." - ;; TODO: Factorize. - (catch #t - (lambda () - ;; Avoid ABI incompatibility with the record. - (set! %fresh-auto-compile #t) + (load* file %user-module)) - (save-module-excursion - (lambda () - (set-current-module %user-module) - (primitive-load file)))) - (lambda args - (report-load-error file args)))) ;;; -- cgit v1.3 From 4d043ab6283cb15e2f0cd0847a38ccf3604aab66 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 20 May 2015 18:42:35 -0400 Subject: ui: Deduplicate 'show-what-to-build*'. * guix/ui.scm (show-what-to-build*): New procedure. * guix/scripts/environment.scm (show-what-to-build*): Delete. * guix/scripts/system.scm (show-what-to-build*): Likewise. * build-aux/make-binary-tarball.scm (show-what-to-build*): Likewise. --- build-aux/make-binary-tarball.scm | 3 --- guix/scripts/environment.scm | 3 --- guix/scripts/system.scm | 2 -- guix/ui.scm | 4 ++++ 4 files changed, 4 insertions(+), 8 deletions(-) (limited to 'guix/scripts/system.scm') diff --git a/build-aux/make-binary-tarball.scm b/build-aux/make-binary-tarball.scm index 0b5dbaf1d..e12bec476 100644 --- a/build-aux/make-binary-tarball.scm +++ b/build-aux/make-binary-tarball.scm @@ -27,9 +27,6 @@ (gnu system install) (ice-9 match)) -(define show-what-to-build* - (store-lift show-what-to-build)) - (define copy-file* (lift2 copy-file %store-monad)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index e81532c7e..f403e95f3 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -192,9 +192,6 @@ packages." (append-map transitive-inputs packages))) ;; TODO: Deduplicate these. -(define show-what-to-build* - (store-lift show-what-to-build)) - (define set-build-options-from-command-line* (store-lift set-build-options-from-command-line)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 459b2da0c..8d5fbe5a7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -67,8 +67,6 @@ (store-lift references)) (define topologically-sorted* (store-lift topologically-sorted)) -(define show-what-to-build* - (store-lift show-what-to-build)) (define* (copy-item item target diff --git a/guix/ui.scm b/guix/ui.scm index 920355fbb..9bab7c51d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -57,6 +57,7 @@ string->number* size->number show-what-to-build + show-what-to-build* show-manifest-transaction call-with-error-handling with-error-handling @@ -453,6 +454,9 @@ available for download." (null? download) download))) (pair? build))) +(define show-what-to-build* + (store-lift show-what-to-build)) + (define (right-arrow port) "Return either a string containing the 'RIGHT ARROW' character, or an ASCII replacement if PORT is not Unicode-capable." -- cgit v1.3 From 4a35a866be51361b80a5618e422d135959960c3d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 23 May 2015 16:52:17 +0200 Subject: guix system: init: Make sure the target is root-owned. Suggested by Mark H Weaver . * guix/scripts/system.scm (install): Add 'chown' and 'chmod' calls for TARGET when running as root, and warn otherwise. --- guix/scripts/system.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'guix/scripts/system.scm') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8d5fbe5a7..1feb82138 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -145,6 +145,16 @@ 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))))) + ;; Make sure TARGET is root-owned when running as root, but still allow + ;; non-root uses (useful for testing.) See + ;; . + (if (zero? (geteuid)) + (chown target 0 0) + (warning (_ "not running as 'root', so \ +the ownership of '~a' may be incorrect!~%") + target)) + + (chmod target #o755) (let ((os-dir (derivation->output-path os-drv)) (format (lift format %store-monad)) (populate (lift2 populate-root-file-system %store-monad))) -- cgit v1.3 From 328639e48f7ccb8e32fa42a8a0fbc2097fac38e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 24 May 2015 17:15:16 +0200 Subject: guix system: Always add zero previous entries in grub.cfg for 'init'. * guix/scripts/system.scm (grub.cfg): Remove. (perform-action): Call 'operating-system-grub.cfg' with the empty list as the 2nd argument when ACTION is 'init. --- guix/scripts/system.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix/scripts/system.scm') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1feb82138..5a2bf7b4b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -284,10 +284,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 +313,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))) -- cgit v1.3 From f245b03debfa05fa692e95769a9b7116200bf191 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 24 May 2015 17:20:24 +0200 Subject: guix system: init: Copy the closure of 'grub.cfg', not that of the system. Fixes . Reported by Daniel Pimentel . * guix/scripts/system.scm (install): Copy the closure of GRUB.CFG rather than that of OS-DIR. --- guix/scripts/system.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix/scripts/system.scm') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5a2bf7b4b..277f31f6f 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) -- cgit v1.3 From db030303b820297da23f8ce7101be88427eeef8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 May 2015 22:52:41 +0200 Subject: guix system: Add '--on-error'. * guix/ui.scm (load*): Add #:on-error parameter. [tag, error-string]: New variables. Wrap 'load' call in 'call-with-prompt'. Pass TAG to 'make-stack'. Honor ON-ERROR after 'report-load-error' call. (report-load-error): Change to not exit on error. Make private. * guix/scripts/system.scm (show-help, %options): Add --on-error. (guix-system): Use 'load*' and pass it #:on-error. --- doc/guix.texi | 19 +++++++++++++++++ guix/scripts/system.scm | 10 ++++++++- guix/ui.scm | 55 +++++++++++++++++++++++++++++++++++-------------- 3 files changed, 68 insertions(+), 16 deletions(-) (limited to 'guix/scripts/system.scm') diff --git a/doc/guix.texi b/doc/guix.texi index a4aa1b67f..a97436cc0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5995,6 +5995,25 @@ For the @code{vm-image} and @code{disk-image} actions, create an image of the given @var{size}. @var{size} may be a number of bytes, or it may include a unit as a suffix (@pxref{Block size, size specifications,, coreutils, GNU Coreutils}). + +@item --on-error=@var{strategy} +Apply @var{strategy} when an error occurs when reading @var{file}. +@var{strategy} may be one of the following: + +@table @code +@item nothing-special +Report the error concisely and exit. This is the default strategy. + +@item backtrace +Likewise, but also display a backtrace. + +@item debug +Report the error and enter Guile's debugger. From there, you can run +commands such as @code{,bt} to get a backtrace, @code{,locals} to +display local variable values, and more generally inspect the program's +state. @xref{Debug Commands,,, guile, GNU Guile Reference Manual}, for +a list of available debugging commands. +@end table @end table Note that all the actions above, except @code{build} and @code{init}, diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 277f31f6f..b6d7d0d04 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -382,6 +382,9 @@ Build the operating system declared in FILE according to ACTION.\n")) - 'init', initialize a root file system to run GNU.\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 (_ " @@ -422,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) @@ -514,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 d590eef04..7490de080 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -43,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_ @@ -51,7 +53,6 @@ leave make-user-module load* - report-load-error warn-about-load-error show-version-and-exit show-bug-report-information @@ -146,7 +147,8 @@ 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. @@ -158,6 +160,14 @@ messages." 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. @@ -170,11 +180,14 @@ messages." ;; Hide the "auto-compiling" messages. (parameterize ((current-warning-port (%make-void-port "w"))) - ;; 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)))))) + (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. @@ -182,31 +195,43 @@ messages." (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)) + (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))))) + + (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, and exit. + "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 frame (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 -- cgit v1.3 From 2a4e2e4b015ceeb5a0a55e9ab0484b5136c324cd Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Sun, 7 Jun 2015 11:46:06 +0300 Subject: guix: Clean up --help messages. * guix/scripts/import.scm (show-help): Add newline before a list of importers. * guix/scripts/lint.scm (show-help): Split a long description line. * guix/scripts/package.scm (show-help): Improve docstrings for --install and --remove options. * guix/scripts/system.scm (show-help): Format actions the same way as guix commands and importers are formatted. --- guix/scripts/import.scm | 1 + guix/scripts/lint.scm | 3 ++- guix/scripts/package.scm | 10 ++++++---- guix/scripts/system.scm | 13 +++++++------ 4 files changed, 16 insertions(+), 11 deletions(-) (limited to 'guix/scripts/system.scm') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 06b4c1757..45ce092f1 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -86,6 +86,7 @@ rather than \\n." Run IMPORTER with ARGS.\n")) (newline) (display (_ "IMPORTER must be one of the importers listed below:\n")) + (newline) (format #t "~{ ~a~%~}" importers) (display (_ " -h, --help display this help and exit")) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 3b139ce6b..3740b71d5 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -575,7 +575,8 @@ descriptions maintained upstream." (define (show-help) (display (_ "Usage: guix lint [OPTION]... [PACKAGE]... -Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n")) +Run a set of checkers on the specified package; if none is specified, +run the checkers on all packages.\n")) (display (_ " -c, --checkers=CHECKER1,CHECKER2... only run the specificed checkers")) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4ae511480..d9f38fb8b 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -422,15 +422,17 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (substitutes? . #t))) (define (show-help) - (display (_ "Usage: guix package [OPTION]... PACKAGES... -Install, remove, or upgrade PACKAGES in a single transaction.\n")) + (display (_ "Usage: guix package [OPTION]... +Install, remove, or upgrade packages in a single transaction.\n")) (display (_ " - -i, --install=PACKAGE install PACKAGE")) + -i, --install PACKAGE ... + install PACKAGEs")) (display (_ " -e, --install-from-expression=EXP install the package EXP evaluates to")) (display (_ " - -r, --remove=PACKAGE remove PACKAGE")) + -r, --remove PACKAGE ... + remove PACKAGEs")) (display (_ " -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b6d7d0d04..f7c9d83e9 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -368,18 +368,19 @@ boot directly to the kernel or to the bootloader." Build the operating system declared in FILE according to ACTION.\n")) (newline) (display (_ "The valid values for ACTION are:\n")) + (newline) (display (_ "\ - - 'reconfigure', switch to a new operating system configuration\n")) + reconfigure switch to a new operating system configuration\n")) (display (_ "\ - - 'build', build the operating system without installing anything\n")) + build build the operating system without installing anything\n")) (display (_ "\ - - 'vm', build a virtual machine image that shares the host's store\n")) + vm build a virtual machine image that shares the host's store\n")) (display (_ "\ - - 'vm-image', build a freestanding virtual machine image\n")) + vm-image build a freestanding virtual machine image\n")) (display (_ "\ - - 'disk-image', build a disk image, suitable for a USB stick\n")) + disk-image build a disk image, suitable for a USB stick\n")) (display (_ "\ - - 'init', initialize a root file system to run GNU.\n")) + init initialize a root file system to run GNU.\n")) (show-build-options-help) (display (_ " -- cgit v1.3 From 78acff7c11507c68b63ad289b2bbe396602b9dcf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jun 2015 10:31:47 +0200 Subject: guix system: init: Overwrite the items in the target store. Fixes . Reported by Eric Bavier . * guix/scripts/system.scm (copy-item): Check whether DEST exists and remove it if it does. --- guix/scripts/system.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix/scripts/system.scm') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f7c9d83e9..aa9b3f838 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -76,6 +76,13 @@ (let ((dest (string-append target item)) (state (string-append target "/var/guix"))) (format log-port "copying '~a'...~%" item) + + ;; Remove DEST if it exists to make sure that (1) we do not fail badly + ;; while trying to overwrite it (see ), and + ;; (2) we end up with the right contents. + (when (file-exists? dest) + (delete-file-recursively dest)) + (copy-recursively item dest #:log (%make-void-port "w")) -- cgit v1.3