diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/processes.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 25 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 21 |
9 files changed, 123 insertions, 50 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ba143ad16b..8fa700c883 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -65,7 +65,7 @@ (define %default-log-urls ;; Default base URLs for build logs. - '("http://ci.guix.info/log")) + '("http://ci.guix.gnu.org/log")) ;; XXX: The following procedure cannot be in (guix store) because of the ;; dependency on (guix derivations). @@ -370,7 +370,10 @@ a checkout of the Git repository at the given URL." (package (inherit old) (source (git-checkout (url url) - (recursive? #t))))))))) + (recursive? #t))))))) + (_ + (leave (G_ "~a: invalid Git URL replacement specification~%") + spec)))) replacement-specs)) (define rewrite diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 99c351ae43..c1341628a8 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -341,7 +341,7 @@ for the corresponding packages." (list (package->manifest-entry* package output)))) (('package 'package (? string? spec)) (package-environment-inputs - (specification->package+output spec))) + (transform (specification->package+output spec)))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. (packages->outputs (read/eval str) mode)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 2a7b84b847..802b26c64c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -724,6 +724,10 @@ please email '~a'~%") (alist-cons 'profile-name arg result)) (_ (leave (G_ "~a: unsupported profile name~%") arg))))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number* arg))) @@ -769,6 +773,9 @@ Create a bundle of PACKAGE.\n")) --profile-name=NAME populate /var/guix/profiles/.../NAME")) (display (G_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) @@ -882,7 +889,11 @@ Create a bundle of PACKAGE.\n")) (leave (G_ "~a: unknown pack format~%") pack-format)))) (localstatedir? (assoc-ref opts 'localstatedir?)) - (profile-name (assoc-ref opts 'profile-name))) + (profile-name (assoc-ref opts 'profile-name)) + (gc-root (assoc-ref opts 'gc-root))) + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; building an empty pack~%"))) + (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest @@ -919,6 +930,11 @@ Create a bundle of PACKAGE.\n")) #:dry-run? dry-run?) (munless dry-run? (built-derivations (list drv)) + (mwhen gc-root + (register-root* (match (derivation->output-paths drv) + (((names . items) ...) + items)) + gc-root)) (return (format #t "~a~%" (derivation->output-path drv)))))) #:system (assoc-ref opts 'system)))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index aa27984ea2..06e4cf5b9c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -180,9 +180,9 @@ hooks\" run when building the profile." ;;; (define (find-packages-by-description regexps) - "Return two values: the list of packages whose name, synopsis, or -description matches at least one of REGEXPS sorted by relevance, and the list -of relevance scores." + "Return two values: the list of packages whose name, synopsis, description, +or output matches at least one of REGEXPS sorted by relevance, and the list of +relevance scores." (let ((matches (fold-packages (lambda (package result) (if (package-superseded package) result diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index 6a2f603599..a2ab017490 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -103,9 +103,16 @@ processes." (let ((directory (string-append "/proc/" (number->string (process-id process)) "/fd"))) - (map (lambda (fd) - (readlink (string-append directory "/" fd))) - (or (scandir directory string->number) '())))) + (filter-map (lambda (fd) + ;; There's a TOCTTOU race here, hence the 'catch'. + (catch 'system-error + (lambda () + (readlink (string-append directory "/" fd))) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + (or (scandir directory string->number) '())))) ;; Daemon session. (define-record-type <daemon-session> @@ -151,15 +158,22 @@ active sessions, and the master 'guix-daemon' process." (= pid (process-parent-id process)))) processes)) - (values (map (lambda (process) - (match (process-command process) - ((argv0 (= string->number client) _ ...) - (let ((files (process-open-files process))) - (daemon-session process - (lookup-process client) - (lookup-children (process-id process)) - (filter lock-file? files)))))) - children) + (define (child-process->session process) + (match (process-command process) + ((argv0 (= string->number client) _ ...) + (let ((files (process-open-files process)) + (client (lookup-process client))) + ;; After a client has died, there's a window during which its + ;; corresponding 'guix-daemon' process is still alive, in which + ;; case 'lookup-process' returns #f. In that case ignore the + ;; session. + (and client + (daemon-session process client + (lookup-children + (process-id process)) + (filter lock-file? files))))))) + + (values (filter-map child-process->session children) master))) (define (daemon-session->recutils session port) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 3929cd402e..2d428546c9 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -203,6 +203,10 @@ true, display what would be built without actually building it." (define update-profile (store-lift build-and-use-profile)) + (define guix-command + ;; The 'guix' command before we've built the new profile. + (which "guix")) + (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad (update-profile profile manifest @@ -211,17 +215,18 @@ true, display what would be built without actually building it." (munless dry-run? (return (newline)) (return (display-profile-news profile #:concise? #t)) - (match (which "guix") - (#f (return #f)) - (str - (let ((new (map (cut string-append <> "/bin/guix") - (list (user-friendly-profile profile) - profile)))) - (unless (member str new) - (display-hint (format #f (G_ "After setting @code{PATH}, run + (if guix-command + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + ;; Is the 'guix' command previously in $PATH the same as the new + ;; one? If the answer is "no", then suggest 'hash guix'. + (unless (member guix-command new) + (display-hint (format #f (G_ "After setting @code{PATH}, run @command{hash guix} to make sure your shell refers to @file{~a}.") - (first new)))) - (return #f)))))))) + (first new)))) + (return #f)) + (return #f)))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 797a76db3f..135398ba48 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1061,7 +1061,7 @@ found." (#f ;; This can only happen when this script is not invoked by the ;; daemon. - '("http://ci.guix.info")))) + '("http://ci.guix.gnu.org")))) (define substitute-urls ;; List of substitute URLs. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3c3d6cbd5f..60c1ca5c9a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -756,13 +757,17 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action os action #:key image-size file-system-type - full-boot? mappings) + full-boot? container-shared-network? + mappings) "Return as a monadic value the derivation for OS according to ACTION." (case action ((build init reconfigure) (operating-system-derivation os)) ((container) - (container-script os #:mappings mappings)) + (container-script + os + #:mappings mappings + #:shared-network? container-shared-network?)) ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) @@ -781,7 +786,7 @@ checking this by themselves in their 'check' procedure." #:disk-image-size image-size #:file-system-type file-system-type)) ((docker-image) - (system-docker-image os #:register-closures? #t)))) + (system-docker-image os)))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." @@ -826,6 +831,7 @@ and TARGET arguments." dry-run? derivations-only? use-substitutes? bootloader-target target image-size file-system-type full-boot? + container-shared-network? (mappings '()) (gc-root #f)) "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install @@ -834,6 +840,8 @@ target root directory; IMAGE-SIZE is the size of the image to be built, for the 'vm-image' and 'disk-image' actions. The root file system is created as a FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. +CONTAINER-SHARED-NETWORK? determines if the container will use a separate +network namespace. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without building anything. @@ -883,6 +891,7 @@ static checks." #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? + #:container-shared-network? container-shared-network? #:mappings mappings)) ;; For 'init' and 'reconfigure', always build BOOTCFG, even if @@ -1020,6 +1029,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --share=SPEC for 'vm', share host file system according to SPEC")) (display (G_ " + -N, --network for 'container', allow containers to access the network")) + (display (G_ " -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', and 'build', make FILE a symlink to the result, and register it as a garbage collector root")) @@ -1066,6 +1077,9 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) result))) + (option '(#\N "network") #f #f + (lambda (opt name arg result) + (alist-cons 'container-shared-network? #t result))) (option '("no-bootloader" "no-grub") #f #f (lambda (opt name arg result) (alist-cons 'install-bootloader? #f result))) @@ -1129,22 +1143,30 @@ Some ACTIONS support additional ARGS.\n")) ACTION must be one of the sub-commands that takes an operating system declaration as an argument (a file name.) OPTS is the raw alist of options resulting from command-line parsing." + (define (ensure-operating-system file-or-exp obj) + (unless (operating-system? obj) + (leave (G_ "'~a' does not return an operating system~%") + file-or-exp)) + obj) + (let* ((file (match args (() #f) ((x . _) x))) (expr (assoc-ref opts 'expression)) (system (assoc-ref opts 'system)) - (os (cond - ((and expr file) - (leave - (G_ "both file and expression cannot be specified~%"))) - (expr - (read/eval expr)) - (file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error))) - (else - (leave (G_ "no configuration specified~%"))))) + (os (ensure-operating-system + (or file expr) + (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%")))))) (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) @@ -1182,6 +1204,8 @@ resulting from command-line parsing." #:file-system-type (assoc-ref opts 'file-system-type) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) + #:container-shared-network? + (assoc-ref opts 'container-shared-network?) #:mappings (filter-map (match-lambda (('file-system-mapping . m) m) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 4b12f9550e..78b8674e0c 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -252,7 +252,7 @@ are queued~%") ;;; (define (show-help) - (display (G_ "Usage: guix weather [OPTIONS] + (display (G_ "Usage: guix weather [OPTIONS] [PACKAGES ...] Report the availability of substitutes.\n")) (display (G_ " --substitute-urls=URLS @@ -469,6 +469,20 @@ SERVER. Display information for packages with at least THRESHOLD dependents." ;;; (define (guix-weather . args) + (define (package-list opts) + ;; Return the package list specified by OPTS. + (let ((file (assoc-ref opts 'manifest)) + (base (filter-map (match-lambda + (('argument . spec) + (specification->package spec)) + (_ + #f)) + opts))) + (if (and (not file) (null? base)) + (all-packages) + (append base + (if file (load-manifest file) '()))))) + (with-error-handling (parameterize ((current-terminal-columns (terminal-columns))) (let* ((opts (parse-command-line args %options @@ -481,10 +495,7 @@ SERVER. Display information for packages with at least THRESHOLD dependents." opts) (() (list (%current-system))) (systems systems))) - (packages (let ((file (assoc-ref opts 'manifest))) - (if file - (load-manifest file) - (all-packages)))) + (packages (package-list opts)) (items (with-store store (parameterize ((%graft? #f)) (concatenate |