path: root/mumi/messages.scm

;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 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 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?

            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."
  (let* ((cached (filter-map cached? ids))
         (uncached-ids (lset-difference eq?
                                        ids
                                        (map bug-num cached)))
         (new (filter-map bug-status uncached-ids )))
    ;; Cache new things
    (map (lambda (bug) (cache! (bug-num bug) bug)) new)
    ;; Return everything from cache
    (sort (append cached new) (lambda (a b) (< (bug-num a) (bug-num b))))))

(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)
  (or (and=> (header message 'from) first)
      '((name . "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 (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))
  (define file
    (or (and (file-exists? archived-log) archived-log)
        (and (file-exists? active-log) active-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* (search-bugs query #:key (sets '()) (max 400))
  "Return a list of all bugs matching the given QUERY string.
Intersect the result with the id sets in the list SETS."
  (let* ((ids (delete-duplicates
               (map string->number
                    (search query))))
         (filtered (match sets
                     (() ids)
                     (_ (apply lset-intersection eq? ids sets)))))
    (status-with-cache (if (> (length filtered) max)
                           (take filtered max) filtered))))

(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))
            (((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)))