04/04: git: Always use the system certificates by default.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit bc041b3e264380bd49025515d3c5d11319aa3f50
Author: Ludovic Courtès <address@hidden>
Date:   Fri Feb 8 10:31:23 2019 +0100

    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(-)

diff --git a/guix/git.scm b/guix/git.scm
index 51b8aa9..0e3ce37 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 683ab3f..3320200 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."