[bug#74776] [PATCH 0/7] Adding '--no-check-certificate' to 'pull' and 'time-machine'

[bug#74776] [PATCH 0/7] Adding '--no-check-certificate' to 'pull' and 'time-machine'

[Ludovic Courtès]

Hello,

As discussed with Nicolas in <https://issues.guix.gnu.org/74711>, being
able to skip X.509 certificate verification in ‘guix pull’ & co. can
be useful in emergency situations.

This patch series:

  • fixes ‘guix download --git --no-check-certificate’ so that
    ‘--no-check-certificate’ is actually honored;

  • adds ‘--no-check-certificate’ to ‘pull’ and ‘time-machine’.

Thoughts?

Ludo’.

Ludovic Courtès (7):
  git: Remove Guile-Git < 0.4.0 compatibility fallback.
  git: Allow X.509 certificate verification to be disabled.
  guix download: Honor ‘--no-check-certificate’ for ‘--git’.
  channels: Add #:verify-certificate? and honor it.
  pull: Add ‘--no-check-certificate’.
  inferior: Add #:verify-certificate? to ‘cached-channel-instance’.
  time-machine: Add ‘--no-check-certificate’.

 doc/guix.texi                 |  8 ++++
 guix/channels.scm             | 22 ++++++++---
 guix/git.scm                  | 72 ++++++++++++++++++++++++-----------
 guix/inferior.scm             | 24 ++++++++----
 guix/scripts/download.scm     | 34 +++++++++--------
 guix/scripts/pull.scm         | 16 ++++++--
 guix/scripts/time-machine.scm | 14 ++++++-
 7 files changed, 134 insertions(+), 56 deletions(-)


base-commit: dcaccc8b722cee279c00bb321baa48ae73563931
-- 
2.46.0

[bug#74776] [PATCH 1/7] git: Remove Guile-Git < 0.4.0 compatibility fallback.

[Ludovic Courtès]

Guile-Git 0.4.0 was released in October 2020.

* guix/git.scm (make-default-fetch-options): Remove
‘wrong-number-of-args’ fallback.

Change-Id: I5ebcb7212fd96241ea5defc4127e9880a6dd9667
---
 guix/git.scm | 20 +++++++-------------
 1 file changed, 7 insertions(+), 13 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index 410cd4c153..1b0839b1e3 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -185,19 +185,13 @@ (define (show-progress progress)
 (define (make-default-fetch-options)
   "Return the default fetch options."
   (let ((auth-method (%make-auth-ssh-agent)))
-    ;; The #:transfer-progress and #:proxy-url options appeared in Guile-Git
-    ;; 0.4.0.  Omit them when using an older version.
-    (catch 'wrong-number-of-args
-      (lambda ()
-        (make-fetch-options auth-method
-                            ;; Guile-Git doesn't distinguish between these.
-                            #:proxy-url (or (getenv "http_proxy")
-                                            (getenv "https_proxy"))
-                            #:transfer-progress
-                            (and (isatty? (current-error-port))
-                                 show-progress)))
-      (lambda args
-        (make-fetch-options auth-method)))))
+    (make-fetch-options auth-method
+                        ;; Guile-Git doesn't distinguish between these.
+                        #:proxy-url (or (getenv "http_proxy")
+                                        (getenv "https_proxy"))
+                        #:transfer-progress
+                        (and (isatty? (current-error-port))
+                             show-progress))))
 
 (define GITERR_HTTP
   ;; Guile-Git <= 0.5.2 lacks this constant.
-- 
2.46.0

[bug#74776] [PATCH 2/7] git: Allow X.509 certificate verification to be disabled.

[Ludovic Courtès]

* guix/git.scm (make-default-fetch-options): Add #:verify-certificate?
and honor it.  Define ‘warn-for-invalid-certificate’.
(clone*): Add #:verify-certificate? and pass it on.
(clone/swh-fallback): Likewise.
(update-cached-checkout): Likewise.
(latest-repository-commit): Likewise.

Change-Id: Ibf535a4a8d2a7e0c4026a896da9d4ab72e85401a
---
 guix/git.scm | 66 ++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 49 insertions(+), 17 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index 1b0839b1e3..6ac6e4e3a2 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -182,16 +182,29 @@ (define (show-progress progress)
   ;; Return true to indicate that we should go on.
   #t)
 
-(define (make-default-fetch-options)
-  "Return the default fetch options."
-  (let ((auth-method (%make-auth-ssh-agent)))
-    (make-fetch-options auth-method
-                        ;; Guile-Git doesn't distinguish between these.
-                        #:proxy-url (or (getenv "http_proxy")
-                                        (getenv "https_proxy"))
-                        #:transfer-progress
-                        (and (isatty? (current-error-port))
-                             show-progress))))
+(define* (make-default-fetch-options #:key (verify-certificate? #t))
+  "Return the default fetch options.  VERIFY-CERTIFICATE? determines whether
+to verify X.509 host certificates."
+  (define (warn-for-invalid-certificate host valid?)
+    (unless valid?
+      (warning (G_ "ignoring invalid certificate for '~a'~%") host)))
+
+  (let* ((auth-method (%make-auth-ssh-agent))
+         (options
+          (make-fetch-options auth-method
+                              ;; Guile-Git doesn't distinguish between these.
+                              #:proxy-url (or (getenv "http_proxy")
+                                              (getenv "https_proxy"))
+                              #:transfer-progress
+                              (and (isatty? (current-error-port))
+                                   show-progress))))
+    ;; When VERIFY-CERTIFICATE? is true, keep the default libgit2 behavior,
+    ;; which is to raise an exception upon invalid certificates.
+    (unless verify-certificate?
+      (let ((callbacks (fetch-options-remote-callbacks options)))
+        (set-remote-callbacks-certificate-check! callbacks
+                                                 warn-for-invalid-certificate)))
+    options))
 
 (define GITERR_HTTP
   ;; Guile-Git <= 0.5.2 lacks this constant.
@@ -213,7 +226,7 @@ (define (set-git-timeouts connection-timeout read-timeout)
              read-timeout)
     (set-server-timeout! read-timeout)))
 
-(define (clone* url directory)
+(define* (clone* url directory #:key (verify-certificate? #t))
   "Clone git repository at URL into DIRECTORY.  Upon failure,
 make sure no empty directory is left behind."
   (with-throw-handler #t
@@ -222,7 +235,8 @@ (define (clone* url directory)
 
       (clone url directory
              (make-clone-options
-              #:fetch-options (make-default-fetch-options))))
+              #:fetch-options (make-default-fetch-options
+                               #:verify-certificate? verify-certificate?))))
     (lambda _
       (false-if-exception (rmdir directory)))))
 
@@ -445,7 +459,8 @@ (define (clone-from-swh url tag-or-commit output)
             (remote-set-url! repository "origin" url)
             repository)))))
 
-(define (clone/swh-fallback url ref cache-directory)
+(define* (clone/swh-fallback url ref cache-directory
+                             #:key (verify-certificate? #t))
   "Like 'clone', but fallback to Software Heritage if the repository cannot be
 found at URL."
   (define (inaccessible-url-error? err)
@@ -456,7 +471,8 @@ (define (clone/swh-fallback url ref cache-directory)
 
   (catch 'git-error
     (lambda ()
-      (clone* url cache-directory))
+      (clone* url cache-directory
+              #:verify-certificate? verify-certificate?))
     (lambda (key err)
       (match ref
         (((or 'commit 'tag-or-commit) . commit)
@@ -526,6 +542,7 @@ (define* (update-cached-checkout url
                                  (check-out? #t)
                                  starting-commit
                                  (log-port (%make-void-port "w"))
+                                 (verify-certificate? #t)
                                  (cache-directory
                                   (url-cache-directory
                                    url (%repository-cache-directory)
@@ -544,6 +561,9 @@ (define* (update-cached-checkout url
 When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
 it unchanged.
 
+When VERIFY-CERTIFICATE? is true, raise an error when encountering an invalid
+X.509 host certificate; otherwise, warn about the problem and keep going.
+
 Wait for up to CONNECTION-TIMEOUT milliseconds when establishing connection to
 the remote server, and for up to READ-TIMEOUT milliseconds when reading from
 it.  When zero, use the system defaults for these timeouts; when false, leave
@@ -573,15 +593,22 @@ (define* (update-cached-checkout url
    (let* ((cache-exists? (openable-repository? cache-directory))
           (repository    (if cache-exists?
                              (repository-open cache-directory)
-                             (clone/swh-fallback url ref cache-directory))))
+                             (clone/swh-fallback url ref cache-directory
+                                                 #:verify-certificate?
+                                                 verify-certificate?))))
      ;; Only fetch remote if it has not been cloned just before.
      (when (and cache-exists?
                 (not (reference-available? repository ref)))
        (remote-fetch (remote-lookup repository "origin")
-                     #:fetch-options (make-default-fetch-options)))
+                     #:fetch-options (make-default-fetch-options
+                                      #:verify-certificate?
+                                      verify-certificate?)))
      (when recursive?
        (update-submodules repository #:log-port log-port
-                          #:fetch-options (make-default-fetch-options)))
+                          #:fetch-options
+                          (make-default-fetch-options
+                           #:verify-certificate?
+                           verify-certificate?)))
 
      ;; Note: call 'commit-relation' from here because it's more efficient
      ;; than letting users re-open the checkout later on.
@@ -632,6 +659,7 @@ (define* (latest-repository-commit store url
                                    #:key
                                    recursive?
                                    (log-port (%make-void-port "w"))
+                                   (verify-certificate? #t)
                                    (cache-directory
                                     (%repository-cache-directory))
                                    (ref '()))
@@ -644,6 +672,9 @@ (define* (latest-repository-commit store url
 
 When RECURSIVE? is true, check out submodules as well, if any.
 
+When VERIFY-CERTIFICATE? is true, raise an error when encountering an invalid
+X.509 host certificate; otherwise, warn about the problem and keep going.
+
 Git repositories are kept in the cache directory specified by
 %repository-cache-directory parameter.
 
@@ -668,6 +699,7 @@ (define* (latest-repository-commit store url
                                 (url-cache-directory url cache-directory
                                                      #:recursive?
                                                      recursive?)
+                                #:verify-certificate? verify-certificate?
                                 #:log-port log-port))
        ((name)
         (url+commit->name url commit)))
-- 
2.46.0

[bug#74776] [PATCH 3/7] guix download: Honor ‘--no-check-certificate’ for ‘--git’.

[Ludovic Courtès]

Until now ‘--no-check-certificate’ had no effect when combined with
‘--git’.  This can be tested with:

  guix shell libfaketime -- faketime 2019-01-01 \
    guix download --no-check-certificate --git \
    https://git.savannah.gnu.org/git/shepherd.git

* guix/scripts/download.scm (git-download-to-file): Add #:verify-certificate?
and honor it.
(git-download-to-store*): Likewise.
(add-git-download-option): Likewise.
(%options): Likewise.

Change-Id: Ib3905398199d814a02319ed3328eb8a4ed219bd5
---
 guix/scripts/download.scm | 34 +++++++++++++++++++---------------
 1 file changed, 19 insertions(+), 15 deletions(-)

diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index de68e6f328..f373e46941 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2013, 2015-2017, 2020, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -94,7 +94,8 @@ (define (copy-recursively-without-dot-git source destination)
                     #t
                     source))
 
-(define (git-download-to-file url file reference recursive?)
+(define* (git-download-to-file url file reference recursive?
+                               #:key (verify-certificate? #t))
   "Download the git repo at URL to file, checked out at REFERENCE.
 REFERENCE must be a pair argument as understood by 'latest-repository-commit'.
 Return FILE."
@@ -108,7 +109,8 @@ (define (git-download-to-file url file reference recursive?)
                     (else url))))
     (copy-recursively-without-dot-git
      (with-git-error-handling
-      (update-cached-checkout url #:ref reference #:recursive? recursive?))
+      (update-cached-checkout url #:ref reference #:recursive? recursive?
+                              #:verify-certificate? verify-certificate?))
      file))
   file)
 
@@ -151,12 +153,13 @@ (define* (git-download-to-store* url
                                   (string-drop url (string-length "file:")))
                    url)))
     (with-store store
-      ;; TODO: Verify certificate support and deactivation.
       (with-git-error-handling
        (latest-repository-commit store
                                  url
                                  #:recursive? recursive?
-                                 #:ref reference)))))
+                                 #:ref reference
+                                 #:verify-certificate?
+                                 verify-certificate?)))))
 
 (define %default-options
   ;; Alist of default option values.
@@ -207,9 +210,10 @@ (define (show-help)
 
 (define (add-git-download-option result)
   (alist-cons 'download-proc
-              ;; XXX: #:verify-certificate? currently ignored.
               (lambda* (url #:key verify-certificate? ref recursive?)
-                (git-download-to-store* url ref recursive?))
+                (git-download-to-store* url ref recursive?
+                                        #:verify-certificate?
+                                        verify-certificate?))
               (alist-delete 'download result)))
 
 (define %options
@@ -243,20 +247,20 @@ (define %options
                   (alist-cons 'verify-certificate? #f result)))
         (option '(#\o "output") #t #f
                 (lambda (opt name arg result)
-                  (let* ((git
-                          (assoc-ref result 'git-reference)))
+                  (let* ((git (assoc-ref result 'git-reference)))
                     (if git
                         (alist-cons 'download-proc
-                                    (lambda* (url
-                                              #:key
-                                              verify-certificate?
-                                              ref
-                                              recursive?)
+                                    (lambda* (url #:key
+                                                  (verify-certificate? #t)
+                                                  ref
+                                                  recursive?)
                                       (git-download-to-file
                                        url
                                        arg
                                        (assoc-ref result 'git-reference)
-                                       recursive?))
+                                       recursive?
+                                       #:verify-certificate?
+                                       verify-certificate?))
                                     (alist-delete 'download result))
                         (alist-cons 'download-proc
                                     (lambda* (url
-- 
2.46.0

[bug#74776] [PATCH 4/7] channels: Add #:verify-certificate? and honor it.

[Ludovic Courtès]

* guix/channels.scm (latest-channel-instance): Add #:verify-certificate?
and pass it on.
(latest-channel-instances): Likewise.

Change-Id: I43564738dfeefa5b735e6f9e349f9f5596d25164
---
 guix/channels.scm | 22 ++++++++++++++++------
 1 file changed, 16 insertions(+), 6 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index 34f63eb833..4700f7a45d 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -407,12 +407,15 @@ (define* (authenticate-channel channel checkout commit
 (define* (latest-channel-instance store channel
                                   #:key (patches %patches)
                                   starting-commit
-                                  (authenticate? #f)
+                                  (authenticate? #t)
                                   (validate-pull
-                                   ensure-forward-channel-update))
+                                   ensure-forward-channel-update)
+                                  (verify-certificate? #t))
   "Return the latest channel instance for CHANNEL.  When STARTING-COMMIT is
 true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
-their relation.  When AUTHENTICATE? is false, CHANNEL is not authenticated."
+their relation.  When AUTHENTICATE? is false, CHANNEL is not authenticated.
+When VERIFY-CERTIFICATE? is false, invalid X.509 host certificates are
+accepted."
   (define (dot-git? file stat)
     (and (string=? (basename file) ".git")
          (eq? 'directory (stat:type stat))))
@@ -421,7 +424,8 @@ (define* (latest-channel-instance store channel
         (checkout commit relation
                   (update-cached-checkout (channel-url channel)
                                           #:ref (channel-reference channel)
-                                          #:starting-commit starting-commit)))
+                                          #:starting-commit starting-commit
+                                          #:verify-certificate? verify-certificate?)))
     (when relation
       (validate-pull channel starting-commit commit relation))
 
@@ -505,13 +509,17 @@ (define* (latest-channel-instances store channels
                                    (current-channels '())
                                    (authenticate? #t)
                                    (validate-pull
-                                    ensure-forward-channel-update))
+                                    ensure-forward-channel-update)
+                                   (verify-certificate? #t))
   "Return a list of channel instances corresponding to the latest checkouts of
 CHANNELS and the channels on which they depend.
 
 When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a
 \"channel introduction\".
 
+When VERIFY-CERTIFICATE? is false, invalid X.509 host certificates are
+accepted.
+
 CURRENT-CHANNELS is the list of currently used channels.  It is compared
 against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
 for each channel update and can choose to emit warnings or raise an error,
@@ -562,7 +570,9 @@ (define* (latest-channel-instances store channels
                                                 #:validate-pull
                                                 validate-pull
                                                 #:starting-commit
-                                                current)))
+                                                current
+                                                #:verify-certificate?
+                                                verify-certificate?)))
                  (when authenticate?
                    ;; CHANNEL is authenticated so we can trust the
                    ;; primary URL advertised in its metadata and warn
-- 
2.46.0

[bug#74776] [PATCH 5/7] pull: Add ‘--no-check-certificate’.

[Ludovic Courtès]

This can be tested with:

  guix shell libfaketime -- faketime 2019-01-01 \
    guix pull -q --no-check-certificate -p /tmp/p

* guix/scripts/pull.scm (%options, show-help): Add
‘--no-check-certificate’.
(%default-options): Add ‘verify-certificate?’ key.
(guix-pull): Honor it.
* doc/guix.texi (Invoking guix pull): Document it.

Change-Id: Ia9d7af1c64156b112e86027fb637e2e02dae6e3c
---
 doc/guix.texi         |  8 ++++++++
 guix/scripts/pull.scm | 16 +++++++++++++---
 2 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index a2915de954..cad16a0660 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4635,6 +4635,14 @@ Invoking guix pull
 @option{--disable-authentication}.
 @end quotation
 
+@item --no-check-certificate
+Do not validate the X.509 certificates of HTTPS servers.
+
+When using this option, you have @emph{absolutely no guarantee} that you
+are communicating with the authentic server responsible for the given
+URL.  Unless the channel is authenticated, this makes you vulnerable to
+``man-in-the-middle'' attacks.
+
 @item --system=@var{system}
 @itemx -s @var{system}
 Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58d3cd7e83..76aed0b5cc 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2015, 2017-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2015, 2017-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
@@ -77,6 +77,7 @@ (define %default-options
     (debug . 0)
     (verbosity . 1)
     (authenticate-channels? . #t)
+    (verify-certificate? . #t)
     (validate-pull . ,ensure-forward-channel-update)))
 
 (define (show-help)
@@ -98,6 +99,9 @@ (define (show-help)
   (display (G_ "
       --disable-authentication
                          disable channel authentication"))
+  (display (G_ "
+      --no-check-certificate
+                         do not validate the certificate of HTTPS servers"))
   (display (G_ "
   -N, --news             display news compared to the previous generation"))
   (display (G_ "
@@ -183,6 +187,9 @@ (define %options
          (option '("disable-authentication") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'authenticate-channels? #f result)))
+         (option '("no-check-certificate") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'verify-certificate? #f result)))
          (option '(#\p "profile") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'profile (canonicalize-profile arg)
@@ -845,7 +852,8 @@ (define-command (guix-pull . args)
             (profile      (or (assoc-ref opts 'profile) %current-profile))
             (current-channels (profile-channels profile))
             (validate-pull    (assoc-ref opts 'validate-pull))
-            (authenticate?    (assoc-ref opts 'authenticate-channels?)))
+            (authenticate?    (assoc-ref opts 'authenticate-channels?))
+            (verify-certificate? (assoc-ref opts 'verify-certificate?)))
        (cond
         ((assoc-ref opts 'query)
          (process-query opts profile))
@@ -877,7 +885,9 @@ (define-command (guix-pull . args)
                                                    #:validate-pull
                                                    validate-pull
                                                    #:authenticate?
-                                                   authenticate?)))
+                                                   authenticate?
+                                                   #:verify-certificate?
+                                                   verify-certificate?)))
                    (format (current-error-port)
                            (N_ "Building from this channel:~%"
                                "Building from these channels:~%"
-- 
2.46.0

[bug#74776] [PATCH 5/7] pull: Add ‘--no-check-certificate’.

[Maxim Cournoyer]

Hello!

I've read this commit's diff only (received because I'm in the
documentation team I think), and it looks good to me!  Here's my badge
of approval:

Reviewed-by: Maxim Cournoyer <maxim.cournoyer@gmail>

-- 
Thanks,
Maxim

[bug#74776] [PATCH 6/7] inferior: Add #:verify-certificate? to ‘cached-channel-instance’.

[Ludovic Courtès]

* guix/inferior.scm (channel-full-commit): Add #:verify-certificate?
and pass it on.
(cached-channel-instance): Likewise.

Change-Id: I9882660ac9eee2c4d9bb5e227979fd8de10555b1
---
 guix/inferior.scm | 24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index b60bf1ab01..8066cce2fc 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -864,7 +864,7 @@ (define %inferior-cache-directory
   (make-parameter (string-append (cache-directory #:ensure? #f)
                                  "/inferiors")))
 
-(define (channel-full-commit channel)
+(define* (channel-full-commit channel #:key (verify-certificate? #t))
   "Return the commit designated by CHANNEL as quickly as possible.  If
 CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1
 prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
@@ -876,7 +876,8 @@ (define (channel-full-commit channel)
                (cache commit relation
                      (update-cached-checkout (channel-url channel)
                                              #:ref ref
-                                             #:check-out? #f)))
+                                             #:check-out? #f
+                                             #:verify-certificate? verify-certificate?)))
           commit))))
 
 (define* (cached-channel-instance store
@@ -886,7 +887,8 @@ (define* (cached-channel-instance store
                                   (cache-directory (%inferior-cache-directory))
                                   (ttl (* 3600 24 30))
                                   (reference-channels '())
-                                  (validate-channels (const #t)))
+                                  (validate-channels (const #t))
+                                  (verify-certificate? #t))
   "Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
 The directory is a subdirectory of CACHE-DIRECTORY, where entries can be
 reclaimed after TTL seconds.  This procedure opens a new connection to the
@@ -895,12 +897,18 @@ (define* (cached-channel-instance store
 VALIDATE-CHANNELS must be a four-argument procedure used to validate channel
 instances against REFERENCE-CHANNELS; it is passed as #:validate-pull to
 'latest-channel-instances' and should raise an exception in case a target
-channel commit is deemed \"invalid\"."
+channel commit is deemed \"invalid\".
+
+When VERIFY-CERTIFICATE? is true, raise an error when encountering an invalid
+X.509 host certificate; otherwise, warn about the problem and keep going."
   (define commits
     ;; Since computing the instances of CHANNELS is I/O-intensive, use a
     ;; cheaper way to get the commit list of CHANNELS.  This limits overhead
     ;; to the minimum in case of a cache hit.
-    (map channel-full-commit channels))
+    (map (lambda (channel)
+           (channel-full-commit channel
+                                #:verify-certificate? verify-certificate?))
+         channels))
 
   (define key
     (bytevector->base32-string
@@ -951,7 +959,9 @@ (define* (cached-channel-instance store
                                                            #:current-channels
                                                            reference-channels
                                                            #:validate-pull
-                                                           validate-channels))
+                                                           validate-channels
+                                                           #:verify-certificate?
+                                                           verify-certificate?))
                              (profile
                               (channel-instances->derivation instances)))
           (mbegin %store-monad
-- 
2.46.0

[bug#74776] [PATCH 7/7] time-machine: Add ‘--no-check-certificate’.

[Ludovic Courtès]

This can be tested with:

  guix shell libfaketime -- faketime 2019-01-01 \
    guix time-machine -q --no-check-certificate

* guix/scripts/time-machine.scm (%options, show-help): Add
‘--no-check-certificate’.
(%default-options): Add ‘verify-certificate?’ key.
(guix-time-machine): Honor it.

Change-Id: I25a29d03d4df78d1618c6a416ec85fd8e90fec6c
---
 guix/scripts/time-machine.scm | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index 21145239d4..0fd2d15eb5 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -70,6 +70,9 @@ (define (show-help)
   (display (G_ "
       --disable-authentication
                          disable channel authentication"))
+  (display (G_ "
+      --no-check-certificate
+                         do not validate the certificate of HTTPS servers"))
   (newline)
   (show-build-options-help)
   (newline)
@@ -101,6 +104,9 @@ (define %options
          (option '("disable-authentication") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'authenticate-channels? #f result)))
+         (option '("no-check-certificate") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'verify-certificate? #f result)))
          (option '(#\h "help") #f #f
                  (lambda args
                    (leave-on-EPIPE (show-help))
@@ -120,6 +126,7 @@ (define %default-options
     (print-extended-build-trace? . #t)
     (multiplexed-build-output? . #t)
     (authenticate-channels? . #t)
+    (verify-certificate? . #t)
     (graft? . #t)
     (debug . 0)
     (verbosity . 1)))
@@ -180,7 +187,8 @@ (define-command (guix-time-machine . args)
             (command-line (assoc-ref opts 'exec))
             (ref          (assoc-ref opts 'ref))
             (substitutes?  (assoc-ref opts 'substitutes?))
-            (authenticate? (assoc-ref opts 'authenticate-channels?)))
+            (authenticate? (assoc-ref opts 'authenticate-channels?))
+            (verify-certificate? (assoc-ref opts 'verify-certificate?)))
        (let* ((directory
                (with-store store
                  (with-status-verbosity (assoc-ref opts 'verbosity)
@@ -195,7 +203,9 @@ (define-command (guix-time-machine . args)
                                               #:reference-channels
                                               %reference-channels
                                               #:validate-channels
-                                              validate-guix-channel)))))
+                                              validate-guix-channel
+                                              #:verify-certificate?
+                                              verify-certificate?)))))
               (executable (string-append directory "/bin/guix")))
          (if command-line
              (apply execl (cons* executable executable command-line))
-- 
2.46.0