From 7b7e4e89c8a1a34e166a2755493e48035e8a78ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 23 Mar 2019 23:09:45 +0100 Subject: tests: Add missing import. This is a followup to 22f95e028f038cee342f455dfc55bd32b804907c. * tests/scripts.scm: Use (guix tests). --- tests/scripts.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'tests') diff --git a/tests/scripts.scm b/tests/scripts.scm index efee271197..0315642f38 100644 --- a/tests/scripts.scm +++ b/tests/scripts.scm @@ -19,6 +19,7 @@ (define-module (test-scripts) #:use-module (guix scripts) + #:use-module (guix tests) #:use-module ((guix scripts build) #:select (%standard-build-options)) #:use-module (srfi srfi-64)) -- cgit v1.2.3 From 9c2e58564f3c8b53ce86d5791e3ea5818e1a4fd6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 24 Mar 2019 00:10:51 +0100 Subject: tests: Adjust 'guix pack -f squashfs' test. This is a followup to 427c87d0bdc06cc3ee7fc220fd3ad36084412533. * tests/pack.scm ("squashfs-image + localstatedir"): Expect "bin" to be a relative symlink. --- tests/pack.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index 40473a9fe9..ea88cd89f2 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -206,7 +206,11 @@ (define bin (file-exists? "var/guix/db/db.sqlite") (string=? (string-append #$%bootstrap-guile "/bin") (pk 'binlink (readlink bin))) - (string=? (string-append #$profile "/bin") + + ;; This is a relative symlink target. + (string=? (string-drop + (string-append #$profile "/bin") + 1) (pk 'guilelink (readlink "bin")))) (mkdir #$output)))))))) (built-derivations (list check))))) -- cgit v1.2.3 From abd4d6b33dba4de228e90ad15a8efb456fcf7b6e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 22 Mar 2019 14:02:00 +0100 Subject: records: Allow thunked fields to refer to 'this-record'. * guix/records.scm (this-record): New syntax parameter. (make-syntactic-constructor)[wrap-field-value]: When F is thunked, return a one-argument lambda instead of a thunk, and parameterize THIS-RECORD. (define-record-type*)[thunked-field-accessor-definition]: Pass X to (real-get X). * tests/records.scm ("define-record-type* & thunked & this-record") ("define-record-type* & thunked & default & this-record") ("define-record-type* & thunked & inherit & this-record"): New tests. --- guix/records.scm | 24 ++++++++++++++++++++++-- tests/records.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/records.scm b/guix/records.scm index 0649c90ea3..244b124098 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -25,6 +25,8 @@ (define-module (guix records) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:export (define-record-type* + this-record + alist->record object->fields recutils->alist @@ -93,6 +95,17 @@ (define (report-duplicate-field-specifier name ctor) (() #t))))))) +(define-syntax-parameter this-record + (lambda (s) + "Return the record being defined. This macro may only be used in the +context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-record + "cannot be used outside of a record instantiation" + #'id))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -148,7 +161,14 @@ (define (innate-field? f) (define (wrap-field-value f value) (cond ((thunked-field? f) - #`(lambda () #,value)) + #`(lambda (x) + (syntax-parameterize ((this-record + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + #,value))) ((delayed-field? f) #`(delay #,value)) (else value))) @@ -308,7 +328,7 @@ (define (thunked-field-accessor-definition field) (with-syntax ((real-get (wrapped-field-accessor-name field))) #'(define-inlinable (get x) ;; The real value of that field is a thunk, so call it. - ((real-get x))))))) + ((real-get x) x)))))) (define (delayed-field-accessor-definition field) ;; Return the real accessor for FIELD, which is assumed to be a diff --git a/tests/records.scm b/tests/records.scm index d9469a78bd..45614093a0 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -170,6 +170,46 @@ (define-record-type* foo make-foo (parameterize ((mark (cons 'a 'b))) (eq? (foo-bar y) (mark))))))) +(test-assert "define-record-type* & thunked & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked))) + + (let ((x (foo (bar 40) + (baz (+ (foo-bar this-record) 2))))) + (and (= 40 (foo-bar x)) + (= 42 (foo-baz x)))))) + +(test-assert "define-record-type* & thunked & default & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked) + (default (+ (foo-bar this-record) 2)))) + + (let ((x (foo (bar 40)))) + (and (= 40 (foo-bar x)) + (= 42 (foo-baz x)))))) + +(test-assert "define-record-type* & thunked & inherit & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked) + (default (+ (foo-bar this-record) 2)))) + + (let* ((x (foo (bar 40))) + (y (foo (inherit x) (bar -2))) + (z (foo (inherit x) (baz -2)))) + (and (= -2 (foo-bar y)) + (= 0 (foo-baz y)) + (= 40 (foo-bar z)) + (= -2 (foo-baz z)))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo -- cgit v1.2.3 From cf848cc0a17a3a58d600116896f6e7abfb0440d4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 22 Mar 2019 14:06:54 +0100 Subject: accounts: Add default value for the 'home-directory' field of . * gnu/system/accounts.scm ()[home-directory]: Mark as thunked and add a default value. (default-home-directory): New procedure. * doc/guix.texi (User Accounts): Remove 'home-directory' from example. * gnu/system/examples/bare-bones.tmpl: Likewise. * gnu/system/examples/beaglebone-black.tmpl: Likewise. * gnu/system/examples/desktop.tmpl: Likewise. * gnu/system/examples/docker-image.tmpl: Likewise. * gnu/system/examples/lightweight-desktop.tmpl: Likewise. * gnu/system/install.scm (installation-os): Likewise. * gnu/tests.scm (%simple-os): Likewise. * gnu/tests/install.scm (%minimal-os, %minimal-os-on-vda): (%separate-home-os, %encrypted-root-os, %btrfs-root-os): Likewise. * tests/accounts.scm ("allocate-passwd") ("allocate-passwd with previous state"): Likewise. --- doc/guix.texi | 1 - gnu/system/accounts.scm | 7 ++++++- gnu/system/examples/bare-bones.tmpl | 3 +-- gnu/system/examples/beaglebone-black.tmpl | 3 +-- gnu/system/examples/desktop.tmpl | 3 +-- gnu/system/examples/docker-image.tmpl | 3 +-- gnu/system/examples/lightweight-desktop.tmpl | 3 +-- gnu/system/install.scm | 3 +-- gnu/tests.scm | 5 ++--- gnu/tests/install.scm | 14 ++++---------- tests/accounts.scm | 4 ---- 11 files changed, 18 insertions(+), 31 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 63405bcf49..37fef40522 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10927,7 +10927,6 @@ this field must contain the encrypted password, as a string. You can use the @example (user-account (name "charlie") - (home-directory "/home/charlie") (group "users") ;; Specify a SHA-512-hashed initial password. diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm index eb18fb5e43..586cff1842 100644 --- a/gnu/system/accounts.scm +++ b/gnu/system/accounts.scm @@ -67,7 +67,8 @@ (define-record-type* (supplementary-groups user-account-supplementary-groups (default '())) ; list of strings (comment user-account-comment (default "")) - (home-directory user-account-home-directory) + (home-directory user-account-home-directory (thunked) + (default (default-home-directory this-record))) (create-home-directory? user-account-create-home-directory? ;Boolean (default #t)) (shell user-account-shell ; gexp @@ -84,6 +85,10 @@ (define-record-type* (system? user-group-system? ; Boolean (default #f))) +(define (default-home-directory account) + "Return the default home directory for ACCOUNT." + (string-append "/home/" (user-account-name account))) + (define (sexp->user-group sexp) "Take SEXP, a tuple as returned by 'user-group->gexp', and turn it into a user-group record." diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index a88bab034f..4f30a5b756 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -35,8 +35,7 @@ ;; and "video" allows the user to play sound ;; and access the webcam. (supplementary-groups '("wheel" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Globally-installed packages. diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl index 11678063b2..def05e807d 100644 --- a/gnu/system/examples/beaglebone-black.tmpl +++ b/gnu/system/examples/beaglebone-black.tmpl @@ -38,8 +38,7 @@ ;; and "video" allows the user to play sound ;; and access the webcam. (supplementary-groups '("wheel" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Globally-installed packages. diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index c59bf92681..bc5cbd6e6b 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -42,8 +42,7 @@ (comment "Alice's brother") (group "users") (supplementary-groups '("wheel" "netdev" - "audio" "video")) - (home-directory "/home/bob")) + "audio" "video"))) %base-user-accounts)) ;; This is where we specify system-wide packages. diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl index 9690d651c1..ca633cc838 100644 --- a/gnu/system/examples/docker-image.tmpl +++ b/gnu/system/examples/docker-image.tmpl @@ -15,8 +15,7 @@ (comment "Bob's sister") (group "users") (supplementary-groups '("wheel" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Globally-installed packages. diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl index a234badd2b..45d9bf447f 100644 --- a/gnu/system/examples/lightweight-desktop.tmpl +++ b/gnu/system/examples/lightweight-desktop.tmpl @@ -35,8 +35,7 @@ (comment "Bob's sister") (group "users") (supplementary-groups '("wheel" "netdev" - "audio" "video")) - (home-directory "/home/alice")) + "audio" "video"))) %base-user-accounts)) ;; Add a bunch of window managers; we can choose one at diff --git a/gnu/system/install.scm b/gnu/system/install.scm index bad318d06b..aad1deb913 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -379,8 +379,7 @@ (define installation-os (group "users") (supplementary-groups '("wheel")) ; allow use of sudo (password "") - (comment "Guest of GNU") - (home-directory "/home/guest")))) + (comment "Guest of GNU")))) (issue %issue) (services %installation-services) diff --git a/gnu/tests.scm b/gnu/tests.scm index 9e8eed7d95..0871b4c6f7 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; @@ -219,8 +219,7 @@ (define %simple-os (name "alice") (comment "Bob's sister") (group "users") - (supplementary-groups '("wheel" "audio" "video")) - (home-directory "/home/alice")) + (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)))) (define-syntax-rule (simple-operating-system user-services ...) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 277908cc49..c0debbd840 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -74,8 +74,7 @@ (define-os-with-source (%minimal-os %minimal-os-source) (name "alice") (comment "Bob's sister") (group "users") - (supplementary-groups '("wheel" "audio" "video")) - (home-directory "/home/alice")) + (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type (marionette-configuration @@ -357,8 +356,7 @@ (define-os-with-source (%minimal-os-on-vda %minimal-os-on-vda-source) (name "alice") (comment "Bob's sister") (group "users") - (supplementary-groups '("wheel" "audio" "video")) - (home-directory "/home/alice")) + (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type (marionette-configuration @@ -435,12 +433,10 @@ (define-os-with-source (%separate-home-os %separate-home-os-source) %base-file-systems)) (users (cons* (user-account (name "alice") - (group "users") - (home-directory "/home/alice")) + (group "users")) (user-account (name "charlie") - (group "users") - (home-directory "/home/charlie")) + (group "users")) %base-user-accounts)) (services (cons (service marionette-service-type (marionette-configuration @@ -655,7 +651,6 @@ (define-os-with-source (%encrypted-root-os %encrypted-root-os-source) (users (cons (user-account (name "charlie") (group "users") - (home-directory "/home/charlie") (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type @@ -776,7 +771,6 @@ (define-os-with-source (%btrfs-root-os %btrfs-root-os-source) (users (cons (user-account (name "charlie") (group "users") - (home-directory "/home/charlie") (supplementary-groups '("wheel" "audio" "video"))) %base-user-accounts)) (services (cons (service marionette-service-type diff --git a/tests/accounts.scm b/tests/accounts.scm index 127861042d..923ba7dc83 100644 --- a/tests/accounts.scm +++ b/tests/accounts.scm @@ -199,12 +199,10 @@ (define allocate-passwd (@@ (gnu build accounts) allocate-passwd)) (directory "/var/empty"))) (allocate-passwd (list (user-account (name "alice") (comment "Alice") - (home-directory "/home/alice") (shell "/bin/sh") (group "users")) (user-account (name "bob") (comment "Bob") - (home-directory "/home/bob") (shell "/bin/gash") (group "wheel")) (user-account (name "sshd") (system? #t) @@ -234,12 +232,10 @@ (define allocate-passwd (@@ (gnu build accounts) allocate-passwd)) (directory "/home/charlie"))) (allocate-passwd (list (user-account (name "alice") (comment "Alice") - (home-directory "/home/alice") (shell "/bin/sh") ;ignored (group "users")) (user-account (name "charlie") (comment "Charlie") - (home-directory "/home/charlie") (shell "/bin/sh") (group "users"))) (list (group-entry (name "users") (gid 1000))) -- cgit v1.2.3 From 8a9922bdee875b3b5e1d928fc8e2121ffa99663a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 26 Mar 2019 12:12:41 +0100 Subject: environment: Use (gnu build accounts) for /etc/passwd handling. * guix/scripts/environment.scm (launch-environment/container): Remove call to 'mock-passwd'; instantiate a instead. Call 'write-passwd' to write the pasword database instead of using custom code. (mock-passwd): Remove. * tests/guix-environment-container.sh: Test 'getpwuid'. --- guix/scripts/environment.scm | 54 +++++++++---------------------------- tests/guix-environment-container.sh | 6 +++++ 2 files changed, 19 insertions(+), 41 deletions(-) (limited to 'tests') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 63f6129279..597a5b4ab1 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -33,6 +33,7 @@ (define-module (guix scripts environment) #: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,17 @@ (define* (launch-environment/container #:key command bash user user-mappings (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)))))) + (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 +527,7 @@ (define* (launch-environment/container #:key command bash user user-mappings ;; 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)) ;; For convenience, start in the user's current working ;; directory rather than the root directory. @@ -543,32 +541,6 @@ (define* (launch-environment/container #:key command bash user user-mappings (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/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index a2da9a0773..059c4d9213 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,12 @@ else test $? = 42 fi +if test "x$USER" = "x"; then USER="`id -un`"; fi + +# Check whether /etc/passwd is valid. +guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c "(exit (string=? \"$USER\" (passwd:name (getpwuid (getuid)))))" + # Make sure file-not-found errors in mounts are reported. if guix environment --container --ad-hoc --bootstrap guile-bootstrap \ --expose=/does-not-exist -- guile -c 1 2> "$tmpdir/error" -- cgit v1.2.3 From 952afb6f8c209692e52f9561965ee39e143e1d88 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 26 Mar 2019 18:07:58 +0100 Subject: environment: Create /etc/group in containers. Reported by Pierre Neidhardt . * guix/scripts/environment.scm (launch-environment/container): Create GROUPS and call 'write-group'. * tests/guix-environment-container.sh: Test it. --- guix/scripts/environment.scm | 4 ++++ tests/guix-environment-container.sh | 8 +++++++- 2 files changed, 11 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 597a5b4ab1..c27edc7982 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -469,6 +469,9 @@ (define* (launch-environment/container #:key command bash user user-mappings (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 @@ -528,6 +531,7 @@ (define* (launch-environment/container #:key command bash user user-mappings ;; sharing the host's network namespace. (mkdir-p "/etc") (write-passwd (list passwd)) + (write-group groups) ;; For convenience, start in the user's current working ;; directory rather than the root directory. diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 059c4d9213..f2221af95b 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -46,9 +46,15 @@ fi if test "x$USER" = "x"; then USER="`id -un`"; fi -# Check whether /etc/passwd is valid. +# Check whether /etc/passwd and /etc/group are valid. guix environment -C --ad-hoc --bootstrap guile-bootstrap \ -- guile -c "(exit (string=? \"$USER\" (passwd:name (getpwuid (getuid)))))" +guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(exit (string? (group:name (getgrgid (getgid)))))' +guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(use-modules (srfi srfi-1)) + (exit (every group:name + (map getgrgid (vector->list (getgroups)))))' # Make sure file-not-found errors in mounts are reported. if guix environment --container --ad-hoc --bootstrap guile-bootstrap \ -- cgit v1.2.3 From d2be7e3c4ba8d6d0dde9b4c0bff623ab85637424 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 29 Mar 2019 22:40:55 +0100 Subject: records: Support custom 'this' identifiers. This lets record users choose an identifier other than 'this-record'. * guix/records.scm (make-syntactic-constructor): Add #:this-identifier. [wrap-field-value]: Honor it. (define-record-type*): Add form with extra THIS-IDENTIFIER and honor it. * tests/records.scm ("define-record-type* & thunked & inherit & custom this"): New test. --- guix/records.scm | 32 +++++++++++++++++++++++++++++--- tests/records.scm | 18 ++++++++++++++++++ 2 files changed, 47 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/records.scm b/guix/records.scm index 244b124098..99507dc384 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -118,6 +118,7 @@ (define-syntax make-syntactic-constructor ((_ type name ctor (expected ...) #:abi-cookie abi-cookie #:thunked thunked + #:this-identifier this-identifier #:delayed delayed #:innate innate #:defaults defaults) @@ -162,7 +163,7 @@ (define (innate-field? f) (define (wrap-field-value f value) (cond ((thunked-field? f) #`(lambda (x) - (syntax-parameterize ((this-record + (syntax-parameterize ((#,this-identifier (lambda (s) (syntax-case s () (id @@ -254,6 +255,7 @@ (define-syntax define-record-type* (define-record-type* thing make-thing thing? + this-thing (name thing-name (default \"chbouib\")) (port thing-port (default (current-output-port)) (thunked)) @@ -273,7 +275,8 @@ (define-record-type* thing make-thing The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will actually compute the field's value in the current dynamic extent, which is -useful when referring to fluids in a field's value. +useful when referring to fluids in a field's value. Furthermore, that thunk +can access the record it belongs to via the 'this-thing' identifier. A field can also be marked as \"delayed\" instead of \"thunked\", in which case its value is effectively wrapped in a (delay …) form. @@ -352,7 +355,9 @@ (define (compute-abi-cookie field-specs) (syntax-case s () ((_ type syntactic-ctor ctor pred + this-identifier (field get properties ...) ...) + (identifier? #'this-identifier) (let* ((field-spec #'((field get properties ...) ...)) (thunked (filter-map thunked-field? field-spec)) (delayed (filter-map delayed-field? field-spec)) @@ -381,15 +386,36 @@ (define-record-type type field-spec* ...) (define #,(current-abi-identifier #'type) #,cookie) + + #,@(if (free-identifier=? #'this-identifier #'this-record) + #'() + #'((define-syntax-parameter this-identifier + (lambda (s) + "Return the record being defined. This macro may +only be used in the context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-identifier + "cannot be used outside \ +of a record instantiation" + #'id))))))) thunked-field-accessor ... delayed-field-accessor ... (make-syntactic-constructor type syntactic-ctor ctor (field ...) #:abi-cookie #,cookie #:thunked #,thunked + #:this-identifier #'this-identifier #:delayed #,delayed #:innate #,innate - #:defaults #,defaults)))))))) + #:defaults #,defaults))))) + ((_ type syntactic-ctor ctor pred + (field get properties ...) ...) + ;; When no 'this' identifier was specified, use 'this-record'. + #'(define-record-type* type syntactic-ctor ctor pred + this-record + (field get properties ...) ...))))) (define* (alist->record alist make keys #:optional (multiple-value-keys '())) diff --git a/tests/records.scm b/tests/records.scm index 45614093a0..16b7a9c35e 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -210,6 +210,24 @@ (define-record-type* foo make-foo (= 40 (foo-bar z)) (= -2 (foo-baz z)))))) +(test-assert "define-record-type* & thunked & inherit & custom this" + (let () + (define-record-type* foo make-foo + foo? this-foo + (thing foo-thing (thunked))) + (define-record-type* bar make-bar + bar? this-bar + (baz bar-baz (thunked))) + + ;; Nest records and test the two self references. + (let* ((x (foo (thing (bar (baz (list this-bar this-foo)))))) + (y (foo-thing x))) + (match (bar-baz y) + ((first second) + (and (eq? second x) + (bar? first) + (eq? first y))))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo -- cgit v1.2.3 From af76c020bf19de5fe2e92f31d8b85cbd55c481de Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Apr 2019 10:34:48 +0200 Subject: linux-container: Make the guest UID and GID a parameter. * gnu/build/linux-container.scm (initialize-user-namespace): Add #:guest-uid and #:guest-gid parameters and honor them. (run-container): Likewise. (call-with-container): Likewise. * tests/containers.scm ("call-with-container, user namespace, guest UID/GID"): New test. --- gnu/build/linux-container.scm | 48 ++++++++++++++++++++++++++++--------------- tests/containers.scm | 11 ++++++++++ 2 files changed, 43 insertions(+), 16 deletions(-) (limited to 'tests') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 65e1325577..3d7b52f098 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -168,9 +168,12 @@ (define* (mount* source target type #:optional (flags 0) options (umount "real-root" MNT_DETACH) (rmdir "real-root"))) -(define (initialize-user-namespace pid host-uids) +(define* (initialize-user-namespace pid host-uids + #:key (guest-uid 0) (guest-gid 0)) "Configure the user namespace for PID. HOST-UIDS specifies the number of -host user identifiers to map into the user namespace." +host user identifiers to map into the user namespace. GUEST-UID and GUEST-GID +specify the first UID (respectively GID) that host UIDs (respectively GIDs) +map to in the namespace." (define proc-dir (string-append "/proc/" (number->string pid))) @@ -191,10 +194,10 @@ (define (scope file) ;; within the container. (call-with-output-file (scope "/uid_map") (lambda (port) - (format port "0 ~d ~d" uid host-uids))) + (format port "~d ~d ~d" guest-uid uid host-uids))) (call-with-output-file (scope "/gid_map") (lambda (port) - (format port "0 ~d ~d" gid host-uids))))) + (format port "~d ~d ~d" guest-gid gid host-uids))))) (define (namespaces->bit-mask namespaces) "Return the number suitable for the 'flags' argument of 'clone' that @@ -210,13 +213,17 @@ (define (namespaces->bit-mask namespaces) ('net CLONE_NEWNET)) namespaces))) -(define (run-container root mounts namespaces host-uids thunk) +(define* (run-container root mounts namespaces host-uids thunk + #:key (guest-uid 0) (guest-gid 0)) "Run THUNK in a new container process and return its PID. ROOT specifies the root directory for the container. MOUNTS is a list of objects that specify file systems to mount inside the container. NAMESPACES is a list of symbols that correspond to the possible Linux namespaces: mnt, -ipc, uts, user, and net. HOST-UIDS specifies the number of -host user identifiers to map into the user namespace." +ipc, uts, user, and net. + +HOST-UIDS specifies the number of host user identifiers to map into the user +namespace. GUEST-UID and GUEST-GID specify the first UID (respectively GID) +that host UIDs (respectively GIDs) map to in the namespace." ;; The parent process must initialize the user namespace for the child ;; before it can boot. To negotiate this, a pipe is used such that the ;; child process blocks until the parent writes to it. @@ -254,7 +261,9 @@ (define (run-container root mounts namespaces host-uids thunk) (pid (close-port child) (when (memq 'user namespaces) - (initialize-user-namespace pid host-uids)) + (initialize-user-namespace pid host-uids + #:guest-uid guest-uid + #:guest-gid guest-gid)) ;; TODO: Initialize cgroups. (write 'ready parent) (newline parent) @@ -271,23 +280,30 @@ (define (run-container root mounts namespaces host-uids thunk) #f))))))))) (define* (call-with-container mounts thunk #:key (namespaces %namespaces) - (host-uids 1)) + (host-uids 1) (guest-uid 0) (guest-gid 0)) "Run THUNK in a new container process and return its exit status. MOUNTS is a list of objects that specify file systems to mount inside the container. NAMESPACES is a list of symbols corresponding to the identifiers for Linux namespaces: mnt, ipc, uts, pid, user, and net. By -default, all namespaces are used. HOST-UIDS is the number of host user -identifiers to map into the container's user namespace, if there is one. By -default, only a single uid/gid, that of the current user, is mapped into the -container. The host user that creates the container is the root user (uid/gid -0) within the container. Only root can map more than a single uid/gid. +default, all namespaces are used. + +HOST-UIDS is the number of host user identifiers to map into the container's +user namespace, if there is one. By default, only a single uid/gid, that of +the current user, is mapped into the container. The host user that creates +the container is the root user (uid/gid 0) within the container. Only root +can map more than a single uid/gid. + +GUEST-UID and GUEST-GID specify the first UID (respectively GID) that host +UIDs (respectively GIDs) map to in the namespace. Note that if THUNK needs to load any additional Guile modules, the relevant module files must be present in one of the mappings in MOUNTS and the Guile load path must be adjusted as needed." (call-with-temporary-directory (lambda (root) - (let ((pid (run-container root mounts namespaces host-uids thunk))) + (let ((pid (run-container root mounts namespaces host-uids thunk + #:guest-uid guest-uid + #:guest-gid guest-gid))) ;; Catch SIGINT and kill the container process. (sigaction SIGINT (lambda (signum) diff --git a/tests/containers.scm b/tests/containers.scm index 5323e5037d..37408f380d 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson +;;; Copyright © 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,6 +52,16 @@ (define (skip-if-unsupported) (assert-exit (and (zero? (getuid)) (zero? (getgid))))) #:namespaces '(user)))) +(skip-if-unsupported) +(test-assert "call-with-container, user namespace, guest UID/GID" + (zero? + (call-with-container '() + (lambda () + (assert-exit (and (= 42 (getuid)) (= 77 (getgid))))) + #:guest-uid 42 + #:guest-gid 77 + #:namespaces '(user)))) + (skip-if-unsupported) (test-assert "call-with-container, uts namespace" (zero? -- cgit v1.2.3 From 1ccc0f807d3f22fa9ade1c607c112e04df833a72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Apr 2019 10:57:24 +0200 Subject: environment: '-C' creates namespaces where the user is not root. * guix/scripts/environment.scm (launch-environment/container): Add UID and GID. Use them in PASSWD and GROUPS. Pass them as #:guest-uid and #:guest-gid to 'call-with-container'. * tests/guix-environment-container.sh: Test the inner UID. In '--user' test, replace hard-coded 0 with 1000. * doc/guix.texi (Invoking guix environment): Adjust accordingly. --- doc/guix.texi | 13 ++++++++----- guix/scripts/environment.scm | 8 ++++++-- tests/guix-environment-container.sh | 15 ++++++++++++++- 3 files changed, 28 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 616970b505..616c2ef305 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4557,9 +4557,11 @@ Run @var{command} within an isolated container. The current working directory outside the container is mapped inside the container. Additionally, unless overridden with @code{--user}, a dummy home directory is created that matches the current user's home directory, and -@file{/etc/passwd} is configured accordingly. The spawned process runs -as the current user outside the container, but has root privileges in -the context of the container. +@file{/etc/passwd} is configured accordingly. + +The spawned process runs as the current user outside the container. Inside +the container, it has the same UID and GID as the current user, unless +@option{--user} is passed (see below.) @item --network @itemx -N @@ -4587,8 +4589,9 @@ the environment. @itemx -u @var{user} For containers, use the username @var{user} in place of the current user. The generated @file{/etc/passwd} entry within the container will -contain the name @var{user}; the home directory will be -@file{/home/USER}; and no user GECOS data will be copied. @var{user} +contain the name @var{user}, the home directory will be +@file{/home/@var{user}}, and no user GECOS data will be copied. Furthermore, +the UID and GID inside the container are 1000. @var{user} need not exist on the system. Additionally, any shared or exposed path (see @code{--share} and diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index c27edc7982..2d1ba4c938 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -459,17 +459,19 @@ (define* (launch-environment/container #:key command bash user user-mappings (return (let* ((cwd (getcwd)) (home (getenv "HOME")) + (uid (if user 1000 (getuid))) + (gid (if user 1000 (getgid))) (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) + (uid uid) (gid gid) (shell bash) (directory (if user (string-append "/home/" user) (passwd:dir pwd)))))) - (groups (list (group-entry (name "users") (gid 0)) + (groups (list (group-entry (name "users") (gid gid)) (group-entry (gid 65534) ;the overflow GID (name "overflow")))) (home-dir (password-entry-directory passwd)) @@ -541,6 +543,8 @@ (define* (launch-environment/container #:key command bash user user-mappings ;; A container's environment is already purified, so no need to ;; request it be purified again. (launch-environment command profile manifest #:pure? #f))) + #:guest-uid uid + #:guest-gid gid #:namespaces (if network? (delq 'net %namespaces) ; share host network %namespaces))))))) diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index f2221af95b..78507f76c0 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,19 @@ else test $? = 42 fi +# By default, the UID inside the container should be the same as outside. +uid="`id -u`" +inner_uid="`guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(display (getuid))'`" +test $inner_uid = $uid + +# When '--user' is passed, the UID should be 1000. (Note: Use a separate HOME +# so that we don't run into problems when the test directory is under /home.) +export tmpdir +inner_uid="`HOME=$tmpdir guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + --user=gnu-guix -- guile -c '(display (getuid))'`" +test $inner_uid = 1000 + if test "x$USER" = "x"; then USER="`id -un`"; fi # Check whether /etc/passwd and /etc/group are valid. @@ -123,7 +136,7 @@ rm $tmpdir/mounts # Test that user can be mocked. usertest='(exit (and (string=? (getenv "HOME") "/home/foognu") - (string=? (passwd:name (getpwuid 0)) "foognu") + (string=? (passwd:name (getpwuid 1000)) "foognu") (file-exists? "/home/foognu/umock")))' touch "$tmpdir/umock" HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \ -- cgit v1.2.3 From 72eda0624be89ed18302fd7d7f22976071ab020c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 22:27:57 +0200 Subject: Add (guix store roots). * guix/store/roots.scm, tests/store-roots.scm: New files. * Makefile.am (STORE_MODULES): Add guix/store/roots.scm. (SCM_TESTS): Add tests/store-roots.scm. --- Makefile.am | 6 ++- guix/store/roots.scm | 120 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/store-roots.scm | 53 ++++++++++++++++++++++ 3 files changed, 177 insertions(+), 2 deletions(-) create mode 100644 guix/store/roots.scm create mode 100644 tests/store-roots.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 87682b4949..704f2451c3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -277,7 +277,8 @@ endif BUILD_DAEMON_OFFLOAD # Scheme implementation of the build daemon and related functionality. STORE_MODULES = \ guix/store/database.scm \ - guix/store/deduplication.scm + guix/store/deduplication.scm \ + guix/store/roots.scm MODULES += $(STORE_MODULES) @@ -408,7 +409,8 @@ SCM_TESTS = \ tests/pypi.scm \ tests/import-utils.scm \ tests/store-database.scm \ - tests/store-deduplication.scm + tests/store-deduplication.scm \ + tests/store-roots.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/store/roots.scm b/guix/store/roots.scm new file mode 100644 index 0000000000..4f23ae34e8 --- /dev/null +++ b/guix/store/roots.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix store roots) + #:use-module (guix config) + #:use-module ((guix store) #:select (store-path? %gc-roots-directory)) + #:use-module (guix sets) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:re-export (%gc-roots-directory) + #:export (gc-roots + user-owned?)) + +;;; Commentary: +;;; +;;; This module provides tools to list and access garbage collector roots ("GC +;;; roots"). +;;; +;;; Code: + +(define %profile-directory + ;; Directory where user profiles are stored. + ;; XXX: This is redundant with the definition in (guix profiles) and not + ;; entirely needed since in practice /var/guix/gcroots/profiles links to + ;; it. + (string-append %state-directory "/profiles")) + +(define (gc-roots) + "Return the list of garbage collector roots (\"GC roots\"). This includes +\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that +are user-controlled symlinks stored anywhere on the file system." + (define (regular? file) + (match file + (((or "." "..") . _) #f) + (_ #t))) + + (define (file-type=? type) + (match-lambda + ((file . properties) + (match (assq-ref properties 'type) + ('unknown + (let ((stat (lstat file))) + (eq? type (stat:type stat)))) + (actual-type + (eq? type actual-type)))))) + + (define directory? + (file-type=? 'directory)) + + (define symlink? + (file-type=? 'symlink)) + + (define canonical-root + (match-lambda + ((file . properties) + (let ((target (readlink file))) + (cond ((store-path? target) + ;; Regular root: FILE points to the store. + file) + + ;; Indirect root: FILE points to a user-controlled file outside + ;; the store. + ((string-prefix? "/" target) + target) + (else + (string-append (dirname file) "/" target))))))) + + (let loop ((directories (list %gc-roots-directory + %profile-directory)) + (roots '()) + (visited (set))) + (match directories + (() + roots) + ((directory . rest) + (if (set-contains? visited directory) + (loop rest roots visited) + (let*-values (((scope) + (cut string-append directory "/" <>)) + ((sub-directories files) + (partition directory? + (map (match-lambda + ((file . properties) + (cons (scope file) properties))) + (scandir* directory regular?))))) + (loop (append rest (map first sub-directories)) + (append (map canonical-root (filter symlink? files)) + roots) + (set-insert directory visited)))))))) + +(define* (user-owned? root #:optional (uid (getuid))) + "Return true if ROOT exists and is owned by UID, false otherwise." + ;; If ROOT is an indirect root, then perhaps it no longer exists. Thus, + ;; catch 'system-error' exceptions. + (catch 'system-error + (lambda () + (define stat + (lstat root)) + + (= (stat:uid stat) uid)) + (const #f))) diff --git a/tests/store-roots.scm b/tests/store-roots.scm new file mode 100644 index 0000000000..5bcf1bc87e --- /dev/null +++ b/tests/store-roots.scm @@ -0,0 +1,53 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-store-deduplication) + #:use-module (guix tests) + #:use-module (guix store) + #:use-module (guix store roots) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define %store + (open-connection)) + +(test-begin "store-roots") + +(test-assert "gc-roots, regular root" + (let* ((item (add-text-to-store %store "something" + (random-text))) + (root (string-append %gc-roots-directory "/test-gc-root"))) + (symlink item root) + (let ((result (member root (gc-roots)))) + (delete-file root) + result))) + +(test-assert "gc-roots, indirect root" + (call-with-temporary-directory + (lambda (directory) + (let* ((item (add-text-to-store %store "something" + (random-text))) + (root (string-append directory "/gc-root"))) + (symlink item root) + (add-indirect-root %store root) + (let ((result (member root (gc-roots)))) + (delete-file root) + result))))) + +(test-end "store-roots") -- cgit v1.2.3 From bacf980c76c94e7bda86220ca4bf662d0e34a45a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 22:29:18 +0200 Subject: guix gc: Add '--list-roots'. * guix/scripts/gc.scm (show-help, %options): Add '--list-roots'. (guix-gc)[list-roots]: New procedure. Handle '--list-roots'. * tests/guix-gc.sh: Test it. * doc/guix.texi (Invoking guix gc): Document it. --- doc/guix.texi | 6 +++++- guix/scripts/gc.scm | 21 ++++++++++++++++++++- tests/guix-gc.sh | 6 ++++-- 3 files changed, 29 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 2f9fcbe3bf..2345617b2e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3385,7 +3385,7 @@ deleted. The set of garbage collector roots (``GC roots'' for short) includes default user profiles; by default, the symlinks under @file{/var/guix/gcroots} represent these GC roots. New GC roots can be added with @command{guix build --root}, for example (@pxref{Invoking -guix build}). +guix build}). The @command{guix gc --list-roots} command lists them. Prior to running @code{guix gc --collect-garbage} to make space, it is often useful to remove old generations from user profiles; that way, old @@ -3451,6 +3451,10 @@ This prints nothing unless the daemon was started with @option{--cache-failures} (@pxref{Invoking guix-daemon, @option{--cache-failures}}). +@item --list-roots +List the GC roots owned by the user; when run as root, list @emph{all} the GC +roots. + @item --clear-failures Remove the specified store items from the failed-build cache. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 6f37b767ff..2606e20deb 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ (define-module (guix scripts gc) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix store) + #:use-module (guix store roots) #:autoload (guix build syscalls) (free-disk-space) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -48,6 +49,8 @@ (define (show-help) -F, --free-space=FREE attempt to reach FREE available space in the store")) (display (G_ " -d, --delete attempt to delete PATHS")) + (display (G_ " + --list-roots list the user's garbage collector roots")) (display (G_ " --optimize optimize the store by deduplicating identical files")) (display (G_ " @@ -135,6 +138,10 @@ (define %options (alist-cons 'verify-options options (alist-delete 'action result)))))) + (option '("list-roots") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-roots + (alist-delete 'action result)))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -205,6 +212,15 @@ (define (ensure-free-space store space) (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.)) (collect-garbage store to-free))))) + (define (list-roots) + ;; List all the user-owned GC roots. + (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?) + (gc-roots)))) + (for-each (lambda (root) + (display root) + (newline)) + roots))) + (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) @@ -238,6 +254,9 @@ (define (list-relatives relatives) (else (let-values (((paths freed) (collect-garbage store))) (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.))))))) + ((list-roots) + (assert-no-extra-arguments) + (list-roots)) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index ef2d9543b7..8284287730 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2015, 2017, 2018 Ludovic Courtès +# Copyright © 2013, 2015, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -34,7 +34,7 @@ unset drv unset out # For some operations, passing extra arguments is an error. -for option in "" "-C 500M" "--verify" "--optimize" +for option in "" "-C 500M" "--verify" "--optimize" "--list-roots" do if guix gc $option whatever; then false; else true; fi done @@ -69,6 +69,8 @@ guix gc --delete "$drv" drv="`guix build --root=guix-gc-root lsh -d`" test -f "$drv" && test -L guix-gc-root +guix gc --list-roots | grep "$PWD/guix-gc-root" + guix gc --list-live | grep "$drv" if guix gc --delete "$drv"; then false; else true; fi -- cgit v1.2.3 From 4aea820f0954fce4d076718072faf211f62f3f9d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Apr 2019 16:57:12 +0200 Subject: guix build: Fix relative file name canonicalization for '--root'. Fixes . Reported by rendaw <7e9wc56emjakcm@s.rendaw.me>. * guix/scripts/build.scm (register-root): When ROOT is a relative file name, append the basename of ROOT, not ROOT itself. * tests/guix-build.sh: Add test. --- guix/scripts/build.scm | 2 +- tests/guix-build.sh | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 28864435df..fc0c0e2ad3 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -119,7 +119,7 @@ (define (register-root store paths root) (let* ((root (if (string-prefix? "/" root) root (string-append (canonicalize-path (dirname root)) - "/" root)))) + "/" (basename root))))) (catch 'system-error (lambda () (match paths diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 66bf6be8d0..d479296ef1 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -183,6 +183,13 @@ then false; else true; fi rm -f "$result" +# Check relative file name canonicalization: . +mkdir "$result" +guix build -r "$result/x" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' +test -x "$result/x/bin/guile" +rm "$result/x" +rmdir "$result" + # Cross building. guix build coreutils --target=mips64el-linux-gnu --dry-run --no-substitutes -- cgit v1.2.3 From b2c3640d2baa7bc929bf21880e6fb2785f5997f6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 17:29:25 +0200 Subject: tests: Gracefully skip zlib test when zlib is missing. * tests/zlib.scm: Use 'test-skip' instead of (exit 77) when (zlib-available?) returns false. --- tests/zlib.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/tests/zlib.scm b/tests/zlib.scm index 5455240a71..7c595a422c 100644 --- a/tests/zlib.scm +++ b/tests/zlib.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,11 +26,10 @@ (define-module (test-zlib) ;; Test the (guix zlib) module. -(unless (zlib-available?) - (exit 77)) - (test-begin "zlib") +(unless (zlib-available?) + (test-skip 1)) (test-assert "compression/decompression pipe" (let ((data (random-bytevector (+ (random 10000) (* 20 1024))))) -- cgit v1.2.3 From ea261dea0c581771b4cf297e983f7addc6807051 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 19 Apr 2019 15:18:20 +0200 Subject: guix build: Accept multiple '-s' options. * guix/scripts/build.scm (%default-options): Remove 'system'. (%options) <--system>: Keep previous occurrences of 'system in RESULT. (options->derivations)[system]: Remove. [systems, things-to-build]: New variables. [compute-derivation]: New procedure. Iterate on all of SYSTEMS to compute the derivations of THINGS-TO-BUILD. * tests/guix-build.sh: Add test for one and multiple '-s' flags. * doc/guix.texi (Additional Build Options): Document this behavior. --- doc/guix.texi | 4 +- guix/scripts/build.scm | 107 +++++++++++++++++++++++++++---------------------- tests/guix-build.sh | 7 ++++ 3 files changed, 70 insertions(+), 48 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 6b713aaf9c..8c7522f286 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8030,7 +8030,9 @@ The following derivations will be built: @item --system=@var{system} @itemx -s @var{system} Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of -the system type of the build host. +the system type of the build host. The @command{guix build} command allows +you to repeat this option several times, in which case it builds for all the +specified systems; other commands ignore extraneous @option{-s} options. @quotation Note The @code{--system} flag is for @emph{native} compilation and must not diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index fc0c0e2ad3..ba143ad16b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -635,8 +635,7 @@ (define %standard-build-options (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) - (build-mode . ,(build-mode normal)) + `((build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -729,8 +728,7 @@ (define %options rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) + (alist-cons 'system arg result))) (option '("target") #t #f (lambda (opt name arg result) (alist-cons 'target arg @@ -811,56 +809,71 @@ (define package->derivation (cut package-cross-derivation <> <> triplet <>)))) (define src (assoc-ref opts 'source)) - (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) + (define systems + (match (filter-map (match-lambda + (('system . system) system) + (_ #f)) + opts) + (() (list (%current-system))) + (systems systems))) + + (define things-to-build + (map (cut transform store <>) + (options->things-to-build opts))) + + (define (compute-derivation obj system) + ;; Compute the derivation of OBJ for SYSTEM. + (match obj + ((? package? p) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (match (package-source p) + (#f + (format (current-error-port) + (G_ "~a: warning: \ +package '~a' has no source~%") + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? file-like? obj) + (list (run-with-store store + (lower-object obj system + #:target (assoc-ref opts 'target)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)) + #:system system))))) ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields ;; of user packages. Since 'guix build' is the primary tool for people ;; testing new packages, report such errors gracefully. (with-unbound-variable-handling (parameterize ((%graft? graft?)) - (append-map (match-lambda - ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))) - (match src - (#f - (list (package->derivation store p system))) - (#t - (match (package-source p) - (#f - (format (current-error-port) - (G_ "~a: warning: \ -package '~a' has no source~%") - (location->string (package-location p)) - (package-name p)) - '()) - (s - (list (package-source-derivation store s))))) - (proc - (map (cut package-source-derivation store <>) - (proc p)))))) - ((? derivation? drv) - (list drv)) - ((? procedure? proc) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - ((? file-like? obj) - (list (run-with-store store - (lower-object obj system - #:target (assoc-ref opts 'target)) - #:system system))) - ((? gexp? gexp) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system)) - #:system system)))) - (map (cut transform store <>) - (options->things-to-build opts)))))) + (append-map (lambda (system) + (append-map (cut compute-derivation <> system) + things-to-build)) + systems)))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if diff --git a/tests/guix-build.sh b/tests/guix-build.sh index d479296ef1..63a9fe68da 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -44,6 +44,13 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'; \ then exit 1; fi ) +# Passing one '-s' flag. +test `guix build sed -s x86_64-linux -d | wc -l` = 1 + +# Passing multiple '-s' flags. +all_systems="-s x86_64-linux -s i686-linux -s armhf-linux -s aarch64-linux" +test `guix build sed $all_systems -d | sort -u | wc -l` = 4 + # Check --sources option with its arguments module_dir="t-guix-build-$$" mkdir "$module_dir" -- cgit v1.2.3 From 0c329bf4b0c00abdc9a7d9c818d36d4d60b3005d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Apr 2019 16:28:59 +0200 Subject: tests: Adjust accounts test to shell-as-config change. This is a followup to 504a0fc636ec591e65b4a229a37e522e425d8a0c. * tests/accounts.scm ("allocate-passwd with previous state"): Change expected 'shell' for "alice" to "/bin/sh". --- tests/accounts.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/accounts.scm b/tests/accounts.scm index 923ba7dc83..673dd42432 100644 --- a/tests/accounts.scm +++ b/tests/accounts.scm @@ -225,14 +225,14 @@ (define allocate-passwd (@@ (gnu build accounts) allocate-passwd)) ;; Make sure bits of state are preserved: UID, no reuse of previously-used ;; UIDs, and shell. (list (password-entry (name "alice") (uid 1234) (gid 1000) - (real-name "Alice Smith") (shell "/gnu/.../bin/gash") + (real-name "Alice Smith") (shell "/bin/sh") (directory "/home/alice")) (password-entry (name "charlie") (uid 1236) (gid 1000) (real-name "Charlie") (shell "/bin/sh") (directory "/home/charlie"))) (allocate-passwd (list (user-account (name "alice") (comment "Alice") - (shell "/bin/sh") ;ignored + (shell "/bin/sh") ;honored (group "users")) (user-account (name "charlie") (comment "Charlie") @@ -241,7 +241,7 @@ (define allocate-passwd (@@ (gnu build accounts) allocate-passwd)) (list (group-entry (name "users") (gid 1000))) (list (password-entry (name "alice") (uid 1234) (gid 9999) (real-name "Alice Smith") - (shell "/gnu/.../bin/gash") + (shell "/gnu/.../bin/gash") ;ignored (directory "/home/alice")) (password-entry (name "bob") (uid 1235) (gid 1001) (real-name "Bob") (shell "/bin/sh") -- cgit v1.2.3 From d824cfbabeb0780c9ea7a6dab02c47b6a4d029c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Apr 2019 18:04:00 +0200 Subject: guix package: Add 'install', 'remove', and 'upgrade' aliases. * guix/scripts/install.scm, guix/scripts/remove.scm, guix/scripts/upgrade.scm, tests/guix-package-aliases.sh: New files. * Makefile.am (MODULES, SH_TESTS): Add them. * po/guix/POTFILES.in: Add them. * guix/scripts/package.scm (guix-package): Split with... (guix-package*): ... this. New procedure. * doc/guix.texi (Invoking guix package): Document them. (Binary Installation, Application Setup, Package Management) (Packages with Multiple Outputs, Package Modules) (X.509 Certificates, Installing Debugging Files): Use 'guix install' in simple examples. * etc/completion/bash/guix (_guix_complete): Handle "install", "remove", and "upgrade". --- Makefile.am | 4 ++ doc/guix.texi | 39 +++++++++++++------ etc/completion/bash/guix | 11 +++++- guix/scripts/install.scm | 80 +++++++++++++++++++++++++++++++++++++++ guix/scripts/package.scm | 11 +++++- guix/scripts/remove.scm | 77 +++++++++++++++++++++++++++++++++++++ guix/scripts/upgrade.scm | 88 +++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 3 ++ tests/guix-package-aliases.sh | 58 ++++++++++++++++++++++++++++ 9 files changed, 358 insertions(+), 13 deletions(-) create mode 100644 guix/scripts/install.scm create mode 100644 guix/scripts/remove.scm create mode 100644 guix/scripts/upgrade.scm create mode 100644 tests/guix-package-aliases.sh (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 05940719cd..076f1c7a71 100644 --- a/Makefile.am +++ b/Makefile.am @@ -224,6 +224,9 @@ MODULES = \ guix/scripts/archive.scm \ guix/scripts/import.scm \ guix/scripts/package.scm \ + guix/scripts/install.scm \ + guix/scripts/remove.scm \ + guix/scripts/upgrade.scm \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ @@ -425,6 +428,7 @@ SH_TESTS = \ tests/guix-pack-localstatedir.sh \ tests/guix-pack-relocatable.sh \ tests/guix-package.sh \ + tests/guix-package-aliases.sh \ tests/guix-package-net.sh \ tests/guix-system.sh \ tests/guix-archive.sh \ diff --git a/doc/guix.texi b/doc/guix.texi index c28ded1cf1..6c3dc7d208 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -689,7 +689,7 @@ You can confirm that Guix is working by installing a sample package into the root profile: @example -# guix package -i hello +# guix install hello @end example The binary installation tarball can be (re)produced and verified simply @@ -1577,7 +1577,7 @@ available with Guix and then define the @code{GUIX_LOCPATH} environment variable: @example -$ guix package -i glibc-locales +$ guix install glibc-locales $ export GUIX_LOCPATH=$HOME/.guix-profile/lib/locale @end example @@ -1677,7 +1677,7 @@ Multiple Outputs}). For instance, the following command installs fonts for Chinese languages: @example -guix package -i font-adobe-source-han-sans:cn +guix install font-adobe-source-han-sans:cn @end example @cindex @code{xterm} @@ -2492,7 +2492,7 @@ emacs-guix, The Emacs-Guix Reference Manual}), after installing with it): @example -guix package -i emacs-guix +guix install emacs-guix @end example @menu @@ -2610,6 +2610,7 @@ is: @example guix package @var{options} @end example + @cindex transactions Primarily, @var{options} specifies the operations to be performed during the transaction. Upon completion, a new profile is created, but @@ -2623,6 +2624,22 @@ For example, to remove @code{lua} and install @code{guile} and guix package -r lua -i guile guile-cairo @end example +@cindex aliases, for @command{guix package} +For your convenience, we also provide the following aliases: + +@itemize +@item +@command{guix install} is an alias for @command{guix package -i}, +@item +@command{guix remove} is an alias for @command{guix package -r}, +@item +and @command{guix upgrade} is an alias for @command{guix package -u}. +@end itemize + +These aliases are less expressive than @command{guix package} and provide +fewer options, so in some cases you'll probably want to use @command{guix +package} directly. + @command{guix package} also supports a @dfn{declarative approach} whereby the user specifies the exact set of packages to be available and passes it @i{via} the @option{--manifest} option @@ -3312,7 +3329,7 @@ like to discuss this project, join us on @email{guix-devel@@gnu.org}. Often, packages defined in Guix have a single @dfn{output}---i.e., the source package leads to exactly one directory in the store. When running -@command{guix package -i glibc}, one installs the default output of the +@command{guix install glibc}, one installs the default output of the GNU libc package; the default output is called @code{out}, but its name can be omitted as shown in this command. In this particular case, the default output of @code{glibc} contains all the C header files, shared @@ -3328,14 +3345,14 @@ separate output, called @code{doc}. To install the main GLib output, which contains everything but the documentation, one would run: @example -guix package -i glib +guix install glib @end example @cindex documentation The command to install its documentation is: @example -guix package -i glib:doc +guix install glib:doc @end example Some packages install programs with different ``dependency footprints''. @@ -4986,7 +5003,7 @@ module exports a variable named @code{emacs}, which is bound to a The @code{(gnu packages @dots{})} module name space is automatically scanned for packages by the command-line tools. For -instance, when running @code{guix package -i emacs}, all the @code{(gnu +instance, when running @code{guix install emacs}, all the @code{(gnu packages @dots{})} modules are scanned until one that exports a package object whose name is @code{emacs} is found. This package search facility is implemented in the @code{(gnu packages)} module. @@ -23634,7 +23651,7 @@ pointed to by the @code{GIT_SSL_CAINFO} environment variable. Thus, you would typically run something like: @example -$ guix package -i nss-certs +$ guix install nss-certs $ export SSL_CERT_DIR="$HOME/.guix-profile/etc/ssl/certs" $ export SSL_CERT_FILE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt" $ export GIT_SSL_CAINFO="$SSL_CERT_FILE" @@ -23645,7 +23662,7 @@ variable to point to a certificate bundle, so you would have to run something like this: @example -$ guix package -i nss-certs +$ guix install nss-certs $ export CURL_CA_BUNDLE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt" @end example @@ -25427,7 +25444,7 @@ installs the debugging information for the GNU C Library and for GNU Guile: @example -guix package -i glibc:debug guile:debug +guix install glibc:debug guile:debug @end example GDB must then be told to look for debug files in the user's profile, by diff --git a/etc/completion/bash/guix b/etc/completion/bash/guix index 3d2b3ddda7..edfb627e87 100644 --- a/etc/completion/bash/guix +++ b/etc/completion/bash/guix @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +# Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -167,6 +167,15 @@ _guix_complete () else _guix_complete_available_package "$word_at_point" fi + elif _guix_is_command "install" + then + _guix_complete_available_package "$word_at_point" + elif _guix_is_command "remove" + then + _guix_complete_installed_package "$word_at_point" + elif _guix_is_command "upgrade" + then + _guix_complete_installed_package "$word_at_point" elif _guix_is_command "build" then if _guix_is_dash_L diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm new file mode 100644 index 0000000000..d88e86e77a --- /dev/null +++ b/guix/scripts/install.scm @@ -0,0 +1,80 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts install) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-install)) + +(define (show-help) + (display (G_ "Usage: guix install [OPTION] PACKAGES... +Install the given PACKAGES. +This is an alias for 'guix package -i'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + ;; '--bootstrap' not shown here. + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix install"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity" "bootstrap"))) + %package-options) + + %transformation-options + %standard-build-options))) + +(define (guix-install . args) + (define (handle-argument arg result arg-handler) + ;; Treat all non-option arguments as package specs. + (values (alist-cons 'install arg result) + arg-handler)) + + (define opts + (parse-command-line args %options + (list %package-default-options #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 564236988e..aa27984ea2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -58,7 +58,11 @@ (define-module (guix scripts package) delete-generations delete-matching-generations display-search-paths - guix-package)) + guix-package + + (%options . %package-options) + (%default-options . %package-default-options) + guix-package*)) (define %store (make-parameter #f)) @@ -899,6 +903,11 @@ (define opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument)) + (guix-package* opts)) + +(define (guix-package* opts) + "Run the 'guix package' command on OPTS, an alist resulting for command-line +option processing with 'parse-command-line'." (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) diff --git a/guix/scripts/remove.scm b/guix/scripts/remove.scm new file mode 100644 index 0000000000..2f06ea4f37 --- /dev/null +++ b/guix/scripts/remove.scm @@ -0,0 +1,77 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts remove) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-remove)) + +(define (show-help) + (display (G_ "Usage: guix remove [OPTION] PACKAGES... +Remove the given PACKAGES. +This is an alias for 'guix package -r'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + ;; '--bootstrap' not shown here. + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix remove"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity" "bootstrap"))) + %package-options) + + %standard-build-options))) + +(define (guix-remove . args) + (define (handle-argument arg result arg-handler) + ;; Treat all non-option arguments as package specs. + (values (alist-cons 'remove arg result) + arg-handler)) + + (define opts + (parse-command-line args %options + (list %package-default-options #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm new file mode 100644 index 0000000000..7f14a2fdbe --- /dev/null +++ b/guix/scripts/upgrade.scm @@ -0,0 +1,88 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts upgrade) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-upgrade)) + +(define (show-help) + (display (G_ "Usage: guix upgrade [OPTION] [REGEXP] +Upgrade packages that match REGEXP. +This is an alias for 'guix package -u'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix upgrade"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity"))) + %package-options) + + %transformation-options + %standard-build-options))) + +(define (guix-upgrade . args) + (define (handle-argument arg result arg-handler) + ;; Accept at most one non-option argument, and treat it as an upgrade + ;; regexp. + (match (assq-ref result 'upgrade) + (#f + (values (alist-cons 'upgrade arg + (alist-delete 'upgrade result)) + arg-handler)) + (_ + (leave (G_ "~A: extraneous argument~%") arg)))) + + (define opts + (parse-command-line args %options + (list `((upgrade . #f) + ,@%package-default-options) + #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index a2c89db981..91de60efc7 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -41,6 +41,9 @@ guix/scripts/build.scm guix/discovery.scm guix/scripts/download.scm guix/scripts/package.scm +guix/scripts/install.scm +guix/scripts/remove.scm +guix/scripts/upgrade.scm guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/import.scm diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh new file mode 100644 index 0000000000..64ed2fbb67 --- /dev/null +++ b/tests/guix-package-aliases.sh @@ -0,0 +1,58 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2019 Ludovic Courtès +# +# This file is part of GNU Guix. +# +# GNU Guix is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# GNU Guix is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Guix. If not, see . + +# +# Test the `guix package' aliases. +# + +guix install --version + +readlink_base () +{ + basename `readlink "$1"` +} + +profile="t-profile-$$" +rm -f "$profile" + +trap 'rm -f "$profile" "$profile-"[0-9]*' EXIT + +guix install --bootstrap guile-bootstrap -p "$profile" +test -x "$profile/bin/guile" + +# Make sure '-r' isn't passed as-is to 'guix package'. +if guix install -r guile-bootstrap -p "$profile" --bootstrap +then false; else true; fi +test -x "$profile/bin/guile" + +guix upgrade --version +guix upgrade -n +guix upgrade gui.e -n +if guix upgrade foo bar -n; +then false; else true; fi + +guix remove --version +guix remove --bootstrap guile-bootstrap -p "$profile" +! test -x "$profile/bin/guile" +test `guix package -p "$profile" -I | wc -l` -eq 0 + +if guix remove -p "$profile" this-is-not-installed --bootstrap +then false; else true; fi + +if guix remove -i guile-bootstrap -p "$profile" --bootstrap +then false; else true; fi -- cgit v1.2.3 From da56f10971e0b6f32969b10e38ed043b2c99bb82 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 29 Apr 2019 10:41:11 +0200 Subject: guix package: Add 'guix search' alias. * guix/scripts/search.scm: New file. * Makefile.am (MODULES): Add it. * po/guix/POTFILES.in: Add it. * tests/guix-package-aliases.sh: Add test. * doc/guix.texi (Invoking guix package): Document it and use it in a couple of examples. --- Makefile.am | 1 + doc/guix.texi | 13 +++++---- guix/scripts/search.scm | 67 +++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/guix-package-aliases.sh | 2 ++ 5 files changed, 79 insertions(+), 5 deletions(-) create mode 100644 guix/scripts/search.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 076f1c7a71..36f3bc5c27 100644 --- a/Makefile.am +++ b/Makefile.am @@ -227,6 +227,7 @@ MODULES = \ guix/scripts/install.scm \ guix/scripts/remove.scm \ guix/scripts/upgrade.scm \ + guix/scripts/search.scm \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 39d2ee476a..fcee57d9cd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2630,6 +2630,8 @@ For your convenience, we also provide the following aliases: @itemize @item +@command{guix search} is an alias for @command{guix package -s}, +@item @command{guix install} is an alias for @command{guix package -i}, @item @command{guix remove} is an alias for @command{guix package -r}, @@ -2953,12 +2955,13 @@ name: gmp @dots{} @end example -It is also possible to refine search results using several @code{-s} -flags. For example, the following command returns a list of board -games: +It is also possible to refine search results using several @code{-s} flags to +@command{guix package}, or several arguments to @command{guix search}. For +example, the following command returns a list of board games (this time using +the @command{guix search} alias): @example -$ guix package -s '\' -s game | recsel -p name +$ guix search '\' game | recsel -p name name: gnubg @dots{} @end example @@ -2973,7 +2976,7 @@ for cryptographic libraries, filters out Haskell, Perl, Python, and Ruby libraries, and prints the name and synopsis of the matching packages: @example -$ guix package -s crypto -s library | \ +$ guix search crypto library | \ recsel -e '! (name ~ "^(ghc|perl|python|ruby)")' -p name,synopsis @end example diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm new file mode 100644 index 0000000000..8fceb83668 --- /dev/null +++ b/guix/scripts/search.scm @@ -0,0 +1,67 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts search) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-search)) + +(define (show-help) + (display (G_ "Usage: guix search [OPTION] REGEXPS... +Search for packages matching REGEXPS.")) + (display (G_" +This is an alias for 'guix package -s'.\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix search"))))) + +(define (guix-search . args) + (define (handle-argument arg result) + ;; Treat all non-option arguments as regexps. + (cons `(query search ,(or arg "")) + result)) + + (define opts + (args-fold* args %options + (lambda (opt name arg . rest) + (leave (G_ "~A: unrecognized option~%") name)) + handle-argument + '())) + + (unless (assoc-ref opts 'query) + (leave (G_ "missing arguments: no regular expressions to search for~%"))) + + (guix-package* opts)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 91de60efc7..ceee589b2e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -44,6 +44,7 @@ guix/scripts/package.scm guix/scripts/install.scm guix/scripts/remove.scm guix/scripts/upgrade.scm +guix/scripts/search.scm guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/import.scm diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index 64ed2fbb67..5c68664093 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -56,3 +56,5 @@ then false; else true; fi if guix remove -i guile-bootstrap -p "$profile" --bootstrap then false; else true; fi + +guix search '\' game | grep '^name: gnubg' -- cgit v1.2.3