diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/r.scm | 20 | ||||
| -rw-r--r-- | guix/channels.scm | 28 | ||||
| -rw-r--r-- | guix/derivations.scm | 6 | ||||
| -rw-r--r-- | guix/import/cran.scm | 46 | ||||
| -rw-r--r-- | guix/import/gnome.scm | 35 | ||||
| -rw-r--r-- | guix/remote.scm | 72 | ||||
| -rw-r--r-- | guix/scripts/deploy.scm | 25 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 27 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 45 | ||||
| -rw-r--r-- | guix/ssh.scm | 56 | ||||
| -rw-r--r-- | guix/upstream.scm | 9 |
11 files changed, 238 insertions, 131 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index e7214155be..dd2a9fe8de 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -47,14 +47,22 @@ available via the first URI, the second URI points to the archived version." (string-append "mirror://cran/src/contrib/Archive/" name "/" name "_" version ".tar.gz"))) -(define (bioconductor-uri name version) +(define* (bioconductor-uri name version #:optional type) "Return a URI string for the R package archive on Bioconductor for the release corresponding to NAME and VERSION." - (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/" - name "_" version ".tar.gz") - ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.9/bioc/src/contrib/Archive/" - name "_" version ".tar.gz"))) + (let ((type-url-part (match type + ('annotation "/data/annotation") + ('experiment "/data/experiment") + (_ "/bioc")))) + (list (string-append "https://bioconductor.org/packages/release" + type-url-part + "/src/contrib/" + name "_" version ".tar.gz") + ;; TODO: use %bioconductor-version from (guix import cran) + (string-append "https://bioconductor.org/packages/3.9" + type-url-part + "/src/contrib/Archive/" + name "_" version ".tar.gz")))) (define %r-build-system-modules ;; Build-side modules imported by default. diff --git a/guix/channels.scm b/guix/channels.scm index 415246cbd1..ebb2cacbc7 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -65,7 +65,9 @@ latest-channel-derivation channel-instances->manifest %channel-profile-hooks - channel-instances->derivation)) + channel-instances->derivation + + profile-channels)) ;;; Commentary: ;;; @@ -534,3 +536,27 @@ channel instances." latest instances of CHANNELS." (mlet %store-monad ((instances (latest-channel-instances* channels))) (channel-instances->derivation instances))) + +(define (profile-channels profile) + "Return the list of channels corresponding to entries in PROFILE. If +PROFILE is not a profile created by 'guix pull', return the empty list." + (filter-map (lambda (entry) + (match (assq 'source (manifest-entry-properties entry)) + (('source ('repository ('version 0) + ('url url) + ('branch branch) + ('commit commit) + _ ...)) + (channel (name (string->symbol + (manifest-entry-name entry))) + (url url) + (commit commit))) + + ;; No channel information for this manifest entry. + ;; XXX: Pre-0.15.0 Guix did not provide that information, + ;; but there's not much we can do in that case. + (_ #f))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries (profile-manifest profile))))) diff --git a/guix/derivations.scm b/guix/derivations.scm index 92d50503ce..e1073ea39b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -376,8 +376,8 @@ of SUBSTITUTABLES." (substitution-oracle store inputs #:mode mode))) "Given INPUTS, a list of derivation-inputs, return two values: the list of -derivation to build, and the list of substitutable items that, together, -allows INPUTS to be realized. +derivations to build, and the list of substitutable items that, together, +allow INPUTS to be realized. SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned by 'substitution-oracle'." @@ -685,7 +685,7 @@ name of each input with that input's hash." (make-derivation-input hash sub-drvs)))) inputs))) (make-derivation outputs - (sort inputs + (sort (delete-duplicates inputs) (lambda (drv1 drv2) (string<? (derivation-input-derivation drv1) (derivation-input-derivation drv2)))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 3240094444..9c964701b1 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -132,14 +132,19 @@ package definition." ;; updated together. (define %bioconductor-version "3.9") -(define %bioconductor-packages-list-url +(define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" - %bioconductor-version "/bioc/src/contrib/PACKAGES")) - -(define (bioconductor-packages-list) + %bioconductor-version + (match type + ('annotation "/data/annotation") + ('experiment "/data/experiment") + (_ "/bioc")) + "/src/contrib/PACKAGES")) + +(define* (bioconductor-packages-list #:optional type) "Return the latest version of package NAME for the current bioconductor release." - (let ((url (string->uri %bioconductor-packages-list-url))) + (let ((url (string->uri (bioconductor-packages-list-url type)))) (guard (c ((http-get-error? c) (format (current-error-port) "error: failed to retrieve list of packages from ~s: ~a (~s)~%" @@ -153,12 +158,12 @@ release." (description->alist (string-join chunk "\n"))) (chunk-lines (read-lines (http-fetch/cached url))))))) -(define (latest-bioconductor-package-version name) +(define* (latest-bioconductor-package-version name #:optional type) "Return the version string corresponding to the latest release of the bioconductor package NAME, or #F if the package is unknown." (and=> (find (lambda (meta) (string=? (assoc-ref meta "Package") name)) - (bioconductor-packages-list)) + (bioconductor-packages-list type)) (cut assoc-ref <> "Version"))) ;; Little helper to download URLs only once. @@ -187,8 +192,12 @@ from ~s: ~a (~s)~%" ;; Currently, the bioconductor project does not offer a way to access a ;; package's DESCRIPTION file over HTTP, so we determine the version, ;; download the source tarball, and then extract the DESCRIPTION file. - (and-let* ((version (latest-bioconductor-package-version name)) - (url (car (bioconductor-uri name version))) + (and-let* ((type (or + (and (latest-bioconductor-package-version name) #t) + (and (latest-bioconductor-package-version name 'annotation) 'annotation) + (and (latest-bioconductor-package-version name 'experiment) 'experiment))) + (version (latest-bioconductor-package-version name type)) + (url (car (bioconductor-uri name version type))) (tarball (download url))) (call-with-temporary-directory (lambda (dir) @@ -198,8 +207,11 @@ from ~s: ~a (~s)~%" "--strip-components=1" "-C" dir "-f" tarball "*/DESCRIPTION")) - (description->alist (with-input-from-file - (string-append dir "/DESCRIPTION") read-string)))))))))) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (if (boolean? type) meta + (cons `(bioconductor-type . ,type) meta)))))))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -306,7 +318,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (home-page (match (listify meta "URL") ((url rest ...) url) (_ (string-append base-url name)))) - (source-url (match (uri-helper name version) + (source-url (match (apply uri-helper name version + (case repository + ((bioconductor) + (list (assoc-ref meta 'bioconductor-type))) + (else '()))) ((url rest ...) url) ((? string? url) url) (_ #f))) @@ -330,7 +346,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (version ,version) (source (origin (method url-fetch) - (uri (,(procedure-name uri-helper) ,name version)) + (uri (,(procedure-name uri-helper) ,name version + ,@(or (and=> (assoc-ref meta 'bioconductor-type) + (lambda (type) + (list (list 'quote type)))) + '()))) (sha256 (base32 ,(bytevector->nix-base32-string (file-sha256 tarball)))))) diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 1ade63e1af..436ec88ef9 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,7 +46,7 @@ source for metadata." (package name) (version version) (urls (filter-map (lambda (extension) - (match (hash-ref dictionary extension) + (match (assoc-ref dictionary extension) (#f #f) ((? string? relative-url) @@ -86,21 +86,22 @@ not be determined." (json (json->scm port))) (close-port port) (match json - ((4 (? hash-table? releases) _ ...) - (let* ((releases (hash-ref releases upstream-name)) - (latest (hash-fold (lambda (key value result) - (cond ((even-minor-version? key) - (match result - (#f - (cons key value)) - ((newest . _) - (if (version>? key newest) - (cons key value) - result)))) - (else - result))) - #f - releases))) + (#(4 releases _ ...) + (let* ((releases (assoc-ref releases upstream-name)) + (latest (fold (match-lambda* + (((key . value) result) + (cond ((even-minor-version? key) + (match result + (#f + (cons key value)) + ((newest . _) + (if (version>? key newest) + (cons key value) + result)))) + (else + result)))) + #f + releases))) (and latest (jsonish->upstream-source upstream-name latest)))))))) diff --git a/guix/remote.scm b/guix/remote.scm index 5fecd954e9..d0c3d04a25 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -19,13 +19,17 @@ (define-module (guix remote) #:use-module (guix ssh) #:use-module (guix gexp) + #:use-module (guix i18n) #:use-module (guix inferior) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix modules) #:use-module (guix derivations) + #:use-module (guix utils) #:use-module (ssh popen) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:export (remote-eval)) @@ -40,29 +44,41 @@ ;;; ;;; Code: -(define (remote-pipe-for-gexp lowered session) - "Return a remote pipe for the given SESSION to evaluate LOWERED." +(define* (remote-pipe-for-gexp lowered session #:optional become-command) + "Return a remote pipe for the given SESSION to evaluate LOWERED. If +BECOME-COMMAND is given, use that to invoke the remote Guile REPL." (define shell-quote (compose object->string object->string)) - (apply open-remote-pipe* session OPEN_READ - (string-append (derivation-input-output-path - (lowered-gexp-guile lowered)) - "/bin/guile") - "--no-auto-compile" - (append (append-map (lambda (directory) - `("-L" ,directory)) - (lowered-gexp-load-path lowered)) - (append-map (lambda (directory) - `("-C" ,directory)) - (lowered-gexp-load-path lowered)) - `("-c" - ,(shell-quote (lowered-gexp-sexp lowered)))))) + (define repl-command + (append (or become-command '()) + (list + (string-append (derivation-input-output-path + (lowered-gexp-guile lowered)) + "/bin/guile") + "--no-auto-compile") + (append-map (lambda (directory) + `("-L" ,directory)) + (lowered-gexp-load-path lowered)) + (append-map (lambda (directory) + `("-C" ,directory)) + (lowered-gexp-load-path lowered)) + `("-c" + ,(shell-quote (lowered-gexp-sexp lowered))))) -(define (%remote-eval lowered session) + (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command))) + (when (eof-object? (peek-char pipe)) + (raise (condition + (&message + (message (format #f (G_ "failed to run '~{~a~^ ~}'") + repl-command)))))) + pipe)) + +(define* (%remote-eval lowered session #:optional become-command) "Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the -prerequisites of EXP are already available on the host at SESSION." - (let* ((pipe (remote-pipe-for-gexp lowered session)) +prerequisites of EXP are already available on the host at SESSION. If +BECOME-COMMAND is given, use that to invoke the remote Guile REPL." + (let* ((pipe (remote-pipe-for-gexp lowered session become-command)) (result (read-repl-response pipe))) (close-port pipe) result)) @@ -71,7 +87,7 @@ prerequisites of EXP are already available on the host at SESSION." "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation result to the current output port using the (guix repl) protocol." (define program - (scheme-file "remote-exp.scm" exp)) + (program-file "remote-exp.scm" exp)) (with-imported-modules (source-module-closure '((guix repl))) #~(begin @@ -89,17 +105,21 @@ result to the current output port using the (guix repl) protocol." (define* (remote-eval exp session #:key (build-locally? #t) + (system (%current-system)) (module-path %load-path) - (socket-name "/var/guix/daemon-socket/socket")) + (socket-name (%daemon-socket-uri)) + (become-command #f)) "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that all the elements EXP refers to are built and deployed to SESSION beforehand. When BUILD-LOCALLY? is true, said dependencies are built locally and sent to the remote store afterwards; otherwise, dependencies are built directly on the remote store." - (mlet %store-monad ((lowered (lower-gexp (trampoline exp) - #:module-path %load-path)) - (remote -> (connect-to-remote-daemon session - socket-name))) + (mlet* %store-monad ((lowered (lower-gexp (trampoline exp) + #:system system + #:guile-for-build #f + #:module-path %load-path)) + (remote -> (connect-to-remote-daemon session + socket-name))) (define inputs (cons (lowered-gexp-guile lowered) (lowered-gexp-inputs lowered))) @@ -115,7 +135,7 @@ remote store." (built-derivations inputs) ((store-lift send-files) to-send remote #:recursive? #t) (return (close-connection remote)) - (return (%remote-eval lowered session)))) + (return (%remote-eval lowered session become-command)))) (let ((to-send (append (map (compose derivation-file-name derivation-input-derivation) inputs) @@ -124,4 +144,4 @@ remote store." ((store-lift send-files) to-send remote #:recursive? #t) (return (build-derivations remote inputs)) (return (close-connection remote)) - (return (%remote-eval lowered session))))))) + (return (%remote-eval lowered session become-command))))))) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ebc99e52cc..6a67985c8b 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -28,6 +28,8 @@ #:use-module (guix grafts) #:use-module (ice-9 format) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:export (guix-deploy)) @@ -43,8 +45,6 @@ (define (show-help) (display (G_ "Usage: guix deploy [OPTION] FILE... Perform the deployment specified by FILE.\n")) - (display (G_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (show-build-options-help) (newline) (display (G_ " @@ -66,8 +66,7 @@ Perform the deployment specified by FILE.\n")) %standard-build-options)) (define %default-options - `((system . ,(%current-system)) - (substitutes? . #t) + `((substitutes? . #t) (build-hook? . #t) (graft? . #t) (debug . 0) @@ -91,8 +90,18 @@ Perform the deployment specified by FILE.\n")) (with-store store (set-build-options-from-command-line store opts) (for-each (lambda (machine) - (info (G_ "deploying to ~a...") (machine-display-name machine)) - (parameterize ((%current-system (assq-ref opts 'system)) - (%graft? (assq-ref opts 'graft?))) - (run-with-store store (deploy-machine machine)))) + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: '~a'~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine))))) machines)))) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index fa6b6cae37..99a88c50fa 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -153,30 +153,9 @@ in the format specified by FMT." (generation-number profile)) (define channels - (map (lambda (entry) - (match (assq 'source (manifest-entry-properties entry)) - (('source ('repository ('version 0) - ('url url) - ('branch branch) - ('commit commit) - _ ...)) - (channel (name (string->symbol (manifest-entry-name entry))) - (url url) - (commit commit))) - - ;; Pre-0.15.0 Guix does not provide that information, - ;; so there's not much we can do in that case. - (_ (channel (name 'guix) - (url "?") - (commit "?"))))) - - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest - (if (zero? number) - profile - (generation-file-name profile number))))))) + (profile-channels (if (zero? number) + profile + (generation-file-name profile number)))) (match fmt ('human diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index dd7026a6a4..4591d0f308 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -285,10 +285,9 @@ update would trigger a complete rebuild." (exit 0)) (define (warn-no-updater package) - (format (current-error-port) - (G_ "~a: warning: no updater for ~a~%") - (location->string (package-location package)) - (package-name package))) + (warning (package-location package) + (G_ "no updater for ~a~%") + (package-name package))) (define* (update-package store package updaters #:key (key-download 'interactive) warn?) @@ -306,11 +305,10 @@ warn about packages that have no matching updater." (when version (if (and=> tarball file-exists?) (begin - (format (current-error-port) - (G_ "~a: ~a: updating from version ~a to version ~a...~%") - (location->string loc) - (package-name package) - (package-version package) version) + (info loc + (G_ "~a: updating from version ~a to version ~a...~%") + (package-name package) + (package-version package) version) (for-each (lambda (change) (format (current-error-port) @@ -350,27 +348,24 @@ WARN? is true and no updater exists for PACKAGE, print a warning." (case (version-compare (upstream-source-version source) (package-version package)) ((>) - (format (current-error-port) - (G_ "~a: ~a would be upgraded from ~a to ~a~%") - (location->string loc) - (package-name package) (package-version package) - (upstream-source-version source))) + (info loc + (G_ "~a would be upgraded from ~a to ~a~%") + (package-name package) (package-version package) + (upstream-source-version source))) ((=) (when warn? - (format (current-error-port) - (G_ "~a: info: ~a is already the latest version of ~a~%") - (location->string loc) - (package-version package) - (package-name package)))) + (info loc + (G_ "~a is already the latest version of ~a~%") + (package-version package) + (package-name package)))) (else (when warn? - (format (current-error-port) - (G_ "~a: warning: ~a is greater than \ + (warning loc + (G_ "~a is greater than \ the latest known version of ~a (~a)~%") - (location->string loc) - (package-version package) - (package-name package) - (upstream-source-version source))))))) + (package-version package) + (package-name package) + (upstream-source-version source))))))) (#f (when warn? (warn-no-updater package))))) diff --git a/guix/ssh.scm b/guix/ssh.scm index ede00133c8..7bc499a2fe 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -21,6 +21,7 @@ #:use-module (guix inferior) #:use-module (guix i18n) #:use-module ((guix utils) #:select (&fix-hint)) + #:use-module (gcrypt pk-crypto) #:use-module (ssh session) #:use-module (ssh auth) #:use-module (ssh key) @@ -39,6 +40,8 @@ remote-inferior remote-daemon-channel connect-to-remote-daemon + remote-system + remote-authorize-signing-key send-files retrieve-files retrieve-files* @@ -97,16 +100,27 @@ specifies; otherwise use them. Throw an error on failure." (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") host (get-error session)))))))))) -(define (remote-inferior session) - "Return a remote inferior for the given SESSION." - (let ((pipe (open-remote-pipe* session OPEN_BOTH - "guix" "repl" "-t" "machine"))) +(define* (remote-inferior session #:optional become-command) + "Return a remote inferior for the given SESSION. If BECOME-COMMAND is +given, use that to invoke the remote Guile REPL." + (let* ((repl-command (append (or become-command '()) + '("guix" "repl" "-t" "machine"))) + (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command))) + ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the + ;; process does succeed. This doesn't reflect the documentation, so it's + ;; possible that it's a bug in guile-ssh. + (when (eof-object? (peek-char pipe)) + (raise (condition + (&message + (message (format #f (G_ "failed to run '~{~a~^ ~}'") + repl-command)))))) (port->inferior pipe))) -(define (inferior-remote-eval exp session) +(define* (inferior-remote-eval exp session #:optional become-command) "Evaluate EXP in a new inferior running in SESSION, and close the inferior -right away." - (let ((inferior (remote-inferior session))) +right away. If BECOME-COMMAND is given, use that to invoke the remote Guile +REPL." + (let ((inferior (remote-inferior session become-command))) (dynamic-wind (const #t) (lambda () @@ -282,6 +296,34 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." ,(object->string (object->string export)))))) +(define (remote-system session) + "Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of +the machine on the other end of SESSION." + (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system)) + session)) + +(define* (remote-authorize-signing-key key session #:optional become-command) + "Send KEY, a canonical sexp containing a public key, over SESSION and add it +to the system ACL file if it has not yet been authorized." + (inferior-remote-eval + `(begin + (use-modules (guix build utils) + (guix pki) + (guix utils) + (gcrypt pk-crypto) + (srfi srfi-26)) + + (define acl (current-acl)) + (define key (string->canonical-sexp ,(canonical-sexp->string key))) + + (unless (authorized-key? key) + (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) + (mkdir-p (dirname %acl-file)) + (with-atomic-file-output %acl-file + (cut write-acl acl <>))))) + session + become-command)) + (define* (send-files local files remote #:key recursive? diff --git a/guix/upstream.scm b/guix/upstream.scm index 1326b3db95..d4f9c5bb45 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -362,6 +362,7 @@ SOURCE, an <upstream-source>." (_ "gz"))) ((url signature-url) + ;; Try to find a URL that matches ARCHIVE-TYPE. (find2 (lambda (url sig-url) ;; Some URIs lack a file extension, like ;; 'https://crates.io/???/0.1/download'. In that @@ -370,7 +371,13 @@ SOURCE, an <upstream-source>." (string-suffix? archive-type url))) urls (or signature-urls (circular-list #f))))) - (let ((tarball (download-tarball store url signature-url + ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case, + ;; pick up the first element of URLS. + (let ((tarball (download-tarball store + (or url (first urls)) + (and (pair? signature-urls) + (or signature-url + (first signature-urls))) #:key-download key-download))) (values version tarball source)))))) |