140 lines
5.2 KiB
Scheme
140 lines
5.2 KiB
Scheme
;;; Guix Data Service -- Information about Guix over time
|
|
;;; Copyright © 2023, 2024, 2025 Christopher Baines <mail@cbaines.net>
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU Affero General Public License
|
|
;;; as published by the Free Software Foundation, either version 3 of
|
|
;;; the License, or (at your option) any later version.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; Affero General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU Affero General Public
|
|
;;; License along with this program. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix-data-service client)
|
|
#:use-module (srfi srfi-71)
|
|
#:use-module (ice-9 exceptions)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (json)
|
|
#:use-module (knots non-blocking)
|
|
#:use-module (web client)
|
|
#:use-module (web uri)
|
|
#:use-module (web response)
|
|
#:use-module (zlib)
|
|
#:use-module ((guix-data-service utils) #:select (retry-on-error))
|
|
#:export (http-get*
|
|
guix-data-service-request))
|
|
|
|
(define-exception-type &guix-data-service-error &error
|
|
make-guix-data-service-error
|
|
guix-data-service-error?
|
|
(response-body guix-data-service-error-response-body)
|
|
(response-code guix-data-service-error-response-code))
|
|
|
|
|
|
(define* (http-get* uri
|
|
#:key
|
|
(method 'GET)
|
|
(body #f)
|
|
(verify-certificate? #t)
|
|
(port #f)
|
|
(version '(1 . 1))
|
|
(keep-alive? #f)
|
|
(headers '())
|
|
(decode-body? #t)
|
|
;; Default to streaming? #t since read-response-body calls
|
|
;; get-bytevector-all, which is implemented in C and
|
|
;; therefore can't be suspended
|
|
(streaming? #t))
|
|
(let ((port
|
|
(non-blocking-open-socket-for-uri
|
|
uri
|
|
#:verify-certificate? verify-certificate?)))
|
|
(http-request uri
|
|
#:method method
|
|
#:body body
|
|
#:verify-certificate? verify-certificate?
|
|
#:port port
|
|
#:version version
|
|
#:keep-alive? keep-alive?
|
|
#:headers headers
|
|
#:decode-body? decode-body?
|
|
#:streaming? streaming?)))
|
|
|
|
|
|
(define* (guix-data-service-request guix-data-service
|
|
path
|
|
#:optional (query-parameters '())
|
|
#:key (retry-times 3) (retry-delay 60))
|
|
(define uri
|
|
(string->uri (string-append
|
|
guix-data-service
|
|
path
|
|
(if (null? query-parameters)
|
|
""
|
|
(string-append
|
|
"?"
|
|
(string-join
|
|
(map (match-lambda
|
|
((key . value)
|
|
(simple-format #f "~A=~A" key value)))
|
|
query-parameters)
|
|
"&"))))))
|
|
|
|
(define (make-request)
|
|
(let ((response
|
|
body
|
|
(http-get* uri
|
|
#:headers
|
|
'((accept-encoding . ((1 . "gzip"))))
|
|
#:streaming? #t)))
|
|
(cond
|
|
((eq? (response-code response) 404) #f)
|
|
((>= (response-code response) 400)
|
|
(let ((json-body
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
'error-decoding-body)
|
|
(lambda ()
|
|
(match (response-content-encoding response)
|
|
(('gzip)
|
|
(let ((zlib-input
|
|
(make-zlib-input-port body
|
|
#:format 'gzip)))
|
|
(json->scm zlib-input)))
|
|
(_
|
|
(json->scm body))))
|
|
#:unwind? #t)))
|
|
(raise-exception
|
|
(make-guix-data-service-error json-body
|
|
(response-code response)))))
|
|
(else
|
|
(let ((json-body
|
|
(match (response-content-encoding response)
|
|
(('gzip)
|
|
(let ((zlib-input
|
|
(make-zlib-input-port body
|
|
#:format 'gzip)))
|
|
(json->scm zlib-input)))
|
|
(_
|
|
(json->scm body)))))
|
|
(values json-body
|
|
response))))))
|
|
|
|
(if (= 0 retry-times)
|
|
(make-request)
|
|
(retry-on-error
|
|
make-request
|
|
#:times retry-times
|
|
#:delay-seconds retry-delay
|
|
#:no-retry (lambda (exn)
|
|
(and (guix-data-service-error? exn)
|
|
(not
|
|
(= (guix-data-service-error-response-code exn)
|
|
429))
|
|
(< (guix-data-service-error-response-code exn)
|
|
500))))))
|