futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

git: Always use the system certificates by default.

Browse Source 
'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:
Ludovic Courtès 2019-02-08 10:31:23 +01:00 committed by Ludovic Courtès
parent 024a6bfba9
commit bc041b3e26
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 40 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
guix/git.scm
View File

@ -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

26
guix/scripts/pull.scm
View File

@ -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."