path: root/guix-qa-frontpage/guix-data-service.scm

(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)
                      ;; 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)))))))

  (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))