diff options
Diffstat (limited to 'guix-qa-frontpage/guix-data-service.scm')
| -rw-r--r-- | guix-qa-frontpage/guix-data-service.scm | 286 |
1 files changed, 180 insertions, 106 deletions
diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm index 9bf7997..8540524 100644 --- a/guix-qa-frontpage/guix-data-service.scm +++ b/guix-qa-frontpage/guix-data-service.scm @@ -4,22 +4,33 @@ #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) + #:use-module (ice-9 binary-ports) #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (zlib) #:use-module (json) + #:use-module (fibers) + #:use-module (knots timeout) + #:use-module (knots non-blocking) #:use-module ((guix-build-coordinator utils fibers) #:select (retry-on-error)) #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage patchwork) #:use-module (guix-qa-frontpage manage-patch-branches) - #:export (&guix-data-service-error + #:export (%data-service-url-base + %data-service-guix-repository-id + + &guix-data-service-error guix-data-service-error? guix-data-service-error-response-body guix-data-service-error-response-code + guix-data-service-error-url guix-data-service-error->sexp + guix-data-service-error-summary + guix-data-service-error-sexp->error + guix-data-service-error-invalid-query? guix-data-service-request @@ -51,84 +62,122 @@ package-reproducibility-url)) +(define %data-service-url-base + "https://data.qa.guix.gnu.org") + +(define %data-service-guix-repository-id 1) + (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)) + (response-code guix-data-service-error-response-code) + (url guix-data-service-error-url)) (define (guix-data-service-error->sexp exn) - `((exception . guix-data-service-invalid-parameters) - (invalid_query_parameters - . - ,(filter-map - (match-lambda - ((param . val) - (and=> - (assoc-ref val "invalid_value") - (lambda (value) - (let ((message - (assoc-ref val "message"))) - (cons - param - `((value . ,value) - (error - ;; Convert the HTML error messages - ;; to something easier to handle - . ,(cond - ((string-contains message - "failed to process revision") - 'failed-to-process-revision) - ((string-contains message - "yet to process revision") - 'yet-to-process-revision) - ((string=? message "unknown commit") - 'unknown-commit) - (else - 'unknown-error)))))))))) - (assoc-ref - (guix-data-service-error-response-body exn) - "query_parameters"))))) - -;; Returns the port as well as the raw socket -(define* (open-socket-for-uri* uri - #:key (verify-certificate? #t)) - (define tls-wrap - (@@ (web client) tls-wrap)) - - (define https? - (eq? 'https (uri-scheme uri))) - - (define plain-uri - (if https? - (build-uri - 'http - #:userinfo (uri-userinfo uri) - #:host (uri-host uri) - #:port (or (uri-port uri) 443) - #:path (uri-path uri) - #:query (uri-query uri) - #:fragment (uri-fragment uri)) - uri)) - - (let ((s (open-socket-for-uri plain-uri))) - (values - (if https? - (tls-wrap s (uri-host uri) - #:verify-certificate? verify-certificate?) - s) - s))) + (cond + ((string=? (or (assoc-ref (guix-data-service-error-response-body exn) + "error") + "") + "invalid query") + `((exception . guix-data-service-invalid-parameters) + (invalid_query_parameters + . + ,(filter-map + (match-lambda + ((param . val) + (and=> + (assoc-ref val "invalid_value") + (lambda (value) + (let ((message + (assoc-ref val "message"))) + (cons + param + `((value . ,value) + (error + ;; Convert the HTML error messages + ;; to something easier to handle + . ,(cond + ((string-contains message + "failed to process revision") + 'failed-to-process-revision) + ((string-contains message + "yet to process revision") + 'yet-to-process-revision) + ((string=? message "unknown commit") + 'unknown-commit) + (else + 'unknown-error)))))))))) + (assoc-ref + (guix-data-service-error-response-body exn) + "query_parameters"))))) + (else + `((exception . guix-data-service-exception) + (body . ,(guix-data-service-error-response-body exn)) + (url . ,(guix-data-service-error-url exn)))))) + +(define (guix-data-service-error-summary exn) + (cond + ((string=? (or (assoc-ref (guix-data-service-error-response-body exn) + "error") + "") + "invalid query") + (string-join + (filter-map + (match-lambda + ((param . val) + (and=> + (assoc-ref val "invalid_value") + (lambda (value) + (let ((message + (assoc-ref val "message"))) + (simple-format + #f + "~A: ~A" + param + ;; Convert the HTML error messages + ;; to something easier to handle + (cond + ((string-contains message + "failed to process revision") + 'failed-to-process-revision) + ((string-contains message + "yet to process revision") + 'yet-to-process-revision) + ((string=? message "unknown commit") + 'unknown-commit) + (else + 'unknown-error)))))))) + (assoc-ref + (guix-data-service-error-response-body exn) + "query_parameters")) + ", ")) + (else + (simple-format #f "~A" (guix-data-service-error-response-body exn))))) + +(define (guix-data-service-error-sexp->error sexp) + (make-guix-data-service-error + (if (eq? (assq-ref sexp 'exception) + 'guix-data-service-invalid-parameters) + `(("error" . "invalid-query") + ,@sexp) + sexp) + #f + #f)) + +(define (guix-data-service-error-invalid-query? exn) + (and + (guix-data-service-error? exn) + (string=? + (or (assoc-ref (guix-data-service-error-response-body exn) + "error") + "") + "invalid-query"))) (define* (guix-data-service-request url #:key (retry-times 0) (retry-delay 5)) (define (make-request) (let ((port - socket - (open-socket-for-uri* (string->uri url)))) - - ;; This can't be done earlier as tls-wrap/guile-gnutls doesn't support - ;; handshake on a non blocking socket - (let ((flags (fcntl socket F_GETFL))) - (fcntl socket F_SETFL (logior O_NONBLOCK flags))) + (non-blocking-open-socket-for-uri (string->uri url)))) (let ((response body @@ -137,35 +186,49 @@ '((accept-encoding . ((1 . "gzip")))) #:streaming? #t #:port port))) - (if (eq? (response-code response) - 404) - #f - (let ((json-body - (match (response-content-encoding response) - (('gzip) - ;; Stop fibers from triggering dynamic-wind in (zlib) - (call-with-blocked-asyncs - (lambda () - (call-with-zlib-input-port - body - json->scm - #:format 'gzip)))) - (_ - (json->scm body))))) - (if (or (> (response-code response) - 400) - (assoc-ref json-body "error")) - (raise-exception - (make-guix-data-service-error json-body - (response-code response))) - (values json-body - response))))))) + (cond + ((eq? (response-code response) 404) + #f) + ((not (eq? (first (response-content-type response)) + 'application/json)) + (raise-exception + (make-guix-data-service-error + (utf8->string + (match (response-content-encoding response) + (('gzip) + (call-with-zlib-input-port* + body + get-bytevector-all + #:format 'gzip)) + (_ + (get-bytevector-all body)))) + (response-code response) + url))) + (else + (let ((json-body + (match (response-content-encoding response) + (('gzip) + (call-with-zlib-input-port* + body + json->scm + #:format 'gzip)) + (_ + (json->scm body))))) + (if (or (> (response-code response) + 400) + (assoc-ref json-body "error")) + (raise-exception + (make-guix-data-service-error json-body + (response-code response) + url)) + (values json-body + response)))))))) (if (= 0 retry-times) (make-request) (retry-on-error (lambda () - (with-fibers-port-timeouts + (with-port-timeouts make-request #:timeout 120)) #:times retry-times @@ -179,12 +242,13 @@ #:key system target no-build-from-build-server) (string-append - "https://data.qa.guix.gnu.org/revision/" + %data-service-url-base + "/revision/" commit "/package-derivations.json?" "system=" system "&target=" target - "&field=" "(no-additional-fields)" + "&field=" "no-additional-fields" "&all_results=" "on" (if no-build-from-build-server (string-append @@ -193,7 +257,8 @@ (define* (compare-package-derivations-url base-and-target-refs #:key systems) (string-append - "https://data.qa.guix.gnu.org/compare/package-derivations.json?" + %data-service-url-base + "/compare/package-derivations.json?" "base_commit=" (assq-ref base-and-target-refs 'base) "&target_commit=" (assq-ref base-and-target-refs 'target) (string-join @@ -206,7 +271,8 @@ (define* (compare-package-cross-derivations-url base-and-target-refs #:key systems) (string-append - "https://data.qa.guix.gnu.org/compare/package-derivations.json?" + %data-service-url-base + "/compare/package-derivations.json?" "base_commit=" (assq-ref base-and-target-refs 'base) "&target_commit=" (assq-ref base-and-target-refs 'target) (string-join @@ -225,7 +291,8 @@ (define* (revision-comparison-url base-and-target-refs #:key (json? #t)) (string-append - "https://data.qa.guix.gnu.org/compare" + %data-service-url-base + "/compare" (if json? ".json" "") "?" "base_commit=" (assq-ref base-and-target-refs 'base) @@ -235,7 +302,8 @@ (guix-data-service-request url)) (define (list-branches-url repository-id) - (simple-format #f "https://data.qa.guix.gnu.org/repository/~A.json" + (simple-format #f "~A/repository/~A.json" + %data-service-url-base repository-id)) (define (list-branches url) @@ -248,8 +316,9 @@ (let ((json-body (guix-data-service-request (string-append - "https://data.qa.guix.gnu.org" - "/repository/2" + %data-service-url-base + "/repository/" + (number->string %data-service-guix-repository-id) "/branch/" branch "/latest-processed-revision.json")))) (assoc-ref @@ -259,7 +328,8 @@ (define (branch-revisions-url repository-id branch-name) (simple-format #f - "https://data.qa.guix.gnu.org/repository/~A/branch/~A.json" + "~A/repository/~A/branch/~A.json" + %data-service-url-base repository-id branch-name)) @@ -272,7 +342,8 @@ (define* (revision-details-url commit) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A.json" + "~A/revision/~A.json" + %data-service-url-base commit)) (define (revision-details url) @@ -281,7 +352,8 @@ (define* (revision-system-tests-url commit #:key (system "x86_64-linux")) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A/system-tests.json?system=~A" + "~A/revision/~A/system-tests.json?system=~A" + %data-service-url-base commit system)) @@ -294,7 +366,8 @@ (define* (package-substitute-availability-url commit) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A/package-substitute-availability.json" + "~A/revision/~A/package-substitute-availability.json" + %data-service-url-base commit)) (define (package-substitute-availability url) @@ -307,5 +380,6 @@ (define* (package-reproducibility-url commit) (simple-format #f - "https://data.qa.guix.gnu.org/revision/~A/package-reproducibility.json" + "~A/revision/~A/package-reproducibility.json" + %data-service-url-base commit)) |