(define-module (guix-qa-frontpage guix-data-service) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (zlib) #:use-module (json) #: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 guix-data-service-error? guix-data-service-error-response-body guix-data-service-error-response-code guix-data-service-error->sexp guix-data-service-request package-derivations-url compare-package-derivations-url compare-package-cross-derivations-url compare-package-derivations revision-comparison-url revision-comparison list-branches-url list-branches get-latest-processed-branch-revision branch-revisions-url branch-revisions revision-details revision-details-url revision-system-tests-url revision-system-tests package-substitute-availability-url package-substitute-availability package-reproducibility-url)) (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 (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))) (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))) (let ((response body (http-get (string->uri url) #:headers '((accept-encoding . ((1 . "gzip")))) #:streaming? #t #:port port))) (if (eq? (response-code response) 404) #f (let ((json-body (match (response-content-encoding response) (('gzip) ;; Prevent fibers issues with zlib (non-blocking (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))))))) (if (= 0 retry-times) (make-request) (retry-on-error (lambda () (with-fibers-port-timeouts make-request #:timeout 120)) #:times retry-times #:delay retry-delay #:ignore (lambda (exn) (and (guix-data-service-error? exn) (< (guix-data-service-error-response-code exn) 500)))))) (define* (package-derivations-url commit #:key system target no-build-from-build-server) (string-append "https://data.qa.guix.gnu.org/revision/" commit "/package-derivations.json?" "system=" system "&target=" target "&field=" "(no-additional-fields)" "&all_results=" "on" (if no-build-from-build-server (string-append "&no_build_from_build_server=" no-build-from-build-server) ""))) (define* (compare-package-derivations-url base-and-target-refs #:key systems) (string-append "https://data.qa.guix.gnu.org/compare/package-derivations.json?" "base_commit=" (assq-ref base-and-target-refs 'base) "&target_commit=" (assq-ref base-and-target-refs 'target) (string-join (map (lambda (system) (simple-format #f "&system=~A" system)) (or systems '())) "") "&target=none" "&field=builds&limit_results=&all_results=on")) (define* (compare-package-cross-derivations-url base-and-target-refs #:key systems) (string-append "https://data.qa.guix.gnu.org/compare/package-derivations.json?" "base_commit=" (assq-ref base-and-target-refs 'base) "&target_commit=" (assq-ref base-and-target-refs 'target) (string-join (map (lambda (system) (simple-format #f "&system=~A" system)) (or systems '())) "") "&field=builds&limit_results=&all_results=on")) (define (compare-package-derivations url) (let ((json-body (guix-data-service-request url))) (if json-body json-body #f))) (define* (revision-comparison-url base-and-target-refs #:key (json? #t)) (string-append "https://data.qa.guix.gnu.org/compare" (if json? ".json" "") "?" "base_commit=" (assq-ref base-and-target-refs 'base) "&target_commit=" (assq-ref base-and-target-refs 'target))) (define (revision-comparison url) (guix-data-service-request url)) (define (list-branches-url repository-id) (simple-format #f "https://data.qa.guix.gnu.org/repository/~A.json" repository-id)) (define (list-branches url) (let ((json-body (guix-data-service-request url))) (vector->list (assoc-ref json-body "branches")))) (define (get-latest-processed-branch-revision branch) (let ((json-body (guix-data-service-request (string-append "https://data.qa.guix.gnu.org" "/repository/2" "/branch/" branch "/latest-processed-revision.json")))) (assoc-ref (assoc-ref json-body "revision") "commit"))) (define (branch-revisions-url repository-id branch-name) (simple-format #f "https://data.qa.guix.gnu.org/repository/~A/branch/~A.json" repository-id branch-name)) (define (branch-revisions url) (let ((json-body (guix-data-service-request url))) (vector->list (assoc-ref json-body "revisions")))) (define* (revision-details-url commit) (simple-format #f "https://data.qa.guix.gnu.org/revision/~A.json" commit)) (define (revision-details url) (guix-data-service-request url)) (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" commit system)) (define (revision-system-tests url) (let ((json-body (guix-data-service-request url))) (vector->list (assoc-ref json-body "system_tests")))) (define* (package-substitute-availability-url commit) (simple-format #f "https://data.qa.guix.gnu.org/revision/~A/package-substitute-availability.json" commit)) (define (package-substitute-availability url) (let ((json-body (guix-data-service-request url))) (if json-body (assoc-ref json-body "substitute_servers") #f))) (define* (package-reproducibility-url commit) (simple-format #f "https://data.qa.guix.gnu.org/revision/~A/package-reproducibility.json" commit))