Merge branch 'master' into core-updates

1 files changed, 125 insertions, 11 deletions

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: