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

            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 %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)
  (url           guix-data-service-error-url))

(define (guix-data-service-error->sexp exn)
  (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
           (non-blocking-open-socket-for-uri (string->uri url))))

      (let ((response
             body
             (http-get (string->uri url)
                       #:headers
                       '((accept-encoding . ((1 . "gzip"))))
                       #:streaming? #t
                       #:port port)))
        (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-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
   %data-service-url-base
   "/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
   %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
    (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
   %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
    (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
   %data-service-url-base
   "/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 "~A/repository/~A.json"
                 %data-service-url-base
                 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
           %data-service-url-base
           "/repository/"
           (number->string %data-service-guix-repository-id)
           "/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
   "~A/repository/~A/branch/~A.json"
   %data-service-url-base
   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
   "~A/revision/~A.json"
   %data-service-url-base
   commit))

(define (revision-details url)
  (guix-data-service-request url))

(define* (revision-system-tests-url commit #:key (system "x86_64-linux"))
  (simple-format
   #f
   "~A/revision/~A/system-tests.json?system=~A"
   %data-service-url-base
   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
   "~A/revision/~A/package-substitute-availability.json"
   %data-service-url-base
   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
   "~A/revision/~A/package-reproducibility.json"
   %data-service-url-base
   commit))