mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-02-12 06:41:27 +01:00
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!'.
This commit is contained in:
parent
024a6bfba9
commit
bc041b3e26
2 changed files with 40 additions and 24 deletions
38
guix/git.scm
38
guix/git.scm
|
@ -35,6 +35,8 @@
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
#:export (%repository-cache-directory
|
#:export (%repository-cache-directory
|
||||||
|
honor-system-x509-certificates!
|
||||||
|
|
||||||
update-cached-checkout
|
update-cached-checkout
|
||||||
latest-repository-commit
|
latest-repository-commit
|
||||||
|
|
||||||
|
@ -52,12 +54,48 @@
|
||||||
(make-parameter (string-append (cache-directory #:ensure? #f)
|
(make-parameter (string-append (cache-directory #:ensure? #f)
|
||||||
"/checkouts")))
|
"/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 ...)
|
(define-syntax-rule (with-libgit2 thunk ...)
|
||||||
(begin
|
(begin
|
||||||
;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
|
;; 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,
|
;; but pointer finalizers used in guile-git may be called after shutdown,
|
||||||
;; resulting in a segfault. Hence, let's skip shutdown call for now.
|
;; resulting in a segfault. Hence, let's skip shutdown call for now.
|
||||||
(libgit2-init!)
|
(libgit2-init!)
|
||||||
|
(unless %certificates-initialized?
|
||||||
|
(honor-system-x509-certificates!)
|
||||||
|
(set! %certificates-initialized? #t))
|
||||||
thunk ...))
|
thunk ...))
|
||||||
|
|
||||||
(define* (url-cache-directory url
|
(define* (url-cache-directory url
|
||||||
|
|
|
@ -216,30 +216,8 @@ true, display what would be built without actually building it."
|
||||||
|
|
||||||
(define (honor-x509-certificates store)
|
(define (honor-x509-certificates store)
|
||||||
"Use the right X.509 certificates for Git checkouts over HTTPS."
|
"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
|
(unless (honor-system-x509-certificates!)
|
||||||
;; files (instead of all the certificates) among which "ca-bundle.crt". On
|
(honor-lets-encrypt-certificates! store)))
|
||||||
;; 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))))
|
|
||||||
|
|
||||||
(define (report-git-error error)
|
(define (report-git-error error)
|
||||||
"Report the given Guile-Git error."
|
"Report the given Guile-Git error."
|
||||||
|
|
Loading…
Add table
Reference in a new issue