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 (debbugs cache)
  #:use-module (debbugs soap)
  #:use-module (debbugs operations)
  #:use-module (debbugs bug)
  #:use-module (email email)
  #:use-module (mumi config)
  #:use-module (mumi debbugs)
  #:use-module ((mumi bugs) #:prefix db:)
  #:use-module (web client)
  #:export (search-bugs
            fetch-bug
            recent-bugs
            easy-bugs
            wishlist-bugs
            bugs-by-severity

            bug-id->log-file

            multipart-message?
            extract-attachment))

(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 (soap-invoke* (%config 'debbugs) get-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-public (extract-name address)
  (or (assoc-ref address 'name)
      (and=> (assoc-ref address 'address)
             (lambda (address)
               (string-take address (string-index address #\@))))
      "Somebody"))

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

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

(define-public (sender message)
  (or (and=> (header message 'from) first)
      "unknown sender"))

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

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

(define-public (date message)
  (or (header message 'date) "unknown date"))

(define-public (subject message)
  (or (header message 'subject) "(no 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= (extract-email a)
                                (extract-email b)))
         '() (map sender messages)))

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


(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 (patch-messages id))
         (lambda (msg)
           (cond
            ((multipart-message? msg)
             (traverse path (email-body msg)))
            (else
             (match path
               (() msg)
               (_ #f)))))))


(define* (bug-id->log-file bug-id #:key archived?)
  (format #f "~a/spool/~a/~a/~a.log"
          (%config 'data-dir)
          (if archived? "archive" "db-h")
          (string-take-right (if (string? bug-id)
                                 bug-id
                                 (number->string bug-id)) 2)
          bug-id))

;; This is a modified version of fetch-mbox from guile-debbugs: it
;; supports downloading with an offset.  It also doesn't bother with
;; msg-nums.
(define* (fetch-mbox* instance bug-number #:optional mbox-type
                      #:key offset mdate)
  "Download the mbox containing messages of bug BUG-NUMBER from the
Debbugs server INSTANCE (a procedure returning a string when given the
symbol 'email)."
  (let* ((options
          `((bug . ,(number->string bug-number))
            ,@(cond
               ((member mbox-type '(mboxmaint mboxstat mboxstatus))
                `((mbox-type . "yes")))
               (else '()))
            (mbox . "yes")))
         (uri (string-append (instance 'email) "?"
                             (string-join (map (match-lambda
                                                 ((key . value)
                                                  (format #f "~a=~a" key value)))
                                               options)
                                          ";")))
         (headers `(,@(if offset
                          `((range . (bytes (,offset . #f))))
                          '())
                    ,@(if mdate
                          `((if-modified-since . ,mdate))
                          '()))))
    (http-get uri #:decode-body? #f #:headers headers)))

;; We would like to use get-bug-log here, but it often returns
;; truncated messages.  This is a known bug upstream.
(define-public (patch-messages bug-id)
  "Return list of messages relating to the bug 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 'patch-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 (compose string->number mu:bugid)
                    (mu:message-list query))))
         (filtered (match sets
                     (() ids)
                     (_ (apply lset-intersection eq? ids sets)))))
    (status-with-cache (if (> (length filtered) max)
                           (take filtered max) filtered))))

;; 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."
  (let* ((recent-ids
          (sort
           (delete-duplicates
            (map (compose string->number mu:bugid)
                 (mu:message-list "date:1m..")))
           <))
         (ids (take (reverse recent-ids)
                    (min amount (length recent-ids)))))
    (status-with-cache ids)))

(define (easy-bugs)
  "Return all bugs that have been tagged \"easy\"."
  (let ((ids (db:bugs-by-tag "easy")))
    (status-with-cache ids)))

(define (wishlist-bugs)
  "Return all bugs that have been tagged \"wishlist\"."
  (let ((ids (db:bugs-by-tag "wishlist")))
    (status-with-cache ids)))

(define* (bugs-by-severity severity #:optional status)
  "Return severe bugs."
  (let* ((severity-ids (db:bugs-by-severity severity))
         (ids (if status
                  (let ((status-ids (db:bugs-by-status status)))
                    (lset-intersection eq? severity-ids status-ids))
                  severity-ids)))
    (status-with-cache ids)))

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

(define-public (process-query query)
  "Process the QUERY string and return a list of query terms and
sets that need to overlap the result set."
  ;; Mu doesn't like punctuation.  Replace with spaces.
  (define (clean-term term)
    (string-map (match-lambda
                  ((? punctuation? c) #\space)
                  (c c))
                term))
  (fold (lambda (term acc)
          (match acc
            ((#:terms terms
              #:sets fs)
             (match (string-split term #\:)
               ;; This is not supported by the Debbugs SOAP service,
               ;; so we filter locally.
               (("is" (or "done" "closed"))
                `(#:terms ,terms
                  #:sets ,(cons (db:bugs-by-status "done") fs)))
               (("is" (or "open" "pending"))
                `(#:terms ,terms
                  #:sets ,(cons (db:bugs-by-status "open") fs)))
               (("date" when)
                `(#:terms ,(cons (string-append "date:" when) terms)
                  #:sets ,fs))
               ;; TODO: this should only be the title of the bug, not
               ;; the subject.
               (("title" title)
                `(#:terms
                  ,(cons (string-append "subject:" (clean-term title))
                         terms)
                  #:sets ,fs))
               (("subject" subject)
                `(#:terms
                  ,(cons (string-append "subject:" (clean-term subject))
                         terms)
                  #:sets ,fs))
               (("tag" tag)
                `(#:terms ,terms
                  #:sets
                  ,(cons (db:bugs-by-tag (clean-term tag)) fs)))
               (("author" who)
                `(#:terms
                  ,(cons (string-append "from:" (clean-term who)) terms)
                  #:sets ,fs))
               (("owner" who)
                `(#:terms ,terms
                  #:sets ,(cons (db:bugs-by-owner who) fs)))
               (("submitter" who)
                `(#:terms ,terms
                  #:sets ,(cons (db:bugs-by-submitter who) fs)))
               (("severity" level)
                `(#:terms ,terms
                  #:sets ,(cons (db:bugs-by-severity level) fs)))
               ((whatever term)
                `(#:terms ,(cons (clean-term term) terms)
                  #:sets ,fs))
               (_
                `(#:terms ,(cons (clean-term term) terms)
                  #:sets ,fs))))))
        '(#:terms () #:sets ())
        (string-tokenize query)))