(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 (json)
  #:use-module (guix-build-coordinator 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

            patch-series-derivation-changes-url
            patch-series-derivation-changes

            patch-series-compare-url
            patch-series-comparison

            list-branches-url
            list-branches

            branch-derivation-changes-url
            branch-derivation-changes

            get-latest-processed-branch-revision

            branch-revisions-url
            branch-revisions

            revision-details
            revision-details-url

            revision-system-tests-url
            revision-system-tests))

(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* (patch-series-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 (patch-series-derivation-changes url)
  (let-values (((response body)
                (http-get (string->uri url))))
    (if (eq? (response-code response)
             404)
        (values #f #f)
        (let ((json-body
               (with-exception-handler
                   (lambda _ #f)
                 (lambda ()
                   (json-string->scm (utf8->string body)))
                 #:unwind? #t)))
          (if (or (> (response-code response)
                     400)
                  (assoc-ref json-body "error"))
              (raise-exception
               (make-guix-data-service-error json-body
                                             (response-code response)))
              (values (vector->list
                       (assoc-ref json-body
                                  "derivation_changes"))
                      (alist-delete "derivation_changes"
                                    json-body)))))))

(define* (patch-series-compare-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 (patch-series-comparison url)
  (retry-on-error
   (lambda ()
     (let-values (((response body)
                   (http-get (string->uri url))))
       (if (eq? (response-code response)
                404)
           #f
           (let ((json-body
                  (json-string->scm (utf8->string body))))
             (if (assoc-ref json-body "error")
                 (raise-exception
                  (make-guix-data-service-error json-body
                                                (response-code response)))
                 json-body)))))
   #:times 6
   #:delay 5
   #:ignore guix-data-service-error?))

(define (list-branches-url repository-id)
  (simple-format #f "https://data.qa.guix.gnu.org/repository/~A.json"
                 repository-id))

(define (list-branches url)
  (retry-on-error
   (lambda ()
     (let-values (((response body)
                   (http-get (string->uri url))))
       (if (eq? (response-code response)
                404)
           #f
           (let ((json-body
                  (json-string->scm (utf8->string body))))
             (if (assoc-ref json-body "error")
                 (raise-exception
                  (make-guix-data-service-error json-body
                                                (response-code response)))
                 (vector->list
                  (assoc-ref json-body "branches")))))))
   #:times 6
   #:delay 5))

(define* (branch-derivation-changes-url branch #:key systems)
  (string-append
   "https://data.qa.guix.gnu.org/compare-by-datetime/package-derivations.json?"
   "base_branch=master"
   "&target_branch=" branch
   (string-join
    (map (lambda (system)
           (simple-format #f "&system=~A" system))
         (or systems '()))
    "")
   "&target=none"
   "&field=builds&limit_results=&all_results=on"))

(define (branch-derivation-changes url)
  (retry-on-error
   (lambda ()
     (let-values (((response body)
                   (http-get (string->uri url))))
       (if (eq? (response-code response)
                404)
           (values #f #f)
        (let ((json-body
               (with-exception-handler
                   (lambda _ #f)
                 (lambda ()
                   (json-string->scm (utf8->string body)))
                 #:unwind? #t)))
          (if (or (> (response-code response)
                     400)
                  (assoc-ref json-body "error"))
              (raise-exception
               (make-guix-data-service-error json-body
                                             (response-code response)))
              (values (vector->list
                       (assoc-ref json-body
                                  "derivation_changes"))
                      (alist-delete "derivation_changes"
                                    json-body)))))))
   #:times 1
   #:delay 5))

(define (get-latest-processed-branch-revision branch)
  (retry-on-error
   (lambda ()
     (let-values (((response body)
                   (http-get (string->uri
                              (string-append
                               "https://data.qa.guix.gnu.org"
                               "/repository/2"
                               "/branch/" branch
                               "/latest-processed-revision.json")))))
       (let ((json-body
              (json-string->scm (utf8->string body))))
         (assoc-ref
          (assoc-ref json-body "revision")
          "commit"))))
   #:times 5
   #:delay 5))

(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)
  (retry-on-error
   (lambda ()
     (let-values (((response body)
                   (http-get (string->uri url))))
       (if (eq? (response-code response)
                404)
           #f
           (let ((json-body
                  (json-string->scm (utf8->string body))))
             (if (assoc-ref json-body "error")
                 (raise-exception
                  (make-guix-data-service-error json-body
                                                (response-code response)))
                 (vector->list
                  (assoc-ref json-body "revisions")))))))
   #:times 6
   #:delay 5))

(define* (revision-details-url commit)
  (simple-format
   #f
   "https://data.qa.guix.gnu.org/revision/~A.json"
   commit))

(define (revision-details url)
  (let-values (((response body)
                (http-get (string->uri url))))
    (let ((json-body
           (json-string->scm (utf8->string body))))
      (if (or (> (response-code response)
                 400)
              (assoc-ref json-body "error"))
          (raise-exception
           (make-guix-data-service-error json-body
                                         (response-code response)))
          json-body))))

(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)
  (retry-on-error
   (lambda ()
     (let-values (((response body)
                   (http-get (string->uri url))))
       (if (eq? (response-code response)
                404)
           #f
           (let ((json-body
                  (json-string->scm (utf8->string body))))
             (if (assoc-ref json-body "error")
                 (raise-exception
                  (make-guix-data-service-error json-body))
                 (vector->list
                  (assoc-ref json-body "system_tests")))))))
   #:times 6
   #:delay 5))