(define-module (guix-qa-frontpage guix-data-service)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #: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) #:select (retry-on-error))
  #: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

            revision-derivation-changes-url
            revision-derivation-changes

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

(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-request url #:key (retry-times 1) (retry-delay 5))
  (retry-on-error
   (lambda ()
     (let-values (((response body)
                   (http-get (string->uri url)
                             #:headers
                             '((accept-encoding . ((1 . "gzip"))))
                             #:streaming? #t)))
       (if (eq? (response-code response)
                404)
           #f
           (let ((json-body
                  (with-exception-handler
                      (lambda _ #f)
                    (lambda ()
                      (match (response-content-encoding response)
                        (('gzip)
                         (call-with-zlib-input-port
                          body
                          json->scm
                          #:format 'gzip))
                        (_
                         (json->scm body))))
                    #:unwind? #t)))
             (if (or (> (response-code response)
                        400)
                     (not json-body)
                     (assoc-ref json-body "error"))
                 (raise-exception
                  (make-guix-data-service-error json-body
                                                (response-code response)))
                 (values json-body
                         response))))))
   #:times retry-times
   #:delay retry-delay
   #:ignore (lambda (exn)
              (and (guix-data-service-error? exn)
                   (< (guix-data-service-error-response-code exn)
                      500)))))

(define* (revision-derivation-changes-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 (revision-derivation-changes url)
  (let ((json-body
         (guix-data-service-request url)))
    (if json-body
        (values (vector->list
                 (assoc-ref json-body
                            "derivation_changes"))
                (alist-delete "derivation_changes"
                              json-body))
        (values #f #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)))