;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of mumi.
;;;
;;; mumi is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; mumi 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with mumi.  If not, see <http://www.gnu.org/licenses/>.

(define-module (mumi client)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-43)
  #:use-module (srfi srfi-71)
  #:use-module (srfi srfi-171)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (term ansi-color)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (email email)
  #:use-module (kolam http)
  #:use-module (mumi config)
  #:use-module (mumi web view utils)
  #:export (search
            print-current-issue
            set-current-issue!
            clear-current-issue!
            send-email))

(define (git-top-level)
  "Return the top-level directory of the current git repository."
  (let loop ((curdir (getcwd)))
    (cond
     ((file-exists? (string-append curdir "/.git"))
      curdir)
     ((string=? curdir "/")
      (error "No git top level found"))
     (else
      (loop (dirname curdir))))))

(define (client-config-directory)
  "Return client configuration directory."
  (string-append (git-top-level) "/.mumi"))

(define (client-config key)
  "Return client configuration value corresponding to KEY."
  (or (assq-ref (call-with-input-file (string-append (client-config-directory)
                                                     "/config")
                  read)
                key)
      (case key
        ((mumi-scheme) 'https)
        (else (format (current-error-port)
                      "Key '~a not configured for mumi client.~%"
                      key)))))

(define (graphql-endpoint)
  "Return GraphQL endpoint."
  (uri->string
   (build-uri (client-config 'mumi-scheme)
              #:host (client-config 'mumi-host)
              #:path "/graphql")))

(define (iso8601->date str)
  "Convert ISO-8601 date/time+zone string to date object."
  (string->date str "~Y-~m-~dT~H:~M:~S~z"))

(define (list-issue issue)
  "List issue described by ISSUE association list."
  (display (colorize-string
            (string-append "#"
                           (number->string (assoc-ref issue "number")))
            'YELLOW))
  (display " ")
  (unless (assoc-ref issue "open")
    (display (colorize-string "✓" 'BOLD 'GREEN))
    (display " "))
  (display (colorize-string
            (assoc-ref issue "title")
            'MAGENTA 'UNDERLINE))
  (newline)
  (display (string-append
            "opened "
            (colorize-string (time->string
                              (iso8601->date (assoc-ref issue "date")))
                             'CYAN)
            " by "
            (colorize-string
             (let ((submitter (assoc-ref issue "submitter")))
               (if (eq? (assoc-ref submitter "name") 'null)
                   (assoc-ref submitter "address")
                   (assoc-ref submitter "name")))
             'CYAN)))
  (newline))

(define (search query)
  "Search for issues with QUERY and list results."
  (vector-for-each (lambda (_ issue)
                     (list-issue issue))
                   (assoc-ref
                    (graphql-http-get (graphql-endpoint)
                                      `(document
                                        (query (#(issues #:search ,query)
                                                number
                                                title
                                                open
                                                date
                                                (submitter name address)))))
                    "issues")))

(define (current-issue-file)
  "Return path to current issue number file."
  (string-append (client-config-directory) "/current-issue"))

(define (current-issue-number)
  "Return current issue number."
  (let ((issue-file (current-issue-file)))
    (and (file-exists? issue-file)
         (call-with-input-file issue-file
           read))))

(define (print-current-issue)
  "Print current issue."
  (let ((issue-number (current-issue-number)))
    (if issue-number
        (list-issue
         (assoc-ref
          (graphql-http-get (graphql-endpoint)
                            `(document
                              (query (#(issue #:number ,issue-number)
                                      number
                                      title
                                      open
                                      date
                                      (submitter name address)))))
          "issue"))
        (begin
          (format (current-error-port) "No current issue!~%")
          (exit #f)))))

(define (set-current-issue! issue-number)
  "Set current issue number."
  ;; TODO: Write file atomically.
  (call-with-output-file (current-issue-file)
    (cut write issue-number <>)))

(define (clear-current-issue!)
  "Clear current issue."
  (let ((issue-file (current-issue-file)))
    (when (file-exists? issue-file)
      (delete-file issue-file))))

(define* (issue-number-of-message message-id #:optional (retries 15))
  "Return issue number that MESSAGE-ID belongs to. Retry RETRIES number
of times with an interval of 60 seconds between retries."
  ;; TODO: Re-implement this using our GraphQL endpoint once it
  ;; supports retrieving the issue from a message ID. Later,
  ;; re-implement this using a GraphQL subscription when kolam
  ;; supports it.
  (define (poll-issue-number-of-message message-id)
    (let ((response _ (http-get (build-uri (client-config 'mumi-scheme)
                                           #:host (client-config 'mumi-host)
                                           #:path (string-append "/msgid/" message-id)))))
      (and (>= (response-code response) 300)
           (< (response-code response) 400)
           (match (split-and-decode-uri-path
                   (uri-path (response-location response)))
             (("issue" issue-number)
              (string->number issue-number))))))

  (let loop ((i retries))
    (if (zero? i)
        (begin
          (format (current-error-port)
                  "Mail not acknowledged by issue tracker. Giving up.~%")
          (exit #f))
        (or (poll-issue-number-of-message message-id)
            (begin
              (let ((retry-interval 60))
                (format (current-error-port)
                        "Server has not yet received our email. Will retry in ~a seconds. ~a retries remaining.~%"
                        retry-interval (1- i))
                (sleep retry-interval))
              (loop (1- i)))))))

(define (call-with-input-pipe command proc)
  "Call PROC with input pipe to COMMAND. COMMAND is a list of program
arguments."
  (match command
    ((prog args ...)
     (let ((port #f))
       (dynamic-wind
         (lambda ()
           (set! port (apply open-pipe* OPEN_READ prog args)))
         (cut proc port)
         (cut close-pipe port))))))

(define* (git-send-email to patches #:optional (options '()))
  "Send PATCHES using git send-email to the TO address with
OPTIONS. Return the message ID of the first email sent."
  (let ((command (cons* "git" "send-email"
                        (string-append "--to=" to)
                        (append options
                                patches))))
    (display (string-join command))
    (newline)
    (call-with-input-pipe command
      (lambda (port)
        ;; FIXME: This messes up the order of stdout and stderr.
        (let ((message-id
               ;; Read till you get the Message ID.
               (port-transduce (tlog (lambda (_ line)
                                       (display line)
                                       (newline)))
                               (rany (lambda (line)
                                       (and (string-prefix-ci? "Message-ID:" line)
                                            (assq-ref
                                             (parse-email-headers
                                              (string-append line "\n"))
                                             'message-id))))
                               get-line
                               port)))
          ;; Pass through the rest.
          (display (get-string-all port))
          message-id)))))

(define (reply-email-headers issue-number)
  "Return an association list of email headers when replying to
ISSUE-NUMBER."
  (let ((messages
         (assoc-ref
          (assoc-ref
           (graphql-http-get (graphql-endpoint)
                             `(document
                               (query (#(issue #:number ,issue-number)
                                       (messages (from name address)
                                                 date)))))
           "issue")
          "messages")))
    ;; When sending email to an issue, we Cc all issue participants.
    ;; TODO: Also add an In-Reply-To header.
    `((x-debbugs-cc
       . ,(delete-duplicates
           (map (lambda (message)
                  (let ((from (assoc-ref message "from")))
                    (string-append (assoc-ref from "name")
                                   " <" (assoc-ref from "address") ">")))
                (vector->list messages)))))))

(define (send-email patches)
  "Send PATCHES via email."
  (if (current-issue-number)
      ;; If an issue is current, send patches to that issue's email
      ;; address.
      (let ((issue-number (current-issue-number)))
        (git-send-email (string-append (number->string issue-number)
                                       "@"
                                       (client-config 'debbugs-host))
                        patches
                        (map (cut string-append "--add-header=X-Debbugs-Cc: " <>)
                             (assq-ref (reply-email-headers issue-number)
                                       'x-debbugs-cc))))
      (match patches
        ;; If it's a single patch, send it to the patch email address
        ;; and be done with it
        ((patch)
         (git-send-email (client-config 'patch-email-address)
                         (list patch)))
        ;; Else, send first patch to the patch email address and get an
        ;; issue number. Then, send the remaining patches to that
        ;; issue's email address.
        ((first-patch other-patches ...)
         (git-send-email
          (string-append (number->string
                          (issue-number-of-message
                           (git-send-email (client-config 'patch-email-address)
                                           (list first-patch))))
                         "@"
                         (client-config 'debbugs-host))
          other-patches)))))