(define-module (guix-qa-frontpage patchwork)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 regex)
  #:use-module (rnrs bytevectors)
  #:use-module (json)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-qa-frontpage mumi)
  #:export (%patchwork-instance

            patchwork-patches
            latest-patchwork-series-by-issue))

(define %patchwork-instance
  (make-parameter "https://patches.guix-patches.cbaines.net"))

(define %link-regex
  (make-regexp "<(.*?)>;?(.*)"))
(define %link-param-regex
  (make-regexp "\\s*(.*)=(.*)"))

(define (parse-link link)
  (define (strip-quotes s)
    (if (and (string-suffix? "\"" s)
             (string-prefix? "\"" s))
        (string-drop-right
         (string-drop s 1)
         1)
        s))

  (let ((link-match (regexp-exec %link-regex link)))
    `((uri    . ,(string->uri (match:substring link-match 1)))
      ,@(map
         (lambda (param)
           (let ((param-match
                  (regexp-exec %link-param-regex param)))
             (cons (string->symbol
                    (match:substring param-match 1))
                   (strip-quotes
                    (match:substring param-match 2)))))
         (string-split (match:substring link-match 2)
                       #\;)))))

(define* (patchwork-patches
          #:key patchwork
          (archived? #f)
          (order "-id")
          (states '("1" "2" "7" "11")))
  (define (set-uri-scheme uri scheme)
    (string->uri
     (simple-format
      #f
      "~A:~A"
      scheme
      (string-join
       (drop (string-split (uri->string uri) #\:) 1)
       ":"))))

  (define initial-uri
    (string->uri
     (string-append (or patchwork
                        (%patchwork-instance))
                    "/api/patches/?"
                    "per_page=500&"
                    "order=" order "&"
                    "archived=" (if archived? "true" "false") "&"
                    (string-join
                     (map (lambda (state)
                            (string-append "state=" state))
                          states)
                     "&"))))

  (define (make-request uri)
    (let-values (((response body)
                  (http-request uri
                                #:decode-body? #f)))
      (append!
       (vector->list
        (json-string->scm (utf8->string body)))
       (or
        (and=> (assq-ref (response-headers response)
                         'link)
               (lambda (link-header)
                 (and=>
                  (find (lambda (link)
                          (let ((link-details (parse-link link)))
                            (string=?
                             (assq-ref link-details 'rel)
                             "next")))
                        (string-split link-header #\,))
                  (lambda (next-link)
                    (let ((link-details (parse-link next-link)))
                      (make-request
                       ;; The link headers don't use https, so to
                       ;; avoid the redirect, modify the URI
                       (set-uri-scheme
                        (assq-ref link-details 'uri)
                        (uri-scheme uri))))))))
        '()))))

  (retry-on-error (lambda () (make-request initial-uri))
                  #:times 10
                  #:delay 5))

(define* (latest-patchwork-series-by-issue
          #:key patchwork)
  (define (patch->issue-number patch)
    (string->number
     (match:substring
      (string-match "\\[?bug#([0-9]*)(,|:|\\])"
                    (assoc-ref patch "name"))
      1)))

  (let ((result
         (make-hash-table 2048)))

    (for-each
     (lambda (patch)
       (let ((issue-number
              (patch->issue-number patch))
             (patch-series
              (assoc-ref patch "series")))

         ;; Some patches are missing series when patchwork has trouble
         ;; processing them
         (when (not (eq? (vector-length patch-series) 0))
           (or (and=>
                (hash-ref result issue-number)
                (lambda (series)
                  (let ((patch-series-number
                         (assoc-ref (vector-ref patch-series 0)
                                    "id")))
                    (when (eq? (assoc-ref series "id")
                               patch-series-number)
                      (hash-set!
                       result
                       issue-number
                       `(,@(alist-delete "patches" series)
                         ("patches" . (,@(assoc-ref series "patches")
                                       ,patch))))))))
               (hash-set!
                result
                issue-number
                `(,@(vector-ref patch-series 0)
                  ("patches" . (,patch))))))))
     (patchwork-patches #:patchwork patchwork))

    (let* ((data (hash-map->list cons result))
           (mumi-data (mumi-bulk-issues
                       (map first data))))
      (sort!
       (filter-map (lambda (data mumi)
                     (if (assq-ref mumi 'open?)
                         `(,@data
                           (mumi . ,mumi))
                         #f))
                   data
                   mumi-data)
       (lambda (a b)
         ;; Sort by issue number
         (> (first a)
            (first b)))))))