;;; Guix QA Frontpage
;;;
;;; Copyright © 2022 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-qa-frontpage mumi)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (json)
  #:use-module (kolam http)
  #:use-module (kolam parse)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module ((guix-data-service utils) #:select (chunk!))
  #:use-module ((guix-build-coordinator utils fibers)
                #:select (retry-on-error))
  #:export (mumi-search-issues

            mumi-issue-open?

            mumi-bulk-issues))

(define (at-most max-length lst)
  "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
return its MAX-LENGTH first elements and its tail."
  (let loop ((len 0)
             (lst lst)
             (result '()))
    (match lst
      (()
       (values (reverse result) '()))
      ((head . tail)
       (if (>= len max-length)
           (values (reverse result) lst)
           (loop (+ 1 len) tail (cons head result)))))))

(define %max-cached-connections
  ;; Maximum number of connections kept in cache by
  ;; 'open-connection-for-uri/cached'.
  16)

(define open-socket-for-uri/cached
  (let ((cache '()))
    (lambda* (uri #:key fresh? verify-certificate?)
      "Return a connection for URI, possibly reusing a cached connection.
When FRESH? is true, delete any cached connections for URI and open a new one.
Return #f if URI's scheme is 'file' or #f.

When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
      (define host (uri-host uri))
      (define scheme (uri-scheme uri))
      (define key (list host scheme (uri-port uri)))

      (and (not (memq scheme '(file #f)))
           (match (assoc-ref cache key)
             (#f
              ;; Open a new connection to URI and evict old entries from
              ;; CACHE, if any.
              (let ((socket
                     (open-socket-for-uri
                      uri
                      #:verify-certificate? verify-certificate?))
                    (new-cache evicted
                               (at-most (- %max-cached-connections 1) cache)))
                (for-each (match-lambda
                            ((_ . port)
                             (false-if-exception (close-port port))))
                          evicted)
                (set! cache (alist-cons key socket new-cache))
                socket))
             (socket
              (if (or fresh? (port-closed? socket))
                  (begin
                    (false-if-exception (close-port socket))
                    (set! cache (alist-delete key cache))
                    (open-socket-for-uri/cached uri
                                                    #:verify-certificate?
                                                    verify-certificate?))
                  (begin
                    ;; Drain input left from the previous use.
                    (drain-input socket)
                    socket))))))))

(define (call-with-cached-connection uri proc)
  (let ((port (open-socket-for-uri/cached uri)))
    (with-throw-handler #t
      (lambda ()
        (proc port))
      (lambda _
        (close-port port)))))

(define* (graphql-http-get*
          uri document
          #:key (verify-certificate? #t)
          (port (open-socket-for-uri
                 uri
                 #:verify-certificate? verify-certificate?))
          (keep-alive? #f)
          (variables '()))
  (call-with-values
      (lambda ()
        (let ((response
               body
               (http-get
                (string-append uri
                               "?query="
                               (uri-encode (scm->graphql-string document))
                               "&"
                               "variables="
                               (uri-encode (scm->json-string
                                            ((@@ (kolam http) variables->alist)
                                             variables))))
                #:streaming? #t
                #:keep-alive? keep-alive?
                #:verify-certificate? verify-certificate?
                #:port port)))
          (values response
                  body)))
    (@@ (kolam http) graphql-http-response)))

(define (mumi-search-issues query)
  (let ((response
         (graphql-http-get "https://issues.guix.gnu.org/graphql"
                           `(document (query (#(issues #:search ,query) number title date open (blocked_by number)))))))
    (assoc-ref response
               "issues")))

(define (mumi-issue-open? number)
  (let ((response
         (graphql-http-get "https://issues.guix.gnu.org/graphql"
                           `(document (query (#(issue #:number ,number) open))))))
    (assoc-ref (cdr (first response))
               "open")))

(define (mumi-bulk-issues numbers)
  (define url
    "https://issues.guix.gnu.org/graphql")

  (let ((number-to-data
         (make-hash-table)))

    (for-each
     (lambda (chunk)
       (let ((response
              (retry-on-error
               (lambda ()
                 (call-with-cached-connection
                  (string->uri url)
                  (lambda (port)
                    (graphql-http-get*
                     url
                     `(document
                       ,@(map (lambda (number)
                                `(query (#(issue #:number ,number)
                                         number title open severity tags
                                         (merged_with number))))
                              chunk))
                     #:keep-alive? #t
                     #:port port))))
               #:times 1
               #:delay 0)))

         (for-each
          (lambda (res)
            (let ((data (cdr res)))
              (hash-set! number-to-data
                         (assoc-ref data "number")
                         `((title . ,(assoc-ref data "title"))
                           (open? . ,(assoc-ref data "open"))
                           (tags . ,(vector->list
                                     (assoc-ref data "tags")))
                           (merged-with . ,(map
                                            (lambda (data)
                                              (assoc-ref data "number"))
                                            (vector->list
                                             (assoc-ref data "merged_with"))))
                           (severity . ,(assoc-ref data "severity"))))))
          response)))
     (chunk! (list-copy numbers) 30))

    (map (lambda (number)
           (hash-ref number-to-data number))
         numbers)))