From e4ee84202633636b4c8cef4a332f0c74912a3b23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Jan 2019 23:14:12 +0100 Subject: download: Ask not to use TLS 1.3. Works around . Reported by Marius Bakke . * guix/build/download.scm (tls-wrap): Add "-VERS-TLS1.3" to the priority string when (gnutls-version) is not prefixed by "3.5". --- guix/build/download.scm | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) (limited to 'guix') 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 . (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 . ;; Explicitly disable SSLv3, which is insecure: ;; . - (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 . + (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) -- cgit v1.2.3 From 0f4432c620f8d569ef29ca74bad2b7eebd803441 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Fri, 1 Feb 2019 15:58:12 +0100 Subject: import: opam: Fix conditions. * guix/import/opam.scm (condition-eq, condition-neq): The first argument can be empty. * tests/opam.scm: Add test case. --- guix/import/opam.scm | 4 ++-- tests/opam.scm | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index c254db5f2c..6ffb16b49b 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -90,8 +90,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)) diff --git a/tests/opam.scm b/tests/opam.scm index e0ec5ef3d4..e8c0d15198 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -192,6 +192,8 @@ url { ("{>= \"0.2.0\" | build}" . (condition-or (condition-greater-or-equal (condition-string "0.2.0")) - (condition-var "build")))))) + (condition-var "build"))) + ("{ = \"1.0+beta19\" }" . (condition-eq + (condition-string "1.0+beta19")))))) (test-end "opam") -- cgit v1.2.3 From beee37ecdb246bf503c72e7da11e51d0b7d1a0b0 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Fri, 1 Feb 2019 16:16:25 +0100 Subject: import: opam: Replace "_" with "-" in imported names. * guix/import/opam.scm (ocaml-name->guix-name): Replace "_" with "-". (opam->guix-packages): Add upstream name when we cannot guess it properly. --- guix/import/opam.scm | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 6ffb16b49b..fa8dc86d32 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -127,12 +127,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) @@ -247,6 +252,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 +268,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 +280,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" -- cgit v1.2.3 From c3a191fafd88e1ecd8bf0ab0adc0cb959c038c94 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Fri, 1 Feb 2019 15:35:45 +0100 Subject: import: opam: Work around janestreet version numbers. janestreet reversionned its packages and prefixed them with "v". Let the importer know about that and choose "v" versions first. * guix/import/opam.scm (find-latest-version): Work around version rewrite from janestreet. (opam->guix-package): Do not pass "v" to version number. --- guix/import/opam.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index fa8dc86d32..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 ;;; ;;; This file is part of GNU Guix. @@ -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)))) @@ -239,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) -- cgit v1.2.3 From 8245bb74fc7bdcdc2f9d458057cefc9cd982e489 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Feb 2019 21:58:43 +0100 Subject: monads, gexp: Prevent redefinition of syntax parameters. Fixes . This fixes multi-threaded compilation of this code where syntax parameters could end up being redefined and where a race condition could lead a thread to see the "wrong" value of the syntax parameter. * guix/monads.scm (define-syntax-parameter-once): New macro. (>>=, return): Use it. * guix/gexp.scm (define-syntax-parameter-once): New macro. (current-imported-modules, current-imported-extensions): Use it. --- guix/gexp.scm | 15 +++++++++++++-- guix/monads.scm | 15 +++++++++++++-- 2 files changed, 26 insertions(+), 4 deletions(-) (limited to 'guix') 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))) ""))) -(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: . + (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/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: . + (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))) -- cgit v1.2.3 From 487cbb0164c715e722b622fa800fa0b217fa132c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Feb 2019 14:54:43 +0100 Subject: profiles: Raise an error for unmatched patterns. Previously, "guix package -r something-not-installed" would silently complete. Now an error is raised. * guix/profiles.scm (&unmatched-pattern-error): New condition type. (manifest-matching-entries): Rewrite to raise an error when one of PATTERNS is not matched. * guix/ui.scm (call-with-error-handling): Handle 'unmatched-pattern-error?'. * tests/guix-package.sh: Add test. * tests/profiles.scm ("manifest-matching-entries"): Don't try to remove unmatched pattern. ("manifest-matching-entries, no match"): New test. ("manifest-transaction-effects"): Remove 'remove' field. --- guix/profiles.scm | 34 ++++++++++++++++++++++++---------- guix/ui.scm | 8 ++++++++ tests/guix-package.sh | 7 ++++++- tests/profiles.scm | 17 +++++++++++------ 4 files changed, 49 insertions(+), 17 deletions(-) (limited to 'guix') 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) ; (conflict profile-collision-error-conflict)) ; +(define-condition-type &unmatched-pattern-error &error + unmatched-pattern-error? + (pattern unmatched-pattern-error-pattern) ; + (manifest unmatched-pattern-error-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/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))) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 7eeb4304d1..0d60481895 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # This file is part of GNU Guix. @@ -97,6 +97,11 @@ then false; else true; fi if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile"; then false; else true; fi +# Make sure we get an error when trying to remove something that's not +# installed. +if guix package --bootstrap -r something-not-installed -p "$profile"; +then false; else true; fi + # Check whether `--list-available' returns something sensible. guix package -p "$profile" -A 'gui.*e' | grep guile diff --git a/tests/profiles.scm b/tests/profiles.scm index 9a05030aff..eef93e24cf 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -93,10 +93,7 @@ (test-assert "manifest-matching-entries" (let* ((e (list guile-2.0.9 guile-2.0.9:debug)) (m (manifest e))) - (and (null? (manifest-matching-entries m - (list (manifest-pattern - (name "python"))))) - (equal? e + (and (equal? e (manifest-matching-entries m (list (manifest-pattern (name "guile") @@ -107,6 +104,15 @@ (name "guile") (version "2.0.9")))))))) +(test-assert "manifest-matching-entries, no match" + (let ((m (manifest (list guile-2.0.9))) + (p (manifest-pattern (name "python")))) + (guard (c ((unmatched-pattern-error? c) + (and (eq? p (unmatched-pattern-error-pattern c)) + (eq? m (unmatched-pattern-error-manifest c))))) + (manifest-matching-entries m (list p)) + #f))) + (test-assert "manifest-remove" (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) (m1 (manifest-remove m0 @@ -165,8 +171,7 @@ (test-assert "manifest-transaction-effects" (let* ((m0 (manifest (list guile-1.8.8))) (t (manifest-transaction - (install (list guile-2.0.9 glibc)) - (remove (list (manifest-pattern (name "coreutils"))))))) + (install (list guile-2.0.9 glibc))))) (let-values (((remove install upgrade downgrade) (manifest-transaction-effects m0 t))) (and (null? remove) (null? downgrade) -- cgit v1.2.3 From 024d5275c5cd72c0121b4f70d64c63f859a68f17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Feb 2019 15:42:18 +0100 Subject: status: Do not systematically erase the previous line. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit After a successful download, we'd erase the download-progress line, and the end result would be two empty lines following the "downloading …" line. Reported by Ricardo Wurmus at . * guix/status.scm (print-build-event)[erase-current-line*]: Set to a no-op when PRINT-LOG? is true. Move calls to 'erase-current-line*' to the 'build-succeeded' and 'build-failed' events. --- guix/status.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') 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) -- cgit v1.2.3 From 60cbc6a8df348b7742fc47912a0827a697804d23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Feb 2019 09:12:07 +0100 Subject: git: Support recursive updates of submodules. * guix/git.scm: Autoload (git submodule). (url-cache-directory): Add #:recursive? and honor it. (call-with-repository): New procedure. (with-repository): New macro. (update-submodules): New procedure. (update-cached-checkout): Add #:recursive? and #:log-port and honor them. (latest-repository-commit): Add #:recursive? and honor it. [dot-git?]: Recognize ".git" regular files when RECURSIVE? is true. --- guix/git.scm | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 79 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index 0666f0c0a9..e2daa78f6b 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Mathieu Othacehe -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +43,11 @@ git-checkout-url git-checkout-branch)) +;; XXX: Use this hack instead of #:autoload to avoid compilation errors. +;; See . +(module-autoload! (current-module) + '(git submodule) '(repository-submodules)) + (define %repository-cache-directory (make-parameter (string-append (cache-directory #:ensure? #f) "/checkouts"))) @@ -57,11 +62,15 @@ (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 +128,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 [ | | ]." +data, respectively [ | | ]. + +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 +203,8 @@ data, respectively [ | | ]." ;; 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 +217,7 @@ data, respectively [ | | ]." (define* (latest-repository-commit store url #:key + recursive? (log-port (%make-void-port "w")) (cache-directory (%repository-cache-directory)) @@ -172,21 +228,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 [ | | ]. +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) @@ -244,3 +312,7 @@ Log progress and checkout info to LOG-PORT." `(commit . ,commit) `(branch . ,branch)) #:log-port (current-error-port))))) + +;; Local Variables: +;; eval: (put 'with-repository 'scheme-indent-function 2) +;; End: -- cgit v1.2.3 From 06fff484cec2abc1702e2131d963ed086c5e0b29 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Feb 2019 09:16:27 +0100 Subject: git: Add a 'recursive?' field to records. * guix/git.scm ()[recursive?]: New field. (latest-repository-commit*): Add #:recursive? and honor it. (git-checkout-compiler): Honor the 'recursive?' field of CHECKOUT. --- guix/git.scm | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index e2daa78f6b..51b8aa9ae5 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -273,9 +273,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 @@ -284,7 +285,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 @@ -306,11 +309,12 @@ Log progress and checkout info to LOG-PORT." ;; "Compile" CHECKOUT by updating the local checkout and adding it to the ;; store. (match checkout - (($ url branch commit) + (($ url branch commit recursive?) (latest-repository-commit* url #:ref (if commit `(commit . ,commit) `(branch . ,branch)) + #:recursive? recursive? #:log-port (current-error-port))))) ;; Local Variables: -- cgit v1.2.3 From 024a6bfba906742c136a47b4099f06880f1d3f15 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Feb 2019 09:29:39 +0100 Subject: guix build: '--with-branch' & co. fetch submodules. * guix/scripts/build.scm (transform-package-source-branch)[replace]: Add 'recursive?' field to the new package. --- doc/guix.texi | 3 ++- guix/scripts/build.scm | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 53c133804d..69b6985051 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7289,7 +7289,8 @@ care! Build @var{package} from the latest commit of @var{branch}. The @code{source} field of @var{package} must be an origin with the @code{git-fetch} method (@pxref{origin Reference}) or a @code{git-checkout} object; the repository URL -is taken from that @code{source}. +is taken from that @code{source}. Git sub-modules of the repository are +fetched, recursively. For instance, the following command builds @code{guile-sqlite3} from the latest commit of its @code{master} branch, and then builds @code{guix} (which 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)) -- cgit v1.2.3 From bc041b3e264380bd49025515d3c5d11319aa3f50 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Feb 2019 10:31:23 +0100 Subject: git: Always use the system certificates by default. 'guix pull' was always doing it, and now '--with-branch' & co. will do it as well. * guix/git.scm (honor-system-x509-certificates!): New procedure. (%certificates-initialized?): New variable. (with-libgit2): Add call to 'honor-system-x509-certificates!'. * guix/scripts/pull.scm (honor-x509-certificates): Call 'honor-system-x509-certificates!' and fall back to 'honor-lets-encrypt-certificates!'. --- guix/git.scm | 38 ++++++++++++++++++++++++++++++++++++++ guix/scripts/pull.scm | 26 ++------------------------ 2 files changed, 40 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index 51b8aa9ae5..0e3ce37e26 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -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 @@ -52,12 +54,48 @@ (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 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." -- cgit v1.2.3