diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2015-12-12 11:42:12 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2015-12-12 11:48:46 +0100 |
| commit | e82e55e58c67b0215e768c4612ca542bc670f633 (patch) | |
| tree | 856c4512fa1fbde59c1d9845c5a763ef8c4a14b4 /guix/scripts | |
| parent | 98bd851ee891ca4a84e061fe1e78ba78c292b096 (diff) | |
| parent | e35dff973375266db253747140ddf25084ecddc2 (diff) | |
| download | gnu-guix-e82e55e58c67b0215e768c4612ca542bc670f633.tar gnu-guix-e82e55e58c67b0215e768c4612ca542bc670f633.tar.gz | |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 271 | ||||
| -rw-r--r-- | guix/scripts/challenge.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/container.scm | 63 | ||||
| -rw-r--r-- | guix/scripts/container/exec.scm | 94 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/edit.scm | 37 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 382 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 148 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 16 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 67 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 878 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 159 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 3 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 155 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 284 |
17 files changed, 1539 insertions, 1040 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a357cf8aa4..8ecd9560ed 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -171,6 +171,8 @@ options handled by 'set-build-options-from-command-line', and listed in (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) (display (_ " + --rounds=N build N times in a row to detect non-determinism")) + (display (_ " -c, --cores=N allow the use of up to N CPU cores for the build")) (display (_ " -M, --max-jobs=N allow at most N build jobs"))) @@ -181,12 +183,12 @@ options handled by 'set-build-options-from-command-line', and listed in ;; TODO: Add more options. (set-build-options store #:keep-failed? (assoc-ref opts 'keep-failed?) + #:rounds (assoc-ref opts 'rounds) #:build-cores (or (assoc-ref opts 'cores) 0) #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) - #:substitute-urls (or (assoc-ref opts 'substitute-urls) - %default-substitute-urls) + #:substitute-urls (assoc-ref opts 'substitute-urls) #:use-build-hook? (assoc-ref opts 'build-hook?) #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) @@ -211,6 +213,12 @@ options handled by 'set-build-options-from-command-line', and listed in (apply values (alist-cons 'keep-failed? #t result) rest))) + (option '("rounds") #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'rounds (string->number* arg) + result) + rest))) (option '("fallback") #f #f (lambda (opt name arg result . rest) (apply values @@ -277,6 +285,7 @@ options handled by 'set-build-options-from-command-line', and listed in (define %default-options ;; Alist of default option values. `((system . ,(%current-system)) + (build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -290,6 +299,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " + -f, --file=FILE build the package or derivation that the code within + FILE evaluates to")) + (display (_ " -S, --source build the packages' source derivations")) (display (_ " --sources[=TYPE] build source derivations; TYPE may optionally be one @@ -306,6 +318,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " -d, --derivations return the derivation paths of the given packages")) (display (_ " + --check rebuild items to check for non-determinism issues")) + (display (_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (_ " @@ -345,6 +359,12 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (leave (_ "invalid argument: '~a' option argument: ~a, ~ must be one of 'package', 'all', or 'transitive'~%") name arg))))) + (option '("check") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'build-mode (build-mode check) + result) + rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -359,6 +379,9 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\f "file") #t #f + (lambda (opt name arg result) + (alist-cons 'file arg result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -378,9 +401,40 @@ must be one of 'package', 'all', or 'transitive'~%") %standard-build-options)) +(define (options->things-to-build opts) + "Read the arguments from OPTS and return a list of high-level objects to +build---packages, gexps, derivations, and so on." + (define ensure-list + (match-lambda + ((x ...) x) + (x (list x)))) + + (append-map (match-lambda + (('argument . (? string? spec)) + (cond ((derivation-path? spec) + (list (call-with-input-file spec read-derivation))) + ((store-path? spec) + ;; Nothing to do; maybe for --log-file. + '()) + (else + (list (specification->package spec))))) + (('file . file) + (ensure-list (load* file (make-user-module '())))) + (('expression . str) + (ensure-list (read/eval str))) + (('argument . (? derivation? drv)) + drv) + (('argument . (? derivation-path? drv)) + (list )) + (_ '())) + opts)) + (define (options->derivations store opts) "Given OPTS, the result of 'args-fold', return a list of derivations to build." + (define transform + (options->transformation opts)) + (define package->derivation (match (assoc-ref opts 'target) (#f package-derivation) @@ -388,101 +442,99 @@ build." (cut package-cross-derivation <> <> triplet <>)))) (define src (assoc-ref opts 'source)) - (define sys (assoc-ref opts 'system)) + (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? graft?)) - (let ((opts (options/with-source store - (options/resolve-packages store opts)))) - (concatenate - (filter-map (match-lambda - (('argument . (? package? p)) - (match src - (#f - (list (package->derivation store p sys))) - (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) - (proc - (map (cut package-source-derivation store <>) - (proc p))))) - (('argument . (? derivation? drv)) - (list drv)) - (('argument . (? derivation-path? drv)) - (list (call-with-input-file drv read-derivation))) - (('argument . (? store-path?)) - ;; Nothing to do; maybe for --log-file. - #f) - (_ #f)) - opts))))) - -(define (options/resolve-packages store opts) - "Return OPTS with package specification strings replaced by actual -packages." - (define system - (or (assoc-ref opts 'system) (%current-system))) - - (map (match-lambda - (('argument . (? string? spec)) - (if (store-path? spec) - `(argument . ,spec) - `(argument . ,(specification->package spec)))) - (('expression . str) - (match (read/eval str) - ((? package? p) - `(argument . ,p)) - ((? procedure? proc) - (let ((drv (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - `(argument . ,drv))) - ((? gexp? gexp) - (let ((drv (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system))))) - `(argument . ,drv))))) - (opt opt)) - opts)) - -(define (options/with-source store opts) - "Process with 'with-source' options in OPTS, replacing the relevant package -arguments with packages that use the specified source." + (append-map (match-lambda + ((? package? p) + (match src + (#f + (list (package->derivation store p system))) + (#t + (let ((s (package-source p))) + (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))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)))))) + (transform store (options->things-to-build opts))))) + +(define (transform-package-source sources) + "Return a transformation procedure that uses replaces package sources with +the matching URIs given in SOURCES." (define new-sources - (filter-map (match-lambda - (('with-source . uri) - (cons (package-name->name+version (basename uri)) - uri)) - (_ #f)) - opts)) - - (let loop ((opts opts) - (sources new-sources) - (result '())) - (match opts - (() - (unless (null? sources) - (warning (_ "sources do not match any package:~{ ~a~}~%") - (match sources - (((name . uri) ...) - uri)))) - (reverse result)) - ((('argument . (? package? p)) tail ...) - (let ((source (assoc-ref sources (package-name p)))) - (loop tail - (alist-delete (package-name p) sources) - (alist-cons 'argument - (if source - (package-with-source store p source) - p) - result)))) - ((('with-source . _) tail ...) - (loop tail sources result)) - ((head tail ...) - (loop tail sources (cons head result)))))) + (map (lambda (uri) + (cons (package-name->name+version (basename uri)) + uri)) + sources)) + + (lambda (store packages) + (let loop ((packages packages) + (sources new-sources) + (result '())) + (match packages + (() + (unless (null? sources) + (warning (_ "sources do not match any package:~{ ~a~}~%") + (match sources + (((name . uri) ...) + uri)))) + (reverse result)) + (((? package? p) tail ...) + (let ((source (assoc-ref sources (package-name p)))) + (loop tail + (alist-delete (package-name p) sources) + (cons (if source + (package-with-source store p source) + p) + result)))) + ((thing tail ...) + (loop tail sources result)))))) + +(define %transformations + ;; Transformations that can be applied to things to build. The car is the + ;; key used in the option alist, and the cdr is the transformation + ;; procedure; it is called with two arguments: the store, and a list of + ;; things to build. + `((with-source . ,transform-package-source))) + +(define (options->transformation opts) + "Return a procedure that, when passed a list of things to build (packages, +derivations, etc.), applies the transformations specified by OPTS." + (apply compose + (map (match-lambda + ((key . transform) + (let ((args (filter-map (match-lambda + ((k . arg) + (and (eq? k key) arg))) + opts))) + (if (null? args) + (lambda (store things) things) + (transform args))))) + %transformations))) + +(define (show-build-log store file urls) + "Show the build log for FILE, falling back to remote logs from URLS if +needed." + (let ((log (or (log-file store file) + (log-url store file #:base-urls urls)))) + (if log + (format #t "~a~%" log) + (leave (_ "no build log for '~a'~%") file)))) ;;; @@ -497,47 +549,44 @@ arguments with packages that use the specified source." (let* ((opts (parse-command-line args %options (list %default-options))) (store (open-connection)) + (mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") (if (assoc-ref opts 'substitutes?) (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. %default-substitute-urls) '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) + (('gc-root . root) root) + (_ #f)) opts))) (set-build-options-from-command-line store opts) (unless (assoc-ref opts 'log-file?) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?))) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) (cond ((assoc-ref opts 'log-file?) - (for-each (lambda (file) - (let ((log (or (log-file store file) - (log-url store file - #:base-urls urls)))) - (if log - (format #t "~a~%" log) - (leave (_ "no build log for '~a'~%") - file)))) + (for-each (cut show-build-log store <> urls) (delete-duplicates (append (map derivation-file-name drv) - (filter-map (match-lambda - (('argument - . (? store-path? file)) - file) - (_ #f)) - opts))))) + items)))) ((assoc-ref opts 'derivations-only?) (format #t "~{~a~%~}" (map derivation-file-name drv)) (for-each (cut register-root store <> <>) (map (compose list derivation-file-name) drv) roots)) ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv) + (and (build-derivations store drv mode) (for-each show-derivation-outputs drv) (for-each (cut register-root store <> <>) (map (lambda (drv) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 19a9b061b8..4a0c865b07 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -125,10 +125,8 @@ taken since we do not import the archives." servers)) ;; No 'assert-valid-narinfo' on purpose. (narinfos -> (fold (lambda (narinfo vhash) - (if narinfo - (vhash-cons (narinfo-path narinfo) narinfo - vhash) - vhash)) + (vhash-cons (narinfo-path narinfo) narinfo + vhash)) vlist-null remote))) (return (filter-map (lambda (item local) diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm new file mode 100644 index 0000000000..cd9f345b68 --- /dev/null +++ b/guix/scripts/container.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts container) + #:use-module (ice-9 match) + #:use-module (guix ui) + #:export (guix-container)) + +(define (show-help) + (display (_ "Usage: guix container ACTION ARGS... +Build and manipulate Linux containers.\n")) + (newline) + (display (_ "The valid values for ACTION are:\n")) + (newline) + (display (_ "\ + exec execute a command inside of an existing container\n")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %actions '("exec")) + +(define (resolve-action name) + (let ((module (resolve-interface + `(guix scripts container ,(string->symbol name)))) + (proc (string->symbol (string-append "guix-container-" name)))) + (module-ref module proc))) + +(define (guix-container . args) + (with-error-handling + (match args + (() + (format (current-error-port) + (_ "guix container: missing action~%"))) + ((or ("-h") ("--help")) + (show-help) + (exit 0)) + (("--version") + (show-version-and-exit "guix container")) + ((action args ...) + (if (member action %actions) + (apply (resolve-action action) args) + (format (current-error-port) + (_ "guix container: invalid action~%"))))))) diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm new file mode 100644 index 0000000000..10e70568cc --- /dev/null +++ b/guix/scripts/container/exec.scm @@ -0,0 +1,94 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts container exec) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (gnu build linux-container) + #:export (guix-container-exec)) + +(define %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 container exec"))))) + +(define (show-help) + (display (_ "Usage: guix container exec PID COMMAND [ARGS...] +Execute COMMMAND within the container process PID.\n")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (partition-args args) + "Split ARGS into two lists; one containing the arguments for this program, +and the other containing arguments for the command to be executed." + (define (number-string? str) + (false-if-exception (string->number str))) + + (let loop ((a '()) + (b args)) + (match b + (() + (values (reverse a) '())) + (((? number-string? head) . tail) + (values (reverse (cons head a)) tail)) + ((head . tail) + (loop (cons head a) tail))))) + +(define (guix-container-exec . args) + (define (handle-argument arg result) + (if (assoc-ref result 'pid) + (leave (_ "~a: extraneous argument~%") arg) + (alist-cons 'pid (string->number* arg) result))) + + (with-error-handling + (let-values (((args command) (partition-args args))) + (let* ((opts (parse-command-line args %options '(()) + #:argument-handler + handle-argument)) + (pid (assoc-ref opts 'pid))) + + (unless pid + (leave (_ "no pid specified~%"))) + + (when (null? command) + (leave (_ "no command specified~%"))) + + (unless (file-exists? (string-append "/proc/" (number->string pid))) + (leave (_ "no such process ~d~%") pid)) + + (let ((result (container-excursion pid + (lambda () + (match command + ((program . program-args) + (apply execlp program program program-args))))))) + (unless (zero? result) + (leave (_ "exec failed with status ~d~%") result))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 533970ffbb..6ebc14f573 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,13 +96,17 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) (lambda (arg result) + (when (assq 'argument result) + (leave (_ "~A: extraneous argument~%") arg)) + (alist-cons 'argument arg result)) %default-options)) (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) - (arg (assq-ref opts 'argument)) + (arg (or (assq-ref opts 'argument) + (leave (_ "no download URI was specified~%")))) (uri (or (string->uri arg) (leave (_ "~a: failed to parse URI~%") arg))) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 30146af10b..ce3ac4146d 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +39,7 @@ (define (show-help) (display (_ "Usage: guix edit PACKAGE... -Start $EDITOR to edit the definitions of PACKAGE...\n")) +Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (newline) (display (_ " -h, --help display this help and exit")) @@ -48,7 +49,10 @@ Start $EDITOR to edit the definitions of PACKAGE...\n")) (show-bug-report-information)) (define %editor - (make-parameter (or (getenv "EDITOR") "emacsclient"))) + ;; XXX: It would be better to default to something more likely to be + ;; pre-installed on an average GNU system. Since Nano is not suited for + ;; editing Scheme, Emacs is used instead. + (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") "emacs"))) (define (search-path* path file) "Like 'search-path' but exit if FILE is not found." @@ -59,6 +63,15 @@ Start $EDITOR to edit the definitions of PACKAGE...\n")) file path)) absolute-file-name)) +(define (package->location-specification package) + "Return the location specification for PACKAGE for a typical editor command +line." + (let ((loc (package-location package))) + (list (string-append "+" + (number->string + (location-line loc))) + (search-path* %load-path (location-file loc))))) + (define (guix-edit . args) (with-error-handling @@ -70,11 +83,15 @@ Start $EDITOR to edit the definitions of PACKAGE...\n")) (leave (_ "source location of package '~a' is unknown~%") (package-full-name package)))) packages) - (apply execlp (%editor) (%editor) - (append-map (lambda (package) - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) - packages))))) + + (catch 'system-error + (lambda () + (let ((file-names (append-map package->location-specification + packages))) + ;; Use `system' instead of `exec' in order to sanely handle + ;; possible command line arguments in %EDITOR. + (exit (system (string-join (cons (%editor) file-names)))))) + (lambda args + (let ((errno (system-error-errno args))) + (leave (_ "failed to launch '~a': ~a~%") + (%editor) (strerror errno)))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2408420e18..2cc5f366a7 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -25,13 +25,19 @@ #:use-module (guix profiles) #:use-module (guix search-paths) #:use-module (guix utils) + #:use-module (guix build utils) #:use-module (guix monads) #:use-module ((guix gexp) #:select (lower-inputs)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (gnu build linux-container) + #:use-module (gnu system linux-container) + #:use-module (gnu system file-systems) #:use-module (gnu packages) + #:use-module (gnu packages bash) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -60,6 +66,12 @@ OUTPUT) tuples." (define %default-shell (or (getenv "SHELL") "/bin/sh")) +(define %network-configuration-files + '("/etc/resolv.conf" + "/etc/nsswitch.conf" + "/etc/services" + "/etc/hosts")) + (define (purify-environment) "Unset almost all environment variables. A small number of variables such as 'HOME' and 'USER' are left untouched." @@ -124,6 +136,18 @@ COMMAND or an interactive shell in that environment.\n")) --search-paths display needed environment variable definitions")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + -C, --container run command within an isolated container")) + (display (_ " + -N, --network allow containers to access the network")) + (display (_ " + --share=SPEC for containers, share writable host file system + according to SPEC")) + (display (_ " + --expose=SPEC for containers, expose read-only host file system + according to SPEC")) + (display (_ " + --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) (newline) @@ -136,12 +160,21 @@ COMMAND or an interactive shell in that environment.\n")) (define %default-options ;; Default to opening a new shell. - `((exec . (,%default-shell)) - (system . ,(%current-system)) + `((system . ,(%current-system)) (substitutes? . #t) (max-silent-time . 3600) (verbosity . 0))) +(define (tag-package-arg opts arg) + "Return a two-element list with the form (TAG ARG) that tags ARG with either +'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise." + ;; Normally, the transitive inputs to a package are added to an environment, + ;; but the ad-hoc? flag changes the meaning of a package argument such that + ;; the package itself is added to the environment instead. + (if (assoc-ref opts 'ad-hoc?) + `(ad-hoc-package ,arg) + `(package ,arg))) + (define %options ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f @@ -162,10 +195,14 @@ COMMAND or an interactive shell in that environment.\n")) (alist-cons 'search-paths #t result))) (option '(#\l "load") #t #f (lambda (opt name arg result) - (alist-cons 'load arg result))) + (alist-cons 'load + (tag-package-arg result arg) + result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) - (alist-cons 'expression arg result))) + (alist-cons 'expression + (tag-package-arg result arg) + result))) (option '("ad-hoc") #f #f (lambda (opt name arg result) (alist-cons 'ad-hoc? #t result))) @@ -176,6 +213,25 @@ COMMAND or an interactive shell in that environment.\n")) (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '(#\C "container") #f #f + (lambda (opt name arg result) + (alist-cons 'container? #t result))) + (option '(#\N "network") #f #f + (lambda (opt name arg result) + (alist-cons 'network? #t result))) + (option '("share") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #t) + result))) + (option '("expose") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #f) + result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) %standard-build-options)) (define (pick-all alist key) @@ -189,29 +245,40 @@ COMMAND or an interactive shell in that environment.\n")) (_ memo))) '() alist)) +(define (compact lst) + "Remove all #f elements from LST." + (filter identity lst)) + (define (options/resolve-packages opts) "Return OPTS with package specification strings replaced by actual packages." - (append-map (match-lambda - (('package . (? string? spec)) - (let-values (((package output) - (specification->package+output spec))) - `((package ,package ,output)))) - (('expression . str) - ;; Add all the outputs of the package STR evaluates to. - (match (read/eval str) - ((? package? package) - (map (lambda (output) - `(package ,package ,output)) - (package-outputs package))))) - (('load . file) - ;; Add all the outputs of the package defined in FILE. - (let ((package (load* file (make-user-module '())))) - (map (lambda (output) - `(package ,package ,output)) - (package-outputs package)))) - (opt (list opt))) - opts)) + (define (package->outputs package mode) + (map (lambda (output) + (list mode package output)) + (package-outputs package))) + + (define (packages->outputs packages mode) + (match packages + ((? package? package) + (package->outputs package mode)) + (((? package? packages) ...) + (append-map (cut package->outputs <> mode) packages)))) + + (compact + (append-map (match-lambda + (('package mode (? string? spec)) + (let-values (((package output) + (specification->package+output spec))) + (list (list mode package output)))) + (('expression mode str) + ;; Add all the outputs of the package STR evaluates to. + (packages->outputs (read/eval str) mode)) + (('load mode file) + ;; Add all the outputs of the package defined in FILE. + (let ((module (make-user-module '()))) + (packages->outputs (load* file module) mode))) + (_ '(#f))) + opts))) (define (build-inputs inputs opts) "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION @@ -227,14 +294,145 @@ OUTPUT) tuples, using the build options in OPTS." (if dry-run? (return #f) (mbegin %store-monad - (set-build-options-from-command-line* opts) (built-derivations derivations) (return derivations)))))))) +(define requisites* (store-lift requisites)) + +(define (inputs->requisites inputs) + "Convert INPUTS, a list of input tuples or store path strings, into a set of +requisite store items i.e. the union closure of all the inputs." + (define (input->requisites input) + (requisites* + (match input + ((drv output) + (derivation->output-path drv output)) + ((drv) + (derivation->output-path drv)) + ((? direct-store-path? path) + path)))) + + (mlet %store-monad ((reqs (sequence %store-monad + (map input->requisites inputs)))) + (return (delete-duplicates (concatenate reqs))))) + +(define (status->exit-code status) + "Compute the exit code made from STATUS, a value as returned by 'waitpid', +and suitable for 'exit'." + ;; See <bits/waitstatus.h>. + (or (status:exit-val status) + (logior #x80 (status:term-sig status)))) + +(define exit/status (compose exit status->exit-code)) +(define primitive-exit/status (compose primitive-exit status->exit-code)) + +(define (launch-environment command inputs paths pure?) + "Run COMMAND in a new environment containing INPUTS, using the native search +paths defined by the list PATHS. When PURE?, pre-existing environment +variables are cleared before setting the new ones." + (create-environment inputs paths pure?) + (apply system* command)) + +(define* (launch-environment/container #:key command bash user-mappings + inputs paths network?) + "Run COMMAND within a Linux container. The environment features INPUTS, a +list of derivations to be shared from the host system. Environment variables +are set according to PATHS, a list of native search paths. The global shell +is BASH, a file name for a GNU Bash binary in the store. When NETWORK?, +access to the host system network is permitted. USER-MAPPINGS, a list of file +system mappings, contains the user-specified host file systems to mount inside +the container." + (mlet %store-monad ((reqs (inputs->requisites + (cons (direct-store-path bash) inputs)))) + (return + (let* ((cwd (getcwd)) + ;; Bind-mount all requisite store items, user-specified mappings, + ;; /bin/sh, the current working directory, and possibly networking + ;; configuration files within the container. + (mappings + (append user-mappings + ;; Current working directory. + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))) + ;; When in Rome, do as Nix build.cc does: Automagically + ;; map common network configuration files. + (if network? + (filter-map (lambda (file) + (and (file-exists? file) + (file-system-mapping + (source file) + (target file) + (writable? #f)))) + %network-configuration-files) + '()) + ;; Mappings for the union closure of all inputs. + (map (lambda (dir) + (file-system-mapping + (source dir) + (target dir) + (writable? #f))) + reqs))) + (file-systems (append %container-file-systems + (map mapping->file-system mappings)))) + (exit/status + (call-with-container (map file-system->spec file-systems) + (lambda () + ;; Setup global shell. + (mkdir-p "/bin") + (symlink bash "/bin/sh") + + ;; Setup directory for temporary files. + (mkdir-p "/tmp") + (for-each (lambda (var) + (setenv var "/tmp")) + ;; The same variables as in Nix's 'build.cc'. + '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) + + ;; From Nix build.cc: + ;; + ;; Set HOME to a non-existing path to prevent certain + ;; programs from using /etc/passwd (or NIS, or whatever) + ;; to locate the home directory (for example, wget looks + ;; for ~/.wgetrc). I.e., these tools use /etc/passwd if + ;; HOME is not set, but they will just assume that the + ;; settings file they are looking for does not exist if + ;; HOME is set but points to some non-existing path. + (setenv "HOME" "/homeless-shelter") + + ;; For convenience, start in the user's current working + ;; directory rather than the root directory. + (chdir cwd) + + (primitive-exit/status + ;; A container's environment is already purified, so no need to + ;; request it be purified again. + (launch-environment command inputs paths #f))) + #:namespaces (if network? + (delq 'net %namespaces) ; share host network + %namespaces))))))) + +(define (environment-bash container? bootstrap? system) + "Return a monadic value in the store monad for the version of GNU Bash +needed in the environment for SYSTEM, if any. If CONTAINER? is #f, return #f. +If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash. +Otherwise, return the derivation for the Bash package." + (with-monad %store-monad + (cond + ((and container? (not bootstrap?)) + (package->derivation bash)) + ;; Use the bootstrap Bash instead. + ((and container? bootstrap?) + (interned-file + (search-bootstrap-binary "bash" system))) + (else + (return #f))))) + (define (parse-args args) "Parse the list of command line arguments ARGS." (define (handle-argument arg result) - (alist-cons 'package arg result)) + (alist-cons 'package (tag-package-arg result arg) result)) ;; The '--' token is used to separate the command to run from the rest of ;; the operands. @@ -245,55 +443,103 @@ OUTPUT) tuples, using the build options in OPTS." opts (alist-cons 'exec command opts))))) +(define (assert-container-features) + "Check if containers can be created and exit with an informative error +message if any test fails." + (unless (user-namespace-supported?) + (report-error (_ "cannot create container: user namespaces unavailable\n")) + (leave (_ "is your kernel version < 3.10?\n"))) + + (unless (unprivileged-user-namespace-supported?) + (report-error (_ "cannot create container: unprivileged user cannot create user namespaces\n")) + (leave (_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n"))) + + (unless (setgroups-supported?) + (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) + (leave (_ "is your kernel version < 3.19?\n")))) + ;; Entry point. (define (guix-environment . args) (with-error-handling - (let* ((opts (parse-args args)) - (pure? (assoc-ref opts 'pure)) - (ad-hoc? (assoc-ref opts 'ad-hoc?)) - (command (assoc-ref opts 'exec)) - (packages (pick-all (options/resolve-packages opts) 'package)) - (inputs (if ad-hoc? - (append-map (match-lambda - ((package output) - (package+propagated-inputs package - output))) - packages) - (append-map (compose bag-transitive-inputs - package->bag - first) - packages))) - (paths (delete-duplicates - (cons $PATH - (append-map (match-lambda - ((label (? package? p) _ ...) - (package-native-search-paths p)) - (_ - '())) - inputs)) - eq?))) + (let* ((opts (parse-args args)) + (pure? (assoc-ref opts 'pure)) + (container? (assoc-ref opts 'container?)) + (network? (assoc-ref opts 'network?)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (system (assoc-ref opts 'system)) + (command (or (assoc-ref opts 'exec) + ;; Spawn a shell if the user didn't specify + ;; anything in particular. + (if container? + ;; The user's shell is likely not available + ;; within the container. + '("/bin/sh") + (list %default-shell)))) + (packages (options/resolve-packages opts)) + (mappings (pick-all opts 'file-system-mapping)) + (inputs (delete-duplicates + (append-map (match-lambda + (('ad-hoc-package package output) + (package+propagated-inputs package + output)) + (('package package output) + (bag-transitive-inputs + (package->bag package)))) + packages))) + (paths (delete-duplicates + (cons $PATH + (append-map (match-lambda + ((label (? package? p) _ ...) + (package-native-search-paths p)) + (_ + '())) + inputs)) + eq?))) + + (when container? (assert-container-features)) + (with-store store + (set-build-options-from-command-line store opts) (run-with-store store - (mlet %store-monad ((inputs (lower-inputs - (map (match-lambda + (mlet* %store-monad ((inputs (lower-inputs + (map (match-lambda ((label item) (list item)) ((label item output) (list item output))) - inputs) - #:system (assoc-ref opts 'system)))) + inputs) + #:system system)) + ;; Containers need a Bourne shell at /bin/sh. + (bash (environment-bash container? + bootstrap? + system))) (mbegin %store-monad - ;; First build INPUTS. This is necessary even for - ;; --search-paths. - (build-inputs inputs opts) - (cond ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths inputs paths pure?) - (return #t)) - (else - (create-environment inputs paths pure?) - (return - (exit - (status:exit-val - (apply system* command))))))))))))) + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash + ;; for a container. + (build-inputs (if (derivation? bash) + `((,bash "out") ,@inputs) + inputs) + opts) + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths inputs paths pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + bash + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user-mappings mappings + #:inputs inputs + #:paths paths + #:network? network?))) + (else + (return + (exit/status + (launch-environment command inputs paths pure?)))))))))))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 89a68d51d0..fe1bb93f7f 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -182,6 +182,10 @@ Invoke the garbage collector.\n")) (('argument . arg) arg) (_ #f)) opts))) + (define (assert-no-extra-arguments) + (unless (null? paths) + (leave (_ "extraneous arguments: ~{~a ~}~%") paths))) + (define (list-relatives relatives) (for-each (compose (lambda (path) (for-each (cut simple-format #t "~a~%" <>) @@ -192,6 +196,7 @@ Invoke the garbage collector.\n")) (case (assoc-ref opts 'action) ((collect-garbage) + (assert-no-extra-arguments) (let ((min-freed (assoc-ref opts 'min-freed))) (if min-freed (collect-garbage store min-freed) @@ -205,8 +210,10 @@ Invoke the garbage collector.\n")) ((list-referrers) (list-relatives referrers)) ((optimize) + (assert-no-extra-arguments) (optimize-store store)) ((verify) + (assert-no-extra-arguments) (let ((options (assoc-ref opts 'verify-options))) (exit (verify-store store diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 734a47719a..9255f0018a 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -18,6 +18,7 @@ (define-module (guix scripts graph) #:use-module (guix ui) + #:use-module (guix graph) #:use-module (guix scripts) #:use-module (guix utils) #:use-module (guix packages) @@ -28,53 +29,23 @@ #:use-module ((guix build-system gnu) #:select (standard-packages)) #:use-module (gnu packages) #:use-module (guix sets) - #:use-module (guix records) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type %bag-node-type + %bag-with-origins-node-type %bag-emerged-node-type %derivation-node-type %reference-node-type %node-types - node-type - node-type? - node-type-identifier - node-type-label - node-type-edges - node-type-convert - node-type-name - node-type-description - - %graphviz-backend - graph-backend? - graph-backend - - export-graph - guix-graph)) ;;; -;;; Node types. -;;; - -(define-record-type* <node-type> node-type make-node-type - node-type? - (identifier node-type-identifier) ;node -> M identifier - (label node-type-label) ;node -> string - (edges node-type-edges) ;node -> M list of nodes - (convert node-type-convert ;package -> M list of nodes - (default (lift1 list %store-monad))) - (name node-type-name) ;string - (description node-type-description)) ;string - - -;;; ;;; Package DAG. ;;; @@ -135,17 +106,23 @@ file name." low)))))) (define (bag-node-edges thing) - "Return the list of dependencies of THING, a package or origin, etc." - (if (package? thing) - (match (bag-direct-inputs (package->bag thing)) - (((labels things . outputs) ...) - (filter-map (match-lambda - ((? package? p) p) - ;; XXX: Here we choose to filter out origins, files, - ;; etc. Replace "#f" with "x" to reinstate them. - (x #f)) - things))) - '())) + "Return the list of dependencies of THING, a package or origin. +Dependencies may include packages, origin, and file names." + (cond ((package? thing) + (match (bag-direct-inputs (package->bag thing)) + (((labels things . outputs) ...) + things))) + ((origin? thing) + (cons (origin-patch-guile thing) + (if (or (pair? (origin-patches thing)) + (origin-snippet thing)) + (match (origin-patch-inputs thing) + (#f '()) + (((labels dependencies _ ...) ...) + (delete-duplicates dependencies eq?))) + '()))) + (else + '()))) (define %bag-node-type ;; Type for the traversal of package nodes via the "bag" representation, @@ -155,7 +132,22 @@ file name." (description "the DAG of packages, including implicit inputs") (identifier bag-node-identifier) (label node-full-name) - (edges (lift1 bag-node-edges %store-monad)))) + (edges (lift1 (compose (cut filter package? <>) bag-node-edges) + %store-monad)))) + +(define %bag-with-origins-node-type + (node-type + (name "bag-with-origins") + (description "the DAG of packages and origins, including implicit inputs") + (identifier bag-node-identifier) + (label node-full-name) + (edges (lift1 (lambda (thing) + (filter (match-lambda + ((? package?) #t) + ((? origin?) #t) + (_ #f)) + (bag-node-edges thing))) + %store-monad)))) (define standard-package-set (memoize @@ -270,6 +262,7 @@ substitutes." ;; List of all the node types. (list %package-node-type %bag-node-type + %bag-with-origins-node-type %bag-emerged-node-type %derivation-node-type %reference-node-type)) @@ -293,73 +286,6 @@ substitutes." ;;; -;;; Graphviz export. -;;; - -(define-record-type <graph-backend> - (graph-backend prologue epilogue node edge) - graph-backend? - (prologue graph-backend-prologue) - (epilogue graph-backend-epilogue) - (node graph-backend-node) - (edge graph-backend-edge)) - -(define (emit-prologue name port) - (format port "digraph \"Guix ~a\" {\n" - name)) -(define (emit-epilogue port) - (display "\n}\n" port)) -(define (emit-node id label port) - (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%" - id label)) -(define (emit-edge id1 id2 port) - (format port " \"~a\" -> \"~a\" [color = red];~%" - id1 id2)) - -(define %graphviz-backend - (graph-backend emit-prologue emit-epilogue - emit-node emit-edge)) - -(define* (export-graph sinks port - #:key - reverse-edges? - (node-type %package-node-type) - (backend %graphviz-backend)) - "Write to PORT the representation of the DAG with the given SINKS, using the -given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is -true, draw reverse arrows." - (match backend - (($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge) - (emit-prologue (node-type-name node-type) port) - - (match node-type - (($ <node-type> node-identifier node-label node-edges) - (let loop ((nodes sinks) - (visited (set))) - (match nodes - (() - (with-monad %store-monad - (emit-epilogue port) - (store-return #t))) - ((head . tail) - (mlet %store-monad ((id (node-identifier head))) - (if (set-contains? visited id) - (loop tail visited) - (mlet* %store-monad ((dependencies (node-edges head)) - (ids (mapm %store-monad - node-identifier - dependencies))) - (emit-node id (node-label head) port) - (for-each (lambda (dependency dependency-id) - (if reverse-edges? - (emit-edge dependency-id id port) - (emit-edge id dependency-id port))) - dependencies ids) - (loop (append dependencies tail) - (set-insert id visited))))))))))))) - - -;;; ;;; Command-line options. ;;; diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 8d31128c47..4e84278a78 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import hackage) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix packages) #:use-module (guix scripts) #:use-module (guix import hackage) #:use-module (guix scripts import) @@ -34,10 +35,13 @@ ;;; Command-line options. ;;; +(define ghc-default-version + (string-append "ghc-" (package-version (@ (gnu packages haskell) ghc)))) + (define %default-options - '((include-test-dependencies? . #t) + `((include-test-dependencies? . #t) (read-from-stdin? . #f) - ('cabal-environment . '()))) + (cabal-environment . ,`(("impl" . ,ghc-default-version))))) (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME @@ -55,7 +59,7 @@ version.\n")) (display (_ " -s, --stdin read from standard input")) (display (_ " - -t, --no-test-dependencies don't include test only dependencies")) + -t, --no-test-dependencies don't include test-only dependencies")) (display (_ " -V, --version display version information and exit")) (newline) @@ -134,9 +138,9 @@ from standard input~%"))))) ((package-name) (run-importer package-name opts (lambda () - (leave - (_ "failed to download cabal file for package '~a'~%")) - package-name))) + (leave (_ "failed to download cabal file \ +for package '~a'~%") + package-name)))) (() (leave (_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b1707ade44..338c7e827d 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -32,6 +32,7 @@ #:use-module (guix scripts) #:use-module (guix gnu-maintenance) #:use-module (guix monads) + #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -61,6 +62,7 @@ check-source check-source-file-name check-license + check-vulnerabilities check-formatting run-checkers @@ -266,10 +268,13 @@ the synopsis") (check-start-with-package-name synopsis) (check-synopsis-length synopsis)))) -(define (probe-uri uri) +(define* (probe-uri uri #:key timeout) "Probe URI, a URI object, and return two values: a symbol denoting the probing status, such as 'http-response' when we managed to get an HTTP -response from URI, and additional details, such as the actual HTTP response." +response from URI, and additional details, such as the actual HTTP response. + +TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait +for connections to complete; when TIMEOUT is #f, wait as long as needed." (define headers '((User-Agent . "GNU Guile") (Accept . "*/*"))) @@ -280,7 +285,7 @@ response from URI, and additional details, such as the actual HTTP response." ((or 'http 'https) (catch #t (lambda () - (let ((port (open-connection-for-uri uri)) + (let ((port (open-connection-for-uri uri #:timeout timeout)) (request (build-request uri #:headers headers))) (define response (dynamic-wind @@ -313,7 +318,7 @@ response from URI, and additional details, such as the actual HTTP response." ('ftp (catch #t (lambda () - (let ((conn (ftp-open (uri-host uri) 21))) + (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) (define response (dynamic-wind (const #f) @@ -338,7 +343,7 @@ response from URI, and additional details, such as the actual HTTP response." "Return #t if the given URI can be reached, otherwise return #f and emit a warning for PACKAGE mentionning the FIELD." (let-values (((status argument) - (probe-uri uri))) + (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) (or (= 200 (response-code argument)) @@ -568,6 +573,53 @@ descriptions maintained upstream." (emit-warning package (_ "invalid license field") 'license)))) +(define (patch-file-name patch) + "Return the basename of PATCH's file name, or #f if the file name could not +be determined." + (match patch + ((? string?) + (basename patch)) + ((? origin?) + (and=> (origin-actual-file-name patch) basename)))) + +(define (package-name->cpe-name name) + "Do a basic conversion of NAME, a Guix package name, to the corresponding +Common Platform Enumeration (CPE) name." + (match name + ("icecat" "firefox") ;or "firefox_esr" + ;; TODO: Add more. + (_ name))) + +(define package-vulnerabilities + (let ((lookup (delay (vulnerabilities->lookup-proc + (current-vulnerabilities))))) + (lambda (package) + "Return a list of vulnerabilities affecting PACKAGE." + ((force lookup) + (package-name->cpe-name (package-name package)) + (package-version package))))) + +(define (check-vulnerabilities package) + "Check for known vulnerabilities for PACKAGE." + (match (package-vulnerabilities package) + (() + #t) + ((vulnerabilities ...) + (let* ((patches (filter-map patch-file-name + (or (and=> (package-source package) + origin-patches) + '()))) + (unpatched (remove (lambda (vuln) + (find (cute string-contains + <> (vulnerability-id vuln)) + patches)) + vulnerabilities))) + (unless (null? unpatched) + (emit-warning package + (format #f (_ "probably vulnerable to ~a") + (string-join (map vulnerability-id unpatched) + ", ")))))))) + ;;; ;;; Source code formatting. @@ -706,6 +758,11 @@ or a list thereof") (description "Validate package synopses") (check check-synopsis-style)) (lint-checker + (name 'cve) + (description "Check the Common Vulnerabilities and Exposures\ + (CVE) database") + (check check-vulnerabilities)) + (lint-checker (name 'formatting) (description "Look for formatting issues in the source") (check check-formatting)))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e0fe1ddb27..c62daee9a7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -32,27 +32,21 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module ((guix build utils) - #:select (directory-exists? mkdir-p search-path-as-list)) + #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (gnu packages) - #:use-module (gnu packages base) - #:use-module (gnu packages guile) - #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) - #:export (switch-to-generation - switch-to-previous-generation - roll-back - delete-generation - delete-generations + #:autoload (gnu packages base) (canonical-package) + #:autoload (gnu packages guile) (guile-2.0) + #:autoload (gnu packages bootstrap) (%bootstrap-guile) + #:export (delete-generations display-search-paths guix-package)) @@ -100,149 +94,59 @@ indirectly, or PROFILE." %user-profile-directory profile)) -(define (link-to-empty-profile store generation) - "Link GENERATION, a string, to the empty profile." - (let* ((drv (run-with-store store - (profile-derivation (manifest '())))) - (prof (derivation->output-path drv "out"))) - (when (not (build-derivations store (list drv))) - (leave (_ "failed to build the empty profile~%"))) - - (switch-symlinks generation prof))) - -(define (switch-to-generation profile number) - "Atomically switch PROFILE to the generation NUMBER." - (let ((current (generation-number profile)) - (generation (generation-file-name profile number))) - (cond ((not (file-exists? profile)) - (raise (condition (&profile-not-found-error - (profile profile))))) - ((not (file-exists? generation)) - (raise (condition (&missing-generation-error - (profile profile) - (generation number))))) - (else - (format #t (_ "switching from generation ~a to ~a~%") - current number) - (switch-symlinks profile generation))))) - -(define (switch-to-previous-generation profile) - "Atomically switch PROFILE to the previous generation." - (switch-to-generation profile - (previous-generation-number profile))) - -(define (roll-back store profile) - "Roll back to the previous generation of PROFILE." - (let* ((number (generation-number profile)) - (previous-number (previous-generation-number profile number)) - (previous-generation (generation-file-name profile previous-number))) - (cond ((not (file-exists? profile)) ; invalid profile - (raise (condition (&profile-not-found-error - (profile profile))))) - ((zero? number) ; empty profile - (format (current-error-port) - (_ "nothing to do: already at the empty profile~%"))) - ((or (zero? previous-number) ; going to emptiness - (not (file-exists? previous-generation))) - (link-to-empty-profile store previous-generation) - (switch-to-previous-generation profile)) - (else - (switch-to-previous-generation profile))))) ; anything else - -(define (delete-generation store profile number) - "Delete generation with NUMBER from PROFILE." - (define (display-and-delete) - (let ((generation (generation-file-name profile number))) - (format #t (_ "deleting ~a~%") generation) - (delete-file generation))) - - (let* ((current-number (generation-number profile)) - (previous-number (previous-generation-number profile number)) - (previous-generation (generation-file-name profile previous-number))) - (cond ((zero? number)) ; do not delete generation 0 - ((and (= number current-number) - (not (file-exists? previous-generation))) - (link-to-empty-profile store previous-generation) - (switch-to-previous-generation profile) - (display-and-delete)) - ((= number current-number) - (roll-back store profile) - (display-and-delete)) - (else - (display-and-delete))))) +(define (ensure-default-profile) + "Ensure the default profile symlink and directory exist and are writable." + + (define (rtfm) + (format (current-error-port) + (_ "Try \"info '(guix) Invoking guix package'\" for \ +more information.~%")) + (exit 1)) + + ;; Create ~/.guix-profile if it doesn't exist yet. + (when (and %user-profile-directory + %current-profile + (not (false-if-exception + (lstat %user-profile-directory)))) + (symlink %current-profile %user-profile-directory)) + + (let ((s (stat %profile-directory #f))) + ;; Attempt to create /…/profiles/per-user/$USER if needed. + (unless (and s (eq? 'directory (stat:type s))) + (catch 'system-error + (lambda () + (mkdir-p %profile-directory)) + (lambda args + ;; Often, we cannot create %PROFILE-DIRECTORY because its + ;; parent directory is root-owned and we're running + ;; unprivileged. + (format (current-error-port) + (_ "error: while creating directory `~a': ~a~%") + %profile-directory + (strerror (system-error-errno args))) + (format (current-error-port) + (_ "Please create the `~a' directory, with you as the owner.~%") + %profile-directory) + (rtfm)))) + + ;; Bail out if it's not owned by the user. + (unless (or (not s) (= (stat:uid s) (getuid))) + (format (current-error-port) + (_ "error: directory `~a' is not owned by you~%") + %profile-directory) + (format (current-error-port) + (_ "Please change the owner of `~a' to user ~s.~%") + %profile-directory (or (getenv "USER") + (getenv "LOGNAME") + (getuid))) + (rtfm)))) (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. GENERATIONS is a list of generation numbers." - (for-each (cut delete-generation store profile <>) + (for-each (cut delete-generation* store profile <>) generations)) -(define* (matching-generations str #:optional (profile %current-profile) - #:key (duration-relation <=)) - "Return the list of available generations matching a pattern in STR. See -'string->generations' and 'string->duration' for the list of valid patterns. -When STR is a duration pattern, return all the generations whose ctime has -DURATION-RELATION with the current time." - (define (valid-generations lst) - (define (valid-generation? n) - (any (cut = n <>) (generation-numbers profile))) - - (fold-right (lambda (x acc) - (if (valid-generation? x) - (cons x acc) - acc)) - '() - lst)) - - (define (filter-generations generations) - (match generations - (() '()) - (('>= n) - (drop-while (cut > n <>) - (generation-numbers profile))) - (('<= n) - (valid-generations (iota n 1))) - ((lst ..1) - (valid-generations lst)) - (_ #f))) - - (define (filter-by-duration duration) - (define (time-at-midnight time) - ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and - ;; hours to zeros. - (let ((d (time-utc->date time))) - (date->time-utc - (make-date 0 0 0 0 - (date-day d) (date-month d) - (date-year d) (date-zone-offset d))))) - - (define generation-ctime-alist - (map (lambda (number) - (cons number - (time-second - (time-at-midnight - (generation-time profile number))))) - (generation-numbers profile))) - - (match duration - (#f #f) - (res - (let ((s (time-second - (subtract-duration (time-at-midnight (current-time)) - duration)))) - (delete #f (map (lambda (x) - (and (duration-relation s (cdr x)) - (first x))) - generation-ctime-alist)))))) - - (cond ((string->generations str) - => - filter-generations) - ((string->duration str) - => - filter-by-duration) - (else #f))) - (define (delete-matching-generations store profile pattern) "Delete from PROFILE all the generations matching PATTERN. PATTERN must be a string denoting a set of generations: the empty list means \"all generations @@ -253,7 +157,7 @@ denote ranges as interpreted by 'matching-derivations'." (raise (condition (&profile-not-found-error (profile profile))))) ((string-null? pattern) - (delete-generations (%store) profile + (delete-generations store profile (delv current (profile-generations profile)))) ;; Do not delete the zeroth generation. ((equal? 0 (string->number pattern)) @@ -274,10 +178,53 @@ denote ranges as interpreted by 'matching-derivations'." (let ((numbers (delv current numbers))) (when (null-list? numbers) (leave (_ "no matching generation~%"))) - (delete-generations (%store) profile numbers)))) + (delete-generations store profile numbers)))) (else (leave (_ "invalid syntax: ~a~%") pattern))))) +(define* (build-and-use-profile store profile manifest + #:key + bootstrap? use-substitutes? + dry-run?) + "Build a new generation of PROFILE, a file name, using the packages +specified in MANIFEST, a manifest object." + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (let* ((prof-drv (run-with-store store + (profile-derivation manifest + #:hooks (if bootstrap? + '() + %default-profile-hooks)))) + (prof (derivation->output-path prof-drv))) + (show-what-to-build store (list prof-drv) + #:use-substitutes? use-substitutes? + #:dry-run? dry-run?) + + (cond + (dry-run? #t) + ((and (file-exists? profile) + (and=> (readlink* profile) (cut string=? prof <>))) + (format (current-error-port) (_ "nothing to be done~%"))) + (else + (let* ((number (generation-number profile)) + + ;; Always use NUMBER + 1 for the new profile, possibly + ;; overwriting a "previous future generation". + (name (generation-file-name profile (+ 1 number)))) + (and (build-derivations store (list prof-drv)) + (let* ((entries (manifest-entries manifest)) + (count (length entries))) + (switch-symlinks name prof) + (switch-symlinks profile name) + (unless (string=? profile %current-profile) + (register-gc-root store name)) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count) + (display-search-paths entries (list profile))))))))) + ;;; ;;; Package specifications. @@ -327,11 +274,11 @@ an output path different than CURRENT-PATH." ;;; Search paths. ;;; -(define* (search-path-environment-variables entries profile +(define* (search-path-environment-variables entries profiles #:optional (getenv getenv) #:key (kind 'exact)) "Return environment variable definitions that may be needed for the use of -ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the +ENTRIES, a list of manifest entries, in PROFILES. Use GETENV to determine the current settings and report only settings not already effective. KIND must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search path definition to be returned." @@ -346,15 +293,15 @@ path definition to be returned." (environment-variable-definition variable value #:separator sep #:kind kind)))) - (evaluate-search-paths search-paths (list profile) + (evaluate-search-paths search-paths profiles getenv)))) -(define* (display-search-paths entries profile +(define* (display-search-paths entries profiles #:key (kind 'exact)) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." - (let* ((profile (user-friendly-profile profile)) - (settings (search-path-environment-variables entries profile + (let* ((profiles (map user-friendly-profile profiles)) + (settings (search-path-environment-variables entries profiles #:kind kind))) (unless (null? settings) (format #t (_ "The following environment variable definitions may be needed:~%")) @@ -367,8 +314,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (define %default-options ;; Alist of default option values. - `((profile . ,%current-profile) - (max-silent-time . 3600) + `((max-silent-time . 3600) (verbosity . 0) (substitutes? . #t))) @@ -527,7 +473,7 @@ kind of search path~%") (option '(#\p "profile") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'profile (canonicalize-profile arg) - (alist-delete 'profile result)) + result) #f))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result arg-handler) @@ -564,87 +510,76 @@ kind of search path~%") %standard-build-options)) -(define (options->installable opts manifest) - "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', -return the new list of manifest entries." - (define (package->manifest-entry* package output) - (check-package-freshness package) - ;; When given a package via `-e', install the first of its - ;; outputs (XXX). - (package->manifest-entry package output)) - +(define (options->upgrade-predicate opts) + "Return a predicate based on the upgrade/do-not-upgrade regexps in OPTS +that, given a package name, returns true if the package is a candidate for +upgrading, #f otherwise." (define upgrade-regexps (filter-map (match-lambda - (('upgrade . regexp) - (make-regexp (or regexp ""))) - (_ #f)) + (('upgrade . regexp) + (make-regexp* (or regexp ""))) + (_ #f)) opts)) (define do-not-upgrade-regexps (filter-map (match-lambda - (('do-not-upgrade . regexp) - (make-regexp regexp)) - (_ #f)) + (('do-not-upgrade . regexp) + (make-regexp* regexp)) + (_ #f)) opts)) - (define packages-to-upgrade - (match upgrade-regexps - (() - '()) - ((_ ...) - (filter-map (match-lambda - (($ <manifest-entry> name version output path _) - (and (any (cut regexp-exec <> name) - upgrade-regexps) - (not (any (cut regexp-exec <> name) - do-not-upgrade-regexps)) - (upgradeable? name version path) - (let ((output (or output "out"))) - (call-with-values - (lambda () - (specification->package+output name output)) - list)))) - (_ #f)) - (manifest-entries manifest))))) + (lambda (name) + (and (any (cut regexp-exec <> name) upgrade-regexps) + (not (any (cut regexp-exec <> name) do-not-upgrade-regexps))))) + +(define (store-item->manifest-entry item) + "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name." + (let-values (((name version) + (package-name->name+version (store-path-package-name item)))) + (manifest-entry + (name name) + (version version) + (output #f) + (item item)))) + +(define (options->installable opts manifest) + "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', +return the new list of manifest entries." + (define (package->manifest-entry* package output) + (check-package-freshness package) + (package->manifest-entry package output)) + + (define upgrade? + (options->upgrade-predicate opts)) (define to-upgrade - (map (match-lambda - ((package output) - (package->manifest-entry* package output))) - packages-to-upgrade)) + (filter-map (match-lambda + (($ <manifest-entry> name version output path _) + (and (upgrade? name) + (upgradeable? name version path) + (let ((output (or output "out"))) + (call-with-values + (lambda () + (specification->package+output name output)) + package->manifest-entry*)))) + (_ #f)) + (manifest-entries manifest))) - (define packages-to-install + (define to-install (filter-map (match-lambda - (('install . (? package? p)) - (list p "out")) - (('install . (? string? spec)) - (and (not (store-path? spec)) + (('install . (? package? p)) + ;; When given a package via `-e', install the first of its + ;; outputs (XXX). + (package->manifest-entry* p "out")) + (('install . (? string? spec)) + (if (store-path? spec) + (store-item->manifest-entry spec) (let-values (((package output) (specification->package+output spec))) - (and package (list package output))))) - (_ #f)) + (package->manifest-entry* package output)))) + (_ #f)) opts)) - (define to-install - (append (map (match-lambda - ((package output) - (package->manifest-entry* package output))) - packages-to-install) - (filter-map (match-lambda - (('install . (? package?)) - #f) - (('install . (? store-path? path)) - (let-values (((name version) - (package-name->name+version - (store-path-package-name path)))) - (manifest-entry - (name name) - (version version) - (output #f) - (item path)))) - (_ #f)) - opts))) - (append to-upgrade to-install)) (define (options->removable options manifest) @@ -678,33 +613,200 @@ doesn't need it." (add-indirect-root store absolute)) -(define (readlink* file) - "Call 'readlink' until the result is not a symlink." - (define %max-symlink-depth 50) - - (let loop ((file file) - (depth 0)) - (define (absolute target) - (if (absolute-file-name? target) - target - (string-append (dirname file) "/" target))) - - (if (>= depth %max-symlink-depth) - file - (call-with-values - (lambda () - (catch 'system-error - (lambda () - (values #t (readlink file))) - (lambda args - (let ((errno (system-error-errno args))) - (if (or (= errno EINVAL)) - (values #f file) - (apply throw args)))))) - (lambda (success? target) - (if success? - (loop (absolute target) (+ depth 1)) - file)))))) + +;;; +;;; Queries and actions. +;;; + +(define (process-query opts) + "Process any query specified by OPTS. Return #t when a query was actually +processed, #f otherwise." + (let* ((profiles (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst lst))) + (profile (match profiles + ((head tail ...) head)))) + (match (assoc-ref opts 'query) + (('list-generations pattern) + (define (list-generation number) + (unless (zero? number) + (display-generation profile number) + (display-profile-content profile number) + (newline))) + + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (for-each list-generation (profile-generations profile))) + ((matching-generations pattern profile) + => + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (leave-on-EPIPE + (for-each list-generation numbers))))) + (else + (leave (_ "invalid syntax: ~a~%") + pattern))) + #t) + + (('list-installed regexp) + (let* ((regexp (and regexp (make-regexp* regexp))) + (manifest (profile-manifest profile)) + (installed (manifest-entries manifest))) + (leave-on-EPIPE + (for-each (match-lambda + (($ <manifest-entry> name version output path _) + (when (or (not regexp) + (regexp-exec regexp name)) + (format #t "~a\t~a\t~a\t~a~%" + name (or version "?") output path)))) + + ;; Show most recently installed packages last. + (reverse installed))) + #t)) + + (('list-available regexp) + (let* ((regexp (and regexp (make-regexp* regexp))) + (available (fold-packages + (lambda (p r) + (let ((n (package-name p))) + (if (supported-package? p) + (if regexp + (if (regexp-exec regexp n) + (cons p r) + r) + (cons p r)) + r))) + '()))) + (leave-on-EPIPE + (for-each (lambda (p) + (format #t "~a\t~a\t~a\t~a~%" + (package-name p) + (package-version p) + (string-join (package-outputs p) ",") + (location->string (package-location p)))) + (sort available + (lambda (p1 p2) + (string<? (package-name p1) + (package-name p2)))))) + #t)) + + (('search regexp) + (let ((regexp (make-regexp* regexp regexp/icase))) + (leave-on-EPIPE + (for-each (cute package->recutils <> (current-output-port)) + (find-packages-by-description regexp))) + #t)) + + (('show requested-name) + (let-values (((name version) + (package-name->name+version requested-name))) + (leave-on-EPIPE + (for-each (cute package->recutils <> (current-output-port)) + (find-packages-by-name name version))) + #t)) + + (('search-paths kind) + (let* ((manifests (map profile-manifest profiles)) + (entries (append-map manifest-entries manifests)) + (profiles (map user-friendly-profile profiles)) + (settings (search-path-environment-variables entries profiles + (const #f) + #:kind kind))) + (format #t "~{~a~%~}" settings) + #t)) + + (_ #f)))) + + +(define* (roll-back-action store profile arg opts + #:key dry-run?) + "Roll back PROFILE to its previous generation." + (unless dry-run? + (roll-back* store profile))) + +(define* (switch-generation-action store profile spec opts + #:key dry-run?) + "Switch PROFILE to the generation specified by SPEC." + (unless dry-run? + (let* ((number (string->number spec)) + (number (and number + (case (string-ref spec 0) + ((#\+ #\-) + (relative-generation profile number)) + (else number))))) + (if number + (switch-to-generation* profile number) + (leave (_ "cannot switch to generation '~a'~%") spec))))) + +(define* (delete-generations-action store profile pattern opts + #:key dry-run?) + "Delete PROFILE's generations that match PATTERN." + (unless dry-run? + (delete-matching-generations store profile pattern))) + +(define* (manifest-action store profile file opts + #:key dry-run?) + "Change PROFILE to contain the packages specified in FILE." + (let* ((user-module (make-user-module '((guix profiles) (gnu)))) + (manifest (load* file user-module)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (substitutes? (assoc-ref opts 'substitutes?))) + (if dry-run? + (format #t (_ "would install new manifest from '~a' with ~d entries~%") + file (length (manifest-entries manifest))) + (format #t (_ "installing new manifest from '~a' with ~d entries~%") + file (length (manifest-entries manifest)))) + (build-and-use-profile store profile manifest + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?))) + +(define %actions + ;; List of actions that may be processed. The car of each pair is the + ;; action's symbol in the option list; the cdr is the action's procedure. + `((roll-back? . ,roll-back-action) + (switch-generation . ,switch-generation-action) + (delete-generations . ,delete-generations-action) + (manifest . ,manifest-action))) + +(define (process-actions store opts) + "Process any install/remove/upgrade action from OPTS." + + (define dry-run? (assoc-ref opts 'dry-run?)) + (define bootstrap? (assoc-ref opts 'bootstrap?)) + (define substitutes? (assoc-ref opts 'substitutes?)) + (define profile (or (assoc-ref opts 'profile) %current-profile)) + + ;; First, process roll-backs, generation removals, etc. + (for-each (match-lambda + ((key . arg) + (and=> (assoc-ref %actions key) + (lambda (proc) + (proc store profile arg opts + #:dry-run? dry-run?))))) + opts) + + ;; Then, process normal package installation/removal/upgrade. + (let* ((manifest (profile-manifest profile)) + (install (options->installable opts manifest)) + (remove (options->removable opts manifest)) + (transaction (manifest-transaction (install install) + (remove remove))) + (new (manifest-perform-transaction manifest transaction))) + + (unless (and (null? install) (null? remove)) + (show-manifest-transaction store manifest transaction + #:dry-run? dry-run?) + (build-and-use-profile store profile new + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?)))) ;;; @@ -718,278 +820,6 @@ doesn't need it." (arg-handler arg result) (leave (_ "~A: extraneous argument~%") arg))) - (define (ensure-default-profile) - ;; Ensure the default profile symlink and directory exist and are - ;; writable. - - (define (rtfm) - (format (current-error-port) - (_ "Try \"info '(guix) Invoking guix package'\" for \ -more information.~%")) - (exit 1)) - - ;; Create ~/.guix-profile if it doesn't exist yet. - (when (and %user-profile-directory - %current-profile - (not (false-if-exception - (lstat %user-profile-directory)))) - (symlink %current-profile %user-profile-directory)) - - (let ((s (stat %profile-directory #f))) - ;; Attempt to create /…/profiles/per-user/$USER if needed. - (unless (and s (eq? 'directory (stat:type s))) - (catch 'system-error - (lambda () - (mkdir-p %profile-directory)) - (lambda args - ;; Often, we cannot create %PROFILE-DIRECTORY because its - ;; parent directory is root-owned and we're running - ;; unprivileged. - (format (current-error-port) - (_ "error: while creating directory `~a': ~a~%") - %profile-directory - (strerror (system-error-errno args))) - (format (current-error-port) - (_ "Please create the `~a' directory, with you as the owner.~%") - %profile-directory) - (rtfm)))) - - ;; Bail out if it's not owned by the user. - (unless (or (not s) (= (stat:uid s) (getuid))) - (format (current-error-port) - (_ "error: directory `~a' is not owned by you~%") - %profile-directory) - (format (current-error-port) - (_ "Please change the owner of `~a' to user ~s.~%") - %profile-directory (or (getenv "USER") - (getenv "LOGNAME") - (getuid))) - (rtfm)))) - - (define (process-actions opts) - ;; Process any install/remove/upgrade action from OPTS. - - (define dry-run? (assoc-ref opts 'dry-run?)) - (define profile (assoc-ref opts 'profile)) - - (define (build-and-use-profile manifest) - (let* ((bootstrap? (assoc-ref opts 'bootstrap?))) - - (when (equal? profile %current-profile) - (ensure-default-profile)) - - (let* ((prof-drv (run-with-store (%store) - (profile-derivation - manifest - #:hooks (if bootstrap? - '() - %default-profile-hooks)))) - (prof (derivation->output-path prof-drv))) - (show-what-to-build (%store) (list prof-drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - - (cond - (dry-run? #t) - ((and (file-exists? profile) - (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) - (else - (let* ((number (generation-number profile)) - - ;; Always use NUMBER + 1 for the new profile, - ;; possibly overwriting a "previous future - ;; generation". - (name (generation-file-name profile - (+ 1 number)))) - (and (build-derivations (%store) (list prof-drv)) - (let* ((entries (manifest-entries manifest)) - (count (length entries))) - (switch-symlinks name prof) - (switch-symlinks profile name) - (unless (string=? profile %current-profile) - (register-gc-root (%store) name)) - (format #t (N_ "~a package in profile~%" - "~a packages in profile~%" - count) - count) - (display-search-paths entries profile))))))))) - - ;; First roll back if asked to. - (cond ((and (assoc-ref opts 'roll-back?) - (not dry-run?)) - (roll-back (%store) profile) - (process-actions (alist-delete 'roll-back? opts))) - ((and (assoc-ref opts 'switch-generation) - (not dry-run?)) - (for-each - (match-lambda - (('switch-generation . pattern) - (let* ((number (string->number pattern)) - (number (and number - (case (string-ref pattern 0) - ((#\+ #\-) - (relative-generation profile number)) - (else number))))) - (if number - (switch-to-generation profile number) - (leave (_ "cannot switch to generation '~a'~%") - pattern))) - (process-actions (alist-delete 'switch-generation opts))) - (_ #f)) - opts)) - ((and (assoc-ref opts 'delete-generations) - (not dry-run?)) - (for-each - (match-lambda - (('delete-generations . pattern) - (delete-matching-generations (%store) profile pattern) - - (process-actions - (alist-delete 'delete-generations opts))) - (_ #f)) - opts)) - ((assoc-ref opts 'manifest) - (let* ((file-name (assoc-ref opts 'manifest)) - (user-module (make-user-module '((guix profiles) - (gnu)))) - (manifest (load* file-name user-module))) - (if (assoc-ref opts 'dry-run?) - (format #t (_ "would install new manifest from '~a' with ~d entries~%") - file-name (length (manifest-entries manifest))) - (format #t (_ "installing new manifest from '~a' with ~d entries~%") - file-name (length (manifest-entries manifest)))) - (build-and-use-profile manifest))) - (else - (let* ((manifest (profile-manifest profile)) - (install (options->installable opts manifest)) - (remove (options->removable opts manifest)) - (transaction (manifest-transaction (install install) - (remove remove))) - (new (manifest-perform-transaction - manifest transaction))) - - (unless (and (null? install) (null? remove)) - (show-manifest-transaction (%store) manifest transaction - #:dry-run? dry-run?) - (build-and-use-profile new)))))) - - (define (process-query opts) - ;; Process any query specified by OPTS. Return #t when a query was - ;; actually processed, #f otherwise. - (let ((profile (assoc-ref opts 'profile))) - (match (assoc-ref opts 'query) - (('list-generations pattern) - (define (list-generation number) - (unless (zero? number) - (let ((header (format #f (_ "Generation ~a\t~a") number - (date->string - (time-utc->date - (generation-time profile number)) - "~b ~d ~Y ~T"))) - (current (generation-number profile))) - (if (= number current) - (format #t (_ "~a\t(current)~%") header) - (format #t "~a~%" header))) - (for-each (match-lambda - (($ <manifest-entry> name version output location _) - (format #t " ~a\t~a\t~a\t~a~%" - name version output location))) - - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest - (generation-file-name profile number))))) - (newline))) - - (cond ((not (file-exists? profile)) ; XXX: race condition - (raise (condition (&profile-not-found-error - (profile profile))))) - ((string-null? pattern) - (for-each list-generation (profile-generations profile))) - ((matching-generations pattern profile) - => - (lambda (numbers) - (if (null-list? numbers) - (exit 1) - (leave-on-EPIPE - (for-each list-generation numbers))))) - (else - (leave (_ "invalid syntax: ~a~%") - pattern))) - #t) - - (('list-installed regexp) - (let* ((regexp (and regexp (make-regexp regexp))) - (manifest (profile-manifest profile)) - (installed (manifest-entries manifest))) - (leave-on-EPIPE - (for-each (match-lambda - (($ <manifest-entry> name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - - ;; Show most recently installed packages last. - (reverse installed))) - #t)) - - (('list-available regexp) - (let* ((regexp (and regexp (make-regexp regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (supported-package? p) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) - '()))) - (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) - (sort available - (lambda (p1 p2) - (string<? (package-name p1) - (package-name p2)))))) - #t)) - - (('search regexp) - (let ((regexp (make-regexp regexp regexp/icase))) - (leave-on-EPIPE - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-description regexp))) - #t)) - - (('show requested-name) - (let-values (((name version) - (package-name->name+version requested-name))) - (leave-on-EPIPE - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-name name version))) - #t)) - - (('search-paths kind) - (let* ((manifest (profile-manifest profile)) - (entries (manifest-entries manifest)) - (profile (user-friendly-profile profile)) - (settings (search-path-environment-variables entries profile - (const #f) - #:kind kind))) - (format #t "~{~a~%~}" settings) - #t)) - - (_ #f)))) - (let ((opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument))) (with-error-handling @@ -1003,4 +833,4 @@ more information.~%")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.0))))) - (process-actions opts))))))) + (process-actions (%store) opts))))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 56ee9acb18..a4824e4fd7 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -18,6 +18,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) + #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 6f7ca4a41b..a5834d12cc 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +27,11 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix upstream) - #:use-module ((guix gnu-maintenance) #:select (%gnu-updater)) + #:use-module (guix graph) + #:use-module (guix scripts graph) + #:use-module (guix monads) + #:use-module ((guix gnu-maintenance) + #:select (%gnu-updater %gnome-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) #:use-module (guix gnupg) @@ -41,7 +46,8 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (rnrs io ports) - #:export (guix-refresh)) + #:export (guix-refresh + %updaters)) ;;; @@ -68,7 +74,16 @@ arg))))) (option '(#\t "type") #t #f (lambda (opt name arg result) - (alist-cons 'updater (string->symbol arg) result))) + (let* ((not-comma (char-set-complement (char-set #\,))) + (names (map string->symbol + (string-tokenize arg not-comma)))) + (alist-cons 'updaters names result)))) + (option '(#\L "list-updaters") #f #f + (lambda args + (list-updaters-and-exit))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) @@ -105,12 +120,17 @@ When PACKAGE... is given, update only the specified packages. Otherwise update all the packages of the distribution, or the subset thereof specified with `--select'.\n")) (display (_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) + (display (_ " -u, --update update source files in place")) (display (_ " -s, --select=SUBSET select all the packages in SUBSET, one of `core' or `non-core'")) (display (_ " - -t, --type=UPDATER restrict to updates from UPDATER--e.g., 'gnu'")) + -t, --type=UPDATER,... restrict to updates from the specified updaters + (e.g., 'gnu')")) + (display (_ " + -L, --list-updaters list available updaters and exit")) (display (_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) @@ -137,17 +157,62 @@ specified with `--select'.\n")) ;;; Updates. ;;; +(define-syntax maybe-updater + ;; Helper macro for 'list-updaters'. + (syntax-rules (=>) + ((_ ((module => updater) rest ...) result) + (maybe-updater (rest ...) + (let ((iface (false-if-exception + (resolve-interface 'module))) + (tail result)) + (if iface + (cons (module-ref iface 'updater) tail) + tail)))) + ((_ (updater rest ...) result) + (maybe-updater (rest ...) + (cons updater result))) + ((_ () result) + (reverse result)))) + +(define-syntax-rule (list-updaters updaters ...) + "Expand to '(list UPDATERS ...)' but only the subset of UPDATERS that are +either unconditional, or have their requirement met. + +A conditional updater has this form: + + ((SOME MODULE) => UPDATER) + +meaning that UPDATER is added to the list if and only if (SOME MODULE) could +be resolved at run time. + +This is a way to discard at macro expansion time updaters that depend on +unavailable optional dependencies such as Guile-JSON." + (maybe-updater (updaters ...) '())) + (define %updaters ;; List of "updaters" used by default. They are consulted in this order. - (list %gnu-updater - %elpa-updater - %cran-updater)) + (list-updaters %gnu-updater + %gnome-updater + %elpa-updater + %cran-updater + ((guix import pypi) => %pypi-updater))) (define (lookup-updater name) "Return the updater called NAME." - (find (lambda (updater) - (eq? name (upstream-updater-name updater))) - %updaters)) + (or (find (lambda (updater) + (eq? name (upstream-updater-name updater))) + %updaters) + (leave (_ "~a: no such updater~%") name))) + +(define (list-updaters-and-exit) + "Display available updaters and exit." + (format #t (_ "Available updaters:~%")) + (for-each (lambda (updater) + (format #t "- ~a: ~a~%" + (upstream-updater-name updater) + (_ (upstream-updater-description updater)))) + %updaters) + (exit 0)) (define* (update-package store package updaters #:key (key-download 'interactive)) @@ -177,6 +242,50 @@ downloaded and authenticated; not updating~%") ;;; +;;; Dependents. +;;; + +(define (all-packages) + "Return the list of all the distro's packages." + (fold-packages cons '())) + +(define (list-dependents packages) + "List all the things that would need to be rebuilt if PACKAGES are changed." + (with-store store + (run-with-store store + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (mlet %store-monad ((edges (node-back-edges %bag-node-type + (all-packages)))) + (let* ((dependents (node-transitive-edges packages edges)) + (covering (filter (lambda (node) + (null? (edges node))) + dependents))) + (match dependents + (() + (format (current-output-port) + (N_ "No dependents other than itself: ~{~a~}~%" + "No dependents other than themselves: ~{~a~^ ~}~%" + (length packages)) + (map package-full-name packages))) + + ((x) + (format (current-output-port) + (_ "A single dependent package: ~a~%") + (package-full-name x))) + (lst + (format (current-output-port) + (N_ "Building the following package would ensure ~d \ +dependent packages are rebuilt: ~*~{~a~^ ~}~%" + "Building the following ~d packages would ensure ~d \ +dependent packages are rebuilt: ~{~a~^ ~}~%" + (length covering)) + (length covering) (length dependents) + (map package-full-name covering)))) + (return #t)))))) + + +;;; ;;; Entry point. ;;; @@ -193,15 +302,15 @@ downloaded and authenticated; not updating~%") (define (options->updaters opts) ;; Return the list of updaters to use. (match (filter-map (match-lambda - (('updater . name) - (lookup-updater name)) + (('updaters . names) + (map lookup-updater names)) (_ #f)) opts) (() ;; Use the default updaters. %updaters) - (lst - lst))) + (lists + (concatenate lists)))) (define (keep-newest package lst) ;; If a newer version of PACKAGE is already in LST, return LST; otherwise @@ -248,6 +357,8 @@ update would trigger a complete rebuild." ;; Take either the specified version or the ;; latest one. (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) (_ #f)) opts) (() ; default to all packages @@ -265,25 +376,7 @@ update would trigger a complete rebuild." (with-error-handling (cond (list-dependent? - (let* ((rebuilds (map package-full-name - (package-covering-dependents packages))) - (total-dependents - (length (package-transitive-dependents packages)))) - (if (= total-dependents 0) - (format (current-output-port) - (N_ "No dependents other than itself: ~{~a~}~%" - "No dependents other than themselves: ~{~a~^ ~}~%" - (length packages)) - (map package-full-name packages)) - (format (current-output-port) - (N_ (N_ "A single dependent package: ~2*~{~a~}~%" - "Building the following package would ensure ~d \ -dependent packages are rebuilt; ~*~{~a~^ ~}~%" - total-dependents) - "Building the following ~d packages would ensure ~d \ -dependent packages are rebuilt: ~{~a~^ ~}~%" - (length rebuilds)) - (length rebuilds) total-dependents rebuilds)))) + (list-dependents packages)) (update? (let ((store (open-connection))) (parameterize ((%openpgp-key-server diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 44ff92655b..e999cce1fd 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -252,8 +252,7 @@ Report the size of PACKAGE and its dependencies.\n")) (show-version-and-exit "guix size"))))) (define %default-options - `((system . ,(%current-system)) - (substitute-urls . ,%default-substitute-urls))) + `((system . ,(%current-system)))) ;;; diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8967fa062e..01cc3f129e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -72,6 +72,7 @@ assert-valid-narinfo lookup-narinfos + lookup-narinfos/diverse read-narinfo write-narinfo guix-substitute)) @@ -474,12 +475,13 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-url requests proc) +(define (http-multiple-get base-url proc seed requests) "Send all of REQUESTS to the server at BASE-URL. Call PROC for each -response, passing it the request object, the response, and a port from which -to read the response body. Return the list of results." +response, passing it the request object, the response, a port from which to +read the response body, and the previous result, starting with SEED, à la +'fold'. Return the final result." (let connect ((requests requests) - (result '())) + (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) (let ((p (open-socket-for-uri base-url))) @@ -497,7 +499,7 @@ to read the response body. Return the list of results." ((head tail ...) (let* ((resp (read-response p)) (body (response-body-port resp)) - (result (cons (proc head resp body) result))) + (result (proc head resp body result))) ;; The server can choose to stop responding at any time, in which ;; case we have to try again. Check whether that is the case. ;; Note that even upon "Connection: close", we can read from BODY. @@ -536,7 +538,7 @@ if file doesn't exist, and the narinfo otherwise." url (* 100. (/ done (length paths)))) (set! done (+ 1 done))))) - (define (handle-narinfo-response request response port) + (define (handle-narinfo-response request response port result) (let ((len (response-content-length response))) ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. @@ -545,7 +547,7 @@ if file doesn't exist, and the narinfo otherwise." (let ((narinfo (read-narinfo port url #:size len))) (cache-narinfo! url (narinfo-path narinfo) narinfo) (update-progress!) - narinfo)) + (cons narinfo result))) ((404) ; failure (let* ((path (uri-path (request-uri request))) (hash-part (string-drop-right path 8))) ; drop ".narinfo" @@ -555,38 +557,45 @@ if file doesn't exist, and the narinfo otherwise." (cache-narinfo! url (find (cut string-contains <> hash-part) paths) #f) - (update-progress!)) - #f) + (update-progress!) + result)) (else ; transient failure (if len (get-bytevector-n port len) (read-to-eof port)) - #f)))) + result)))) + + (define (do-fetch uri) + (case (and=> uri uri-scheme) + ((http) + (let ((requests (map (cut narinfo-request url <>) paths))) + (update-progress!) + (let ((result (http-multiple-get url + handle-narinfo-response '() + requests))) + (newline (current-error-port)) + result))) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))) (define cache-info (download-cache-info url)) (and cache-info - (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (let ((uri (string->uri url))) - (case (and=> uri uri-scheme) - ((http) - (let ((requests (map (cut narinfo-request url <>) paths))) - (update-progress!) - (let ((result (http-multiple-get url requests - handle-narinfo-response))) - (newline (current-error-port)) - result))) - ((file #f) - (let* ((base (string-append (uri-path uri) "/")) - (files (map (compose (cut string-append base <> ".narinfo") - store-path-hash-part) - paths))) - (filter-map (cut narinfo-from-file <> url) files))) - (else - (leave (_ "~s: unsupported server URI scheme~%") - (if uri (uri-scheme uri) url))))))) + (if (string=? (cache-info-store-directory cache-info) + (%store-prefix)) + (do-fetch (string->uri url)) + (begin + (warning (_ "'~a' uses different store '~a'; ignoring it~%") + url (cache-info-store-directory cache-info)) + #f)))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no @@ -596,7 +605,9 @@ information is available locally." (let-values (((valid? value) (cached-narinfo cache path))) (if valid? - (values (cons value cached) missing) + (if value + (values (cons value cached) missing) + (values cached missing)) (values cached (cons path missing))))) '() '() @@ -606,11 +617,32 @@ information is available locally." (let ((missing (fetch-narinfos cache missing))) (append cached (or missing '())))))) -(define (lookup-narinfo cache path) - "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was -found." - (match (lookup-narinfos cache (list path)) - ((answer) answer))) +(define (lookup-narinfos/diverse caches paths) + "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. +That is, when a cache lacks a narinfo, look it up in the next cache, and so +on. Return a list of narinfos for PATHS or a subset thereof." + (let loop ((caches caches) + (paths paths) + (result '())) + (match paths + (() ;we're done + result) + (_ + (match caches + ((cache rest ...) + (let* ((narinfos (lookup-narinfos cache paths)) + (hits (map narinfo-path narinfos)) + (missing (lset-difference string=? paths hits))) ;XXX: perf + (loop rest missing (append narinfos result)))) + (() ;that's it + result)))))) + +(define (lookup-narinfo caches path) + "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH +was found." + (match (lookup-narinfos/diverse caches (list path)) + ((answer) answer) + (_ #f))) (define (remove-expired-cached-narinfos directory) "Remove expired narinfo entries from DIRECTORY. The sole purpose of this @@ -752,34 +784,34 @@ expected by the daemon." (or (narinfo-size narinfo) 0))) (define* (process-query command - #:key cache-url acl) + #:key cache-urls acl) "Reply to COMMAND, a query as written by the daemon to this process's standard input. Use ACL as the access-control list against which to check authorized substitutes." (define (valid? obj) - (and (narinfo? obj) (valid-narinfo? obj acl))) + (valid-narinfo? obj acl)) (match (string-tokenize command) (("have" paths ..1) - ;; Return the subset of PATHS available in CACHE-URL. - (let ((substitutable (lookup-narinfos cache-url paths))) + ;; Return the subset of PATHS available in CACHE-URLS. + (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) (for-each (lambda (narinfo) (format #t "~a~%" (narinfo-path narinfo))) (filter valid? substitutable)) (newline))) (("info" paths ..1) - ;; Reply info about PATHS if it's in CACHE-URL. - (let ((substitutable (lookup-narinfos cache-url paths))) + ;; Reply info about PATHS if it's in CACHE-URLS. + (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) (for-each display-narinfo-data (filter valid? substitutable)) (newline))) (wtf (error "unknown `--query' command" wtf)))) (define* (process-substitution store-item destination - #:key cache-url acl) - "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to + #:key cache-urls acl) + "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL." - (let* ((narinfo (lookup-narinfo cache-url store-item)) + (let* ((narinfo (lookup-narinfo cache-urls store-item)) (uri (narinfo-uri narinfo))) ;; Make sure it is signed and everything. (assert-valid-narinfo narinfo acl) @@ -876,21 +908,16 @@ found." b first))) -(define %cache-url +(define %cache-urls (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client (find-daemon-option "substitute-urls")) ;admin string-tokenize) - ((url) - url) - ((head tail ..1) - ;; Currently we don't handle multiple substitute URLs. - (warning (_ "these substitute URLs will not be used:~{ ~a~}~%") - tail) - head) + ((urls ...) + urls) (#f ;; This can only happen when this script is not invoked by the ;; daemon. - "http://hydra.gnu.org"))) + '("http://hydra.gnu.org")))) (define (guix-substitute . args) "Implement the build daemon's substituter protocol." @@ -901,20 +928,8 @@ found." ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly ;; when we know we cannot substitute, but we must emit a newline on stdout ;; when everything is alright. - (let ((uri (string->uri %cache-url))) - (case (uri-scheme uri) - ((http) - ;; Exit gracefully if there's no network access. - (let ((host (uri-host uri))) - (catch 'getaddrinfo-error - (lambda () - (getaddrinfo host)) - (lambda (key error) - (warning (_ "failed to look up host '~a' (~a), \ -substituter disabled~%") - host (gai-strerror error)) - (exit 0))))) - (else #t))) + (when (null? %cache-urls) + (exit 0)) ;; Say hello (see above.) (newline) @@ -929,13 +944,13 @@ substituter disabled~%") (or (eof-object? command) (begin (process-query command - #:cache-url %cache-url + #:cache-urls %cache-urls #:acl acl) (loop (read-line))))))) (("--substitute" store-path destination) ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. (process-substitution store-path destination - #:cache-url %cache-url + #:cache-urls %cache-urls #:acl (current-acl))) (("--version") (show-version-and-exit "guix substitute")) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b5da57a9ce..1407dc73fa 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -25,14 +25,17 @@ #:use-module (guix packages) #:use-module (guix utils) #:use-module (guix monads) + #:use-module (guix records) #:use-module (guix profiles) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix build utils) #:use-module (gnu build install) #:use-module (gnu system) #:use-module (gnu system file-systems) + #:use-module (gnu system linux-container) #:use-module (gnu system vm) #:use-module (gnu system grub) #:use-module (gnu services) @@ -41,6 +44,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-system @@ -186,6 +191,39 @@ the ownership of '~a' may be incorrect!~%") ;;; +;;; Boot parameters +;;; + +(define-record-type* <boot-parameters> + boot-parameters make-boot-parameters boot-parameters? + (label boot-parameters-label) + (root-device boot-parameters-root-device) + (kernel boot-parameters-kernel) + (kernel-arguments boot-parameters-kernel-arguments)) + +(define (read-boot-parameters port) + "Read boot parameters from PORT and return the corresponding +<boot-parameters> object or #f if the format is unrecognized." + (match (read port) + (('boot-parameters ('version 0) + ('label label) ('root-device root) + ('kernel linux) + rest ...) + (boot-parameters + (label label) + (root-device root) + (kernel linux) + (kernel-arguments + (match (assq 'kernel-arguments rest) + ((_ args) args) + (#f '()))))) ;the old format + (x ;unsupported format + (warning (_ "unrecognized boot parameters for '~a'~%") + system) + #f))) + + +;;; ;;; Reconfiguration. ;;; @@ -247,30 +285,22 @@ it atomically, and then run OS's activation script." "Return a list of 'menu-entry' for the generations of PROFILE." (define (system->grub-entry system number time) (unless-file-not-found - (call-with-input-file (string-append system "/parameters") - (lambda (port) - (match (read port) - (('boot-parameters ('version 0) - ('label label) ('root-device root) - ('kernel linux) - rest ...) - (menu-entry - (label (string-append label " (#" - (number->string number) ", " - (seconds->string time) ")")) - (linux linux) - (linux-arguments - (cons* (string-append "--root=" root) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system "/boot") - (match (assq 'kernel-arguments rest) - ((_ args) args) - (#f '())))) ;old format - (initrd #~(string-append #$system "/initrd")))) - (_ ;unsupported format - (warning (_ "unrecognized boot parameters for '~a'~%") - system) - #f)))))) + (let ((file (string-append system "/parameters"))) + (match (call-with-input-file file read-boot-parameters) + (($ <boot-parameters> label root kernel kernel-arguments) + (menu-entry + (label (string-append label " (#" + (number->string number) ", " + (seconds->string time) ")")) + (linux kernel) + (linux-arguments + (cons* (string-append "--root=" root) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system "/boot") + kernel-arguments)) + (initrd #~(string-append #$system "/initrd")))) + (#f ;invalid format + #f))))) (let* ((numbers (generation-numbers profile)) (systems (map (cut generation-file-name profile <>) @@ -327,6 +357,48 @@ list of services." ;;; +;;; Generations. +;;; + +(define* (display-system-generation number + #:optional (profile %system-profile)) + "Display a summary of system generation NUMBER in a human-readable format." + (unless (zero? number) + (let* ((generation (generation-file-name profile number)) + (param-file (string-append generation "/parameters")) + (params (call-with-input-file param-file read-boot-parameters))) + (display-generation profile number) + (format #t (_ " file name: ~a~%") generation) + (format #t (_ " canonical file name: ~a~%") (readlink* generation)) + (match params + (($ <boot-parameters> label root kernel) + ;; TRANSLATORS: Please preserve the two-space indentation. + (format #t (_ " label: ~a~%") label) + (format #t (_ " root device: ~a~%") root) + (format #t (_ " kernel: ~a~%") kernel)) + (_ + #f))))) + +(define* (list-generations pattern #:optional (profile %system-profile)) + "Display in a human-readable format all the system generations matching +PATTERN, a string. When PATTERN is #f, display all the system generations." + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (for-each display-system-generation (profile-generations profile))) + ((matching-generations pattern profile) + => + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (leave-on-EPIPE + (for-each display-system-generation numbers))))) + (else + (leave (_ "invalid syntax: ~a~%") pattern)))) + + +;;; ;;; Action. ;;; @@ -336,6 +408,8 @@ list of services." (case action ((build init reconfigure) (operating-system-derivation os)) + ((container) + (container-script os #:mappings mappings)) ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) @@ -368,12 +442,20 @@ building anything." #:full-boot? full-boot? #:mappings mappings)) (grub (package->derivation grub)) - (grub.cfg (operating-system-grub.cfg os - (if (eq? 'init action) - '() - (previous-grub-entries)))) - (drvs -> (if (and grub? (memq action '(init reconfigure))) - (list sys grub grub.cfg) + (grub.cfg (if (eq? 'container action) + (return #f) + (operating-system-grub.cfg os + (if (eq? 'init action) + '() + (previous-grub-entries))))) + + ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if + ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC + ;; root. See <http://bugs.gnu.org/21068>. + (drvs -> (if (memq action '(init reconfigure)) + (if grub? + (list sys grub.cfg grub) + (list sys grub.cfg)) (list sys))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) @@ -416,10 +498,10 @@ building anything." (define (export-extension-graph os port) "Export the service extension graph of OS to PORT." (let* ((services (operating-system-services os)) - (boot (find (lambda (service) - (eq? (service-kind service) boot-service-type)) + (system (find (lambda (service) + (eq? (service-kind service) system-service-type)) services))) - (export-graph (list boot) (current-output-port) + (export-graph (list system) (current-output-port) #:node-type (service-node-type services) #:reverse-edges? #t))) @@ -442,7 +524,7 @@ building anything." ;;; (define (show-help) - (display (_ "Usage: guix system [OPTION] ACTION FILE + (display (_ "Usage: guix system [OPTION] ACTION [FILE] Build the operating system declared in FILE according to ACTION.\n")) (newline) (display (_ "The valid values for ACTION are:\n")) @@ -450,8 +532,12 @@ Build the operating system declared in FILE according to ACTION.\n")) (display (_ "\ reconfigure switch to a new operating system configuration\n")) (display (_ "\ + list-generations list the system generations\n")) + (display (_ "\ build build the operating system without installing anything\n")) (display (_ "\ + container build a container that shares the host's store\n")) + (display (_ "\ vm build a virtual machine image that shares the host's store\n")) (display (_ "\ vm-image build a freestanding virtual machine image\n")) @@ -488,19 +574,6 @@ Build the operating system declared in FILE according to ACTION.\n")) (newline) (show-bug-report-information)) -(define (specification->file-system-mapping spec writable?) - "Read the SPEC and return the corresponding <file-system-mapping>." - (let ((index (string-index spec #\=))) - (if index - (file-system-mapping - (source (substring spec 0 index)) - (target (substring spec (+ 1 index))) - (writable? writable?)) - (file-system-mapping - (source spec) - (target spec) - (writable? writable?))))) - (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -563,6 +636,71 @@ Build the operating system declared in FILE according to ACTION.\n")) ;;; Entry point. ;;; +(define (process-action action args opts) + "Process ACTION, a sub-command, with the arguments are listed in ARGS. +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." + (let* ((file (match args + (() #f) + ((x . _) x))) + (system (assoc-ref opts 'system)) + (os (if file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error)) + (leave (_ "no configuration file specified~%")))) + + (dry? (assoc-ref opts 'dry-run?)) + (grub? (assoc-ref opts 'install-grub?)) + (target (match args + ((first second) second) + (_ #f))) + (device (and grub? + (grub-configuration-device + (operating-system-bootloader os))))) + + (with-store store + (set-build-options-from-command-line store opts) + + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (case action + ((extension-graph) + (export-extension-graph os (current-output-port))) + ((dmd-graph) + (export-dmd-graph os (current-output-port))) + (else + (perform-action action os + #:dry-run? dry? + #:derivations-only? (assoc-ref opts + 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:image-size (assoc-ref opts 'image-size) + #:full-boot? (assoc-ref opts 'full-boot?) + #:mappings (filter-map (match-lambda + (('file-system-mapping . m) + m) + (_ #f)) + opts) + #:grub? grub? + #:target target #:device device)))) + #:system system)))) + +(define (process-command command args opts) + "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its +argument list and OPTS is the option alist." + (case command + ((list-generations) + ;; List generations. No need to connect to the daemon, etc. + (let ((pattern (match args + (() "") + ((pattern) pattern) + (x (leave (_ "wrong number of arguments~%")))))) + (list-generations pattern))) + (else + (process-action command args opts)))) + (define (guix-system . args) (define (parse-sub-command arg result) ;; Parse sub-command ARG and augment RESULT accordingly. @@ -570,8 +708,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build vm vm-image disk-image reconfigure init - extension-graph dmd-graph) + ((build container vm vm-image disk-image reconfigure init + extension-graph dmd-graph list-generations) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -599,7 +737,7 @@ Build the operating system declared in FILE according to ACTION.\n")) (exit 1)) (case action - ((build vm vm-image disk-image reconfigure) + ((build container vm vm-image disk-image reconfigure) (unless (= count 1) (fail))) ((init) @@ -613,49 +751,7 @@ Build the operating system declared in FILE according to ACTION.\n")) #:argument-handler parse-sub-command)) (args (option-arguments opts)) - (file (first args)) - (action (assoc-ref opts 'action)) - (system (assoc-ref opts 'system)) - (os (if file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error)) - (leave (_ "no configuration file specified~%")))) - - (dry? (assoc-ref opts 'dry-run?)) - (grub? (assoc-ref opts 'install-grub?)) - (target (match args - ((first second) second) - (_ #f))) - (device (and grub? - (grub-configuration-device - (operating-system-bootloader os)))) - - (store (open-connection))) - (set-build-options-from-command-line store opts) - - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (case action - ((extension-graph) - (export-extension-graph os (current-output-port))) - ((dmd-graph) - (export-dmd-graph os (current-output-port))) - (else - (perform-action action os - #:dry-run? dry? - #:derivations-only? (assoc-ref opts - 'derivations-only?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:image-size (assoc-ref opts 'image-size) - #:full-boot? (assoc-ref opts 'full-boot?) - #:mappings (filter-map (match-lambda - (('file-system-mapping . m) - m) - (_ #f)) - opts) - #:grub? grub? - #:target target #:device device)))) - #:system system)))) + (command (assoc-ref opts 'action))) + (process-command command args opts)))) ;;; system.scm ends here |