diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/download.scm | 16 | ||||
| -rw-r--r-- | guix/gexp.scm | 15 | ||||
| -rw-r--r-- | guix/git.scm | 136 | ||||
| -rw-r--r-- | guix/import/opam.scm | 46 | ||||
| -rw-r--r-- | guix/monads.scm | 15 | ||||
| -rw-r--r-- | guix/profiles.scm | 34 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 26 | ||||
| -rw-r--r-- | guix/status.scm | 8 | ||||
| -rw-r--r-- | guix/ui.scm | 8 |
10 files changed, 237 insertions, 70 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index c08221b3b2..a64e0f0bd3 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -157,7 +157,8 @@ out if the connection could not be established in less than TIMEOUT seconds." ;; XXX: Use this hack instead of #:autoload to avoid compilation errors. ;; See <http://bugs.gnu.org/12202>. (module-autoload! (current-module) - '(gnutls) '(make-session connection-end/client)) + '(gnutls) + '(gnutls-version make-session connection-end/client)) (define %tls-ports ;; Mapping of session record ports to the underlying file port. @@ -268,7 +269,18 @@ host name without trailing dot." ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>. ;; Explicitly disable SSLv3, which is insecure: ;; <https://tools.ietf.org/html/rfc7568>. - (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0") + ;; + ;; FIXME: Since we currently fail to handle TLS 1.3 (with GnuTLS 3.6.5), + ;; remove it; see <https://bugs.gnu.org/34102>. + (set-session-priorities! session + (string-append + "NORMAL:%COMPAT:-VERS-SSL3.0" + + ;; The "VERS-TLS1.3" priority string is not + ;; supported by GnuTLS 3.5. + (if (string-prefix? "3.5." (gnutls-version)) + "" + ":-VERS-TLS1.3"))) (set-session-credentials! session (if (and verify-certificate? ca-certs) diff --git a/guix/gexp.scm b/guix/gexp.scm index f7c064297b..5b5b064b59 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -920,7 +920,18 @@ and in the current monad setting (system type, etc.)" (simple-format #f "~a:~a" line column))) "<unknown location>"))) -(define-syntax-parameter current-imported-modules +(define-syntax-rule (define-syntax-parameter-once name proc) + ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME + ;; does not get redefined. This works around a race condition in a + ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. + (eval-when (load eval expand compile) + (define name + (if (module-locally-bound? (current-module) 'name) + (module-ref (current-module) 'name) + (make-syntax-transformer 'name 'syntax-parameter + (list proc)))))) + +(define-syntax-parameter-once current-imported-modules ;; Current list of imported modules. (identifier-syntax '())) @@ -931,7 +942,7 @@ environment." (identifier-syntax modules))) body ...)) -(define-syntax-parameter current-imported-extensions +(define-syntax-parameter-once current-imported-extensions ;; Current list of extensions. (identifier-syntax '())) diff --git a/guix/git.scm b/guix/git.scm index 0666f0c0a9..0e3ce37e26 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +35,8 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (%repository-cache-directory + honor-system-x509-certificates! + update-cached-checkout latest-repository-commit @@ -43,25 +45,70 @@ git-checkout-url git-checkout-branch)) +;; XXX: Use this hack instead of #:autoload to avoid compilation errors. +;; See <http://bugs.gnu.org/12202>. +(module-autoload! (current-module) + '(git submodule) '(repository-submodules)) + (define %repository-cache-directory (make-parameter (string-append (cache-directory #:ensure? #f) "/checkouts"))) +(define (honor-system-x509-certificates!) + "Use the system's X.509 certificates for Git checkouts over HTTPS. Honor +the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." + ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of + ;; files (instead of all the certificates) among which "ca-bundle.crt". On + ;; other distros /etc/ssl/certs usually contains the whole set of + ;; certificates along with "ca-certificates.crt". Try to choose the right + ;; one. + (let ((file (letrec-syntax ((choose + (syntax-rules () + ((_ file rest ...) + (let ((f file)) + (if (and f (file-exists? f)) + f + (choose rest ...)))) + ((_) + #f)))) + (choose (getenv "SSL_CERT_FILE") + "/etc/ssl/certs/ca-certificates.crt" + "/etc/ssl/certs/ca-bundle.crt"))) + (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) + (and (or file + (and=> (stat directory #f) + (lambda (st) + (> (stat:nlink st) 2)))) + (begin + (set-tls-certificate-locations! directory file) + #t)))) + +(define %certificates-initialized? + ;; Whether 'honor-system-x509-certificates!' has already been called. + #f) + (define-syntax-rule (with-libgit2 thunk ...) (begin ;; XXX: The right thing to do would be to call (libgit2-shutdown) here, ;; but pointer finalizers used in guile-git may be called after shutdown, ;; resulting in a segfault. Hence, let's skip shutdown call for now. (libgit2-init!) + (unless %certificates-initialized? + (honor-system-x509-certificates!) + (set! %certificates-initialized? #t)) thunk ...)) (define* (url-cache-directory url #:optional (cache-directory - (%repository-cache-directory))) + (%repository-cache-directory)) + #:key recursive?) "Return the directory associated to URL in %repository-cache-directory." (string-append cache-directory "/" - (bytevector->base32-string (sha256 (string->utf8 url))))) + (bytevector->base32-string + (sha256 (string->utf8 (if recursive? + (string-append "R:" url) + url)))))) (define (clone* url directory) "Clone git repository at URL into DIRECTORY. Upon failure, @@ -119,18 +166,62 @@ OID (roughly the commit hash) corresponding to REF." (reset repository obj RESET_HARD) (object-id obj)) +(define (call-with-repository directory proc) + (let ((repository #f)) + (dynamic-wind + (lambda () + (set! repository (repository-open directory))) + (lambda () + (proc repository)) + (lambda () + (repository-close! repository))))) + +(define-syntax-rule (with-repository directory repository exp ...) + "Open the repository at DIRECTORY and bind REPOSITORY to it within the +dynamic extent of EXP." + (call-with-repository directory + (lambda (repository) exp ...))) + +(define* (update-submodules repository + #:key (log-port (current-error-port))) + "Update the submodules of REPOSITORY, a Git repository object." + ;; Guile-Git < 0.2.0 did not have (git submodule). + (if (false-if-exception (resolve-interface '(git submodule))) + (for-each (lambda (name) + (let ((submodule (submodule-lookup repository name))) + (format log-port (G_ "updating submodule '~a'...~%") + name) + (submodule-update submodule) + + ;; Recurse in SUBMODULE. + (let ((directory (string-append + (repository-working-directory repository) + "/" (submodule-path submodule)))) + (with-repository directory repository + (update-submodules repository + #:log-port log-port))))) + (repository-submodules repository)) + (format (current-error-port) + (G_ "Support for submodules is missing; \ +please upgrade Guile-Git.~%")))) + (define* (update-cached-checkout url #:key (ref '(branch . "master")) + recursive? + (log-port (%make-void-port "w")) (cache-directory (url-cache-directory - url (%repository-cache-directory)))) + url (%repository-cache-directory) + #:recursive? recursive?))) "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two values: the cache directory name, and the SHA1 commit (a string) corresponding to REF. REF is pair whose key is [branch | commit | tag] and value the associated -data, respectively [<branch name> | <sha1> | <tag name>]." +data, respectively [<branch name> | <sha1> | <tag name>]. + +When RECURSIVE? is true, check out submodules as well, if any." (define canonical-ref ;; We used to require callers to specify "origin/" for each branch, which ;; made little sense since the cache should be transparent to them. So @@ -150,6 +241,8 @@ data, respectively [<branch name> | <sha1> | <tag name>]." ;; Only fetch remote if it has not been cloned just before. (when cache-exists? (remote-fetch (remote-lookup repository "origin"))) + (when recursive? + (update-submodules repository #:log-port log-port)) (let ((oid (switch-to-ref repository canonical-ref))) ;; Reclaim file descriptors and memory mappings associated with @@ -162,6 +255,7 @@ data, respectively [<branch name> | <sha1> | <tag name>]." (define* (latest-repository-commit store url #:key + recursive? (log-port (%make-void-port "w")) (cache-directory (%repository-cache-directory)) @@ -172,21 +266,33 @@ reference to be checkout, once the repository is fetched, is specified by REF. REF is pair whose key is [branch | commit | tag] and value the associated data, respectively [<branch name> | <sha1> | <tag name>]. +When RECURSIVE? is true, check out submodules as well, if any. + Git repositories are kept in the cache directory specified by %repository-cache-directory parameter. Log progress and checkout info to LOG-PORT." (define (dot-git? file stat) (and (string=? (basename file) ".git") - (eq? 'directory (stat:type stat)))) + (or (eq? 'directory (stat:type stat)) + + ;; Submodule checkouts end up with a '.git' regular file that + ;; contains metadata about where their actual '.git' directory + ;; lives. + (and recursive? + (eq? 'regular (stat:type stat)))))) (format log-port "updating checkout of '~a'...~%" url) (let*-values (((checkout commit) (update-cached-checkout url + #:recursive? recursive? #:ref ref #:cache-directory - (url-cache-directory url cache-directory))) + (url-cache-directory url cache-directory + #:recursive? + recursive?) + #:log-port log-port)) ((name) (url+commit->name url commit))) (format log-port "retrieved commit ~a~%" commit) @@ -205,9 +311,10 @@ Log progress and checkout info to LOG-PORT." git-checkout? (url git-checkout-url) (branch git-checkout-branch (default "master")) - (commit git-checkout-commit (default #f))) + (commit git-checkout-commit (default #f)) + (recursive? git-checkout-recursive? (default #f))) -(define* (latest-repository-commit* url #:key ref log-port) +(define* (latest-repository-commit* url #:key ref recursive? log-port) ;; Monadic variant of 'latest-repository-commit'. (lambda (store) ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so @@ -216,7 +323,9 @@ Log progress and checkout info to LOG-PORT." (catch 'git-error (lambda () (values (latest-repository-commit store url - #:ref ref #:log-port log-port) + #:ref ref + #:recursive? recursive? + #:log-port log-port) store)) (lambda (key error . _) (raise (condition @@ -238,9 +347,14 @@ Log progress and checkout info to LOG-PORT." ;; "Compile" CHECKOUT by updating the local checkout and adding it to the ;; store. (match checkout - (($ <git-checkout> url branch commit) + (($ <git-checkout> url branch commit recursive?) (latest-repository-commit* url #:ref (if commit `(commit . ,commit) `(branch . ,branch)) + #:recursive? recursive? #:log-port (current-error-port))))) + +;; Local Variables: +;; eval: (put 'with-repository 'scheme-indent-function 2) +;; End: diff --git a/guix/import/opam.scm b/guix/import/opam.scm index c254db5f2c..7b2e832e92 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -1,4 +1,3 @@ -;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. @@ -90,8 +89,8 @@ (define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string)) (define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form)) (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form)) -(define-peg-pattern condition-eq all (and condition-content (* SP) (ignore "=") (* SP) condition-content)) -(define-peg-pattern condition-neq all (and condition-content (* SP) (ignore (and "!" "=")) (* SP) condition-content)) +(define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content)) +(define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content)) (define-peg-pattern condition-content body (or condition-string condition-var)) (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!")))) (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) @@ -117,7 +116,11 @@ path to the repository." (lambda (dir) (string-join (cdr (string-split dir #\.)) ".")) versions))) - (latest-version versions)) + ;; Workaround for janestreet re-versionning + (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions))) + (if (null? v-versions) + (latest-version versions) + (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions)))))) (begin (format #t (G_ "Package not found in opam repository: ~a~%") package) #f)))) @@ -127,12 +130,17 @@ path to the repository." (lambda _ (peg:tree (match-pattern records (get-string-all (current-input-port))))))) +(define (substitute-char str what with) + (string-join (string-split str what) with)) + (define (ocaml-name->guix-name name) - (cond - ((equal? name "ocamlfind") "ocaml-findlib") - ((string-prefix? "ocaml" name) name) - ((string-prefix? "conf-" name) (substring name 5)) - (else (string-append "ocaml-" name)))) + (substitute-char + (cond + ((equal? name "ocamlfind") "ocaml-findlib") + ((string-prefix? "ocaml" name) name) + ((string-prefix? "conf-" name) (substring name 5)) + (else (string-append "ocaml-" name))) + #\_ "-")) (define (metadata-ref file lookup) (fold (lambda (record acc) @@ -234,7 +242,9 @@ path to the repository." (values `(package (name ,(ocaml-name->guix-name name)) - (version ,version) + (version ,(if (string-prefix? "v" version) + (substring version 1) + version)) (source (origin (method url-fetch) @@ -247,6 +257,10 @@ path to the repository." ,@(if (null? native-inputs) '() `((native-inputs ,(list 'quasiquote native-inputs)))) + ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) + '() + `((properties + ,(list 'quasiquote `((upstream-name . ,name)))))) (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) (description ,(metadata-ref opam-content "description")) @@ -259,6 +273,11 @@ path to the repository." (opam->guix-package name)) #:guix-name ocaml-name->guix-name)) +(define (guix-name->opam-name name) + (if (string-prefix? "ocaml-" name) + (substring name 6) + name)) + (define (guix-package->opam-name package) "Given an OCaml PACKAGE built from OPAM, return the name of the package in OPAM." @@ -266,10 +285,9 @@ package in OPAM." (package-properties package) 'upstream-name)) (name (package-name package))) - (cond - (upstream-name upstream-name) - ((string-prefix? "ocaml-" name) (substring name 6)) - (else name)))) + (if upstream-name + upstream-name + (guix-name->opam-name name)))) (define (opam-package? package) "Return true if PACKAGE is an OCaml package from OPAM" diff --git a/guix/monads.scm b/guix/monads.scm index 6ae616aca9..6924471345 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -274,12 +274,23 @@ more optimizations." (_ #'generic-name)))))))))) -(define-syntax-parameter >>= +(define-syntax-rule (define-syntax-parameter-once name proc) + ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME + ;; does not get redefined. This works around a race condition in a + ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. + (eval-when (load eval expand compile) + (define name + (if (module-locally-bound? (current-module) 'name) + (module-ref (current-module) 'name) + (make-syntax-transformer 'name 'syntax-parameter + (list proc)))))) + +(define-syntax-parameter-once >>= ;; The name 'bind' is already taken, so we choose this (obscure) symbol. (lambda (s) (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) -(define-syntax-parameter return +(define-syntax-parameter-once return (lambda (s) (syntax-violation 'return "return used outside of 'with-monad'" s))) diff --git a/guix/profiles.scm b/guix/profiles.scm index efe5ecb9dc..6564526aee 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -63,6 +63,10 @@ &missing-generation-error missing-generation-error? missing-generation-error-generation + &unmatched-pattern-error + unmatched-pattern-error? + unmatched-pattern-error-pattern + unmatched-pattern-error-manifest manifest make-manifest manifest? @@ -156,6 +160,11 @@ (entry profile-collision-error-entry) ;<manifest-entry> (conflict profile-collision-error-conflict)) ;<manifest-entry> +(define-condition-type &unmatched-pattern-error &error + unmatched-pattern-error? + (pattern unmatched-pattern-error-pattern) ;<manifest-pattern> + (manifest unmatched-pattern-error-manifest)) ;<manifest> + (define-condition-type &missing-generation-error &profile-error missing-generation-error? (generation missing-generation-error-generation)) @@ -559,16 +568,21 @@ no match.." (->bool (manifest-lookup manifest pattern))) (define (manifest-matching-entries manifest patterns) - "Return all the entries of MANIFEST that match one of the PATTERNS." - (define predicates - (map entry-predicate patterns)) - - (define (matches? entry) - (any (lambda (pred) - (pred entry)) - predicates)) - - (filter matches? (manifest-entries manifest))) + "Return all the entries of MANIFEST that match one of the PATTERNS. Raise +an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one +of PATTERNS." + (fold-right (lambda (pattern matches) + (match (filter (entry-predicate pattern) + (manifest-entries manifest)) + (() + (raise (condition + (&unmatched-pattern-error + (pattern pattern) + (manifest manifest))))) + (lst + (append lst matches)))) + '() + patterns)) (define (manifest-search-paths manifest) "Return the list of search path specifications that apply to MANIFEST, diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 5a158799ae..fb7e04904d 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -308,7 +308,8 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using (package (inherit old) (version (string-append "git." branch)) - (source (git-checkout (url url) (branch branch))))) + (source (git-checkout (url url) (branch branch) + (recursive? #t))))) (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 683ab3f059..3320200c07 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -216,30 +216,8 @@ true, display what would be built without actually building it." (define (honor-x509-certificates store) "Use the right X.509 certificates for Git checkouts over HTTPS." - ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of - ;; files (instead of all the certificates) among which "ca-bundle.crt". On - ;; other distros /etc/ssl/certs usually contains the whole set of - ;; certificates along with "ca-certificates.crt". Try to choose the right - ;; one. - (let ((file (letrec-syntax ((choose - (syntax-rules () - ((_ file rest ...) - (let ((f file)) - (if (and f (file-exists? f)) - f - (choose rest ...)))) - ((_) - #f)))) - (choose (getenv "SSL_CERT_FILE") - "/etc/ssl/certs/ca-certificates.crt" - "/etc/ssl/certs/ca-bundle.crt"))) - (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) - (if (or file - (and=> (stat directory #f) - (lambda (st) - (> (stat:nlink st) 2)))) - (set-tls-certificate-locations! directory file) - (honor-lets-encrypt-certificates! store)))) + (unless (honor-system-x509-certificates!) + (honor-lets-encrypt-certificates! store))) (define (report-git-error error) "Report the given Guile-Git error." diff --git a/guix/status.scm b/guix/status.scm index 984f329964..cd5027ef17 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -498,14 +498,12 @@ addition to build events." (spin! #f port)))))) (define erase-current-line* - (if (isatty?* port) - (lambda (port) + (if (and (not print-log?) (isatty?* port)) + (lambda () (erase-current-line port) (force-output port)) (const #t))) - (unless print-log? - (erase-current-line* port)) ;clear the spinner or progress bar (match event (('build-started drv . _) (let ((properties (derivation-properties @@ -530,6 +528,7 @@ addition to build events." (format port (info (G_ "building ~a...")) drv)))) (newline port)) (('build-succeeded drv . _) + (erase-current-line*) ;erase spinner or progress bar (when (or print-log? (not (extended-build-trace-supported?))) (format port (success (G_ "successfully built ~a")) drv) (newline port)) @@ -542,6 +541,7 @@ addition to build events." (length ongoing)) (map build-derivation ongoing))))) (('build-failed drv . _) + (erase-current-line*) ;erase spinner or progress bar (format port (failure (G_ "build of ~a failed")) drv) (newline port) (match (derivation-log-file drv) diff --git a/guix/ui.scm b/guix/ui.scm index 9eab4ba3f7..f0465519b6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -643,6 +643,14 @@ or remove one of them from the profile.") (leave (G_ "generation ~a of profile '~a' does not exist~%") (missing-generation-error-generation c) (profile-error-profile c))) + ((unmatched-pattern-error? c) + (let ((pattern (unmatched-pattern-error-pattern c))) + (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%") + (manifest-pattern-name pattern) + (manifest-pattern-version pattern) + (match (manifest-pattern-output pattern) + ("out" #f) + (output output))))) ((profile-collision-error? c) (let ((entry (profile-collision-error-entry c)) (conflict (profile-collision-error-conflict c))) |