diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | doc/guix.texi | 31 | ||||
| -rw-r--r-- | gnu/packages/gnome.scm | 146 | ||||
| -rw-r--r-- | gnu/packages/xml.scm | 33 | ||||
| -rw-r--r-- | gnu/system.scm | 4 | ||||
| -rw-r--r-- | gnu/system/examples/bare-bones.tmpl | 5 | ||||
| -rw-r--r-- | gnu/system/examples/desktop.tmpl | 5 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 46 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 28 | ||||
| -rw-r--r-- | guix/ui.scm | 103 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/guix-package.sh | 18 | ||||
| -rw-r--r-- | tests/guix-system.sh | 65 |
15 files changed, 462 insertions, 39 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index eb3da94da4..7ac7e13ff1 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -13,6 +13,7 @@ . ((indent-tabs-mode . nil) (eval . (put 'eval-when 'scheme-indent-function 1)) + (eval . (put 'call-with-prompt 'scheme-indent-function 1)) (eval . (put 'test-assert 'scheme-indent-function 1)) (eval . (put 'test-assertm 'scheme-indent-function 1)) (eval . (put 'test-equal 'scheme-indent-function 1)) diff --git a/.gitignore b/.gitignore index 47cb39584e..7db4a9f9aa 100644 --- a/.gitignore +++ b/.gitignore @@ -62,6 +62,7 @@ config.cache /pre-inst-env /doc/.dirstamp /doc/guix.info +/doc/guix.info-[0-9] /doc/guix.pdf /doc/stamp-vti /doc/version.texi diff --git a/doc/guix.texi b/doc/guix.texi index cfb626c705..a97436cc0c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4413,7 +4413,7 @@ configuration (@pxref{Using the Configuration System}). @table @asis @item @code{kernel} (default: @var{linux-libre}) -The package object of the operating system to use@footnote{Currently +The package object of the operating system kernel to use@footnote{Currently only the Linux-libre kernel is supported. In the future, it will be possible to use the GNU@tie{}Hurd.}. @@ -4453,7 +4453,7 @@ A list of strings identifying devices to be used for ``swap space'' (@pxref{Memory Concepts,,, libc, The GNU C Library Reference Manual}). For example, @code{'("/dev/sda3")}. -@item @code{users} (default: @code{'()}) +@item @code{users} (default: @code{%base-user-accounts}) @itemx @code{groups} (default: @var{%base-groups}) List of user accounts and groups. @xref{User Accounts}. @@ -4832,6 +4832,14 @@ to be present on the system. This includes groups such as ``root'', specific devices such as ``audio'', ``disk'', and ``cdrom''. @end defvr +@defvr {Scheme Variable} %base-user-accounts +This is the list of basic system accounts that programs may expect to +find on a GNU/Linux system, such as the ``nobody'' account. + +Note that the ``root'' account is not included here. It is a +special-case and is automatically added whether or not it is specified. +@end defvr + @node Locales @subsection Locales @@ -5987,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/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index eefe75de1e..35af94f4fc 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com> ;;; Copyright © 2015 David Hashe <david.hashe@dhashe.com> +;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,6 +61,7 @@ #:use-module (gnu packages pulseaudio) #:use-module (gnu packages python) #:use-module (gnu packages scanner) + #:use-module (gnu packages ssh) #:use-module (gnu packages xml) #:use-module (gnu packages gl) #:use-module (gnu packages compression) @@ -181,6 +183,50 @@ Gnome project. It includes xml2po tool which makes it easier to translate and keep up to date translations of documentation.") (license license:gpl2+))) ; xslt under lgpl +(define-public gcr + (package + (name "gcr") + (version "3.16.0") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnome/sources/" name "/" + (version-major+minor version) "/" + name "-" version ".tar.xz")) + (sha256 + (base32 + "0xfhi0w358lvca1jjx24x2gm67mif33dsnmi9cv5i0f83ks8vzpc")))) + (build-system gnu-build-system) + (arguments + '(#:tests? #f ;25 of 598 tests fail because /var/lib/dbus/machine-id does + ;not exist + #:phases (modify-phases %standard-phases + (add-before + 'check 'pre-check + (lambda* (#:key inputs #:allow-other-keys) + (substitute* "build/tap-driver" + (("/usr/bin/env python") (which "python")))))))) + (inputs + `(("dbus" ,dbus) + ("gnupg" ,gnupg) ;called as a child process during tests + ("libgcrypt" ,libgcrypt))) + (native-inputs + `(("python" ,python-2) ;for tests + ("pkg-config" ,pkg-config) + ("glib" ,glib "bin") + ("intltool" ,intltool))) + ;; mentioned in gck.pc, gcr.pc and gcr-ui.pc + (propagated-inputs + `(("p11-kit" ,p11-kit) + ("glib" ,glib) + ("gtk+" ,gtk+))) + (home-page "http://www.gnome.org") + (synopsis "Libraries for displaying certificates and accessing key stores") + (description + "The GCR package contains libraries used for displaying certificates and +accessing key stores. It also provides the viewer for crypto files on the +GNOME Desktop.") + (license license:lgpl2.1+))) + (define-public libgnome-keyring (package (name "libgnome-keyring") @@ -212,6 +258,73 @@ and keep up to date translations of documentation.") ;; Though a couple of files are LGPLv2.1+. (license license:lgpl2.0+))) +(define-public gnome-keyring + (package + (name "gnome-keyring") + (version "3.16.0") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnome/sources/" name "/" + (version-major+minor version) "/" + name "-" version ".tar.xz")) + (sha256 + (base32 + "1xg1xha3x3hzlmvdq2zm90hc61pj7pnf9yxxvgq4ynl5af6bp8qm")))) + (build-system gnu-build-system) + (arguments + `(#:tests? #f ;48 of 603 tests fail because /var/lib/dbus/machine-id does + ;not exist + #:configure-flags + (list + (string-append "--with-pkcs11-config=" + (assoc-ref %outputs "out") "/share/p11-kit/modules/") + (string-append "--with-pkcs11-modules=" + (assoc-ref %outputs "out") "/share/p11-kit/modules/")) + #:phases + (modify-phases %standard-phases + (add-before + 'check 'pre-check + (lambda* (#:key inputs #:allow-other-keys) + (substitute* "build/tap-driver" + (("/usr/bin/env python") (which "python"))))) + (add-before + 'configure 'fix-docbook + (lambda* (#:key inputs #:allow-other-keys) + (substitute* "docs/Makefile.am" + (("http://docbook.sourceforge.net/release/xsl/current/manpages/docbook.xsl") + (string-append (assoc-ref inputs "docbook-xsl") + "/xml/xsl/docbook-xsl-" + ,(package-version docbook-xsl) + "/manpages/docbook.xsl"))) + (setenv "XML_CATALOG_FILES" + (string-append (assoc-ref inputs "docbook-xml") + "/xml/dtd/docbook/catalog.xml"))))))) + (inputs + `(("libgcrypt" ,libgcrypt) + ("dbus" ,dbus) + ("gcr" ,gcr))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("glib" ,glib "bin") + ("python" ,python-2) ;for tests + ("intltool" ,intltool) + ("autoconf" ,autoconf) + ("automake" ,automake) + ("libxslt" ,libxslt) ;for documentation + ("docbook-xml" ,docbook-xml-4.2) + ("docbook-xsl" ,docbook-xsl))) + (home-page "http://www.gnome.org") + (synopsis "Daemon to store passwords and encryption keys") + (description + "gnome-keyring is a program that keeps passwords and other secrets for +users. It is run as a daemon in the session, similar to ssh-agent, and other +applications locate it via an environment variable or D-Bus. + +The program can manage several keyrings, each with its own master password, +and there is also a session keyring which is never stored to disk, but +forgotten when the session ends.") + (license license:lgpl2.1+))) + (define-public evince (package (name "evince") @@ -1412,6 +1525,39 @@ engineering.") "The default GNOME 3 themes (Adwaita and some accessibility themes).") (license license:lgpl2.1+))) +(define-public seahorse + (package + (name "seahorse") + (version "3.16.0") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnome/sources/" name "/" + (version-major+minor version) "/" name "-" + version ".tar.xz")) + (sha256 + (base32 + "0cg1grgpwbfkiny5148n17rzpc8kswyr5yff0kpm8l3lp01my2kp")))) + (build-system glib-or-gtk-build-system) + (inputs + `(("gtk+" ,gtk+) + ("gcr" ,gcr) + ("gnupg" ,gnupg-1) + ("gpgme" ,gpgme) + ("openssh" ,openssh) + ("libsecret" ,libsecret))) + (native-inputs + `(("intltool" ,intltool) + ("glib:bin" ,glib "bin") + ("itstool" ,itstool) + ("pkg-config" ,pkg-config))) + (home-page "https://launchpad.net/gnome-themes-standard") + (synopsis "Manage encryption keys and passwords in the GNOME keyring") + (description + "Seahorse is a GNOME application for managing encryption keys and +passwords in the GNOME keyring.") + (license license:gpl2+))) + (define-public vala (package (name "vala") diff --git a/gnu/packages/xml.scm b/gnu/packages/xml.scm index d30c40ce1a..8a4d2fbb5b 100644 --- a/gnu/packages/xml.scm +++ b/gnu/packages/xml.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; ;;; This file is part of GNU Guix. @@ -20,8 +20,10 @@ (define-module (gnu packages xml) #:use-module (gnu packages) + #:use-module (gnu packages autotools) #:use-module (gnu packages compression) #:use-module (gnu packages gnupg) + #:use-module (gnu packages gnutls) #:use-module (gnu packages perl) #:use-module (gnu packages python) #:use-module (gnu packages web) @@ -387,3 +389,32 @@ that conforms to the API of the Document Object Model.") stylesheet for the conversion you want and applies it using an external XSL-T processor. It also performs any necessary post-processing.") (license license:gpl2+))) + +(define-public xmlsec + (package + (name "xmlsec") + (version "1.2.20") + (source (origin + (method url-fetch) + (uri (string-append "https://www.aleksey.com/xmlsec/download/" + name "1-" version ".tar.gz")) + (sha256 + (base32 + "01bkbv2y3x8d1sf4dcln1x3y2jyj391s3208d9a2ndhglly5j89j")))) + (build-system gnu-build-system) + (propagated-inputs ; according to xmlsec1.pc + `(("libxml2" ,libxml2) + ("libxslt" ,libxslt))) + (inputs + `(("gnutls" ,gnutls) + ("libgcrypt" ,libgcrypt) + ("libltdl" ,libltdl))) + (home-page "http://www.libexpat.org/") + (synopsis "XML Security Library") + (description + "The XML Security Library is a C library based on Libxml2. It +supports XML security standards such as XML Signature, XML Encryption, +Canonical XML (part of Libxml2) and Exclusive Canonical XML (part of +Libxml2).") + (license (license:x11-style "file://COPYING" + "See 'COPYING' in the distribution.")))) diff --git a/gnu/system.scm b/gnu/system.scm index b8d0e62f60..c4a3bee0eb 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -119,7 +119,7 @@ (default '())) (users operating-system-users ; list of user accounts - (default '())) + (default %base-user-accounts)) (groups operating-system-groups ; list of user groups (default %base-groups)) @@ -686,6 +686,8 @@ etc." (define group-specs (map user-group->gexp groups)) + (assert-valid-users/groups accounts groups) + (gexp->file "activate" #~(begin (eval-when (expand load eval) diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index 8f4faca2d3..dc5cfc81a4 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -23,7 +23,7 @@ ;; This is where user accounts are specified. The "root" ;; account is implicit, and is initially created with the ;; empty password. - (users (list (user-account + (users (cons (user-account (name "alice") (comment "Bob's sister") (group "users") @@ -34,7 +34,8 @@ ;; and access the webcam. (supplementary-groups '("wheel" "audio" "video")) - (home-directory "/home/alice")))) + (home-directory "/home/alice")) + %base-user-accounts)) ;; Globally-installed packages. (packages (cons tcpdump %base-packages)) diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index c78188eb61..988b8f937f 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -20,13 +20,14 @@ (type "ext4")) %base-file-systems)) - (users (list (user-account + (users (cons (user-account (name "bob") (comment "Alice's brother") (group "users") (supplementary-groups '("wheel" "netdev" "audio" "video")) - (home-directory "/home/bob")))) + (home-directory "/home/bob")) + %base-user-accounts)) ;; Add Xfce and Ratpoison; that allows us to choose ;; sessions using either of these at the log-in screen. diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 16b9e4b555..aa97652678 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -21,12 +21,17 @@ #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix sets) + #:use-module (guix ui) #:use-module ((gnu system file-systems) #:select (%tty-gid)) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) #:use-module (gnu packages guile-wm) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (user-account user-account? user-account-name @@ -48,7 +53,9 @@ default-skeletons skeleton-directory - %base-groups)) + %base-groups + %base-user-accounts + assert-valid-users/groups)) ;;; Commentary: ;;; @@ -107,6 +114,16 @@ (system-group (name "tape")) (system-group (name "kvm"))))) ; for /dev/kvm +(define %base-user-accounts + ;; List of standard user accounts. Note that "root" is a special case, so + ;; it's not listed here. + (list (user-account + (name "nobody") + (uid 65534) + (group "nogroup") + (home-directory "/var/empty") + (system? #t)))) + (define (default-skeletons) "Return the default skeleton files for /etc/skel. These files are copied by 'useradd' in the home directory of newly created user accounts." @@ -176,4 +193,31 @@ set debug-file-directory ~/.guix-profile/lib/debug\n"))) '#$skeletons) #t))) +(define (assert-valid-users/groups users groups) + "Raise an error if USERS refer to groups not listed in GROUPS." + (let ((groups (list->set (map user-group-name groups)))) + (define (validate-supplementary-group user group) + (unless (set-contains? groups group) + (raise (condition + (&message + (message + (format #f (_ "supplementary group '~a' \ +of user '~a' is undeclared") + group + (user-account-name user)))))))) + + (for-each (lambda (user) + (unless (set-contains? groups (user-account-group user)) + (raise (condition + (&message + (message + (format #f (_ "primary group '~a' \ +of user '~a' is undeclared") + (user-account-group user) + (user-account-name user))))))) + + (for-each (cut validate-supplementary-group user <>) + (user-account-supplementary-groups user))) + users))) + ;;; shadow.scm ends here 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." diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 30ce28b712..59f353e427 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -3,6 +3,7 @@ gnu/packages.scm gnu/system.scm gnu/services/dmd.scm +gnu/system/shadow.scm guix/scripts/build.scm guix/scripts/download.scm guix/scripts/package.scm diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 26a5e9d1a2..b361b1ba00 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -245,7 +245,7 @@ guix package -I unset GUIX_BUILD_OPTIONS -# Applying a manifest file +# Applying a manifest file. cat > "$module_dir/manifest.scm"<<EOF (use-package-modules bootstrap) @@ -254,3 +254,19 @@ EOF guix package --bootstrap -m "$module_dir/manifest.scm" guix package -I | grep guile test `guix package -I | wc -l` -eq 1 + +# Error reporting. +cat > "$module_dir/manifest.scm"<<EOF +(use-package-modules bootstrap) +(packages->manifest + (list %bootstrap-guile + wonderful-package-that-does-not-exist)) +EOF +if guix package --bootstrap -n -m "$module_dir/manifest.scm" \ + 2> "$module_dir/stderr" +then false +else + cat "$module_dir/stderr" + grep "manifest.scm:[1-3]:.*[Uu]nbound variable.*wonderful-package" \ + "$module_dir/stderr" +fi diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 1b77d1a0db..4289db2390 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -45,6 +45,32 @@ else fi +# Reporting of unbound variables. + +cat > "$tmpfile" <<EOF +(use-modules (gnu)) ; 1 +(use-service-modules networking) ; 2 + +(operating-system ; 4 + (host-name "antelope") ; 5 + (timezone "Europe/Paris") ; 6 + (locale "en_US.UTF-8") ; 7 + + (bootloader (GRUB-config (device "/dev/sdX"))) ; 9 + (file-systems (cons (file-system + (device "root") + (title 'label) + (mount-point "/") + (type "ext4")) + %base-file-systems))) +EOF + +if guix system build "$tmpfile" -n 2> "$errorfile" +then false +else + grep "$tmpfile:9:.*[Uu]nbound variable.*GRUB-config" "$errorfile" +fi + # Reporting of duplicate service identifiers. cat > "$tmpfile" <<EOF @@ -76,3 +102,42 @@ then else grep "service 'networking'.*more than once" "$errorfile" fi + +make_user_config () +{ + cat > "$tmpfile" <<EOF +(use-modules (gnu)) +(use-service-modules networking) + +(operating-system + (host-name "antelope") + (timezone "Europe/Paris") + (locale "en_US.UTF-8") + + (bootloader (grub-configuration (device "/dev/sdX"))) + (file-systems (cons (file-system + (device "root") + (title 'label) + (mount-point "/") + (type "ext4")) + %base-file-systems)) + (users (list (user-account + (name "dave") + (home-directory "/home/dave") + (group "$1") + (supplementary-groups '("$2")))))) +EOF +} + +make_user_config "users" "wheel" +guix system build "$tmpfile" -n # succeeds + +make_user_config "group-that-does-not-exist" "users" +if guix system build "$tmpfile" -n 2> "$errorfile" +then false +else grep "primary group.*group-that-does-not-exist.*undeclared" "$errorfile"; fi + +make_user_config "users" "group-that-does-not-exist" +if guix system build "$tmpfile" -n 2> "$errorfile" +then false +else grep "supplementary group.*group-that-does-not-exist.*undeclared" "$errorfile"; fi |