diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 20 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 207 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 37 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 57 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 21 | ||||
| -rw-r--r-- | guix/scripts/import/cran.scm | 26 | ||||
| -rw-r--r-- | guix/scripts/import/crate.scm | 94 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 75 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 411 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 134 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 2 |
15 files changed, 823 insertions, 292 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 400353247c..6eba9e0008 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ #:use-module (guix ui) #:use-module (guix pki) #:use-module (guix pk-crypto) + #:use-module (guix docker) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) @@ -41,7 +43,8 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 binary-ports) - #:export (guix-archive)) + #:export (guix-archive + options->derivations+files)) ;;; @@ -62,6 +65,8 @@ Export/import one or more packages from/to the store.\n")) (display (_ " --export export the specified files/packages to stdout")) (display (_ " + --format=FMT export files/packages in the specified format FMT")) + (display (_ " -r, --recursive combined with '--export', include dependencies")) (display (_ " --import import from the archive passed on stdin")) @@ -116,6 +121,9 @@ Export/import one or more packages from/to the store.\n")) (option '("export") #f #f (lambda (opt name arg result) (alist-cons 'export #t result))) + (option '(#\f "format") #t #f + (lambda (opt name arg result . rest) + (alist-cons 'format arg result))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'export-recursive? #t result))) @@ -330,7 +338,15 @@ the input port." (else (with-store store (cond ((assoc-ref opts 'export) - (export-from-store store opts)) + (cond ((equal? (assoc-ref opts 'format) "docker") + (match (car opts) + (('argument . (? store-path? item)) + (format #t "~a\n" + (build-docker-image + item + #:system (assoc-ref opts 'system)))) + (_ (leave (_ "argument must be a direct store path~%"))))) + (_ (export-from-store store opts)))) ((assoc-ref opts 'import) (import-paths store (current-input-port))) ((assoc-ref opts 'missing) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8c2c4902fc..ccb4c275fc 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -151,7 +151,11 @@ the new package's version number from URI." ;; Use #:recursive? #t to allow for directories. (source (download-to-store store uri - #:recursive? #t)))))) + #:recursive? #t)) + + ;; Override the replacement, otherwise '--with-source' would + ;; have no effect. + (replacement #f))))) ;;; diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm new file mode 100644 index 0000000000..9ae204e6c6 --- /dev/null +++ b/guix/scripts/copy.scm @@ -0,0 +1,207 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès <ludo@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 copy) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix ssh) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix scripts build) + #:use-module ((guix scripts archive) #:select (options->derivations+files)) + #:use-module (ssh session) + #:use-module (ssh auth) + #:use-module (ssh key) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-copy)) + + +;;; +;;; Exchanging store items over SSH. +;;; + +(define %compression + "zlib@openssh.com,zlib") + +(define* (open-ssh-session host #:key user port) + "Open an SSH session for HOST and return it. When USER and PORT are #f, use +default values or whatever '~/.ssh/config' specifies; otherwise use them. +Throw an error on failure." + (let ((session (make-session #:user user + #:host host + #:port port + #:timeout 10 ;seconds + ;; #:log-verbosity 'protocol + + ;; We need lightweight compression when + ;; exchanging full archives. + #:compression %compression + #:compression-level 3))) + + ;; Honor ~/.ssh/config. + (session-parse-config! session) + + (match (connect! session) + ('ok + ;; Let the SSH agent authenticate us to the server. + (match (userauth-agent! session) + ('success + session) + (x + (disconnect! session) + (leave (_ "SSH authentication failed for '~a': ~a~%") + host (get-error session))))) + (x + ;; Connection failed or timeout expired. + (leave (_ "SSH connection to '~a' failed: ~a~%") + host (get-error session)))))) + +(define (ssh-spec->user+host+port spec) + "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return +three values: the user name (or #f), the host name, and the TCP port +number (or #f) corresponding to SPEC." + (define tokens + (char-set #\@ #\:)) + + (match (string-tokenize spec (char-set-complement tokens)) + ((host) + (values #f host #f)) + ((left right) + (if (string-index spec #\@) + (values left right #f) + (values #f left (string->number right)))) + ((user host port) + (match (string->number port) + ((? integer? port) + (values user host port)) + (x + (leave (_ "~a: invalid TCP port number~%") port)))) + (x + (leave (_ "~a: invalid SSH specification~%") spec)))) + +(define (send-to-remote-host target opts) + "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; +package names, build the underlying packages before sending them." + (with-store local + (set-build-options-from-command-line local opts) + (let-values (((user host port) + (ssh-spec->user+host+port target)) + ((drv items) + (options->derivations+files local opts))) + (show-what-to-build local drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) + + (and (or (assoc-ref opts 'dry-run?) + (build-derivations local drv)) + (let* ((session (open-ssh-session host #:user user #:port port)) + (sent (send-files local items + (connect-to-remote-daemon session) + #:recursive? #t))) + (format #t "~{~a~%~}" sent) + sent))))) + +(define (retrieve-from-remote-host source opts) + "Retrieve ITEMS from SOURCE." + (with-store local + (let*-values (((user host port) + (ssh-spec->user+host+port source)) + ((session) + (open-ssh-session host #:user user #:port port)) + ((remote) + (connect-to-remote-daemon session))) + (set-build-options-from-command-line local opts) + ;; TODO: Here we could to compute and build the derivations on REMOTE + ;; rather than on LOCAL (one-off offloading) but that is currently too + ;; slow due to the many RPC round trips. So we just assume that REMOTE + ;; contains ITEMS. + (let*-values (((drv items) + (options->derivations+files local opts)) + ((retrieved) + (retrieve-files local items remote #:recursive? #t))) + (format #t "~{~a~%~}" retrieved) + retrieved)))) + + +;;; +;;; Options. +;;; + +(define (show-help) + (display (_ "Usage: guix copy [OPTION]... ITEMS... +Copy ITEMS to or from the specified host over SSH.\n")) + (display (_ " + --to=HOST send ITEMS to HOST")) + (display (_ " + --from=HOST receive ITEMS from HOST")) + (newline) + (show-build-options-help) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (cons* (option '("to") #t #f + (lambda (opt name arg result) + (alist-cons 'destination arg result))) + (option '("from") #t #f + (lambda (opt name arg result) + (alist-cons 'source arg result))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix copy"))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + %standard-build-options)) + +(define %default-options + `((system . ,(%current-system)) + (substitutes? . #t) + (graft? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + + +;;; +;;; Entry point. +;;; + +(define (guix-copy . args) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options))) + (source (assoc-ref opts 'source)) + (target (assoc-ref opts 'destination))) + (cond (target (send-to-remote-host target opts)) + (source (retrieve-from-remote-host source opts)) + (else (leave (_ "use '--to' or '--from'~%"))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6dea67ca22..1d3be6a84f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -155,6 +155,9 @@ COMMAND or an interactive shell in that environment.\n")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " -C, --container run command within an isolated container")) (display (_ " -N, --network allow containers to access the network")) @@ -247,6 +250,9 @@ COMMAND or an interactive shell in that environment.\n")) (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -323,7 +329,8 @@ profile." #:system system #:hooks (if bootstrap? '() - %default-profile-hooks))) + %default-profile-hooks) + #:locales? (not bootstrap?))) (define requisites* (store-lift requisites)) @@ -522,7 +529,26 @@ message if any test fails." (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) (leave (_ "is your kernel version < 3.19?\n")))) -;; Entry point. +(define (register-gc-root target root) + "Make ROOT an indirect root to TARGET. This is procedure is idempotent." + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (symlink target root) + ((store-lift add-indirect-root) root)) + (lambda args + (if (and (= EEXIST (system-error-errno args)) + (equal? (false-if-exception (readlink root)) target)) + (with-monad %store-monad + (return #t)) + (apply throw args)))))) + + +;;; +;;; Entry point. +;;; + (define (guix-environment . args) (with-error-handling (let* ((opts (parse-args args)) @@ -578,7 +604,9 @@ message if any test fails." system)) (prof-drv (inputs->profile-derivation inputs system bootstrap?)) - (profile -> (derivation->output-path prof-drv))) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + ;; First build the inputs. This is necessary even for ;; --search-paths. Additionally, we might need to build bash for ;; a container. @@ -587,6 +615,9 @@ message if any test fails." (list prof-drv bash) (list prof-drv)) opts) + (mwhen gc-root + (register-gc-root profile gc-root)) + (cond ((assoc-ref opts 'dry-run?) (return #t)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2f70d64c90..79ce503a2e 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type @@ -103,6 +104,25 @@ name." ;;; +;;; Reverse package DAG. +;;; + +(define %reverse-package-node-type + ;; For this node type we first need to compute the list of packages and the + ;; list of back-edges. Since we want to do it only once, we use the + ;; promises below. + (let* ((packages (delay (fold-packages cons '()))) + (back-edges (delay (run-with-store #f ;store not actually needed + (node-back-edges %package-node-type + (force packages)))))) + (node-type + (inherit %package-node-type) + (name "reverse-package") + (description "the reverse DAG of packages") + (edges (lift1 (force back-edges) %store-monad))))) + + +;;; ;;; Package DAG using bags. ;;; @@ -323,6 +343,7 @@ substitutes." (define %node-types ;; List of all the node types. (list %package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type @@ -337,6 +358,13 @@ substitutes." %node-types) (leave (_ "~a: unknown node type~%") name))) +(define (lookup-backend name) + "Return the graph backend called NAME. Raise an error if it is not found." + (or (find (lambda (backend) + (string=? (graph-backend-name backend) name)) + %graph-backends) + (leave (_ "~a: unknown backend~%") name))) + (define (list-node-types) "Print the available node types along with their synopsis." (display (_ "The available node types are:\n")) @@ -347,6 +375,16 @@ substitutes." (node-type-description type))) %node-types)) +(define (list-backends) + "Print the available backends along with their synopsis." + (display (_ "The available backend types are:\n")) + (newline) + (for-each (lambda (backend) + (format #t " - ~a: ~a~%" + (graph-backend-name backend) + (graph-backend-description backend))) + %graph-backends)) + ;;; ;;; Command-line options. @@ -361,6 +399,14 @@ substitutes." (lambda (opt name arg result) (list-node-types) (exit 0))) + (option '(#\b "backend") #t #f + (lambda (opt name arg result) + (alist-cons 'backend (lookup-backend arg) + result))) + (option '("list-backends") #f #f + (lambda (opt name arg result) + (list-backends) + (exit 0))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -378,6 +424,10 @@ substitutes." (display (_ "Usage: guix graph PACKAGE... Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (display (_ " + -b, --backend=TYPE produce a graph with the given backend TYPE")) + (display (_ " + --list-backends list the available graph backends")) + (display (_ " -t, --type=TYPE represent nodes of the given TYPE")) (display (_ " --list-types list the available graph types")) @@ -392,7 +442,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (show-bug-report-information)) (define %default-options - `((node-type . ,%package-node-type))) + `((node-type . ,%package-node-type) + (backend . ,%graphviz-backend))) ;;; @@ -407,6 +458,7 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) + (backend (assoc-ref opts 'backend)) (type (assoc-ref opts 'node-type)) (items (filter-map (match-lambda (('argument . (? store-path? item)) @@ -429,7 +481,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) items))) (export-graph (concatenate nodes) (current-output-port) - #:node-type type))))))) + #:node-type type + #:backend backend))))))) #t) ;;; graph.scm ends here diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index a339a8556b..640b2417d2 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; @@ -116,6 +116,9 @@ and 'hexadecimal' can be used as well).\n")) (case (stat:type stat) ((directory) (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + ((regular) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git")) (else #f))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index e54744feca..4d07e0fd69 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran" "crate")) (define (resolve-importer name) (let ((module (resolve-interface @@ -107,10 +107,17 @@ Run IMPORTER with ARGS.\n")) (show-version-and-exit "guix import")) ((importer args ...) (if (member importer importers) - (match (apply (resolve-importer importer) args) - ((and expr ('package _ ...)) - (pretty-print expr (newline-rewriting-port - (current-output-port)))) - (x - (leave (_ "'~a' import failed~%") importer))) + (let ((print (lambda (expr) + (pretty-print expr (newline-rewriting-port + (current-output-port)))))) + (match (apply (resolve-importer importer) args) + ((and expr ('package _ ...)) + (print expr)) + ((? list? expressions) + (for-each (lambda (expr) + (print expr) + (newline)) + expressions)) + (x + (leave (_ "'~a' import failed~%") importer)))) (leave (_ "~a: invalid importer~%") importer))))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index ace1123b90..66c660ae14 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-cran)) @@ -63,6 +64,9 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (lambda (opt name arg result) (alist-cons 'repo (string->symbol arg) (alist-delete 'repo result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -88,12 +92,22 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (cran->guix-package package-name - (or (assoc-ref opts 'repo) 'cran)))) - (unless sexp - (leave (_ "failed to download description for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (stream->list (recursive-import package-name + (or (assoc-ref opts 'repo) 'cran)))) + ;; Single import + (let ((sexp (cran->guix-package package-name + (or (assoc-ref opts 'repo) 'cran)))) + (unless sexp + (leave (_ "failed to download description for package '~a'~%") + package-name)) + sexp))) (() (leave (_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm new file mode 100644 index 0000000000..4337a0b623 --- /dev/null +++ b/guix/scripts/import/crate.scm @@ -0,0 +1,94 @@ + +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2016 David Craven <david@craven.ch> +;;; +;;; 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 import crate) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import crate) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-crate)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import crate PACKAGE-NAME +Import and convert the crate.io package for PACKAGE-NAME.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import crate"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-crate . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (crate->guix-package package-name))) + (unless sexp + (leave (_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9641d3926a..9b991786c3 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> +;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,6 +60,7 @@ #:export (guix-lint check-description-style check-inputs-should-be-native + check-inputs-should-not-be-an-input-at-all check-patch-file-names check-synopsis-style check-derivation @@ -229,34 +231,65 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (format #f (_ "invalid description: ~s") description) 'description)))) +(define (warn-if-package-has-input linted inputs-to-check input-names message) + ;; Emit a warning MESSAGE if some of the inputs named in INPUT-NAMES are + ;; contained in INPUTS-TO-CHECK, which are assumed to be inputs of package + ;; LINTED. + (match inputs-to-check + (((labels packages . outputs) ...) + (for-each (lambda (package output) + (when (package? package) + (let ((input (string-append + (package-name package) + (if (> (length output) 0) + (string-append ":" (car output)) + "")))) + (when (member input input-names) + (emit-warning linted + (format #f (_ message) input) + 'inputs-to-check))))) + packages outputs)))) + (define (check-inputs-should-be-native package) ;; Emit a warning if some inputs of PACKAGE are likely to belong to its ;; native inputs. - (let ((linted package) + (let ((message "'~a' should probably be a native input") (inputs (package-inputs package)) - (native-inputs + (input-names '("pkg-config" "extra-cmake-modules" "glib:bin" "intltool" "itstool" - "qttools"))) - (match inputs - (((labels packages . outputs) ...) - (for-each (lambda (package output) - (when (package? package) - (let ((input (string-append - (package-name package) - (if (> (length output) 0) - (string-append ":" (car output)) - "")))) - (when (member input native-inputs) - (emit-warning linted - (format #f (_ "'~a' should probably \ -be a native input") - input) - 'inputs))))) - packages outputs))))) + "qttools" + "python-coverage" "python2-coverage" + "python-cython" "python2-cython" + "python-docutils" "python2-docutils" + "python-mock" "python2-mock" + "python-nose" "python2-nose" + "python-pbr" "python2-pbr" + "python-pytest" "python2-pytest" + "python-pytest-cov" "python2-pytest-cov" + "python-setuptools-scm" "python2-setuptools-scm" + "python-sphinx" "python2-sphinx"))) + (warn-if-package-has-input package inputs input-names message))) + +(define (check-inputs-should-not-be-an-input-at-all package) + ;; Emit a warning if some inputs of PACKAGE are likely to should not be + ;; an input at all. + (let ((message "'~a' should probably not be an input at all") + (inputs (package-inputs package)) + (input-names + '("python-setuptools" + "python2-setuptools" + "python-pip" + "python2-pip"))) + (warn-if-package-has-input package (package-inputs package) + input-names message) + (warn-if-package-has-input package (package-native-inputs package) + input-names message) + (warn-if-package-has-input package (package-propagated-inputs package) + input-names message))) (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginning of a @@ -876,6 +909,10 @@ them for PACKAGE." (description "Identify inputs that should be native inputs") (check check-inputs-should-be-native)) (lint-checker + (name 'inputs-should-not-be-input) + (description "Identify inputs that should be inputs at all") + (check check-inputs-should-not-be-an-input-at-all)) + (lint-checker (name 'patch-file-names) (description "Validate file names and availability of patches") (check check-patch-file-names)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 2e0268020c..6a4ae28689 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -24,8 +24,10 @@ #:use-module (ssh popen) #:use-module (ssh dist) #:use-module (ssh dist node) + #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) + #:use-module (guix ssh) #:use-module (guix store) #:use-module (guix derivations) #:use-module ((guix serialization) @@ -74,6 +76,10 @@ (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) (host-key build-machine-host-key) ; string + (compression build-machine-compression ; string + (default "zlib@openssh.com,zlib")) + (compression-level build-machine-compression-level ;integer + (default 3)) (daemon-socket build-machine-daemon-socket ; string (default "/var/guix/daemon-socket/socket")) (parallel-builds build-machine-parallel-builds ; number @@ -168,86 +174,53 @@ private key from '~a': ~a") (session (make-session #:user (build-machine-user machine) #:host (build-machine-name machine) #:port (build-machine-port machine) - #:timeout 5 ;seconds + #:timeout 10 ;seconds ;; #:log-verbosity 'protocol #:identity (build-machine-private-key machine) + ;; By default libssh reads ~/.ssh/known_hosts + ;; and uses that to adjust its choice of cipher + ;; suites, which changes the type of host key + ;; that the server sends (RSA vs. Ed25519, + ;; etc.). Opt for something reproducible and + ;; stateless instead. + #:knownhosts "/dev/null" + ;; We need lightweight compression when ;; exchanging full archives. - #:compression "zlib" - #:compression-level 3))) - (connect! session) - - ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about - ;; ed25519 keys and 'get-key-type' returns #f in that case. - (let-values (((server) (get-server-public-key session)) - ((type key) (host-key->type+key - (build-machine-host-key machine)))) - (unless (and (or (not (get-key-type server)) - (eq? (get-key-type server) type)) - (string=? (public-key->string server) key)) - ;; Key mismatch: something's wrong. XXX: It could be that the server - ;; provided its Ed25519 key when we where expecting its RSA key. - (leave (_ "server at '~a' returned host key '~a' of type '~a' \ + #:compression + (build-machine-compression machine) + #:compression-level + (build-machine-compression-level machine)))) + (match (connect! session) + ('ok + ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about + ;; ed25519 keys and 'get-key-type' returns #f in that case. + (let-values (((server) (get-server-public-key session)) + ((type key) (host-key->type+key + (build-machine-host-key machine)))) + (unless (and (or (not (get-key-type server)) + (eq? (get-key-type server) type)) + (string=? (public-key->string server) key)) + ;; Key mismatch: something's wrong. XXX: It could be that the server + ;; provided its Ed25519 key when we where expecting its RSA key. + (leave (_ "server at '~a' returned host key '~a' of type '~a' \ instead of '~a' of type '~a'~%") - (build-machine-name machine) - (public-key->string server) (get-key-type server) - key type))) - - (let ((auth (userauth-public-key! session private))) - (unless (eq? 'success auth) - (disconnect! session) - (leave (_ "SSH public key authentication failed for '~a': ~a~%") - (build-machine-name machine) (get-error session)))) - - session)) - -(define* (connect-to-remote-daemon session - #:optional - (socket-name "/var/guix/daemon-socket/socket")) - "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, -an SSH session. Return a <nix-server> object." - (define redirect - ;; Code run in SESSION to redirect the remote process' stdin/stdout to the - ;; daemon's socket, à la socat. The SSH protocol supports forwarding to - ;; Unix-domain sockets but libssh doesn't have an API for that, hence this - ;; hack. - `(begin - (use-modules (ice-9 match) (rnrs io ports)) - - (let ((sock (socket AF_UNIX SOCK_STREAM 0)) - (stdin (current-input-port)) - (stdout (current-output-port))) - (setvbuf stdin _IONBF) - (setvbuf stdout _IONBF) - (connect sock AF_UNIX ,socket-name) - - (let loop () - (match (select (list stdin sock) '() (list stdin stdout sock)) - ((reads writes ()) - (when (memq stdin reads) - (match (get-bytevector-some stdin) - ((? eof-object?) - (primitive-exit 0)) - (bv - (put-bytevector sock bv)))) - (when (memq sock reads) - (match (get-bytevector-some sock) - ((? eof-object?) - (primitive-exit 0)) - (bv - (put-bytevector stdout bv)))) - (loop)) - (_ - (primitive-exit 1))))))) - - (let ((channel - (open-remote-pipe* session OPEN_BOTH - ;; Sort-of shell-quote REDIRECT. - "guile" "-c" - (object->string - (object->string redirect))))) - (open-connection #:port channel))) + (build-machine-name machine) + (public-key->string server) (get-key-type server) + key type))) + + (let ((auth (userauth-public-key! session private))) + (unless (eq? 'success auth) + (disconnect! session) + (leave (_ "SSH public key authentication failed for '~a': ~a~%") + (build-machine-name machine) (get-error session)))) + + session) + (x + ;; Connection failed or timeout expired. + (leave (_ "failed to connect to '~a': ~a~%") + (build-machine-name machine) (get-error session)))))) ;;; @@ -363,8 +336,9 @@ MACHINE." ;; Protect DRV from garbage collection. (add-temp-root store (derivation-file-name drv)) - (send-files (cons (derivation-file-name drv) inputs) - store) + (with-store local + (send-files local (cons (derivation-file-name drv) inputs) store + #:log-port (current-output-port))) (format (current-error-port) "offloading '~a' to '~a'...~%" (derivation-file-name drv) (build-machine-name machine)) (format (current-error-port) "@ build-remote ~a ~a~%" @@ -379,92 +353,20 @@ MACHINE." ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. (primitive-exit 100))) - (build-derivations store (list drv))) + (parameterize ((current-build-output-port (build-log-port))) + (build-derivations store (list drv)))) - (retrieve-files outputs store) + (retrieve-files* outputs store) (format (current-error-port) "done with offloaded '~a'~%" (derivation-file-name drv))) -(define (store-import-channel session) - "Return an output port to which archives to be exported to SESSION's store -can be written." - ;; Using the 'import-paths' RPC on a remote store would be slow because it - ;; makes a round trip every time 32 KiB have been transferred. This - ;; procedure instead opens a separate channel to use the remote - ;; 'import-paths' procedure, which consumes all the data in a single round - ;; trip. - (define import - `(begin - (use-modules (guix)) - - (with-store store - (setvbuf (current-input-port) _IONBF) - (import-paths store (current-input-port))))) - - (open-remote-output-pipe session - (string-join - `("guile" "-c" - ,(object->string - (object->string import)))))) - -(define (store-export-channel session files) - "Return an input port from which an export of FILES from SESSION's store can -be read." - ;; Same as above: this is more efficient than calling 'export-paths' on a - ;; remote store. - (define export - `(begin - (use-modules (guix)) - - (with-store store - (setvbuf (current-output-port) _IONBF) - (export-paths store ',files (current-output-port))))) - - (open-remote-input-pipe session - (string-join - `("guile" "-c" - ,(object->string - (object->string export)))))) - -(define (send-files files remote) - "Send the subset of FILES that's missing to REMOTE, a remote store." - (with-store store - ;; Compute the subset of FILES missing on SESSION, and send them in - ;; topologically sorted order so that they can actually be imported. - (let* ((sorted (topologically-sorted store files)) - (session (channel-get-session (nix-server-socket remote))) - (node (make-node session)) - (missing (node-eval node - `(begin - (use-modules (guix) - (srfi srfi-1) (srfi srfi-26)) - - (with-store store - (remove (cut valid-path? store <>) - ',sorted))))) - (port (store-import-channel session))) - (format #t (_ "sending ~a store files to '~a'...~%") - (length missing) (session-get session 'host)) - - (export-paths store missing port) - - ;; Tell the remote process that we're done. (In theory the - ;; end-of-archive mark of 'export-paths' would be enough, but in - ;; practice it's not.) - (channel-send-eof port) - - ;; Wait for completion of the remote process. - (let ((result (zero? (channel-get-exit-status port)))) - (close-port port) - result)))) - -(define (retrieve-files files remote) - "Retrieve FILES from SESSION's store, and import them." - (let* ((session (channel-get-session (nix-server-socket remote))) - (host (session-get session 'host)) - (port (store-export-channel session files))) - (format #t (_ "retrieving ~a files from '~a'...~%") - (length files) host) +(define (retrieve-files* files remote) + "Retrieve FILES from REMOTE and import them using 'restore-file-set'." + (let-values (((port count) + (file-retrieval-port files remote))) + (format #t (N_ "retrieving ~a store item from '~a'...~%" + "retrieving ~a store items from '~a'...~%" count) + count (remote-store-host remote)) ;; We cannot use the 'import-paths' RPC here because we already ;; hold the locks for FILES. @@ -489,37 +391,30 @@ be read." (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds -allowed on MACHINE." - (let* ((session (open-ssh-session machine)) - (pipe (open-remote-pipe* session OPEN_READ +allowed on MACHINE. Return +∞ if MACHINE is unreachable." + ;; Note: This procedure is costly since it creates a new SSH session. + (match (false-if-exception (open-ssh-session machine)) + ((? session? session) + (let* ((pipe (open-remote-pipe* session OPEN_READ "cat" "/proc/loadavg")) - (line (read-line pipe))) - (close-port pipe) - - (if (eof-object? line) - +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded - (match (string-tokenize line) - ((one five fifteen . _) - (let* ((raw (string->number five)) - (jobs (build-machine-parallel-builds machine)) - (normalized (/ raw jobs))) - (format (current-error-port) "load on machine '~a' is ~s\ + (line (read-line pipe))) + (close-port pipe) + + (if (eof-object? line) + +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded + (match (string-tokenize line) + ((one five fifteen . _) + (let* ((raw (string->number five)) + (jobs (build-machine-parallel-builds machine)) + (normalized (/ raw jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ (normalized: ~s)~%" - (build-machine-name machine) raw normalized) - normalized)) - (_ - +inf.0))))) ;something's fishy about MACHINE, so avoid it - -(define (machine-power-factor m) - "Return a factor that aggregates the speed and load of M. The higher the -better." - (/ (build-machine-speed m) - (+ 1 (machine-load m)))) - -(define (machine-less-loaded-or-faster? m1 m2) - "Return #t if M1 is either less loaded or faster than M2. (This relation -defines a total order on machines.)" - (> (machine-power-factor m1) (machine-power-factor m2))) + (build-machine-name machine) raw normalized) + normalized)) + (_ + +inf.0))))) ;something's fishy about MACHINE, so avoid it + (_ + +inf.0))) ;failed to connect to MACHINE, so avoid it (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." @@ -548,29 +443,39 @@ defines a total order on machines.)" ;; 5. Release the global machine-choice lock. (with-file-lock (machine-choice-lock-file) - (define machines+slots + (define machines+slots+loads (filter-map (lambda (machine) + ;; Call 'machine-load' from here to make sure it is called + ;; only once per machine (it is expensive). (let ((slot (acquire-build-slot machine))) - (and slot (list machine slot)))) + (and slot + (list machine slot (machine-load machine))))) machines)) (define (undecorate pred) (lambda (a b) (match a - ((machine1 slot1) + ((machine1 slot1 load1) (match b - ((machine2 slot2) - (pred machine1 machine2))))))) - - (let loop ((machines+slots - (sort machines+slots + ((machine2 slot2 load2) + (pred machine1 load1 machine2 load2))))))) + + (define (machine-less-loaded-or-faster? m1 l1 m2 l2) + ;; Return #t if M1 is either less loaded or faster than M2, with L1 + ;; being the load of M1 and L2 the load of M2. (This relation defines a + ;; total order on machines.) + (> (/ (build-machine-speed m1) (+ 1 l1)) + (/ (build-machine-speed m2) (+ 1 l2)))) + + (let loop ((machines+slots+loads + (sort machines+slots+loads (undecorate machine-less-loaded-or-faster?)))) - (match machines+slots - (((best slot) others ...) + (match machines+slots+loads + (((best slot load) others ...) ;; Return the best machine unless it's already overloaded. - (if (< (machine-load best) 2.) + (if (< load 2.) (match others - (((machines slots) ...) + (((machines slots loads) ...) ;; Release slots from the uninteresting machines. (for-each release-build-slot slots) @@ -618,6 +523,96 @@ defines a total order on machines.)" ;;; +;;; Installation tests. +;;; + +(define (assert-node-repl node name) + "Bail out if NODE is not running Guile." + (match (node-guile-version node) + (#f + (leave (_ "Guile could not be started on '~a'~%") + name)) + ((? string? version) + ;; Note: The version string already contains the word "Guile". + (info (_ "'~a' is running ~a~%") + name (node-guile-version node))))) + +(define (assert-node-has-guix node name) + "Bail out if NODE lacks the (guix) module, or if its daemon is not running." + (match (node-eval node + '(begin + (use-modules (guix)) + (with-store store + (add-text-to-store store "test" + "Hello, build machine!")))) + ((? string? str) + (info (_ "Guix is usable on '~a' (test returned ~s)~%") + name str)) + (x + (leave (_ "failed to use Guix module on '~a' (test returned ~s)~%") + name x)))) + +(define %random-state + (delay + (seed->random-state (logxor (getpid) (car (gettimeofday)))))) + +(define* (nonce #:optional (name (gethostname))) + (string-append name "-" + (number->string (random 1000000 (force %random-state))))) + +(define (assert-node-can-import node name daemon-socket) + "Bail out if NODE refuses to import our archives." + (let ((session (node-session node))) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (with-store local + (send-files local (list item) remote)) + + (if (valid-path? remote item) + (info (_ "'~a' successfully imported '~a'~%") + name item) + (leave (_ "'~a' was not properly imported on '~a'~%") + item name)))))) + +(define (assert-node-can-export node name daemon-socket) + "Bail out if we cannot import signed archives from NODE." + (let* ((session (node-session node)) + (remote (connect-to-remote-daemon session daemon-socket)) + (item (add-text-to-store remote "import-test" (nonce name)))) + (with-store store + (if (and (retrieve-files store (list item) remote) + (valid-path? store item)) + (info (_ "successfully imported '~a' from '~a'~%") + item name) + (leave (_ "failed to import '~a' from '~a'~%") + item name))))) + +(define (check-machine-availability machine-file pred) + "Check that each machine matching PRED in MACHINE-FILE is usable as a build +machine." + (define (build-machine=? m1 m2) + (and (string=? (build-machine-name m1) (build-machine-name m2)) + (= (build-machine-port m1) (build-machine-port m2)))) + + ;; A given build machine may appear several times (e.g., once for + ;; "x86_64-linux" and a second time for "i686-linux"); test them only once. + (let ((machines (filter pred + (delete-duplicates (build-machines machine-file) + build-machine=?)))) + (info (_ "testing ~a build machines defined in '~a'...~%") + (length machines) machine-file) + (let* ((names (map build-machine-name machines)) + (sockets (map build-machine-daemon-socket machines)) + (sessions (map open-ssh-session machines)) + (nodes (map make-node sessions))) + (for-each assert-node-repl nodes names) + (for-each assert-node-has-guix nodes names) + (for-each assert-node-can-import nodes names sockets) + (for-each assert-node-can-export nodes names sockets)))) + + +;;; ;;; Entry point. ;;; @@ -635,6 +630,12 @@ defines a total order on machines.)" (and=> (passwd:dir (getpw (getuid))) (cut setenv "HOME" <>)) + ;; We rely on protocol-level compression from libssh to optimize large data + ;; transfers. Warn if it's missing. + (unless (zlib-support?) + (warning (_ "Guile-SSH lacks zlib support")) + (warning (_ "data transfers will *not* be compressed!"))) + (match args ((system max-silent-time print-build-trace? build-timeout) (let ((max-silent-time (string->number max-silent-time)) @@ -660,6 +661,18 @@ defines a total order on machines.)" (else (leave (_ "invalid request line: ~s~%") line))) (loop (read-line))))))) + (("test" rest ...) + (with-error-handling + (let-values (((file pred) + (match rest + ((file regexp) + (values file + (compose (cut string-match regexp <>) + build-machine-name))) + ((file) (values file (const #t))) + (() (values %machine-file (const #t))) + (_ (leave (_ "wrong number of arguments~%")))))) + (check-machine-availability (or file %machine-file) pred)))) (("--version") (show-version-and-exit "guix offload")) (("--help") diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 96a22f6fab..90e7fa2298 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -200,7 +200,8 @@ specified in MANIFEST, a manifest object." (profile-derivation manifest #:hooks (if bootstrap? '() - %default-profile-hooks)))) + %default-profile-hooks) + #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) #:use-substitutes? use-substitutes? diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 1b32f639ea..33a7b3bd42 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -365,6 +365,14 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (response-headers response) eq?))) +(define (with-content-length response length) + "Return RESPONSE with a 'content-length' header set to LENGTH." + (set-field response (response-headers) + (alist-cons 'content-length length + (alist-delete 'content-length + (response-headers response) + eq?)))) + (define-syntax-rule (swallow-EPIPE exp ...) "Swallow EPIPE errors raised by EXP..." (catch 'system-error @@ -432,13 +440,8 @@ blocking." (call-with-input-file (utf8->string body) (lambda (input) (let* ((size (stat:size (stat input))) - (headers (alist-cons 'content-length size - (alist-delete 'content-length - (response-headers response) - eq?))) - (response (write-response (set-field response - (response-headers) - headers) + (response (write-response (with-content-length response + size) client)) (output (response-port response))) (dump-port input output) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index b81c69f9fe..0dd7eee974 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -35,7 +35,8 @@ #:select (%gnu-updater %gnome-updater %kde-updater - %xorg-updater)) + %xorg-updater + %kernel.org-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) #:use-module (guix import hackage) @@ -118,7 +119,7 @@ (show-version-and-exit "guix refresh"))))) (define (show-help) - (display (_ "Usage: guix refresh [OPTION]... PACKAGE... + (display (_ "Usage: guix refresh [OPTION]... [PACKAGE]... Update package definitions to match the latest upstream version. When PACKAGE... is given, update only the specified packages. Otherwise @@ -200,15 +201,18 @@ unavailable optional dependencies such as Guile-JSON." %gnome-updater %kde-updater %xorg-updater + %kernel.org-updater %elpa-updater %cran-updater %bioconductor-updater %hackage-updater + ((guix import cpan) => %cpan-updater) ((guix import pypi) => %pypi-updater) ((guix import gem) => %gem-updater) - ((guix import github) => %github-updater))) + ((guix import github) => %github-updater) + ((guix import crate) => %crate-updater))) -(define (lookup-updater name) +(define (lookup-updater-by-name name) "Return the updater called NAME." (or (find (lambda (updater) (eq? name (upstream-updater-name updater))) @@ -218,38 +222,84 @@ unavailable optional dependencies such as Guile-JSON." (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) + (newline) + + (let* ((packages (fold-packages cons '())) + (total (length packages))) + (define covered + (fold (lambda (updater covered) + (let ((matches (count (upstream-updater-predicate updater) + packages))) + ;; TRANSLATORS: The parenthetical expression here is rendered + ;; like "(42% coverage)" and denotes the fraction of packages + ;; covered by the given updater. + (format #t (_ " - ~a: ~a (~2,1f% coverage)~%") + (upstream-updater-name updater) + (_ (upstream-updater-description updater)) + (* 100. (/ matches total))) + (+ covered matches))) + 0 + %updaters)) + + (newline) + (format #t (_ "~2,1f% of the packages are covered by these updaters.~%") + (* 100. (/ covered total)))) (exit 0)) +(define (warn-no-updater package) + (format (current-error-port) + (_ "~a: warning: no updater for ~a~%") + (location->string (package-location package)) + (package-name package))) + (define* (update-package store package updaters - #:key (key-download 'interactive)) + #:key (key-download 'interactive) warn?) "Update the source file that defines PACKAGE with the new version. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed -values: 'interactive' (default), 'always', and 'never'." - (let-values (((version tarball) - (package-update store package updaters - #:key-download key-download)) - ((loc) - (or (package-field-location package 'version) - (package-location package)))) - (when version - (if (and=> tarball file-exists?) - (begin - (format (current-error-port) - (_ "~a: ~a: updating from version ~a to version ~a...~%") - (location->string loc) - (package-name package) - (package-version package) version) - (let ((hash (call-with-input-file tarball - port-sha256))) - (update-package-source package version hash))) - (warning (_ "~a: version ~a could not be \ +values: 'interactive' (default), 'always', and 'never'. When WARN? is true, +warn about packages that have no matching updater." + (if (lookup-updater package updaters) + (let-values (((version tarball) + (package-update store package updaters + #:key-download key-download)) + ((loc) + (or (package-field-location package 'version) + (package-location package)))) + (when version + (if (and=> tarball file-exists?) + (begin + (format (current-error-port) + (_ "~a: ~a: updating from version ~a to version ~a...~%") + (location->string loc) + (package-name package) + (package-version package) version) + (let ((hash (call-with-input-file tarball + port-sha256))) + (update-package-source package version hash))) + (warning (_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") - (package-name package) version))))) + (package-name package) version)))) + (when warn? + (warn-no-updater package)))) + +(define* (check-for-package-update package updaters #:key warn?) + "Check whether an update is available for PACKAGE and print a message. When +WARN? is true and no updater exists for PACKAGE, print a warning." + (match (package-latest-release package updaters) + ((? upstream-source? source) + (when (version>? (upstream-source-version source) + (package-version package)) + (let ((loc (or (package-field-location package 'version) + (package-location package)))) + (format (current-error-port) + (_ "~a: ~a would be upgraded from ~a to ~a~%") + (location->string loc) + (package-name package) (package-version package) + (upstream-source-version source))))) + (#f + (when warn? + (warn-no-updater package))))) + ;;; @@ -312,7 +362,7 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" ;; Return the list of updaters to use. (match (filter-map (match-lambda (('updaters . names) - (map lookup-updater names)) + (map lookup-updater-by-name names)) (_ #f)) opts) (() @@ -360,6 +410,12 @@ update would trigger a complete rebuild." (updaters (options->updaters opts)) (list-dependent? (assoc-ref opts 'list-dependent?)) (key-download (assoc-ref opts 'key-download)) + + ;; Warn about missing updaters when a package is explicitly given on + ;; the command line. + (warn? (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression))) + (packages (match (filter-map (match-lambda (('argument . spec) @@ -397,22 +453,14 @@ update would trigger a complete rebuild." (%gpg-command)))) (for-each (cut update-package store <> updaters - #:key-download key-download) + #:key-download key-download + #:warn? warn?) packages) (with-monad %store-monad (return #t)))) (else - (for-each (lambda (package) - (match (package-update-path package updaters) - ((? upstream-source? source) - (let ((loc (or (package-field-location package 'version) - (package-location package)))) - (format (current-error-port) - (_ "~a: ~a would be upgraded from ~a to ~a~%") - (location->string loc) - (package-name package) (package-version package) - (upstream-source-version source)))) - (#f #f))) + (for-each (cut check-for-package-update <> updaters + #:warn? warn?) packages) (with-monad %store-monad (return #t))))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bb373a6726..144a7fd377 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -326,7 +326,7 @@ it atomically, and then run OS's activation script." (let* ((system (derivation->output-path drv)) (number (+ 1 (generation-number profile))) (generation (generation-file-name profile number))) - (symlink system generation) + (switch-symlinks generation system) (switch-symlinks profile generation) (format #t (_ "activating system...~%")) |