mumi/messages.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
   4 ;;;
   5 ;;; This program is free software: you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Affero General Public License
   7 ;;; as published by the Free Software Foundation, either version 3 of
   8 ;;; the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This program is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Affero General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Affero General Public
  16 ;;; License along with this program.  If not, see
  17 ;;; <http://www.gnu.org/licenses/>.
  18
  19 (define-module (mumi messages)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-19)
  22   #:use-module (srfi srfi-26)
  23   #:use-module (ice-9 optargs)
  24   #:use-module (ice-9 regex)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 textual-ports)
  27   #:use-module (ice-9 binary-ports)
  28   #:use-module (debbugs cache)
  29   #:use-module (debbugs soap)
  30   #:use-module (debbugs operations)
  31   #:use-module (debbugs bug)
  32   #:use-module (email email)
  33   #:use-module (mumi config)
  34   #:use-module ((mumi bugs) #:prefix db:)
  35   #:use-module (mumimu)
  36   #:export (search-bugs
  37             fetch-bug
  38             recent-bugs
  39             easy-bugs
  40             bugs-by-severity
  41
  42             download-message
  43
  44             multipart-message?
  45             extract-attachment))
  46
  47 (define (status-with-cache ids)
  48   "Invoke GET-STATUS, but only on those IDS that have not been cached
  49 yet.  Return new results alongside cached results."
  50   (let* ((cached (filter-map cached? ids))
  51          (uncached-ids (lset-difference eq?
  52                                         ids
  53                                         (map bug-num cached)))
  54          (new (soap-invoke* (%config 'debbugs) get-status uncached-ids)))
  55     ;; Cache new things
  56     (map (lambda (bug) (cache! (bug-num bug) bug)) new)
  57     ;; Return everything from cache
  58     (sort (append cached new) (lambda (a b) (< (bug-num a) (bug-num b))))))
  59
  60 (define-public (extract-name address)
  61   (or (assoc-ref address 'name)
  62       (and=> (assoc-ref address 'address)
  63              (lambda (address)
  64                (string-take address (string-index address #\@))))
  65       "Somebody"))
  66
  67 (define-public (extract-email address)
  68   (assoc-ref address 'address))
  69
  70 (define (header message key)
  71   (assoc-ref (email-headers message) key))
  72
  73 (define-public (sender message)
  74   (first (header message 'from)))
  75
  76 (define-public sender-email
  77   (compose extract-email sender))
  78
  79 (define-public (sender-name message)
  80   (extract-name (sender message)))
  81
  82 (define-public (date message)
  83   (header message 'date))
  84
  85 (define-public (subject message)
  86   (or (header message 'subject) "(no subject)"))
  87
  88 (define-public (message-id message)
  89   (header message 'message-id))
  90
  91 (define-public (participants messages)
  92   "Return a list of unique senders in the conversion."
  93   (apply lset-adjoin (lambda (a b)
  94                        (string= (extract-email a)
  95                                 (extract-email b)))
  96          '() (map sender messages)))
  97
  98 (define-public (recipients message)
  99   "Return a list of recipient email addresses for the given MESSAGE."
 100   (let ((headers (email-headers message)))
 101     (filter-map (match-lambda
 102                   (((or 'cc 'bcc 'to) val) val)
 103                   (_ #f)) headers)))
 104
 105 (define-public (closing? message id)
 106   "Is this MESSAGE closing this bug ID?"
 107   (let ((done (string-append (number->string id)
 108                              "-done")))
 109     (string= (header message 'x-debbugs-envelope-to) done)))
 110
 111 (define-public (bot? address)
 112   (string= "help-debbugs@gnu.org" address))
 113
 114 (define-public (internal-message? message)
 115   (bot? (sender-email message)))
 116
 117 \f
 118 (define (multipart-message? message)
 119   (eq? (assoc-ref (header message 'content-type)
 120                   'type)
 121        'multipart))
 122
 123 (define (extract-attachment id msg-num path)
 124   "Extract attachment from message number MSG-NUM in the thread for
 125 the bug with the given ID.  Follow PATH to get to the correct
 126 multipart chunk containing the attachment.  This is absolutely
 127 horrible because Debbugs does not let us access messages directly, so
 128 we have to do this in a very convoluted way."
 129   (define (nth n lst)
 130     (and (< n (length lst))
 131          (list-ref lst n)))
 132   (define (traverse path parts)
 133     (let loop ((path path)
 134                (parts parts))
 135       (match path
 136         ((pos) (nth pos parts))
 137         ((pos . rest)
 138          (loop rest
 139                (and=> (nth pos parts)
 140                       mime-entity-body))))))
 141   (and=> (fetch-bug id)
 142          (lambda (bug)
 143            (and=> (nth msg-num (patch-messages id))
 144                   (lambda (msg)
 145                     (cond
 146                      ((multipart-message? msg)
 147                       (traverse path (email-body msg)))
 148                      (else
 149                       (match path
 150                         (() msg)
 151                         (_ #f)))))))))
 152
 153 \f
 154 (define (download-message bug-id msg-num)
 155   "Download message number MSG-NUM of bug BUG-ID and store it in the
 156 mail directory if it's not already there.  Return the name of the
 157 target file."
 158   (let ((key (list 'download-message bug-id msg-num)))
 159     (or (cached? key)
 160         (cache! key
 161                 (let ((file-name (format #f "~a/cur/~a-~a"
 162                                          (%config 'mail-dir)
 163                                          bug-id msg-num)))
 164                   (if (file-exists? file-name) file-name
 165                       (begin
 166                         (format (current-error-port)
 167                                 "downloading ~a~%" file-name)
 168                         (call-with-values
 169                             (lambda ()
 170                               (fetch-mbox (%config 'debbugs)
 171                                           bug-id msg-num #:streaming? #t))
 172                           (lambda (response port)
 173                             (with-output-to-file file-name
 174                               (lambda ()
 175                                 (put-bytevector (current-output-port)
 176                                                 (get-bytevector-all port))))
 177                             (close-port port)
 178
 179                             ;; Reset mtime, because mu uses it!
 180                             (with-input-from-file file-name
 181                               (lambda ()
 182                                 (match (mbox->emails (current-input-port))
 183                                   ((email)
 184                                    (let* ((mail (parse-email email))
 185                                           (seconds
 186                                            (time-second
 187                                             (date->time-monotonic
 188                                              (date mail)))))
 189                                      (utime file-name
 190                                             seconds
 191                                             seconds)))
 192                                   (_ #f))))))
 193                         file-name)))))))
 194
 195 ;; We would like to use get-bug-log here, but it often returns
 196 ;; truncated messages.  This is a known bug upstream.
 197 (define-public (patch-messages bug-id)
 198   "Return list of messages relating to the bug BUG-ID.  Cache the
 199 result for a while."
 200   (let ((key (list 'patch-messages bug-id)))
 201     (or (cached? key)
 202         (cache! key
 203                 (match
 204                     (soap-invoke* (%config 'debbugs) get-bug-message-numbers bug-id)
 205                   ((msg-nums . _)
 206                    (map (lambda (msg-num)
 207                           (with-input-from-file (download-message bug-id msg-num)
 208                             (lambda ()
 209                               (match (mbox->emails (current-input-port))
 210                                 ((email) (parse-email email))
 211                                 (_ #f)))))
 212                         msg-nums)))))))
 213
 214 (define* (search-bugs query #:key (sets '()) (max 100))
 215   "Return a list of all bugs matching the given QUERY string.
 216 Interset the result with the id sets in the list SETS."
 217   (let* ((ids (delete-duplicates
 218                (map (compose string->number mu:bugid)
 219                     (mu:message-list query))))
 220          (filtered (match sets
 221                      (() ids)
 222                      (_ (apply lset-intersection eq? ids sets)))))
 223     (status-with-cache (if (> (length filtered) max)
 224                            (take filtered max) filtered))))
 225
 226 ;; TODO: This returns *any* matching debbugs bug, even if it is not
 227 ;; part of the default packages.
 228 (define (fetch-bug id)
 229   "Return the bug matching ID or #F."
 230   (match (soap-invoke* (%config 'debbugs) get-status (list id))
 231     (() #f)
 232     ((bug) bug)))
 233
 234 (define (recent-bugs amount)
 235   "Return up to AMOUNT bugs with most recent activity."
 236   (let* ((recent-ids
 237           (delete-duplicates
 238            (map (compose string->number mu:bugid)
 239                 (mu:message-list (string-append "date:1m..")))))
 240          (ids (take recent-ids (min amount (length recent-ids)))))
 241     (status-with-cache ids)))
 242
 243 (define (easy-bugs)
 244   "Return all bugs that have been tagged \"easy\"."
 245   (let ((ids (db:bugs-by-tag "easy")))
 246     (status-with-cache ids)))
 247
 248 (define* (bugs-by-severity severity #:optional status)
 249   "Return severe bugs."
 250   (let* ((severity-ids (db:bugs-by-severity severity))
 251          (ids (if status
 252                   (let ((status-ids (db:bugs-by-status status)))
 253                     (lset-intersection eq? severity-ids status-ids))
 254                   severity-ids)))
 255     (status-with-cache ids)))
 256
 257 (define punctuation?
 258   (cut char-set-contains? char-set:punctuation <>))
 259
 260 (define-public (process-query query)
 261   "Process the QUERY string and return a list of query terms and
 262 sets that need to overlap the result set."
 263   ;; Mu doesn't like punctuation.  Replace with spaces.
 264   (define (clean-term term)
 265     (string-map (match-lambda
 266                   ((? punctuation? c) #\space)
 267                   (c c))
 268                 term))
 269   (fold (lambda (term acc)
 270           (match acc
 271             ((#:terms terms
 272               #:sets fs)
 273              (match (string-split term #\:)
 274                ;; This is not supported by the Debbugs SOAP service,
 275                ;; so we filter locally.
 276                (("is" (or "done" "closed"))
 277                 `(#:terms ,terms
 278                   #:sets ,(cons (db:bugs-by-status "done") fs)))
 279                (("is" (or "open" "pending"))
 280                 `(#:terms ,terms
 281                   #:sets ,(cons (db:bugs-by-status "open") fs)))
 282                (("date" when)
 283                 `(#:terms ,(cons (string-append "date:" when) terms)
 284                   #:sets ,fs))
 285                ;; TODO: this should only be the title of the bug, not
 286                ;; the subject.
 287                (("title" title)
 288                 `(#:terms
 289                   ,(cons (string-append "subject:" (clean-term title))
 290                          terms)
 291                   #:sets ,fs))
 292                (("subject" subject)
 293                 `(#:terms
 294                   ,(cons (string-append "subject:" (clean-term subject))
 295                          terms)
 296                   #:sets ,fs))
 297                (("tag" tag)
 298                 `(#:terms ,terms
 299                   #:sets
 300                   ,(cons (db:bugs-by-tag (clean-term tag)) fs)))
 301                (("author" who)
 302                 `(#:terms
 303                   ,(cons (string-append "from:" (clean-term who)) terms)
 304                   #:sets ,fs))
 305                (("owner" who)
 306                 `(#:terms ,terms
 307                   #:sets ,(cons (db:bugs-by-owner who) fs)))
 308                (("submitter" who)
 309                 `(#:terms ,terms
 310                   #:sets ,(cons (db:bugs-by-submitter who) fs)))
 311                (("severity" level)
 312                 `(#:terms ,terms
 313                   #:sets ,(cons (db:bugs-by-severity level) fs)))
 314                ((whatever term)
 315                 `(#:terms ,(cons (clean-term term) terms)
 316                   #:sets ,fs))
 317                (_
 318                 `(#:terms ,(cons (clean-term term) terms)
 319                   #:sets ,fs))))))
 320         '(#:terms () #:sets ())
 321         (string-tokenize query)))