diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/environment.scm | 58 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 6 |
3 files changed, 49 insertions, 55 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 63f6129279..c27edc7982 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -33,6 +33,7 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu build linux-container) + #:use-module (gnu build accounts) #:use-module (gnu system linux-container) #:use-module (gnu system file-systems) #:use-module (gnu packages) @@ -458,10 +459,20 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (return (let* ((cwd (getcwd)) (home (getenv "HOME")) - (passwd (mock-passwd (getpwuid (getuid)) - user - bash)) - (home-dir (passwd:dir passwd)) + (passwd (let ((pwd (getpwuid (getuid)))) + (password-entry + (name (or user (passwd:name pwd))) + (real-name (if user + "" + (passwd:gecos pwd))) + (uid 0) (gid 0) (shell bash) + (directory (if user + (string-append "/home/" user) + (passwd:dir pwd)))))) + (groups (list (group-entry (name "users") (gid 0)) + (group-entry (gid 65534) ;the overflow GID + (name "overflow")))) + (home-dir (password-entry-directory passwd)) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. @@ -519,17 +530,8 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ;; to read it, such as 'git clone' over SSH, a valid use-case when ;; sharing the host's network namespace. (mkdir-p "/etc") - (call-with-output-file "/etc/passwd" - (lambda (port) - (display (string-join (list (passwd:name passwd) - "x" ; but there is no shadow - "0" "0" ; user is now root - (passwd:gecos passwd) - (passwd:dir passwd) - bash) - ":") - port) - (newline port))) + (write-passwd (list passwd)) + (write-group groups) ;; For convenience, start in the user's current working ;; directory rather than the root directory. @@ -543,32 +545,6 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (delq 'net %namespaces) ; share host network %namespaces))))))) -(define (mock-passwd passwd user-override shell) - "Generate mock information for '/etc/passwd'. If USER-OVERRIDE is not '#f', -it is expected to be a string representing the mock username; it will produce -a user of that name, with a home directory of '/home/USER-OVERRIDE', and no -GECOS field. If USER-OVERRIDE is '#f', data will be inherited from PASSWD. -In either case, the shadow password and UID/GID are cleared, since the user -runs as root within the container. SHELL will always be used in place of the -shell in PASSWD. - -The resulting vector is suitable for use with Guile's POSIX user procedures. - -See passwd(5) for more information each of the fields." - (if user-override - (vector - user-override - "x" "0" "0" ;; no shadow, user is now root - "" ;; no personal information - (user-override-home user-override) - shell) - (vector - (passwd:name passwd) - "x" "0" "0" ;; no shadow, user is now root - (passwd:gecos passwd) - (passwd:dir passwd) - shell))) - (define (user-override-home user) "Return home directory for override user USER." (string-append "/home/" user)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 730b6a0bf2..2aaf1cc44a 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -181,6 +181,7 @@ Download and deploy the latest version of Guix.\n")) (new (profile-package-alist (generation-file-name profile current)))) (display-new/upgraded-packages old new + #:concise? #t #:heading (G_ "New in this revision:\n")))) (_ #t))) @@ -377,11 +378,33 @@ of packages upgraded in ALIST2." alist2))) (values new upgraded))) +(define* (ellipsis #:optional (port (current-output-port))) + "Return HORIZONTAL ELLIPSIS three dots if PORT's encoding cannot represent +it." + (match (port-encoding port) + ("UTF-8" "…") + (_ "..."))) + (define* (display-new/upgraded-packages alist1 alist2 - #:key (heading "")) + #:key (heading "") concise?) "Given the two package name/version alists ALIST1 and ALIST2, display the list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 -and ALIST2 differ, display HEADING upfront." +and ALIST2 differ, display HEADING upfront. When CONCISE? is true, do not +display long package lists that would fill the user's screen." + (define (pretty str column) + (indented-string (fill-paragraph str (- (%text-width) 4) + column) + 4)) + + (define list->enumeration + (if concise? + (lambda* (lst #:optional (max 12)) + (if (> (length lst) max) + (string-append (string-join (take lst max) ", ") + ", " (ellipsis)) + (string-join lst ", "))) + (cut string-join <> ", "))) + (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) (unless (and (null? new) (null? upgraded)) (display heading)) @@ -392,21 +415,16 @@ and ALIST2 differ, display HEADING upfront." (format #t (N_ " ~h new package: ~a~%" " ~h new packages: ~a~%" count) count - (indented-string - (fill-paragraph (string-join (sort (map first new) string<?) - ", ") - (- (%text-width) 4) 30) - 4)))) + (pretty (list->enumeration (sort (map first new) string<?)) + 30)))) (match (length upgraded) (0 #t) (count (format #t (N_ " ~h package upgraded: ~a~%" " ~h packages upgraded: ~a~%" count) count - (indented-string - (fill-paragraph (string-join (sort upgraded string<?) ", ") - (- (%text-width) 4) 35) - 4)))))) + (pretty (list->enumeration (sort upgraded string<?)) + 35)))))) (define (display-profile-content-diff profile gen1 gen2) "Display the changes in PROFILE GEN2 compared to generation GEN1." diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 5b0f345cde..dd7026a6a4 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -297,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball changes) + (let-values (((version tarball source) (package-update store package updaters #:key-download key-download)) ((loc) @@ -330,10 +330,10 @@ warn about packages that have no matching updater." (G_ "~a: consider removing this propagated input: ~a~%"))) (package-name package) (upstream-input-change-name change))) - (changes)) + (upstream-source-input-changes source)) (let ((hash (call-with-input-file tarball port-sha256))) - (update-package-source package version hash))) + (update-package-source package source hash))) (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") (package-name package) version)))) |