diff options
author | Mathieu Othacehe <m.othacehe@gmail.com> | 2019-11-16 09:34:27 +0100 |
---|---|---|
committer | Mathieu Othacehe <m.othacehe@gmail.com> | 2019-11-16 09:34:27 +0100 |
commit | 154d97abdd16674fdebc763351f661bbcdc869a4 (patch) | |
tree | 0277a9380edd1390f16e432283d32499ffed36d1 /guix | |
parent | e4696c69d75f4fcf54c42beeb928032726bdaf7d (diff) | |
parent | 87e7faa2ae641d8302efc8b90f1e45f43f67f6da (diff) | |
download | gnu-guix-154d97abdd16674fdebc763351f661bbcdc869a4.tar gnu-guix-154d97abdd16674fdebc763351f661bbcdc869a4.tar.gz |
Merge remote-tracking branch master into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/asdf.scm | 13 | ||||
-rw-r--r-- | guix/build/download.scm | 3 | ||||
-rw-r--r-- | guix/build/make-bootstrap.scm | 1 | ||||
-rw-r--r-- | guix/build/svn.scm | 4 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 35 | ||||
-rw-r--r-- | guix/channels.scm | 2 | ||||
-rw-r--r-- | guix/cve.scm | 376 | ||||
-rw-r--r-- | guix/derivations.scm | 38 | ||||
-rw-r--r-- | guix/gexp.scm | 48 | ||||
-rw-r--r-- | guix/inferior.scm | 143 | ||||
-rw-r--r-- | guix/packages.scm | 4 | ||||
-rw-r--r-- | guix/profiles.scm | 3 | ||||
-rw-r--r-- | guix/scripts/build.scm | 15 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 105 | ||||
-rw-r--r-- | guix/scripts/offload.scm | 22 | ||||
-rw-r--r-- | guix/scripts/package.scm | 70 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 62 | ||||
-rw-r--r-- | guix/scripts/system/reconfigure.scm | 5 | ||||
-rw-r--r-- | guix/scripts/system/search.scm | 10 | ||||
-rw-r--r-- | guix/scripts/time-machine.scm | 135 | ||||
-rw-r--r-- | guix/ssh.scm | 10 | ||||
-rw-r--r-- | guix/store.scm | 79 | ||||
-rw-r--r-- | guix/svn-download.scm | 15 | ||||
-rw-r--r-- | guix/ui.scm | 64 |
24 files changed, 900 insertions, 362 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index af04084c86..f794bf006b 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (gnu packages) #:export (%asdf-build-system-modules %asdf-build-modules asdf-build @@ -160,13 +162,22 @@ set up using CL source package conventions." (define (has-from-build-system? pkg) (eq? from-build-system (package-build-system pkg))) + (define (find-input-package pkg) + (let* ((name (package-name pkg)) + (new-name (transform-package-name name)) + (pkgs (find-packages-by-name new-name))) + (if (null? pkgs) #f (list-ref pkgs 0)))) + (define transform (mlambda (pkg) (define rewrite (match-lambda ((name content . rest) (let* ((is-package? (package? content)) - (new-content (if is-package? (transform content) content))) + (new-content (if is-package? + (or (find-input-package content) + (transform content)) + content))) `(,name ,new-content ,@rest))))) ;; Special considerations for source packages: CL inputs become diff --git a/guix/build/download.scm b/guix/build/download.scm index 0c9c61de4b..a4c91550a6 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -172,7 +172,8 @@ session record port using PORT as its underlying communication port." (define %x509-certificate-directory ;; The directory where X.509 authority PEM certificates are stored. (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY") - (getenv "SSL_CERT_DIR")))) ;like OpenSSL + (getenv "SSL_CERT_DIR") ;like OpenSSL + "/etc/ssl/certs"))) (define (set-certificate-credentials-x509-trust-file!* cred file format) "Like 'set-certificate-credentials-x509-trust-file!', but without the file diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index e5ef1d6d2b..0d29338ce3 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -47,7 +47,6 @@ bootstrap libc." (install-file (pk 'src (string-append kernel-headers "/include/linux/" file)) (pk 'dest (string-append incdir "/linux")))) '( - "a.out.h" ; for 2.2.5 "atalk.h" ; for 2.2.5 "errno.h" "falloc.h" diff --git a/guix/build/svn.scm b/guix/build/svn.scm index e3188add3e..33783f3056 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -31,6 +31,7 @@ (define* (svn-fetch url revision directory #:key (svn-command "svn") + (recursive? #t) (user-name #f) (password #f)) "Fetch REVISION from URL into DIRECTORY. REVISION must be an integer, and a @@ -45,6 +46,9 @@ valid Subversion revision. Return #t on success, #f otherwise." (list (string-append "--username=" user-name) (string-append "--password=" password)) '()) + ,@(if recursive? + '() + (list "--ignore-externals")) ,url ,directory)) #t) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index bbf2531c79..a5a9c92a42 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -80,6 +80,7 @@ lock-file unlock-file with-file-lock + with-file-lock/no-wait set-thread-name thread-name @@ -1087,10 +1088,10 @@ exception if it's already taken." ;; Presumably we got EAGAIN or so. (throw 'flock-error err)))))) -(define (lock-file file) +(define* (lock-file file #:key (wait? #t)) "Wait and acquire an exclusive lock on FILE. Return an open port." (let ((port (open-file file "w0"))) - (fcntl-flock port 'write-lock) + (fcntl-flock port 'write-lock #:wait? wait?) port)) (define (unlock-file port) @@ -1119,10 +1120,40 @@ exception if it's already taken." (when port (unlock-file port)))))) +(define (call-with-file-lock/no-wait file thunk handler) + (let ((port (catch #t + (lambda () + (lock-file file #:wait? #f)) + (lambda (key . args) + (match key + ('flock-error + (handler args)) + ('system-error + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno (cons key args))) + #f + (apply throw args))) + (_ (apply throw key args))))))) + (dynamic-wind + (lambda () + #t) + thunk + (lambda () + (when port + (unlock-file port)))))) + (define-syntax-rule (with-file-lock file exp ...) "Wait to acquire a lock on FILE and evaluate EXP in that context." (call-with-file-lock file (lambda () exp ...))) +(define-syntax-rule (with-file-lock/no-wait file handler exp ...) + "Try to acquire a lock on FILE and evaluate EXP in that context. Execute +handler if the lock is already held by another process." + (call-with-file-lock/no-wait file (lambda () exp ...) handler)) + ;;; ;;; Miscellaneous, aka. 'prctl'. diff --git a/guix/channels.scm b/guix/channels.scm index 2c28dccbcb..826ee729ad 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -505,7 +505,7 @@ modules in the old ~/.config/guix/latest style." ;; In the "old style", %SELF-BUILD-FILE would simply return a ;; derivation that builds modules. We have to infer what the ;; dependencies of these modules were. - (list guile-json guile-git guile-bytestructures + (list guile-json-3 guile-git guile-bytestructures (ssh -> guile-ssh) (tls -> gnutls))))) (define (old-style-guix? drv) diff --git a/guix/cve.scm b/guix/cve.scm index 99754fa1f6..903d94a8a6 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,21 +19,43 @@ (define-module (guix cve) #:use-module (guix utils) #:use-module (guix http-client) - #:use-module (sxml ssax) + #:use-module (guix json) + #:use-module (guix i18n) + #:use-module (json) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) - #:export (vulnerability? + #:export (json->cve-items + + cve-item? + cve-item-cve + cve-item-configurations + cve-item-published-date + cve-item-last-modified-date + + cve? + cve-id + cve-data-type + cve-data-format + cvs-references + + cve-reference? + cve-reference-url + cve-reference-tags + + vulnerability? vulnerability-id vulnerability-packages - xml->vulnerabilities + json->vulnerabilities current-vulnerabilities vulnerabilities->lookup-proc)) @@ -41,15 +63,174 @@ ;;; ;;; This modules provides the tools to fetch, parse, and digest part of the ;;; Common Vulnerabilities and Exposures (CVE) feeds provided by the US NIST -;;; at <https://nvd.nist.gov/download.cfm#CVE_FEED>. +;;; at <https://nvd.nist.gov/vuln/data-feeds>. ;;; ;;; Code: -(define-record-type <vulnerability> - (vulnerability id packages) - vulnerability? - (id vulnerability-id) ;string - (packages vulnerability-packages)) ;((p1 v1 v2 v3) (p2 v1) ...) +(define (string->date* str) + (string->date str "~Y-~m-~dT~H:~M~z")) + +(define-json-mapping <cve-item> cve-item cve-item? + json->cve-item + (cve cve-item-cve "cve" json->cve) ;<cve> + (configurations cve-item-configurations ;list of sexps + "configurations" configuration-data->cve-configurations) + (published-date cve-item-published-date + "publishedDate" string->date*) + (last-modified-date cve-item-last-modified-date + "lastModifiedDate" string->date*)) + +(define-json-mapping <cve> cve cve? + json->cve + (id cve-id "CVE_data_meta" ;string + (cut assoc-ref <> "ID")) + (data-type cve-data-type ;'CVE + "data_type" string->symbol) + (data-format cve-data-format ;'MITRE + "data_format" string->symbol) + (references cve-item-references ;list of <cve-reference> + "references" reference-data->cve-references)) + +(define-json-mapping <cve-reference> cve-reference cve-reference? + json->cve-reference + (url cve-reference-url) ;string + (tags cve-reference-tags ;list of strings + "tags" vector->list)) + +(define (reference-data->cve-references alist) + (map json->cve-reference + (vector->list (assoc-ref alist "reference_data")))) + +(define %cpe-package-rx + ;; For applications: "cpe:2.3:a:VENDOR:PACKAGE:VERSION", or sometimes + ;; "cpe:2.3:a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL". + (make-regexp "^cpe:2\\.3:a:([^:]+):([^:]+):([^:]+):([^:]+):")) + +(define (cpe->package-name cpe) + "Converts the Common Platform Enumeration (CPE) string CPE to a package +name, in a very naive way. Return two values: the package name, and its +version string. Return #f and #f if CPE does not look like an application CPE +string." + (cond ((regexp-exec %cpe-package-rx cpe) + => + (lambda (matches) + (values (match:substring matches 2) + (match (match:substring matches 3) + ("*" '_) + (version + (string-append version + (match (match:substring matches 4) + ("" "") + (patch-level + ;; Drop the colon from things like + ;; "cpe:2.3:a:openbsd:openssh:6.8:p1". + (string-drop patch-level 1))))))))) + (else + (values #f #f)))) + +(define (cpe-match->cve-configuration alist) + "Convert ALIST, a \"cpe_match\" alist, into an sexp representing the package +and versions matched. Return #f if ALIST doesn't correspond to an application +package." + (let ((cpe (assoc-ref alist "cpe23Uri")) + (starti (assoc-ref alist "versionStartIncluding")) + (starte (assoc-ref alist "versionStartExcluding")) + (endi (assoc-ref alist "versionEndIncluding")) + (ende (assoc-ref alist "versionEndExcluding"))) + (let-values (((package version) (cpe->package-name cpe))) + (and package + `(,package + ,(cond ((and (or starti starte) (or endi ende)) + `(and ,(if starti `(>= ,starti) `(> ,starte)) + ,(if endi `(<= ,endi) `(< ,ende)))) + (starti `(>= ,starti)) + (starte `(> ,starte)) + (endi `(<= ,endi)) + (ende `(< ,ende)) + (else version))))))) + +(define (configuration-data->cve-configurations alist) + "Given ALIST, a JSON dictionary for the baroque \"configurations\" +element found in CVEs, return an sexp such as (\"binutils\" (< +\"2.31\")) that represents matching configurations." + (define string->operator + (match-lambda + ("OR" 'or) + ("AND" 'and))) + + (define (node->configuration node) + (let ((operator (string->operator (assoc-ref node "operator")))) + (cond + ((assoc-ref node "cpe_match") + => + (lambda (matches) + (let ((matches (vector->list matches))) + (match (filter-map cpe-match->cve-configuration + matches) + (() #f) + ((one) one) + (lst (cons operator lst)))))) + ((assoc-ref node "children") ;typically for 'and' + => + (lambda (children) + (match (filter-map node->configuration (vector->list children)) + (() #f) + ((one) one) + (lst (cons operator lst))))) + (else + #f)))) + + (let ((nodes (vector->list (assoc-ref alist "nodes")))) + (filter-map node->configuration nodes))) + +(define (json->cve-items json) + "Parse JSON, an input port or a string, and return a list of <cve-item> +records." + (let* ((alist (json->scm json)) + (type (assoc-ref alist "CVE_data_type")) + (format (assoc-ref alist "CVE_data_format")) + (version (assoc-ref alist "CVE_data_version"))) + (unless (equal? type "CVE") + (raise (condition (&message + (message "invalid CVE feed"))))) + (unless (equal? format "MITRE") + (raise (condition + (&message + (message (format #f (G_ "unsupported CVE format: '~a'") + format)))))) + (unless (equal? version "4.0") + (raise (condition + (&message + (message (format #f (G_ "unsupported CVE data version: '~a'") + version)))))) + + (map json->cve-item + (vector->list (assoc-ref alist "CVE_Items"))))) + +(define (version-matches? version sexp) + "Return true if VERSION, a string, matches SEXP." + (match sexp + ('_ + #t) + ((? string? expected) + (version-prefix? expected version)) + (('or sexps ...) + (any (cut version-matches? version <>) sexps)) + (('and sexps ...) + (every (cut version-matches? version <>) sexps)) + (('< max) + (version>? max version)) + (('<= max) + (version>=? max version)) + (('> min) + (version>? version min)) + (('>= min) + (version>=? version min)))) + + +;;; +;;; High-level interface. +;;; (define %now (current-date)) @@ -61,8 +242,8 @@ (define (yearly-feed-uri year) "Return the URI for the CVE feed for YEAR." (string->uri - (string-append "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-" - (number->string year) ".xml.gz"))) + (string-append "https://nvd.nist.gov/feeds/json/cve/1.1/nvdcve-1.1-" + (number->string year) ".json.gz"))) (define %current-year-ttl ;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are @@ -73,102 +254,11 @@ ;; Update the previous year's database more and more infrequently. (* 3600 24 (date-month %now))) -(define %cpe-package-rx - ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes - ;; "cpe/a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL". - (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)((:.+)?)")) - -(define (cpe->package-name cpe) - "Converts the Common Platform Enumeration (CPE) string CPE to a package -name, in a very naive way. Return two values: the package name, and its -version string. Return #f and #f if CPE does not look like an application CPE -string." - (cond ((regexp-exec %cpe-package-rx (string-trim-both cpe)) - => - (lambda (matches) - (values (match:substring matches 2) - (string-append (match:substring matches 3) - (match (match:substring matches 4) - ("" "") - (patch-level - ;; Drop the colon from things like - ;; "cpe:/a:openbsd:openssh:6.8:p1". - (string-drop patch-level 1))))))) - (else - (values #f #f)))) - -(define (cpe->product-alist products) - "Given PRODUCTS, a list of CPE names, return the subset limited to the -applications listed in PRODUCTS, with names converted to package names: - - (cpe->product-alist - '(\"cpe:/a:gnu:libtasn1:4.7\" \"cpe:/a:gnu:libtasn1:4.6\" \"cpe:/a:gnu:cpio:2.11\")) - => ((\"libtasn1\" \"4.7\" \"4.6\") (\"cpio\" \"2.11\")) -" - (fold (lambda (product result) - (let-values (((name version) (cpe->package-name product))) - (if name - (match result - (((previous . versions) . tail) - ;; Attempt to coalesce NAME and PREVIOUS. - (if (string=? name previous) - (alist-cons name (cons version versions) tail) - (alist-cons name (list version) result))) - (() - (alist-cons name (list version) result))) - result))) - '() - (sort products string<?))) - -(define %parse-vulnerability-feed - ;; Parse the XML vulnerability feed from - ;; <https://nvd.nist.gov/download.cfm#CVE_FEED> and return a list of - ;; vulnerability objects. - (ssax:make-parser NEW-LEVEL-SEED - (lambda (elem-gi attributes namespaces expected-content - seed) - (match elem-gi - ((name-space . 'entry) - (cons (assoc-ref attributes 'id) seed)) - ((name-space . 'vulnerable-software-list) - (cons '() seed)) - ((name-space . 'product) - (cons 'product seed)) - (x seed))) - - FINISH-ELEMENT - (lambda (elem-gi attributes namespaces parent-seed - seed) - (match elem-gi - ((name-space . 'entry) - (match seed - (((? string? id) . rest) - ;; Some entries have no vulnerable-software-list. - rest) - ((products id . rest) - (match (cpe->product-alist products) - (() - ;; No application among PRODUCTS. - rest) - (packages - (cons (vulnerability id packages) - rest)))))) - (x - seed))) - - CHAR-DATA-HANDLER - (lambda (str _ seed) - (match seed - (('product software-list . rest) - ;; Add STR to the vulnerable software list this - ;; <product> tag is part of. - (cons (cons str software-list) rest)) - (x x))))) - -(define (xml->vulnerabilities port) - "Read from PORT an XML feed of vulnerabilities and return a list of -vulnerability objects." - (reverse (%parse-vulnerability-feed port '()))) +(define-record-type <vulnerability> + (vulnerability id packages) + vulnerability? + (id vulnerability-id) ;string + (packages vulnerability-packages)) ;((p1 sexp1) (p2 sexp2) ...) (define vulnerability->sexp (match-lambda @@ -180,16 +270,70 @@ vulnerability objects." (('v id (packages ...)) (vulnerability id packages)))) +(define (cve-configuration->package-list config) + "Parse CONFIG, a config sexp, and return a list of the form (P SEXP) +where P is a package name and SEXP expresses constraints on the matching +versions." + (let loop ((config config) + (packages '())) + (match config + (('or configs ...) + (fold loop packages configs)) + (('and config _ ...) ;XXX + (loop config packages)) + (((? string? package) '_) ;any version + (cons `(,package _) + (alist-delete package packages))) + (((? string? package) sexp) + (let ((previous (assoc-ref packages package))) + (if previous + (cons `(,package (or ,sexp ,@previous)) + (alist-delete package packages)) + (cons `(,package ,sexp) packages))))))) + +(define (merge-package-lists lst) + "Merge the list in LST, each of which has the form (p sexp), where P +is the name of a package and SEXP is an sexp that constrains matching +versions." + (fold (lambda (plist result) ;XXX: quadratic + (fold (match-lambda* + (((package version) result) + (match (assoc-ref result package) + (#f + (cons `(,package ,version) result)) + ((previous) + (cons `(,package (or ,version ,previous)) + (alist-delete package result)))))) + result + plist)) + '() + lst)) + +(define (cve-item->vulnerability item) + "Return a <vulnerability> corresponding to ITEM, a <cve-item> record; +return #f if ITEM does not list any configuration or if it does not list +any \"a\" (application) configuration." + (let ((id (cve-id (cve-item-cve item)))) + (match (cve-item-configurations item) + (() ;no configurations + #f) + ((configs ...) + (vulnerability id + (merge-package-lists + (map cve-configuration->package-list configs))))))) + +(define (json->vulnerabilities json) + "Parse JSON, an input port or a string, and return the list of +vulnerabilities found therein." + (filter-map cve-item->vulnerability (json->cve-items json))) + (define (write-cache input cache) - "Read vulnerabilities as gzipped XML from INPUT, and write it as a compact + "Read vulnerabilities as gzipped JSON from INPUT, and write it as a compact sexp to CACHE." (call-with-decompressed-port 'gzip input (lambda (input) - ;; XXX: The SSAX "error port" is used to send pointless warnings such as - ;; "warning: Skipping PI". Turn that off. (define vulns - (parameterize ((current-ssax-error-port (%make-void-port "w"))) - (xml->vulnerabilities input))) + (json->vulnerabilities input)) (write `(vulnerabilities 1 ;format version @@ -215,7 +359,7 @@ the given TTL (fetch from the NIST web site when TTL has expired)." (lambda () (read-options options))))) - ;; Note: We used to keep the original XML files in cache but parsing it + ;; Note: We used to keep the original JSON files in cache but parsing it ;; would take typically ~15s for a year of data. Thus, we instead store a ;; summarized version thereof as an sexp, which can be parsed in 1s or so. (let* ((port (http-fetch/cached (yearly-feed-uri year) @@ -269,8 +413,8 @@ vulnerabilities affecting the given package version." (vhash-fold* (if version (lambda (pair result) (match pair - ((vuln . versions) - (if (member version versions) + ((vuln sexp) + (if (version-matches? version sexp) (cons vuln result) result)))) (lambda (pair result) diff --git a/guix/derivations.scm b/guix/derivations.scm index e1073ea39b..6cdf55b1fe 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -622,7 +622,7 @@ that form." (display ")" port)))) (define derivation->bytevector - (mlambda (drv) + (lambda (drv) "Return the external representation of DRV as a UTF-8-encoded string." (with-fluids ((%default-port-encoding "UTF-8")) (call-with-values open-bytevector-output-port @@ -919,7 +919,6 @@ derivation. It is kept as-is, uninterpreted, in the derivation." long-running processes that know what they're doing. Use with care!" ;; Typically this is meant to be used by Cuirass and Hydra, which can clear ;; caches when they start evaluating packages for another architecture. - (invalidate-memoization! derivation->bytevector) (invalidate-memoization! derivation-base16-hash) ;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>. @@ -1207,6 +1206,26 @@ they can refer to each other." #:guile-for-build guile #:local-build? #t))) +(define %module-cache + ;; Map a list of modules to its 'imported+compiled-modules' result. + (make-hash-table)) + +(define* (imported+compiled-modules store modules #:key + (system (%current-system)) + (guile (%guile-for-build))) + "Return a pair containing the derivation to import MODULES and that where +MODULES are compiled." + (define key + (list modules (derivation-file-name guile) system)) + + (or (hash-ref %module-cache key) + (let ((result (cons (%imported-modules store modules + #:system system #:guile guile) + (%compiled-modules store modules + #:system system #:guile guile)))) + (hash-set! %module-cache key result) + result))) + (define* (build-expression->derivation store name exp ;deprecated #:key (system (%current-system)) @@ -1330,16 +1349,15 @@ and PROPERTIES." ;; fixed-output. (filter-map source-path inputs))) - (mod-drv (and (pair? modules) - (%imported-modules store modules - #:guile guile-drv - #:system system))) + (mod+go-drv (if (pair? modules) + (imported+compiled-modules store modules + #:guile guile-drv + #:system system) + '(#f . #f))) + (mod-drv (car mod+go-drv)) + (go-drv (cdr mod+go-drv)) (mod-dir (and mod-drv (derivation->output-path mod-drv))) - (go-drv (and (pair? modules) - (%compiled-modules store modules - #:guile guile-drv - #:system system))) (go-dir (and go-drv (derivation->output-path go-drv)))) (derivation store name guile diff --git a/guix/gexp.scm b/guix/gexp.scm index 7323277511..b640c079e4 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -654,6 +654,31 @@ names and file names suitable for the #:allowed-references argument to (load-path lowered-gexp-load-path) ;list of store items (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items +(define* (imported+compiled-modules modules system + #:key (extensions '()) + deprecation-warnings guile + (module-path %load-path)) + "Return a pair where the first element is the imported MODULES and the +second element is the derivation to compile them." + (mcached equal? + (mlet %store-monad ((modules (if (pair? modules) + (imported-modules modules + #:system system + #:module-path module-path) + (return #f))) + (compiled (if (pair? modules) + (compiled-modules modules + #:system system + #:module-path module-path + #:extensions extensions + #:guile guile + #:deprecation-warnings + deprecation-warnings) + (return #f)))) + (return (cons modules compiled))) + modules + system extensions guile deprecation-warnings module-path)) + (define* (lower-gexp exp #:key (module-path %load-path) @@ -719,20 +744,15 @@ derivations--e.g., code evaluated for its side effects." (lambda (obj) (lower-object obj system)) extensions)) - (modules (if (pair? %modules) - (imported-modules %modules - #:system system - #:module-path module-path) - (return #f))) - (compiled (if (pair? %modules) - (compiled-modules %modules - #:system system - #:module-path module-path - #:extensions extensions - #:guile guile - #:deprecation-warnings - deprecation-warnings) - (return #f)))) + (modules+compiled (imported+compiled-modules + %modules system + #:extensions extensions + #:deprecation-warnings + deprecation-warnings + #:guile guile + #:module-path module-path)) + (modules -> (car modules+compiled)) + (compiled -> (cdr modules+compiled))) (define load-path (search-path modules exts (string-append "/share/guile/site/" effective-version))) diff --git a/guix/inferior.scm b/guix/inferior.scm index d6d2053ab8..71dae89e92 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -89,6 +89,7 @@ gexp->derivation-in-inferior %inferior-cache-directory + cached-channel-instance inferior-for-channels)) ;;; Commentary: @@ -110,11 +111,11 @@ (packages inferior-package-promise) ;promise of inferior packages (table inferior-package-table)) ;promise of vhash -(define (inferior-pipe directory command) +(define* (inferior-pipe directory command error-port) "Return an input/output pipe on the Guix instance in DIRECTORY. This runs 'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if it's an old Guix." - (let ((pipe (with-error-to-port (%make-void-port "w") + (let ((pipe (with-error-to-port error-port (lambda () (open-pipe* OPEN_BOTH (string-append directory "/" command) @@ -125,19 +126,21 @@ it's an old Guix." ;; Older versions of Guix didn't have a 'guix repl' command, so ;; emulate it. - (open-pipe* OPEN_BOTH "guile" - "-L" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/lib/guile/" - (effective-version) "/site-ccache") - "-c" - (object->string - `(begin - (primitive-load ,(search-path %load-path - "guix/repl.scm")) - ((@ (guix repl) machine-repl)))))) + (with-error-to-port error-port + (lambda () + (open-pipe* OPEN_BOTH "guile" + "-L" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/lib/guile/" + (effective-version) "/site-ccache") + "-c" + (object->string + `(begin + (primitive-load ,(search-path %load-path + "guix/repl.scm")) + ((@ (guix repl) machine-repl)))))))) pipe))) (define* (port->inferior pipe #:optional (close close-port)) @@ -161,11 +164,13 @@ inferior." (_ #f))) -(define* (open-inferior directory #:key (command "bin/guix")) +(define* (open-inferior directory + #:key (command "bin/guix") + (error-port (%make-void-port "w"))) "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or equivalent. Return #f if the inferior could not be launched." (define pipe - (inferior-pipe directory command)) + (inferior-pipe directory command error-port)) (port->inferior pipe close-pipe)) @@ -631,6 +636,58 @@ failing when GUIX is too old and lacks the 'guix repl' command." (make-parameter (string-append (cache-directory #:ensure? #f) "/inferiors"))) +(define* (cached-channel-instance store + channels + #:key + (cache-directory (%inferior-cache-directory)) + (ttl (* 3600 24 30))) + "Return a directory containing a guix filetree defined by CHANNELS, a list of channels. +The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. +This procedure opens a new connection to the build daemon." + (define instances + (latest-channel-instances store channels)) + + (define key + (bytevector->base32-string + (sha256 + (string->utf8 + (string-concatenate (map channel-instance-commit instances)))))) + + (define cached + (string-append cache-directory "/" key)) + + (define (base32-encoded-sha256? str) + (= (string-length str) 52)) + + (define (cache-entries directory) + (map (lambda (file) + (string-append directory "/" file)) + (scandir directory base32-encoded-sha256?))) + + (define symlink* + (lift2 symlink %store-monad)) + + (define add-indirect-root* + (store-lift add-indirect-root)) + + (mkdir-p cache-directory) + (maybe-remove-expired-cache-entries cache-directory + cache-entries + #:entry-expiration + (file-expiration-time ttl)) + + (if (file-exists? cached) + cached + (run-with-store store + (mlet %store-monad ((profile + (channel-instances->derivation instances))) + (mbegin %store-monad + (show-what-to-build* (list profile)) + (built-derivations (list profile)) + (symlink* (derivation->output-path profile) cached) + (add-indirect-root* cached) + (return cached)))))) + (define* (inferior-for-channels channels #:key (cache-directory (%inferior-cache-directory)) @@ -641,48 +698,10 @@ procedure opens a new connection to the build daemon. This is a convenience procedure that people may use in manifests passed to 'guix package -m', for instance." - (with-store store - (let () - (define instances - (latest-channel-instances store channels)) - - (define key - (bytevector->base32-string - (sha256 - (string->utf8 - (string-concatenate (map channel-instance-commit instances)))))) - - (define cached - (string-append cache-directory "/" key)) - - (define (base32-encoded-sha256? str) - (= (string-length str) 52)) - - (define (cache-entries directory) - (map (lambda (file) - (string-append directory "/" file)) - (scandir directory base32-encoded-sha256?))) - - (define symlink* - (lift2 symlink %store-monad)) - - (define add-indirect-root* - (store-lift add-indirect-root)) - - (mkdir-p cache-directory) - (maybe-remove-expired-cache-entries cache-directory - cache-entries - #:entry-expiration - (file-expiration-time ttl)) - - (if (file-exists? cached) - (open-inferior cached) - (run-with-store store - (mlet %store-monad ((profile - (channel-instances->derivation instances))) - (mbegin %store-monad - (show-what-to-build* (list profile)) - (built-derivations (list profile)) - (symlink* (derivation->output-path profile) cached) - (add-indirect-root* cached) - (return (open-inferior cached))))))))) + (define cached + (with-store store + (cached-channel-instance store + channels + #:cache-directory cache-directory + #:ttl ttl))) + (open-inferior cached)) diff --git a/guix/packages.scm b/guix/packages.scm index f2c94c7bc2..c98fb98aec 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -241,9 +241,9 @@ name of its URI." (define %hydra-supported-systems ;; This is the list of system types for which build machines are available. ;; - ;; XXX: MIPS is temporarily unavailable on Hydra: + ;; XXX: MIPS is unavailable in CI: ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>. - (fold delete %supported-systems '("aarch64-linux" "mips64el-linux"))) + (fold delete %supported-systems '("mips64el-linux"))) ;; A package. diff --git a/guix/profiles.scm b/guix/profiles.scm index f5c863945c..cd3b21e390 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1732,7 +1732,8 @@ because the NUMBER is zero.)" (string-append %profile-directory "/guix-profile")) (define (ensure-profile-directory) - "Attempt to create /…/profiles/per-user/$USER if needed." + "Attempt to create /…/profiles/per-user/$USER if needed. Nowadays this is +taken care of by the daemon." (let ((s (stat %profile-directory #f))) (unless (and s (eq? 'directory (stat:type s))) (catch 'system-error diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 3ee0b737fe..9ad7379bbe 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -522,7 +522,20 @@ options handled by 'set-build-options-from-command-line', and listed in (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given '%standard-build-options', set the corresponding build options on STORE." - ;; TODO: Add more options. + + ;; '--keep-failed' has no effect when talking to a remote daemon. Catch the + ;; case where GUIX_DAEMON_SOCKET=guix://…. + (when (and (assoc-ref opts 'keep-failed?) + (let* ((socket (store-connection-socket store)) + (peer (catch 'system-error + (lambda () + (and (file-port? socket) + (getpeername socket))) + (const #f)))) + (and peer (not (= AF_UNIX (sockaddr:fam peer)))))) + (warning (G_ "'--keep-failed' ignored since you are \ +talking to a remote daemon\n"))) + (set-build-options store #:keep-failed? (assoc-ref opts 'keep-failed?) #:keep-going? (assoc-ref opts 'keep-going?) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2e14857f1e..7558cb1e85 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -32,6 +32,10 @@ #:use-module (gnu packages) #:use-module (guix sets) #:use-module ((guix utils) #:select (location-file)) + #:use-module ((guix scripts build) + #:select (show-transformation-options-help + options->transformation + %transformation-options)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -446,36 +450,38 @@ package modules, while attempting to retain user package modules." ;;; (define %options - (list (option '(#\t "type") #t #f - (lambda (opt name arg result) - (alist-cons 'node-type (lookup-node-type arg) - result))) - (option '("list-types") #f #f - (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))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix edit"))))) + (cons* (option '(#\t "type") #t #f + (lambda (opt name arg result) + (alist-cons 'node-type (lookup-node-type arg) + result))) + (option '("list-types") #f #f + (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))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix graph"))) + + %transformation-options)) (define (show-help) ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be @@ -495,6 +501,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " -s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\"")) (newline) + (show-transformation-options-help) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -514,21 +522,28 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define (guix-graph . args) (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options) - #:build-options? #f)) - (backend (assoc-ref opts 'backend)) - (type (assoc-ref opts 'node-type)) - (items (filter-map (match-lambda - (('argument . (? store-path? item)) - item) - (('argument . spec) - (specification->package spec)) - (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) - opts))) - (with-store store + (define opts + (parse-command-line args %options + (list %default-options) + #:build-options? #f)) + (define backend + (assoc-ref opts 'backend)) + (define type + (assoc-ref opts 'node-type)) + + (with-store store + (let* ((transform (options->transformation opts)) + (items (filter-map (match-lambda + (('argument . (? store-path? item)) + item) + (('argument . spec) + (transform store + (specification->package spec))) + (('expression . exp) + (transform store + (read/eval-package-expression exp))) + (_ #f)) + opts))) ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index bb307cefd1..1384f6b41d 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -174,7 +174,7 @@ can interpret meaningfully." private key from '~a': ~a") file str)))))))) -(define (open-ssh-session machine) +(define* (open-ssh-session machine #:optional (max-silent-time -1)) "Open an SSH session for MACHINE and return it. Throw an error on failure." (let ((private (private-key-from-file* (build-machine-private-key machine))) (public (public-key-from-file @@ -183,7 +183,7 @@ private key from '~a': ~a") (session (make-session #:user (build-machine-user machine) #:host (build-machine-name machine) #:port (build-machine-port machine) - #:timeout 10 ;seconds + #:timeout 10 ;initial timeout (seconds) ;; #:log-verbosity 'protocol #:identity (build-machine-private-key machine) @@ -225,6 +225,10 @@ instead of '~a' of type '~a'~%") (leave (G_ "SSH public key authentication failed for '~a': ~a~%") (build-machine-name machine) (get-error session)))) + ;; From then on use MAX-SILENT-TIME as the absolute timeout when + ;; reading from or write to a channel for this session. + (session-set! session 'timeout max-silent-time) + session) (x ;; Connection failed or timeout expired. @@ -313,7 +317,7 @@ hook." INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from MACHINE." (define session - (open-ssh-session machine)) + (open-ssh-session machine max-silent-time)) (define store (connect-to-remote-daemon session @@ -472,7 +476,8 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Return the best machine unless it's already overloaded. ;; Note: We call 'node-load' only as a last resort because it is ;; too costly to call it once for every machine. - (let* ((session (false-if-exception (open-ssh-session best))) + (let* ((session (false-if-exception (open-ssh-session best + %short-timeout))) (node (and session (remote-inferior session))) (load (and node (normalized-load best (node-load node)))) (space (and node (node-free-disk-space node)))) @@ -573,6 +578,11 @@ If TIMEOUT is #f, simply evaluate EXP..." ;;; Installation tests. ;;; +(define %short-timeout + ;; Timeout in seconds used on SSH connections where reads and writes + ;; shouldn't take long. + 15) + (define (assert-node-repl node name) "Bail out if NODE is not running Guile." (match (node-guile-version node) @@ -658,7 +668,7 @@ machine." (length machines) machine-file) (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) - (sessions (map open-ssh-session machines)) + (sessions (map (cut open-ssh-session <> %short-timeout) machines)) (nodes (map remote-inferior sessions))) (for-each assert-node-has-guix nodes names) (for-each assert-node-repl nodes names) @@ -682,7 +692,7 @@ machine." (length machines) machine-file) (for-each (lambda (machine) (define session - (open-ssh-session machine)) + (open-ssh-session machine %short-timeout)) (match (remote-inferior session) (#f diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1a58d43e5c..bcd03a1df9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -42,6 +42,8 @@ #:autoload (guix store roots) (gc-roots) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) + #:use-module ((guix build syscalls) + #:select (with-file-lock/no-wait)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -876,36 +878,44 @@ processed, #f otherwise." (package-version item) (manifest-entry-version entry)))))) - ;; First, process roll-backs, generation removals, etc. - (for-each (match-lambda - ((key . arg) - (and=> (assoc-ref %actions key) - (lambda (proc) - (proc store profile arg opts - #:dry-run? dry-run?))))) - opts) - - ;; Then, process normal package removal/installation/upgrade. - (let* ((manifest (profile-manifest profile)) - (step1 (options->removable opts manifest - (manifest-transaction))) - (step2 (options->installable opts manifest step1)) - (step3 (manifest-transaction - (inherit step2) - (install (map transform-entry - (manifest-transaction-install step2))))) - (new (manifest-perform-transaction manifest step3))) - - (warn-about-old-distro) - - (unless (manifest-transaction-null? step3) - (show-manifest-transaction store manifest step3 - #:dry-run? dry-run?) - (build-and-use-profile store profile new - #:allow-collisions? allow-collisions? - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?)))) + + ;; First, acquire a lock on the profile, to ensure only one guix process + ;; is modifying it at a time. + (with-file-lock/no-wait (string-append profile ".lock") + (lambda (key . args) + (leave (G_ "profile ~a is locked by another process~%") + profile)) + + ;; Then, process roll-backs, generation removals, etc. + (for-each (match-lambda + ((key . arg) + (and=> (assoc-ref %actions key) + (lambda (proc) + (proc store profile arg opts + #:dry-run? dry-run?))))) + opts) + + ;; Then, process normal package removal/installation/upgrade. + (let* ((manifest (profile-manifest profile)) + (step1 (options->removable opts manifest + (manifest-transaction))) + (step2 (options->installable opts manifest step1)) + (step3 (manifest-transaction + (inherit step2) + (install (map transform-entry + (manifest-transaction-install step2))))) + (new (manifest-perform-transaction manifest step3))) + + (warn-about-old-distro) + + (unless (manifest-transaction-null? step3) + (show-manifest-transaction store manifest step3 + #:dry-run? dry-run?) + (build-and-use-profile store profile new + #:allow-collisions? allow-collisions? + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?))))) ;;; diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 04970cf503..0ab688ac24 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -56,6 +56,8 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:export (display-profile-content + channel-list + with-git-error-handling guix-pull)) @@ -79,8 +81,6 @@ (display (G_ "Usage: guix pull [OPTION]... Download and deploy the latest version of Guix.\n")) (display (G_ " - --verbose produce verbose output")) - (display (G_ " -C, --channels=FILE deploy the channels defined in FILE")) (display (G_ " --url=URL download from the Git repository at URL")) @@ -120,10 +120,7 @@ Download and deploy the latest version of Guix.\n")) (define %options ;; Specifications of the command-line options. - (cons* (option '("verbose") #f #f - (lambda (opt name arg result) - (alist-cons 'verbose? #t result))) - (option '(#\C "channels") #t #f + (cons* (option '(#\C "channels") #t #f (lambda (opt name arg result) (alist-cons 'channel-file arg result))) (option '(#\l "list-generations") #f #t @@ -235,12 +232,18 @@ purposes." (define title (channel-news-entry-title entry)) - (format port " ~a~%" - (highlight - (string-trim-right - (texi->plain-text (or (assoc-ref title language) - (assoc-ref title (%default-message-language)) - "")))))) + (let ((title (or (assoc-ref title language) + (assoc-ref title (%default-message-language)) + ""))) + (format port " ~a~%" + (highlight + (string-trim-right + (catch 'parser-error + (lambda () + (texi->plain-text title)) + + ;; When Texinfo markup is invalid, display it as-is. + (const title))))))) (define (display-news-entry entry language port) "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to @@ -252,14 +255,20 @@ PORT." (format port (dim (G_ " commit ~a~%")) (channel-news-entry-commit entry)) (newline port) - (format port " ~a~%" - (indented-string - (parameterize ((%text-width (- (%text-width) 4))) - (string-trim-right - (texi->plain-text (or (assoc-ref body language) - (assoc-ref body (%default-message-language)) - "")))) - 4))) + (let ((body (or (assoc-ref body language) + (assoc-ref body (%default-message-language)) + ""))) + (format port " ~a~%" + (indented-string + (parameterize ((%text-width (- (%text-width) 4))) + (string-trim-right + (catch 'parser-error + (lambda () + (texi->plain-text body)) + (lambda _ + ;; When Texinfo markup is invalid, display it as-is. + (fill-paragraph body (%text-width)))))) + 4)))) (define* (display-channel-specific-news new old #:key (port (current-output-port)) @@ -370,7 +379,7 @@ previous generation. Return true if there are news to display." (display-channel-news profile)) (define* (build-and-install instances profile - #:key use-substitutes? verbose? dry-run?) + #:key use-substitutes? dry-run?) "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is true, display what would be built without actually building it." (define update-profile @@ -714,6 +723,9 @@ transformations specified in OPTS (resulting from '--url', '--commit', or (define default-file (string-append (config-directory) "/channels.scm")) + (define global-file + (string-append %sysconfdir "/guix/channels.scm")) + (define (load-channels file) (let ((result (load* file (make-user-module '((guix channels)))))) (if (and (list? result) (every channel? result)) @@ -725,6 +737,8 @@ transformations specified in OPTS (resulting from '--url', '--commit', or (load-channels file)) ((file-exists? default-file) (load-channels default-file)) + ((file-exists? global-file) + (load-channels global-file)) (else %default-channels))) @@ -772,11 +786,11 @@ Use '~/.config/guix/channels.scm' instead.")) (process-generation-change opts profile)) (else (with-store store - (ensure-default-profile) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?))) (set-build-options-from-command-line store opts) + (ensure-default-profile) (honor-x509-certificates store) (let ((instances (latest-channel-instances store channels))) @@ -806,8 +820,6 @@ Use '~/.config/guix/channels.scm' instead.")) #:dry-run? (assoc-ref opts 'dry-run?) #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:verbose? - (assoc-ref opts 'verbose?)))))))))))))) + (assoc-ref opts 'substitutes?)))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 579b7fffbe..2f9dbb2508 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -136,7 +136,10 @@ canonical names (symbols)." (srfi srfi-1)) ;; Load the service files for any new services. - (load-services/safe '#$service-files) + ;; Silence messages coming from shepherd such as "Evaluating + ;; expression ..." since they are unhelpful. + (parameterize ((shepherd-message-port (%make-void-port "w"))) + (load-services/safe '#$service-files)) ;; Unload obsolete services and start new services. (for-each unload-service '#$to-unload) diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index 5278062edd..d2eac06cca 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -65,9 +65,12 @@ provided TYPE has a default value." (define* (service-type->recutils type port #:optional (width (%text-width)) - #:key (extra-fields '())) + #:key + (extra-fields '()) + (hyperlinks? (supports-hyperlinks? port))) "Write to PORT a recutils record of TYPE, arranging to fit within WIDTH -columns." +columns. When HYPERLINKS? is true, emit hyperlink escape sequences when +appropriate." (define width* ;; The available number of columns once we've taken into account space for ;; the initial "+ " prefix. @@ -84,7 +87,8 @@ columns." ;; Note: Don't i18n field names so that people can post-process it. (format port "name: ~a~%" (service-type-name type)) (format port "location: ~a~%" - (or (and=> (service-type-location type) location->string) + (or (and=> (service-type-location type) + (if hyperlinks? location->hyperlink location->string)) (G_ "unknown"))) (format port "extends: ~a~%" diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm new file mode 100644 index 0000000000..19e635555a --- /dev/null +++ b/guix/scripts/time-machine.scm @@ -0,0 +1,135 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net> +;;; Copyright © 2019 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 time-machine) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix inferior) + #:use-module (guix channels) + #:use-module (guix store) + #:use-module (guix status) + #:use-module ((guix utils) + #:select (%current-system)) + #:use-module ((guix scripts pull) + #:select (with-git-error-handling channel-list)) + #:use-module ((guix scripts build) + #:select (%standard-build-options + show-build-options-help + set-build-options-from-command-line)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-time-machine)) + + +;;; +;;; Command-line options. +;;; + +(define (show-help) + (display (G_ "Usage: guix time-machine [OPTION] -- COMMAND ARGS... +Execute COMMAND ARGS... in an older version of Guix.\n")) + (display (G_ " + -C, --channels=FILE deploy the channels defined in FILE")) + (display (G_ " + --url=URL use the Git repository at URL")) + (display (G_ " + --commit=COMMIT use the specified COMMIT")) + (display (G_ " + --branch=BRANCH use the tip of the specified BRANCH")) + (newline) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (cons* (option '(#\C "channels") #t #f + (lambda (opt name arg result) + (alist-cons 'channel-file arg result))) + (option '("url") #t #f + (lambda (opt name arg result) + (alist-cons 'repository-url arg + (alist-delete 'repository-url result)))) + (option '("commit") #t #f + (lambda (opt name arg result) + (alist-cons 'ref `(commit . ,arg) result))) + (option '("branch") #t #f + (lambda (opt name arg result) + (alist-cons 'ref `(branch . ,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 time-machine"))) + + %standard-build-options)) + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (graft? . #t) + (debug . 0) + (verbosity . 1))) + +(define (parse-args args) + "Parse the list of command line arguments ARGS." + ;; The '--' token is used to separate the command to run from the rest of + ;; the operands. + (let-values (((args command) (break (cut string=? "--" <>) args))) + (let ((opts (parse-command-line args %options + (list %default-options)))) + (match command + (() opts) + (("--") opts) + (("--" command ...) (alist-cons 'exec command opts)))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-time-machine . args) + (with-error-handling + (with-git-error-handling + (let* ((opts (parse-args args)) + (channels (channel-list opts)) + (command-line (assoc-ref opts 'exec))) + (when command-line + (let* ((directory + (with-store store + (with-status-verbosity (assoc-ref opts 'verbosity) + (set-build-options-from-command-line store opts) + (cached-channel-instance store channels)))) + (executable (string-append directory "/bin/guix"))) + (apply execl (cons* executable executable command-line)))))))) diff --git a/guix/ssh.scm b/guix/ssh.scm index b6b55bdfcb..5fd3c280e8 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -61,11 +61,16 @@ "zlib@openssh.com,zlib") (define* (open-ssh-session host #:key user port identity - (compression %compression)) + (compression %compression) + (timeout 3600)) "Open an SSH session for HOST and return it. IDENTITY specifies the file name of a private key to use for authenticating with the host. When USER, PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config' -specifies; otherwise use them. Throw an error on failure." +specifies; otherwise use them. Install TIMEOUT as the maximum time in seconds +after which a read or write operation on a channel of the returned session is +considered as failing. + +Throw an error on failure." (let ((session (make-session #:user user #:identity identity #:host host @@ -86,6 +91,7 @@ specifies; otherwise use them. Throw an error on failure." ;; Use public key authentication, via the SSH agent if it's available. (match (userauth-public-key/auto! session) ('success + (session-set! session 'timeout timeout) session) (x (disconnect! session) diff --git a/guix/store.scm b/guix/store.scm index d7c603898c..a276554a52 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -748,6 +748,14 @@ encoding conversion errors." (cut string-append "http://" <>)) '("ci.guix.gnu.org"))) +(define (current-user-name) + "Return the name of the calling user." + (catch #t + (lambda () + (passwd:name (getpwuid (getuid)))) + (lambda _ + (getenv "USER")))) + (define* (set-build-options server #:key keep-failed? keep-going? fallback? (verbosity 0) @@ -759,6 +767,7 @@ encoding conversion errors." (build-verbosity 0) (log-type 0) (print-build-trace #t) + (user-name (current-user-name)) ;; When true, provide machine-readable "build ;; traces" for use by (guix status). Old clients @@ -849,6 +858,9 @@ encoding conversion errors." `(("build-repeat" . ,(number->string (max 0 (1- rounds))))) '()) + ,@(if user-name + `(("user-name" . ,user-name)) + '()) ,@(if terminal-columns `(("terminal-columns" . ,(number->string terminal-columns))) @@ -1600,10 +1612,11 @@ This makes sense only when the daemon was started with '--cache-failures'." ;; from %STATE-MONAD. (template-directory instantiations %store-monad) -(define* (cache-object-mapping object keys result) +(define* (cache-object-mapping object keys result + #:key (vhash-cons vhash-consq)) "Augment the store's object cache with a mapping from OBJECT/KEYS to RESULT. KEYS is a list of additional keys to match against, for instance a (SYSTEM -TARGET) tuple. +TARGET) tuple. Use VHASH-CONS to insert OBJECT into the cache. OBJECT is typically a high-level object such as a <package> or an <origin>, and RESULT is typically its derivation." @@ -1611,8 +1624,8 @@ and RESULT is typically its derivation." (values result (store-connection (inherit store) - (object-cache (vhash-consq object (cons result keys) - (store-connection-object-cache store))))))) + (object-cache (vhash-cons object (cons result keys) + (store-connection-object-cache store))))))) (define record-cache-lookup! (if (profiled? "object-cache") @@ -1641,11 +1654,12 @@ and RESULT is typically its derivation." (lambda (x y) #t))) -(define* (lookup-cached-object object #:optional (keys '())) +(define* (lookup-cached-object object #:optional (keys '()) + #:key (vhash-fold* vhash-foldq*)) "Return the cached object in the store connection corresponding to OBJECT -and KEYS. KEYS is a list of additional keys to match against, and which are -compared with 'equal?'. Return #f on failure and the cached result -otherwise." +and KEYS; use VHASH-FOLD* to look for OBJECT in the cache. KEYS is a list of +additional keys to match against, and which are compared with 'equal?'. +Return #f on failure and the cached result otherwise." (lambda (store) (let* ((cache (store-connection-object-cache store)) @@ -1653,33 +1667,50 @@ otherwise." ;; the whole vlist chain and significantly reduces the number of ;; 'hashq' calls. (value (let/ec return - (vhash-foldq* (lambda (item result) - (match item - ((value . keys*) - (if (equal? keys keys*) - (return value) - result)))) - #f object - cache)))) + (vhash-fold* (lambda (item result) + (match item + ((value . keys*) + (if (equal? keys keys*) + (return value) + result)))) + #f object + cache)))) (record-cache-lookup! value cache) (values value store)))) -(define* (%mcached mthunk object #:optional (keys '())) +(define* (%mcached mthunk object #:optional (keys '()) + #:key + (vhash-cons vhash-consq) + (vhash-fold* vhash-foldq*)) "Bind the monadic value returned by MTHUNK, which supposedly corresponds to -OBJECT/KEYS, or return its cached value." - (mlet %store-monad ((cached (lookup-cached-object object keys))) +OBJECT/KEYS, or return its cached value. Use VHASH-CONS to insert OBJECT into +the cache, and VHASH-FOLD* to look it up." + (mlet %store-monad ((cached (lookup-cached-object object keys + #:vhash-fold* vhash-fold*))) (if cached (return cached) (>>= (mthunk) (lambda (result) - (cache-object-mapping object keys result)))))) + (cache-object-mapping object keys result + #:vhash-cons vhash-cons)))))) -(define-syntax-rule (mcached mvalue object keys ...) - "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the +(define-syntax mcached + (syntax-rules (eq? equal?) + "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the value associated with OBJECT/KEYS in the store's object cache if there is one." - (%mcached (lambda () mvalue) - object (list keys ...))) + ((_ eq? mvalue object keys ...) + (%mcached (lambda () mvalue) + object (list keys ...) + #:vhash-cons vhash-consq + #:vhash-fold* vhash-foldq*)) + ((_ equal? mvalue object keys ...) + (%mcached (lambda () mvalue) + object (list keys ...) + #:vhash-cons vhash-cons + #:vhash-fold* vhash-fold*)) + ((_ mvalue object keys ...) + (mcached eq? mvalue object keys ...)))) (define (preserve-documentation original proc) "Return PROC with documentation taken from ORIGINAL." diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 4139cbc2e2..59e2eb8d07 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -31,6 +31,7 @@ svn-reference? svn-reference-url svn-reference-revision + svn-reference-recursive? svn-fetch download-svn-to-store @@ -39,6 +40,7 @@ svn-multi-reference-url svn-multi-reference-revision svn-multi-reference-locations + svn-multi-reference-recursive? svn-multi-fetch)) ;;; Commentary: @@ -52,10 +54,11 @@ (define-record-type* <svn-reference> svn-reference make-svn-reference svn-reference? - (url svn-reference-url) ; string - (revision svn-reference-revision) ; number - (user-name svn-reference-user-name (default #f)) - (password svn-reference-password (default #f))) + (url svn-reference-url) ; string + (revision svn-reference-revision) ; number + (recursive? svn-reference-recursive? (default #t)) + (user-name svn-reference-user-name (default #f)) + (password svn-reference-password (default #f))) (define (subversion-package) "Return the default Subversion package." @@ -78,6 +81,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." '#$(svn-reference-revision ref) #$output #:svn-command (string-append #+svn "/bin/svn") + #:recursive? #$(svn-reference-recursive? ref) #:user-name #$(svn-reference-user-name ref) #:password #$(svn-reference-password ref))))) @@ -96,6 +100,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (url svn-multi-reference-url) ; string (revision svn-multi-reference-revision) ; number (locations svn-multi-reference-locations) ; list of strings + (recursive? svn-multi-reference-recursive? (default #t)) (user-name svn-multi-reference-user-name (default #f)) (password svn-multi-reference-password (default #f))) @@ -125,6 +130,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (string-append #$output "/" location) (string-append #$output "/" (dirname location))) #:svn-command (string-append #+svn "/bin/svn") + #:recursive? + #$(svn-multi-reference-recursive? ref) #:user-name #$(svn-multi-reference-user-name ref) #:password #$(svn-multi-reference-password ref))) '#$(svn-multi-reference-locations ref))))) diff --git a/guix/ui.scm b/guix/ui.scm index 3e4bd5787e..eb17d274c8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -44,7 +44,8 @@ #:use-module (guix derivations) #:use-module (guix build-system) #:use-module (guix serialization) - #:use-module ((guix licenses) #:select (license? license-name)) + #:use-module ((guix licenses) + #:select (license? license-name license-uri)) #:use-module ((guix build syscalls) #:select (free-disk-space terminal-columns terminal-rows)) @@ -69,6 +70,7 @@ #:autoload (system base compile) (compile-file) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) + #:autoload (web uri) (encode-and-join-uri-path) #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (texinfo string-utils) @@ -108,6 +110,9 @@ package->recutils package-specification->name+version+output + supports-hyperlinks? + location->hyperlink + relevance package-relevance display-search-results @@ -1234,10 +1239,42 @@ followed by \"+ \", which makes for a valid multi-line field value in the '() str))) +(define (hyperlink uri text) + "Return a string that denotes a hyperlink using an OSC escape sequence as +documented at +<https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda>." + (string-append "\x1b]8;;" uri "\x1b\\" + text "\x1b]8;;\x1b\\")) + +(define (supports-hyperlinks? port) + "Return true if PORT is a terminal that supports hyperlink escapes." + ;; Note that terminals are supposed to ignore OSC escapes they don't + ;; understand (this is the case of xterm as of version 349, for instance.) + ;; However, Emacs comint as of 26.3 does not ignore it and instead lets it + ;; through, hence the 'INSIDE_EMACS' special case below. + (and (isatty?* port) + (not (getenv "INSIDE_EMACS")))) + +(define (location->hyperlink location) + "Return a string corresponding to LOCATION, with escapes for a hyperlink." + (let ((str (location->string location)) + (file (if (string-prefix? "/" (location-file location)) + (location-file location) + (search-path %load-path (location-file location))))) + (if file + (hyperlink (string-append "file://" (gethostname) + (encode-and-join-uri-path + (string-split file #\/))) + str) + str))) + (define* (package->recutils p port #:optional (width (%text-width)) - #:key (extra-fields '())) + #:key + (hyperlinks? (supports-hyperlinks? port)) + (extra-fields '())) "Write to PORT a `recutils' record of package P, arranging to fit within -WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit." +WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit. When +HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." (define width* ;; The available number of columns once we've taken into account space for ;; the initial "+ " prefix. @@ -1265,7 +1302,8 @@ WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit." (((labels inputs . _) ...) (dependencies->recutils (filter package? inputs))))) (format port "location: ~a~%" - (or (and=> (package-location p) location->string) + (or (and=> (package-location p) + (if hyperlinks? location->hyperlink location->string)) (G_ "unknown"))) ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in @@ -1278,7 +1316,11 @@ WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit." (string-join (map license-name licenses) ", ")) ((? license? license) - (license-name license)) + (let ((text (license-name license)) + (uri (license-uri license))) + (if (and hyperlinks? uri (string-prefix? "http" uri)) + (hyperlink uri text) + text))) (x (G_ "unknown")))) (format port "synopsis: ~a~%" @@ -1398,11 +1440,13 @@ them. If PORT is a terminal, print at most a full screen of results." (let loop ((matches matches)) (match matches (((package . score) rest ...) - (let ((text (call-with-output-string - (lambda (port) - (print package port - #:extra-fields - `((relevance . ,score))))))) + (let* ((links? (supports-hyperlinks? port)) + (text (call-with-output-string + (lambda (port) + (print package port + #:hyperlinks? links? + #:extra-fields + `((relevance . ,score))))))) (if (and max-rows (> (port-line port) first-line) ;print at least one result (> (+ 4 (line-count text) (port-line port)) |