(define-module (guix-qa-frontpage patchwork)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-43)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #: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)
                #:select (call-with-delay-logging))
  #:use-module ((guix-build-coordinator utils fibers)
                #:select (retry-on-error))
  #:use-module (guix-qa-frontpage mumi)
  #:use-module (guix-qa-frontpage debbugs)
  #:export (%patchwork-instance

            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-series-uri #:key patchwork
                               (per-page 200)
                               (order "-id"))
  (string->uri
   (string-append (or patchwork
                      (%patchwork-instance))
                  "/api/series/?"
                  "per_page=" (number->string per-page) "&"
                  "order=" order "&")))

(define (request-patchwork-series uri)
  (define (set-uri-scheme uri scheme)
    (string->uri
     (simple-format
      #f
      "~A:~A"
      scheme
      (string-join
       (drop (string-split (uri->string uri) #\:) 1)
       ":"))))

  (let ((response
         body
         (retry-on-error
          (lambda ()
            (http-request uri
                          #:decode-body? #f))
          #:times 2
          #:delay 3)))

    (values
     (json-string->scm (utf8->string body))
     (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)))
                   (set-uri-scheme
                    (assq-ref link-details 'uri)
                    (uri-scheme uri))))))))))

(define (parse-patch-name name)
  (let ((args
         (and
          (string-prefix? "[" name)
          (let ((stop (string-index name #\])))
            (substring name 1 stop))))
        (as-bug-number
         (lambda (arg)
           (and (string-prefix? "bug#" arg)
                (string->number (substring arg (string-length "bug#"))))))
        (as-v2
         (lambda (arg)
           (and (string-prefix? "v" arg)
                (string->number (substring arg 1)))))
        (as-patch-number
         (lambda (arg)
           (match (string-split arg #\/)
             (((= string->number index) (= string->number total))
              (and index total (<= index total)
                   (cons index total)))
             (else #f)))))
    (let analyze ((bug-number #f)
                  (branch "master")
                  (version 1)
                  (index 1)
                  (total 1)
                  (arguments
                   (if args
                       (string-split args #\,)
                       '())))
      (match arguments
        ((or ("") ())
         `((bug-number . ,bug-number)
           (branch . ,branch)
           (version . ,version)
           (index . ,index)
           (total . ,total)))
        (((= as-bug-number (? number? new-bug-number))
          arguments ...)
         (analyze new-bug-number branch version index total arguments))
        (((= as-v2 (? number? new-version))
          arguments ...)
         (analyze bug-number branch new-version index total arguments))
        (((= as-patch-number ((? number? new-index) . (? number? new-total)))
          arguments ...)
         (analyze bug-number branch version new-index new-total arguments))
        ((feature-branch arguments ...)
         (analyze bug-number feature-branch version index total arguments))))))

(define parse-issue-title
  (let ((regex (make-regexp "\\[([A-Z\\_a-z0-9\\-]+)\\].*")))
    (lambda (title)
      (match (regexp-exec regex title)
        (#f #f)
        (m
         (let ((branch (match:substring m 1)))
           (if (string=? branch "PATCH")
               #f
               branch)))))))

(define (patchwork-series->branch series)
  (match (assoc-ref series "patches")
    (#() "master")
    (#(first-patch rest ...)
     (let ((details
            (parse-patch-name
             (assoc-ref first-patch "name"))))
       (assq-ref details 'branch)))))

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

  (define (strip-title-prefix str)
    (if (string-prefix? "[" str)
        (let ((start (string-index str #\])))
          (string-drop str (+ 1 start)))
        str))

  (define issue-number-to-series-hash-table
    (make-hash-table))

  (let loop ((patchwork-uri
              (patchwork-series-uri
               #:patchwork patchwork
               #:per-page 200))

             (result '()))

    (if (> (length result) count)
        (let* ((rest
                count-items
                (split-at! result
                           (- (length result)
                              count)))

               (debbugs-guix-usertag-data
                (with-exception-handler
                    (lambda (exn)
                      (simple-format
                       (current-error-port)
                       "exception fetching debbugs-guix-usertag-data: ~A\n"
                       exn)
                      '())
                  (lambda ()
                    (call-with-delay-logging
                     debbugs-get-issues-with-guix-usertag))
                  #:unwind? #t))
               (usertag-lookup
                (let ((hash-table (make-hash-table)))
                  (for-each
                   (match-lambda
                     ((tag . issues)
                      (for-each
                       (lambda (issue)
                         (hash-set! hash-table
                                    issue
                                    (cons tag
                                          (or (hash-ref hash-table issue)
                                              '()))))
                       (if (pair? issues)
                           issues
                           (list issues)))))
                   debbugs-guix-usertag-data)
                  hash-table)))

          (map!
           (lambda (data)
             `(,@data
               (usertags . ,(or (hash-ref usertag-lookup
                                          (car data))
                                '()))))
           count-items))

        ;; Need more series, so keep going
        (let* ((series-batch
                next-page-uri
                (request-patchwork-series patchwork-uri))

               (batch-hash-table
                (make-hash-table)))

          (vector-for-each
           (lambda (_ series-data)
             (let* ((patches
                     (assoc-ref series-data "patches"))
                    (issue-number
                     (if (= 0 (vector-length patches))
                         (let ((cover-letter
                                (assoc-ref series-data "cover_letter")))
                           (and cover-letter
                                (not (eq? 'null cover-letter))
                                (string->issue-number
                                 (assoc-ref cover-letter "name"))))
                         (string->issue-number
                          (assoc-ref
                           (vector-ref (assoc-ref series-data "patches")
                                       0)
                           "name")))))

               (when (and issue-number
                          (not (hash-ref issue-number-to-series-hash-table
                                         issue-number)))
                 (hash-set! issue-number-to-series-hash-table
                            issue-number
                            series-data)
                 (hash-set! batch-hash-table
                            issue-number
                            series-data))))
           series-batch)

          (let* ((series-by-issue-number
                  (hash-map->list
                   cons
                   batch-hash-table))

                 (mumi-data
                  (retry-on-error
                   (lambda ()
                     (call-with-delay-logging mumi-bulk-issues
                                              #:args
                                              (list
                                               (map first series-by-issue-number))))
                   #:times 1
                   #:delay 5)))

            (loop
             next-page-uri
             (fold
              (lambda (data mumi result)
                (let ((issue-number (car data)))
                  (if (and (assq-ref mumi 'open?)
                           (every
                            (lambda (merged-issue-number)
                              (if (< merged-issue-number
                                     issue-number)
                                  (not (hash-ref
                                        issue-number-to-series-hash-table
                                        merged-issue-number))
                                  #t))
                            (assq-ref mumi 'merged-with)))
                      (cons
                       `(,issue-number
                         .
                         (("name" . ,(strip-title-prefix
                                      (assq-ref mumi 'title)))
                          ,@(alist-delete "name" (cdr data) string=?)
                          (branch . ,(or (parse-issue-title
                                          (assq-ref mumi 'title))
                                         (patchwork-series->branch data)))
                          (mumi . ,mumi)))
                       result)
                      result)))
              result
              series-by-issue-number
              mumi-data)))))))