;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.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 textual-ports)
  #:use-module (debbugs soap)
  #:use-module (debbugs operations)
  #:use-module (debbugs email)
  #:use-module (debbugs bug)
  #:use-module (debbugs rfc822)
  #:use-module (mumi config)
  #:use-module (mailutils mailutils)
  #:export (search-bugs
            fetch-bug
            recent-bugs

            split-multipart-message
            multipart-message?))

;; TODO: mu-address-get-personal skips non ASCII characters
;; ex: (mu-address-get-personal "ludo@gnu.org (Ludovic Courtès)")
;; => "Ludovic Courts"
(define-public (extract-name address)
  (let ((name (mu-header-decode (mu-address-get-personal address))))
    (if (string-null? name) "Somebody" name)))

(define-public extract-email mu-address-get-email)

(define (header message key)
  (and=> (assoc-ref (email-headers message) key) first))

(define-public (sender message)
  (header message "from"))

(define-public sender-email
  (compose mu-address-get-email sender))

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

(define-public (date message)
  (header message "date"))

(define-public (subject message)
  (header message "subject"))

(define-public (message-id message)
  (header message "message-id"))

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

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

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

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

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


;; Taken from (debbugs rfc822).
(define* (read-token predicate #:optional (port (current-input-port)))
  "Read characters from PORT and call the procedure PREDICATE with
each character until PREDICATE returns #F.  Return a string with the
accumulated characters."
  (let ((r (open-output-string)))
    (define (finish) (get-output-string r))
    (let loop ((c (peek-char port)))
      (cond ((eof-object? c) (finish))
            ((predicate c)
             (write-char (read-char port) r)
             (loop (peek-char port)))
            (else (finish))))))

(define* (read-until delimiter #:optional (port (current-input-port)))
  "Return the string up to DELIMITER.  Also read DELIMITER and throw
it away."
  (let ((result (read-token (lambda (char) (not (char=? char delimiter))) port)))
    (read-token (cut char=? <> delimiter) port)
    result))

(define* (read-between delimiter #:optional (port (current-input-port)))
  "Return the string after DELIMITER and before DELIMITER from PORT."
  (read-token (cut char=? <> delimiter) port)
  (read-until delimiter port))

(define* (read-key-value-pair #:optional (port (current-input-port)))
  "Read a single key value pair from PORT.  The key is separated from
the value by an equal sign.  The value may be wrapped in double
quotes.  The pair must end with a semicolon."
  (let* ((key (read-until #\= port))
         (val (if (char=? (peek-char port) #\")
                  (let ((return (read-between #\" port)))
                    (read-until #\; port)
                    return)
                  (read-until #\; port))))
    (cons (string-downcase key) val)))

(define (throw-away char-pred)
  "Return a procedure that reads and discards any number of characters
for which the predicate CHAR-PRED returns #T from a port."
  (lambda* (#:optional (port (current-input-port)))
    (while (char-pred (peek-char port))
      (read-token char-pred port))))

(define (parse-multipart-header port)
  "Read a multipart header string from PORT and return an alist of
attributes."
  (let loop ((acc `(("type" . ,(read-until #\; port)))))
    (if (eof-object? (peek-char port))
        acc
        (begin
          ((throw-away char-whitespace?) port)
          (loop (cons (read-key-value-pair port) acc))))))

(define (multipart-header? line)
  "Return the attributes of the provided Content-Type header value."
  (and (string? line)
       (string-prefix? "multipart" line)
       (call-with-input-string line parse-multipart-header)))

(define (multipart-message? message)
  (multipart-header? (header message "content-type")))

(define (qp-decoder port)
  "Read a quoted-printable line from PORT and return the decoded
string."
  (let ((decoder-port (mu-decoder-port port "quoted-printable")))
    (with-output-to-string
      (lambda ()
        (let loop ((line (get-line decoder-port)))
          (cond
           ((eof-object? line) #t)
           (else
            (display line)
            (newline)
            (loop (get-line decoder-port)))))))))

(define (decode headers str)
  "Decode the string STR according to the encoding specified in
HEADERS."
  (if (and=> (assoc-ref headers "content-transfer-encoding")
             (lambda (values)
               (string-contains (first values) "quoted-printable")))
      (with-input-from-string str
        (lambda () (qp-decoder (current-input-port))))
      str))

(define* (collect-parts boundary port #:key nested?)
  "Read multipart message parts from PORT and return them as a list of
containing #:headers and #:body.  If NESTED? is #T look for nested
multipart messages."
  (define final-boundary (string-append boundary "--"))
  (let loop ((headers (rfc822-header->list port))
             (line (get-line port))
             (current-part '())
             (parts '()))
    (cond
     ((or (string=? line final-boundary)
          (eof-object? line))
      ;; We're done!
      (reverse (cons `(#:headers ,headers
                       #:body ,(decode headers
                                       (string-join (reverse current-part) "\n")))
                     parts)))
     ((string=? boundary line)
      ;; End of this part
      (let ((next-headers (rfc822-header->list port))
            (next-line (get-line port)))
        (loop next-headers
              next-line
              '()
              (cons `(#:headers ,headers
                      #:body ,(decode headers
                                      (string-join (reverse current-part) "\n")))
                    parts))))
     ;; New part beginning with an in-body multipart
     ;; header.
     ((and nested?
           (null? current-part)
           (and=> (assoc-ref headers "content-type")
                  (match-lambda
                    (() #f)
                    ((val) (multipart-header? val)))))
      => (lambda (attributes)
           ;; Parse multipart body.
           (let ((embedded-parts
                  (let* ((boundary (string-append "--"
                                                  (assoc-ref attributes "boundary")))
                         (final-boundary (string-append boundary "--")))
                    (cond
                     ((or (string=? boundary line)
                          ;; It's possible that the first line is
                          ;; empty and is followed by the boundary.
                          (and (string-null? line)
                               (string=? boundary (get-line port))))
                      (collect-parts boundary port))
                     (else
                      ;; Invalid multipart message
                      '())))))
             ;; TODO: there might be some white space after the end of
             ;; this embedded multipart message.  Not sure what to do
             ;; with it, though.
             (loop '()
                   (get-line port)
                   '()
                   (cons `(#:headers ,headers
                           #:body ,(decode headers
                                           embedded-parts))
                         parts)))))
     ;; Just a boring old message body: add the line to
     ;; the current part.
     (else
      (loop headers
            (get-line port)
            (cons line current-part)
            parts)))))

;; A multipart message may contain a body that is a multipart message
;; itself.  This is signalized by a Content-Type header on the first
;; line after the boundary.
(define (split-multipart-message attributes message)
  "Return list of message parts contained in the multipart MESSAGE.
The ATTRIBUTES alist must contain the boundary string and the
multipart type, among other things.  A message part is either a list
of strings, or if the body itself contains a multipart message a lists
of message parts."
  (let ((boundary (string-append "--"
                                 (assoc-ref attributes "boundary"))))
    (call-with-input-string (email-body message)
      (lambda (port)
        ;; Ignore everything up to the first boundary string.
        (let ((found (let loop ((line (get-line port)))
                       (cond
                        ((eof-object? line) #f)
                        ((string=? boundary line) #t)
                        (else (loop (get-line port)))))))
          (if found
              (collect-parts boundary port #:nested? #t)
              ;; Invalid multipart message
              '()))))))


(define-public (patch-messages id)
  "Return list of messages relating to the bug ID."
  ;; TODO: sort by date necessary?
  (soap-invoke* (%config 'debbugs) get-bug-log id))

(define* (search-bugs query #:key (attributes '()) (max 100))
  "Return a list of all bugs matching the given QUERY string."
  (let* ((matches (soap-invoke* (%config 'debbugs)
                                search-est
                                query
                                #:max max
                                #:attributes
                                (append attributes
                                        '((package string-prefix "guix")))))
         (ids (filter-map (lambda (item)
                            (assoc-ref item "id"))
                          matches)))
    (soap-invoke* (%config 'debbugs) get-status ids)))

;; TODO: This returns *any* matching debbugs bug, even if it is not
;; part of the default packages.
(define (fetch-bug id)
  "Return the bug matching ID or #F."
  (match (soap-invoke* (%config 'debbugs) get-status (list id))
    (() #f)
    ((bug) bug)))

(define (recent-bugs amount)
  "Return up to AMOUNT bugs with most recent activity."
  ;; "search-est" does not return unique items, so we have to take
  ;; more and then filter the results.  To allow for caching we round
  ;; off the current time to the start of the hour.
  (let* ((matches
          (soap-invoke* (%config 'debbugs)
                        search-est
                        ""
                        #:max 50
                        #:attributes
                        `((package string-prefix "guix")
                          (@cdate >= ,(let ((this-hour
                                             (date->time-utc (let ((now (current-date)))
                                                               (make-date 0 0 0 (date-hour now)
                                                                          (date-day now)
                                                                          (date-month now)
                                                                          (date-year now) 0))))
                                            (one-month
                                             (make-time time-duration 0 (* 60 60 24 30))))
                                        (time-second (subtract-duration this-hour one-month)))))))
         (ids (take (delete-duplicates
                     (filter-map (lambda (item)
                                   (assoc-ref item "id"))
                                 matches)) amount)))
    (soap-invoke* (%config 'debbugs) get-status ids)))

(define (ago unit amount)
  "Return the point in time that lies AMOUNT UNITs in the past."
  (let ((amount* (match unit
                   ('hours amount)
                   ('days (* 24 amount))
                   ('weeks (* 24 7 amount))
                   ('months (* 24 30 amount))
                   ('years (* 24 365 amount)))))
    (subtract-duration (date->time-utc (current-date))
                       (make-time time-duration 0 (* 60 60 amount*)))))

(define (date-term->epoch-seconds term)
  "Convert a date search term string into seconds since the epoch, or
return #F if the term is invalid."
  (match term
    ("now" 'now)
    ("today" (time-second (ago 'days 1)))
    ("yesterday" (time-second (ago 'days 2)))
    (_
     (cond
      ;; TODO: support more date template strings
      ((or (false-if-exception (string->date term "~Y~m~d"))
           (false-if-exception (string->date term "~Y-~m-~d")))
       => (lambda (date)
            (time-second (date->time-utc date))))
      ;; e.g. "12h" meaning "12 hours ago"
      ((string->number (string-drop-right term 1))
       => (lambda (amount)
            (match (string-take-right term 1)
              ("h"
               (time-second (ago 'hours amount)))
              ("d"
               (time-second (ago 'days amount)))
              ("w"
               (time-second (ago 'weeks amount)))
              ("m"
               (time-second (ago 'months amount)))
              ("y"
               (time-second (ago 'years amount)))
              (_ #f))))
      (else #f)))))

(define-public (process-query query)
  "Process the QUERY string and return two values: the remaining
unprocessed query string and an alist of search attributes."
  (fold (lambda (term acc)
          (match acc
            ((#:terms terms
              #:attributes attrs
              #:filters fs)
             (match (string-split term #\:)
               ;; This is not supported by the Debbugs SOAP service,
               ;; so we filter locally.
               (("is" (or "done" "closed"))
                `(#:terms ,terms
                  #:attributes ,attrs
                  #:filters
                  ,(cons bug-done fs)))
               (("is" (or "open" "pending"))
                `(#:terms ,terms
                  #:attributes ,attrs
                  #:filters
                  ,(cons (negate bug-done) fs)))
               ;; "date" for submission date, "mdate" for message date.
               (((and (or "date" "mdate") type) when)
                (let ((date-attribute (match type
                                        ("date" 'date)
                                        ("mdate" '@cdate)))
                      (pat "(yesterday|today|now|[1-9][0-9]*(h|d|w|m|y)|[0-9]+)"))
                  (or (match (map (compose date-term->epoch-seconds
                                           match:substring)
                                  (list-matches pat when))
                        ((and ((? number? start)
                               (? number? end))
                              range)
                         (match (sort range <)
                           ((start end)
                            `(#:terms ,terms
                              #:attributes ,(cons `(,date-attribute >< ,start ,end) attrs)
                              #:filters ,fs))))
                        ((or ('now (? number? since))
                             ((? number? since) 'now))
                         `(#:terms ,terms
                           #:attributes ,(cons `(,date-attribute > ,since) attrs)
                           #:filters ,fs))
                        (_ #f))
                      ;; Invalid, don't do anything.
                      `(#:terms ,terms
                        #:attributes ,attrs
                        #:filters ,fs))))
               (("title" title)
                `(#:terms ,terms
                  #:attributes ,(cons `(subject string-contains ,title) attrs)
                  #:filters ,fs))
               (("tag" tag)
                `(#:terms ,terms
                  #:attributes ,(cons `(tags string= ,tag) attrs)
                  #:filters ,fs))
               (("author" who)
                `(#:terms ,terms
                  #:attributes ,(cons `(@author string-contains ,who) attrs)
                  #:filters ,fs))
               ;; This is not supported by the Debbugs SOAP service,
               ;; so we filter locally.  At least we know that we need
               ;; bugs where the author is "who".
               (("submitter" who)
                `(#:terms ,terms
                  #:attributes ,(cons `(@author string-contains ,who) attrs)
                  #:filters ,(cons (lambda (bug)
                                     (string-contains-ci (bug-originator bug)
                                                         who))
                                   fs)))
               (("severity" level)
                `(#:terms ,terms
                  #:attributes ,(cons `(severity string= ,level) attrs)
                  #:filters ,fs))
               (_
                `(#:terms ,(cons term terms)
                  #:attributes ,attrs
                  #:filters ,fs))))))
        '(#:terms () #:attributes () #:filters ())
        (string-tokenize query)))