diff options
Diffstat (limited to 'guix/swh.scm')
| -rw-r--r-- | guix/swh.scm | 34 |
1 files changed, 25 insertions, 9 deletions
diff --git a/guix/swh.scm b/guix/swh.scm index 913f0d1c9d..a343ccfdd7 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 |