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/git.scm') 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/git.scm') 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 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/git.scm') 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