;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019, 2022 Arun Isaac <arunisaac@systemreboot.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 (mumi messages)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 threads)
  #:use-module (email email)
  #:use-module (mumi cache)
  #:use-module (mumi config)
  #:use-module (mumi debbugs)
  #:use-module (mumi xapian)
  #:use-module (web client)
  #:export (search-bugs
            recent-bugs
            forgotten-issues
            easy-bugs
            bugs-by-severity

            multipart-message?
            extract-attachment

            extract-name
            extract-email
            sender
            sender-email
            sender-name
            date
            subject
            message-id
            participants
            recipients
            closing?
            bot?
            internal-message?
            patch-message?

            patch-messages
            issue-messages
            process-query))

(define (status-with-cache ids)
  "Invoke GET-STATUS, but only on those IDS that have not been cached
yet.  Return new results alongside cached results."
  (map (lambda (id)
         (or (cached? id)
             (cache! id (bug-status id))))
       ids))

(define (extract-name address)
  (or (assoc-ref address 'name)
      (and=> (assoc-ref address 'address)
             (lambda (address)
               (string-take address (string-index address #\@))))
      "Somebody"))

(define (extract-email address)
  (assoc-ref address 'address))

(define (header message key)
  (assoc-ref (or (email-headers message) '()) key))

(define (sender message)
  (let ((from (header message 'from)))
    (or (false-if-exception (and=> from first))
        `((name . ,(or from "Unknown sender"))
          (address . "unknown")))))

(define sender-email
  (compose extract-email sender))

(define (sender-name message)
  (extract-name (sender message)))

(define (date message)
  (let ((d (header message 'date)))
    (cond
     ((date? d) d)
     ((boolean? d)
      (current-date))
     ((and (string? d)
           (string->number d)) =>
      (lambda (seconds)
        (let* ((time (make-time time-utc 0 seconds))
               (date (time-utc->date time)))
          date))))))

(define (subject message)
  (or (header message 'subject) "(no subject)"))

(define (message-id message)
  (header message 'message-id))

(define (participants messages)
  "Return a list of unique senders in the conversion."
  (apply lset-adjoin (lambda (a b)
                       (string= (extract-email a)
                                (extract-email b)))
         '() (map sender messages)))

(define (recipients message)
  "Return a list of recipient email addresses for the given MESSAGE."
  (let ((headers (or (email-headers message) '())))
    (filter-map (match-lambda
                  (((or 'cc 'bcc 'to) val) val)
                  (_ #f)) headers)))

(define (closing? message id)
  "Is this MESSAGE closing this bug ID?"
  (let ((done (string-append (number->string id)
                             "-done")))
    (and=> (header message 'x-debbugs-envelope-to)
           (cut string= <> done))))

(define (bot? address)
  (string= "help-debbugs@gnu.org" address))

(define (internal-message? message)
  (bot? (sender-email message)))

(define* (patch-message? message #:optional patch-set-number)
  (let ((prefix (if patch-set-number
                    (format #false "[PATCH v~a" patch-set-number)
                    "[PATCH")))
    (string-prefix? prefix (subject message))))


(define (multipart-message? message)
  (eq? (assoc-ref (header message 'content-type)
                  'type)
       'multipart))

(define (extract-attachment id msg-num path)
  "Extract attachment from message number MSG-NUM in the thread for
the bug with the given ID.  Follow PATH to get to the correct
multipart chunk containing the attachment.  This is absolutely
horrible because Debbugs does not let us access messages directly, so
we have to do this in a very convoluted way."
  (define (nth n lst)
    (and (< n (length lst))
         (list-ref lst n)))
  (define (traverse path parts)
    (let loop ((path path)
               (parts parts))
      (match path
        ((pos) (nth pos parts))
        ((pos . rest)
         (loop rest
               (and=> (nth pos parts)
                      mime-entity-body))))))
  (and=> (nth msg-num (issue-messages id))
         (lambda (msg)
           (cond
            ((multipart-message? msg)
             (traverse path (email-body msg)))
            (else
             (match path
               (() msg)
               (_ #f)))))))


;; We would like to use get-bug-log here, but it often returns
;; truncated messages.  This is a known bug upstream.
(define (issue-messages bug-id)
  "Return list of messages relating to the issue BUG-ID.  Cache the
result for a while."
  (define archived-log
    (bug-id->log-file bug-id #:archived? #t))
  (define active-log
    (bug-id->log-file bug-id))
  ;; Prefer the active log over the archived log.  This is useful if
  ;; the bug has been unarchived.  The mere existence of an archived
  ;; log does not mean that the bug is *currently* archived.
  (define file
    (or (and (file-exists? active-log) active-log)
        (and (file-exists? archived-log) archived-log)))
  (if file
      (let ((key (list 'issue-messages bug-id)))
        (or (cached? key)
            (cache! key
                    (call-with-input-file file
                      read-emails-from-bug-log))))
      '()))

(define* (patch-messages id #:optional patch-set)
  "Return a string corresponding to the patch messages in the provided
PATCH-SET.  If PATCH-SET is not provided, return all patches."
  (define (get-emails file)
    (call-with-input-file file
      (cut read-emails-from-bug-log <> #:raw? #true)))
  (define emails
    (let* ((candidate (lambda (archived?)
                        (bug-id->log-file id #:archived? archived?)))
           (file (find file-exists?
                       (list (candidate #f)
                             (candidate #t)))))
      (and file (get-emails file))))
  (define pat (make-regexp "^From" regexp/newline))
  (let* ((messages (issue-messages id))
         (total (length messages))
         (messages-with-numbers
          (zip (iota total) messages))
         (message-numbers
          (map first
               (sort (filter (match-lambda
                               ((number message)
                                (patch-message? message patch-set)))
                             messages-with-numbers)
                     ;; Sort by subject to ensure that patches are in
                     ;; order even if they were received out of order.
                     (lambda (a b)
                       (match (list a b)
                         (((a-number a-message)
                           (b-number b-message))
                          (string< (subject a-message)
                                   (subject b-message)))))))))
    (string-join (map (lambda (message-number)
                        (let ((text (list-ref emails message-number)))
                          (match (regexp-exec pat text)
                            (#false text)
                            (m
                             (string-drop text (match:start m 0))))))
                      message-numbers)
                 "\n")))

(define* (search-bugs query #:key (max 400))
  "Return a list of all bugs matching the given QUERY string."
  (status-with-cache (map string->number
                          (search query #:pagesize max))))

(define (recent-bugs amount)
  "Return up to AMOUNT bugs with most recent activity."
  (let* ((recent-ids
          (sort
           (delete-duplicates
            (map string->number
                 (search "mdate:1m..")))
           <))
         (ids (take (reverse recent-ids)
                    (min amount (length recent-ids)))))
    (status-with-cache ids)))

(define (forgotten-issues amount)
  "Return up to AMOUNT issues that appear to have been forgotten
about."
  (let* ((forgotten-ids (forgotten-bug-numbers (%config 'packages)))
         (ids (take (reverse forgotten-ids)
                    (min amount (length forgotten-ids)))))
    (status-with-cache ids)))

(define (easy-bugs)
  "Return all bugs that have been tagged \"easy\"."
  (search-bugs "tag:easy"))

(define* (bugs-by-severity severity #:optional status)
  "Return severe bugs."
  (search-bugs (if status
                   (format #f "severity:~a status:~a" severity status)
                   (format #f "severity:~a" severity))))

(define punctuation?
  (cut char-set-contains? char-set:punctuation <>))

(define (process-query query)
  "Process the QUERY string and return a list of query terms and
sets that need to overlap the result set."
  ;; Xapian doesn't like punctuation.  Replace with spaces.  Leave
  ;; hyphens and quotes.
  (define (clean-term term)
    (string-map (match-lambda
                  ((and (or #\" #\-) c) c)
                  ((? punctuation? c) #\space)
                  (c c))
                term))
  (fold (lambda (term terms)
          (match (string-split term #\:)
            (("is" (or "done" "closed"))
             (cons "status:done" terms))
            (("is" (or "open" "pending"))
             (cons "status:open" terms))
            ;; Do not mangle message ids
            (("msgid" msgid)
             (cons (format #false "msgid:~a" msgid) terms))
            (((and (or "date" "subject" "tag"
                       "author" "owner" "submitter"
                       "severity")
                   prefix) value)
             (cons (string-append prefix ":"
                                  (clean-term value))
                   terms))
            ;; TODO: this should only be the title of the bug, not
            ;; the subject.
            (("title" title)
             (cons (string-append "subject:" (clean-term title))
                   terms))
            (_
             (cons (clean-term term) terms))))
        '()
        (tokenize query)))