02/05: swh: Allow callers to disable X.509 certificate verification.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 722ad41c44a499d2250c79527ef7d069ca728de0
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jul 9 17:19:52 2020 +0200

    swh: Allow callers to disable X.509 certificate verification.
    
    * guix/swh.scm (%verify-swh-certificate?): New parameter.
    (http-get*, http-post*): New procedures.
    (request-rate-limit-reached?): Use 'http-post*' instead of 'http-post'.
    (update-rate-limit-reset-time!): Likewise.
    (request-cooking): Likewise.
    (call): Method defaults to 'http-get*' instead of 'http-get'.  Pass
     #:verify-certificate? to METHOD.
    (vault-fetch): Likewise.
---
 guix/swh.scm | 34 +++++++++++++++++++++++++---------
 1 file changed, 25 insertions(+), 9 deletions(-)

diff --git a/guix/swh.scm b/guix/swh.scm
index 913f0d1..a343ccf 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -35,6 +35,7 @@
   #:use-module (ice-9 popen)
   #:use-module ((ice-9 ftw) #:select (scandir))
   #:export (%swh-base-url
+            %verify-swh-certificate?
             %allow-request?
 
             request-rate-limit-reached?
@@ -126,6 +127,10 @@
   ;; Presumably we won't need to change it.
   (make-parameter "https://archive.softwareheritage.org";))
 
+(define %verify-swh-certificate?
+  ;; Whether to verify the X.509 HTTPS certificate for %SWH-BASE-URL.
+  (make-parameter #t))
+
 (define (swh-url path . rest)
   ;; URLs returned by the API may be relative or absolute. This has changed
   ;; without notice before. Handle both cases by detecting whether the path
@@ -143,6 +148,13 @@
       url
       (string-append url "/")))
 
+;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would
+;; be ignored (<https://bugs.gnu.org/40486>).
+(define* (http-get* uri #:rest rest)
+  (apply http-request uri #:method 'GET rest))
+(define* (http-post* uri #:rest rest)
+  (apply http-request uri #:method 'POST rest))
+
 (define %date-regexp
   ;; Match strings like "2014-11-17T22:09:38+01:00" or
   ;; "2018-09-30T23:20:07.815449+00:00"".
@@ -179,7 +191,7 @@ Software Heritage."
 
 (define %allow-request?
   ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true
-  ;; to keep going.  This can be used to disallow a requests when
+  ;; to keep going.  This can be used to disallow requests when
   ;; 'request-rate-limit-reached?' returns true, for instance.
   (make-parameter (const #t)))
 
@@ -195,7 +207,7 @@ Software Heritage."
     (string->uri url))
 
   (define reset-time
-    (if (and (eq? method http-post)
+    (if (and (eq? method http-post*)
              (string-prefix? "/api/1/origin/save/" (uri-path uri)))
         %save-rate-limit-reset-time
         %general-rate-limit-reset-time))
@@ -208,21 +220,23 @@ RESPONSE."
   (let ((uri (string->uri url)))
     (match (assq-ref (response-headers response) 'x-ratelimit-reset)
       ((= string->number (? number? reset))
-       (if (and (eq? method http-post)
+       (if (and (eq? method http-post*)
                 (string-prefix? "/api/1/origin/save/" (uri-path uri)))
            (set! %save-rate-limit-reset-time reset)
            (set! %general-rate-limit-reset-time reset)))
       (_
        #f))))
 
-(define* (call url decode #:optional (method http-get)
+(define* (call url decode #:optional (method http-get*)
                #:key (false-if-404? #t))
   "Invoke the endpoint at URL using METHOD.  Decode the resulting JSON body
 using DECODE, a one-argument procedure that takes an input port.  When
 FALSE-IF-404? is true, return #f upon 404 responses."
   (and ((%allow-request?) url method)
        (let*-values (((response port)
-                      (method url #:streaming? #t)))
+                      (method url #:streaming? #t
+                              #:verify-certificate?
+                              (%verify-swh-certificate?))))
          ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
          (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
            (#f #t)
@@ -467,7 +481,7 @@ directory entries; if it has type 'file, return its 
<content> object."
 (define* (save-origin url #:optional (type "git"))
   "Request URL to be saved."
   (call (swh-url "/api/1/origin/save" type "url" url) json->save-reply
-        http-post))
+        http-post*))
 
 (define-query (save-origin-status url type)
   "Return the status of a /save request for URL and TYPE (e.g., \"git\")."
@@ -489,7 +503,7 @@ directory entries; if it has type 'file, return its 
<content> object."
 to the vault.  Return a <vault-reply>."
   (call (swh-url "/api/1/vault" (symbol->string kind) id)
         json->vault-reply
-        http-post))
+        http-post*))
 
 (define* (vault-fetch id kind
                       #:key (log-port (current-error-port)))
@@ -508,8 +522,10 @@ revision, it is a gzip-compressed stream for 'git 
fast-import'."
          ('done
           ;; Fetch the bundle.
           (let-values (((response port)
-                        (http-get (swh-url (vault-reply-fetch-url reply))
-                                  #:streaming? #t)))
+                        (http-get* (swh-url (vault-reply-fetch-url reply))
+                                   #:streaming? #t
+                                   #:verify-certificate?
+                                   (%verify-swh-certificate?))))
             (if (= (response-code response) 200)
                 port
                 (begin                            ;shouldn't happen