diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/import/cran.scm | 13 | ||||
| -rw-r--r-- | guix/import/crate.scm | 2 | ||||
| -rw-r--r-- | guix/import/print.scm | 3 | ||||
| -rw-r--r-- | guix/import/utils.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/import/cran.scm | 45 | ||||
| -rw-r--r-- | guix/scripts/import/crate.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 3 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 97 | ||||
| -rw-r--r-- | guix/ssh.scm | 91 | ||||
| -rw-r--r-- | guix/transformations.scm | 63 | ||||
| -rw-r--r-- | guix/utils.scm | 6 |
11 files changed, 223 insertions, 110 deletions
diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 9d38be7a1e..fd44d80915 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -51,7 +51,9 @@ #:use-module (guix upstream) #:use-module (guix packages) #:use-module (gnu packages) - #:export (cran->guix-package + #:export (%input-style + + cran->guix-package bioconductor->guix-package cran-recursive-import %cran-updater @@ -74,6 +76,9 @@ ;;; ;;; Code: +(define %input-style + (make-parameter 'variable)) ; or 'specification + (define string->license (match-lambda ("AGPL-3" 'agpl3+) @@ -128,7 +133,11 @@ (define (format-inputs names) "Generate a sorted list of package inputs from a list of package NAMES." (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) + (case (%input-style) + ((specification) + (list name (list 'unquote (list 'specification->package name)))) + (else + (list name (list 'unquote (string->symbol name)))))) (sort names string-ci<?))) (define* (maybe-inputs package-inputs #:optional (type 'inputs)) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index c10c0d55ea..aee1b01c9f 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -358,7 +358,7 @@ look up the development dependencs for the given crate." (define %crate-updater (upstream-updater - (name 'crates) + (name 'crate) (description "Updater for crates.io packages") (pred crate-package?) (latest latest-release))) diff --git a/guix/import/print.scm b/guix/import/print.scm index d21ce57aeb..a2ab810a5c 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -57,7 +57,8 @@ when evaluated." ;; Print either license variable name or the code for a license object (define (license->code lic) (let ((var (variable-name lic '(guix licenses)))) - (or (symbol-append 'license: var) + (if var + (symbol-append 'license: var) `(license (name ,(license-name lic)) (uri ,(license-uri lic)) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index e227c2e42d..cdbcf6bfa5 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -372,8 +372,12 @@ specifications to look up and replace them with plain symbols instead." (match (assoc-ref meta "license") (#f #f) (l - (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) - (spdx-string->license l)) + (or (false-if-exception + (module-ref (resolve-interface '(guix licenses)) + (string->symbol l))) + (false-if-exception + (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) + (spdx-string->license l))) (license:fsdg-compatible l))))))) (define* (read-lines #:optional (port (current-input-port))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 20e82ae2ca..4767bc082d 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -67,6 +67,10 @@ 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 '(#\s "style") #t #f + (lambda (opt name arg result) + (alist-cons 'style (string->symbol arg) + (alist-delete 'style result)))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) @@ -93,23 +97,24 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) value) (_ #f)) (reverse opts)))) - (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (with-error-handling - (map package->definition - (filter identity - (cran-recursive-import package-name - #:repo (or (assoc-ref opts 'repo) 'cran))))) - ;; Single import - (let ((sexp (cran->guix-package package-name - #:repo (or (assoc-ref opts 'repo) 'cran)))) - (unless sexp - (leave (G_ "failed to download description for package '~a'~%") - package-name)) - sexp))) - (() - (leave (G_ "too few arguments~%"))) - ((many ...) - (leave (G_ "too many arguments~%")))))) + (parameterize ((%input-style (assoc-ref opts 'style))) + (match args + ((package-name) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (with-error-handling + (map package->definition + (filter identity + (cran-recursive-import package-name + #:repo (or (assoc-ref opts 'repo) 'cran))))) + ;; Single import + (let ((sexp (cran->guix-package package-name + #:repo (or (assoc-ref opts 'repo) 'cran)))) + (unless sexp + (leave (G_ "failed to download description for package '~a'~%") + package-name)) + sexp))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%"))))))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 9252c52dfa..3a96defb86 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -42,7 +42,7 @@ (define (show-help) (display (G_ "Usage: guix import crate PACKAGE-NAME -Import and convert the crate.io package for PACKAGE-NAME.\n")) +Import and convert the crates.io package for PACKAGE-NAME.\n")) (display (G_ " -r, --recursive import packages recursively")) (newline) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 58ee53e85c..835078cb97 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -634,7 +634,8 @@ daemon is not running." (and add-text-to-store 'alright)) node) ('alright #t) - (_ (report-module-error name))) + (_ (leave (G_ "(guix) module not usable on remote host '~a'") + name))) (match (inferior-eval '(begin (use-modules (guix)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 38702d0c4b..8084c89ae5 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -514,12 +514,18 @@ return its MAX-LENGTH first elements and its tail." (define* (http-multiple-get base-uri proc seed requests #:key port (verify-certificate? #t) + (open-connection guix:open-connection-for-uri) + (keep-alive? #t) (batch-size 1000)) "Send all of REQUESTS to the server at BASE-URI. Call PROC for each 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. When PORT is specified, use it as the -initial connection on which HTTP requests are sent." +'fold'. Return the final result. + +When PORT is specified, use it as the initial connection on which HTTP +requests are sent; otherwise call OPEN-CONNECTION to open a new connection for +a URI. When KEEP-ALIVE? is false, close the connection port before +returning." (let connect ((port port) (requests requests) (result seed)) @@ -528,10 +534,9 @@ initial connection on which HTTP requests are sent." ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (or port (guix:open-connection-for-uri - base-uri - #:verify-certificate? - verify-certificate?)))) + (let ((p (or port (open-connection base-uri + #:verify-certificate? + verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) (setvbuf p 'block (expt 2 16))) @@ -556,7 +561,8 @@ initial connection on which HTTP requests are sent." (() (match (drop requests processed) (() - (close-port p) + (unless keep-alive? + (close-port p)) (reverse result)) (remainder (connect p remainder result)))) @@ -598,18 +604,18 @@ if file doesn't exist, and the narinfo otherwise." (define* (open-connection-for-uri/maybe uri #:key - (verify-certificate? #f) + fresh? (time %fetch-timeout)) - "Open a connection to URI and return a port to it, or, if connection failed, -print a warning and return #f." + "Open a connection to URI via 'open-connection-for-uri/cached' and return a +port to it, or, if connection failed, print a warning and return #f. Pass +#:fresh? to 'open-connection-for-uri/cached'." (define host (uri-host uri)) (catch #t (lambda () - (guix:open-connection-for-uri uri - #:verify-certificate? verify-certificate? - #:timeout time)) + (open-connection-for-uri/cached uri #:timeout time + #:fresh? fresh?)) (match-lambda* (('getaddrinfo-error error) (unless (hash-ref %unreachable-hosts host) @@ -683,23 +689,26 @@ print a warning and return #f." (define (do-fetch uri) (case (and=> uri uri-scheme) ((http https) - (let ((requests (map (cut narinfo-request url <>) paths))) - (match (open-connection-for-uri/maybe uri) - (#f - '()) - (port - (update-progress!) - ;; Note: Do not check HTTPS server certificates to avoid depending - ;; on the X.509 PKI. We can do it because we authenticate - ;; narinfos, which provides a much stronger guarantee. - (let ((result (http-multiple-get uri - handle-narinfo-response '() - requests - #:verify-certificate? #f - #:port port))) - (close-port port) - (newline (current-error-port)) - result))))) + ;; Note: Do not check HTTPS server certificates to avoid depending + ;; on the X.509 PKI. We can do it because we authenticate + ;; narinfos, which provides a much stronger guarantee. + (let* ((requests (map (cut narinfo-request url <>) paths)) + (result (call-with-cached-connection uri + (lambda (port) + (if port + (begin + (update-progress!) + (http-multiple-get uri + handle-narinfo-response '() + requests + #:open-connection + open-connection-for-uri/cached + #:verify-certificate? #f + #:port port)) + '())) + open-connection-for-uri/maybe))) + (newline (current-error-port)) + result)) ((file #f) (let* ((base (string-append (uri-path uri) "/")) (files (map (compose (cut string-append base <> ".narinfo") @@ -990,10 +999,14 @@ the URI, its compression method (a string), and the compressed file size." (define open-connection-for-uri/cached (let ((cache '())) - (lambda* (uri #:key fresh?) + (lambda* (uri #:key fresh? timeout verify-certificate?) "Return a connection for URI, possibly reusing a cached connection. -When FRESH? is true, delete any cached connections for URI and open a new -one. Return #f if URI's scheme is 'file' or #f." +When FRESH? is true, delete any cached connections for URI and open a new one. +Return #f if URI's scheme is 'file' or #f. + +When true, TIMEOUT is the maximum number of milliseconds to wait for +connection establishment. When VERIFY-CERTIFICATE? is true, verify HTTPS +server certificates." (define host (uri-host uri)) (define scheme (uri-scheme uri)) (define key (list host scheme (uri-port uri))) @@ -1005,7 +1018,9 @@ one. Return #f if URI's scheme is 'file' or #f." ;; CACHE, if any. (let-values (((socket) (guix:open-connection-for-uri - uri #:verify-certificate? #f)) + uri + #:verify-certificate? verify-certificate? + #:timeout timeout)) ((new-cache evicted) (at-most (- %max-cached-connections 1) cache))) (for-each (match-lambda @@ -1019,14 +1034,19 @@ one. Return #f if URI's scheme is 'file' or #f." (begin (false-if-exception (close-port socket)) (set! cache (alist-delete key cache)) - (open-connection-for-uri/cached uri)) + (open-connection-for-uri/cached uri #:timeout timeout + #:verify-certificate? + verify-certificate?)) (begin ;; Drain input left from the previous use. (drain-input socket) socket)))))))) -(define (call-with-cached-connection uri proc) - (let ((port (open-connection-for-uri/cached uri))) +(define* (call-with-cached-connection uri proc + #:optional + (open-connection + open-connection-for-uri/cached)) + (let ((port (open-connection uri))) (catch #t (lambda () (proc port)) @@ -1038,7 +1058,7 @@ one. Return #f if URI's scheme is 'file' or #f." (if (or (and (eq? key 'system-error) (= EPIPE (system-error-errno `(,key ,@args)))) (memq key '(bad-response bad-header bad-header-component))) - (proc (open-connection-for-uri/cached uri #:fresh? #t)) + (proc (open-connection uri #:fresh? #t)) (apply throw key args)))))) (define-syntax-rule (with-cached-connection uri port exp ...) @@ -1341,6 +1361,7 @@ default value." ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; eval: (put 'with-cached-connection 'scheme-indent-function 2) +;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1) ;;; End: ;;; substitute.scm ends here diff --git a/guix/ssh.scm b/guix/ssh.scm index e41bffca65..457d1890f9 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -54,8 +54,7 @@ retrieve-files* remote-store-host - report-guile-error - report-module-error)) + report-guile-error)) ;;; Commentary: ;;; @@ -206,6 +205,40 @@ REPL." ;; <https://bugs.gnu.org/26976>.) (close-inferior inferior))))) +(define (remote-run exp session) + "Run EXP in a new process in SESSION and return a remote pipe. + +Unlike 'inferior-remote-eval', this is used for side effects and may +communicate over stdout/stdin as it sees fit. EXP is typically a loop that +processes data from stdin and/or sends data to stdout. The assumption is that +EXP never returns or calls 'primitive-exit' when it's done." + (define pipe + (open-remote-pipe* session OPEN_BOTH + "guix" "repl" "-t" "machine")) + + (match (read pipe) + (('repl-version _ ...) + #t) + ((? eof-object?) + (close-port pipe) + (raise (formatted-message + (G_ "failed to start 'guix repl' on '~a'") + (session-get session 'host))))) + + ;; Disable buffering so 'guix repl' does not read more than what's really + ;; sent to itself. + (write '(setvbuf (current-input-port) 'none) pipe) + (force-output pipe) + + ;; Read the reply and subsequent newline. + (read pipe) (get-u8 pipe) + + (write exp pipe) + (force-output pipe) + + ;; From now on, we stop following the inferior protocol. + pipe) + (define* (remote-daemon-channel session #:optional (socket-name @@ -261,11 +294,7 @@ REPL." (_ (primitive-exit 1))))))) - (open-remote-pipe* session OPEN_BOTH - ;; Sort-of shell-quote REDIRECT. - "guile" "-c" - (object->string - (object->string redirect)))) + (remote-run redirect session)) (define* (connect-to-remote-daemon session #:optional @@ -288,11 +317,6 @@ can be written." ;; consumed. (define import `(begin - (eval-when (load expand eval) - (unless (resolve-module '(guix) #:ensure #f) - (write `(module-error)) - (exit 7))) - (use-modules (guix) (srfi srfi-34) (rnrs io ports) (rnrs bytevectors)) @@ -322,13 +346,10 @@ can be written." (import-paths store (current-input-port)) '(success)))) (lambda args - (cons 'error args)))))) + (cons 'error args)))) + (primitive-exit 0))) - (open-remote-pipe session - (string-join - `("guile" "-c" - ,(object->string (object->string import)))) - OPEN_BOTH)) + (remote-run import session)) (define* (store-export-channel session files #:key recursive?) @@ -338,22 +359,20 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." ;; remote store. (define export `(begin - (eval-when (load expand eval) - (unless (resolve-module '(guix) #:ensure #f) - (write `(module-error)) - (exit 7))) - (use-modules (guix) (srfi srfi-1) (srfi srfi-26) (srfi srfi-34)) (guard (c ((nix-connection-error? c) (write `(connection-error ,(nix-connection-error-file c) - ,(nix-connection-error-code c)))) + ,(nix-connection-error-code c))) + (primitive-exit 1)) ((nix-protocol-error? c) (write `(protocol-error ,(nix-protocol-error-status c) - ,(nix-protocol-error-message c)))) + ,(nix-protocol-error-message c))) + (primitive-exit 2)) (else - (write `(exception)))) + (write `(exception)) + (primitive-exit 3))) (with-store store (let* ((files ',files) (invalid (remove (cut valid-path? store <>) @@ -371,13 +390,10 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." (setvbuf (current-output-port) 'none) (export-paths store files (current-output-port) - #:recursive? ,recursive?)))))) + #:recursive? ,recursive?) + (primitive-exit 0)))))) - (open-remote-input-pipe session - (string-join - `("guile" "-c" - ,(object->string - (object->string export)))))) + (remote-run export session)) (define (remote-system session) "Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of @@ -563,8 +579,6 @@ REMOTE." (match sexp ((? eof-object?) (report-guile-error (remote-store-host remote))) - (('module-error . _) - (report-module-error (remote-store-host remote))) (('connection-error file code . _) (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a") file (remote-store-host remote) (strerror code))) @@ -626,15 +640,6 @@ LOCAL. When RECURSIVE? is true, retrieve the closure of FILES." check.") host))) -(define (report-module-error host) - "Report an error about missing Guix modules on HOST." - ;; TRANSLATORS: Leave "Guile" untranslated. - (raise-error (G_ "Guile modules not found on remote host '~A'") host - (=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix' -own module directory. Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to -check.") - host))) - (define (report-inferior-exception exception host) "Report EXCEPTION, an &inferior-exception that occurred on HOST." (raise-error (G_ "exception occurred on remote host '~A': ~s") diff --git a/guix/transformations.scm b/guix/transformations.scm index d49041cf59..2385d3231e 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -41,6 +41,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (options->transformation manifest-entry-with-transformations @@ -456,6 +457,60 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field." (rewrite obj) obj))) +(define (transform-package-patches specs) + "Return a procedure that, when passed a package, returns a package with +additional patches." + (define (package-with-extra-patches p patches) + (if (origin? (package-source p)) + (package/inherit p + (source (origin + (inherit (package-source p)) + (patches (append (map (lambda (file) + (local-file file)) + patches) + (origin-patches (package-source p))))))) + p)) + + (define (coalesce-alist alist) + ;; Coalesce multiple occurrences of the same key in ALIST. + (let loop ((alist alist) + (keys '()) + (mapping vlist-null)) + (match alist + (() + (map (lambda (key) + (cons key (vhash-fold* cons '() key mapping))) + (delete-duplicates (reverse keys)))) + (((key . value) . rest) + (loop rest + (cons key keys) + (vhash-cons key value mapping)))))) + + (define patches + ;; Spec/patch alist. + (coalesce-alist + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((spec patch) + (cons spec (canonicalize-path patch))) + (_ + (raise (formatted-message + (G_ "~a: invalid package patch specification") + spec))))) + specs))) + + (define rewrite + (package-input-rewriting/spec + (map (match-lambda + ((spec . patches) + (cons spec (cut package-with-extra-patches <> patches)))) + patches))) + + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj))) + (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 @@ -469,7 +524,8 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field." (with-git-url . ,transform-package-source-git-url) (with-c-toolchain . ,transform-package-toolchain) (with-debug-info . ,transform-package-with-debug-info) - (without-tests . ,transform-package-tests))) + (without-tests . ,transform-package-tests) + (with-patch . ,transform-package-patches))) (define (transformation-procedure key) "Return the transformation procedure associated with KEY, a symbol such as @@ -509,6 +565,8 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field." (parser 'with-debug-info)) (option '("without-tests") #t #f (parser 'without-tests)) + (option '("with-patch") #t #f + (parser 'with-patch)) (option '("help-transform") #f #f (lambda _ @@ -538,6 +596,9 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field." --with-git-url=PACKAGE=URL build PACKAGE from the repository at URL")) (display (G_ " + --with-patch=PACKAGE=FILE + add FILE to the list of patches of PACKAGE")) + (display (G_ " --with-c-toolchain=PACKAGE=TOOLCHAIN build PACKAGE and its dependents with TOOLCHAIN")) (display (G_ " diff --git a/guix/utils.scm b/guix/utils.scm index a591b62f30..0df46f1062 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -79,6 +79,7 @@ target-64bit? cc-for-target cxx-for-target + pkg-config-for-target version-compare version>? @@ -548,6 +549,11 @@ a character other than '@'." (string-append target "-g++") "g++")) +(define* (pkg-config-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-pkg-config") + "pkg-config")) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) |