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 (or (email-headers message) '()) key))
  72
  73 (define-public (sender message)
  74   (or (and=> (header message 'from) first)
  75       "unknown sender"))
  76
  77 (define-public sender-email
  78   (compose extract-email sender))
  79
  80 (define-public (sender-name message)
  81   (extract-name (sender message)))
  82
  83 (define-public (date message)
  84   (or (header message 'date) "unknown date"))
  85
  86 (define-public (subject message)
  87   (or (header message 'subject) "(no subject)"))
  88
  89 (define-public (message-id message)
  90   (header message 'message-id))
  91
  92 (define-public (participants messages)
  93   "Return a list of unique senders in the conversion."
  94   (apply lset-adjoin (lambda (a b)
  95                        (string= (extract-email a)
  96                                 (extract-email b)))
  97          '() (map sender messages)))
  98
  99 (define-public (recipients message)
 100   "Return a list of recipient email addresses for the given MESSAGE."
 101   (let ((headers (or (email-headers message) '())))
 102     (filter-map (match-lambda
 103                   (((or 'cc 'bcc 'to) val) val)
 104                   (_ #f)) headers)))
 105
 106 (define-public (closing? message id)
 107   "Is this MESSAGE closing this bug ID?"
 108   (let ((done (string-append (number->string id)
 109                              "-done")))
 110     (string= (header message 'x-debbugs-envelope-to) done)))
 111
 112 (define-public (bot? address)
 113   (string= "help-debbugs@gnu.org" address))
 114
 115 (define-public (internal-message? message)
 116   (bot? (sender-email message)))
 117
 118 \f
 119 (define (multipart-message? message)
 120   (eq? (assoc-ref (header message 'content-type)
 121                   'type)
 122        'multipart))
 123
 124 (define (extract-attachment id msg-num path)
 125   "Extract attachment from message number MSG-NUM in the thread for
 126 the bug with the given ID.  Follow PATH to get to the correct
 127 multipart chunk containing the attachment.  This is absolutely
 128 horrible because Debbugs does not let us access messages directly, so
 129 we have to do this in a very convoluted way."
 130   (define (nth n lst)
 131     (and (< n (length lst))
 132          (list-ref lst n)))
 133   (define (traverse path parts)
 134     (let loop ((path path)
 135                (parts parts))
 136       (match path
 137         ((pos) (nth pos parts))
 138         ((pos . rest)
 139          (loop rest
 140                (and=> (nth pos parts)
 141                       mime-entity-body))))))
 142   (and=> (fetch-bug id)
 143          (lambda (bug)
 144            (and=> (nth msg-num (patch-messages id))
 145                   (lambda (msg)
 146                     (cond
 147                      ((multipart-message? msg)
 148                       (traverse path (email-body msg)))
 149                      (else
 150                       (match path
 151                         (() msg)
 152                         (_ #f)))))))))
 153
 154 \f
 155 (define (download-message bug-id msg-num)
 156   "Download message number MSG-NUM of bug BUG-ID and store it in the
 157 mail directory if it's not already there.  Return the name of the
 158 target file."
 159   (let ((key (list 'download-message bug-id msg-num)))
 160     (or (cached? key)
 161         (cache! key
 162                 (let ((file-name (format #f "~a/cur/~a-~a"
 163                                          (%config 'mail-dir)
 164                                          bug-id msg-num)))
 165                   (if (file-exists? file-name) file-name
 166                       (begin
 167                         (format (current-error-port)
 168                                 "downloading ~a~%" file-name)
 169                         (call-with-values
 170                             (lambda ()
 171                               (fetch-mbox (%config 'debbugs)
 172                                           bug-id msg-num #:streaming? #t))
 173                           (lambda (response port)
 174                             (with-output-to-file file-name
 175                               (lambda ()
 176                                 (put-bytevector (current-output-port)
 177                                                 (get-bytevector-all port))))
 178                             (close-port port)
 179
 180                             ;; Reset mtime, because mu uses it!
 181                             (with-input-from-file file-name
 182                               (lambda ()
 183                                 (match (mbox->emails (current-input-port))
 184                                   ((email)
 185                                    (let* ((mail (parse-email email))
 186                                           (seconds
 187                                            (time-second
 188                                             (date->time-monotonic
 189                                              (date mail)))))
 190                                      (utime file-name
 191                                             seconds
 192                                             seconds)))
 193                                   (_ #f))))))
 194                         file-name)))))))
 195
 196 ;; We would like to use get-bug-log here, but it often returns
 197 ;; truncated messages.  This is a known bug upstream.
 198 (define-public (patch-messages bug-id)
 199   "Return list of messages relating to the bug BUG-ID.  Cache the
 200 result for a while."
 201   (let ((key (list 'patch-messages bug-id)))
 202     (or (cached? key)
 203         (cache! key
 204                 (match
 205                     (soap-invoke* (%config 'debbugs) get-bug-message-numbers bug-id)
 206                   ((msg-nums . _)
 207                    (map (lambda (msg-num)
 208                           (with-input-from-file (download-message bug-id msg-num)
 209                             (lambda ()
 210                               (match (mbox->emails (current-input-port))
 211                                 ((email) (parse-email email))
 212                                 (_ #f)))))
 213                         msg-nums)))))))
 214
 215 (define* (search-bugs query #:key (sets '()) (max 100))
 216   "Return a list of all bugs matching the given QUERY string.
 217 Interset the result with the id sets in the list SETS."
 218   (let* ((ids (delete-duplicates
 219                (map (compose string->number mu:bugid)
 220                     (mu:message-list query))))
 221          (filtered (match sets
 222                      (() ids)
 223                      (_ (apply lset-intersection eq? ids sets)))))
 224     (status-with-cache (if (> (length filtered) max)
 225                            (take filtered max) filtered))))
 226
 227 ;; TODO: This returns *any* matching debbugs bug, even if it is not
 228 ;; part of the default packages.
 229 (define (fetch-bug id)
 230   "Return the bug matching ID or #F."
 231   (match (soap-invoke* (%config 'debbugs) get-status (list id))
 232     (() #f)
 233     ((bug) bug)))
 234
 235 (define (recent-bugs amount)
 236   "Return up to AMOUNT bugs with most recent activity."
 237   (let* ((recent-ids
 238           (delete-duplicates
 239            (map (compose string->number mu:bugid)
 240                 (mu:message-list (string-append "date:1m..")))))
 241          (ids (take recent-ids (min amount (length recent-ids)))))
 242     (status-with-cache ids)))
 243
 244 (define (easy-bugs)
 245   "Return all bugs that have been tagged \"easy\"."
 246   (let ((ids (db:bugs-by-tag "easy")))
 247     (status-with-cache ids)))
 248
 249 (define* (bugs-by-severity severity #:optional status)
 250   "Return severe bugs."
 251   (let* ((severity-ids (db:bugs-by-severity severity))
 252          (ids (if status
 253                   (let ((status-ids (db:bugs-by-status status)))
 254                     (lset-intersection eq? severity-ids status-ids))
 255                   severity-ids)))
 256     (status-with-cache ids)))
 257
 258 (define punctuation?
 259   (cut char-set-contains? char-set:punctuation <>))
 260
 261 (define-public (process-query query)
 262   "Process the QUERY string and return a list of query terms and
 263 sets that need to overlap the result set."
 264   ;; Mu doesn't like punctuation.  Replace with spaces.
 265   (define (clean-term term)
 266     (string-map (match-lambda
 267                   ((? punctuation? c) #\space)
 268                   (c c))
 269                 term))
 270   (fold (lambda (term acc)
 271           (match acc
 272             ((#:terms terms
 273               #:sets fs)
 274              (match (string-split term #\:)
 275                ;; This is not supported by the Debbugs SOAP service,
 276                ;; so we filter locally.
 277                (("is" (or "done" "closed"))
 278                 `(#:terms ,terms
 279                   #:sets ,(cons (db:bugs-by-status "done") fs)))
 280                (("is" (or "open" "pending"))
 281                 `(#:terms ,terms
 282                   #:sets ,(cons (db:bugs-by-status "open") fs)))
 283                (("date" when)
 284                 `(#:terms ,(cons (string-append "date:" when) terms)
 285                   #:sets ,fs))
 286                ;; TODO: this should only be the title of the bug, not
 287                ;; the subject.
 288                (("title" title)
 289                 `(#:terms
 290                   ,(cons (string-append "subject:" (clean-term title))
 291                          terms)
 292                   #:sets ,fs))
 293                (("subject" subject)
 294                 `(#:terms
 295                   ,(cons (string-append "subject:" (clean-term subject))
 296                          terms)
 297                   #:sets ,fs))
 298                (("tag" tag)
 299                 `(#:terms ,terms
 300                   #:sets
 301                   ,(cons (db:bugs-by-tag (clean-term tag)) fs)))
 302                (("author" who)
 303                 `(#:terms
 304                   ,(cons (string-append "from:" (clean-term who)) terms)
 305                   #:sets ,fs))
 306                (("owner" who)
 307                 `(#:terms ,terms
 308                   #:sets ,(cons (db:bugs-by-owner who) fs)))
 309                (("submitter" who)
 310                 `(#:terms ,terms
 311                   #:sets ,(cons (db:bugs-by-submitter who) fs)))
 312                (("severity" level)
 313                 `(#:terms ,terms
 314                   #:sets ,(cons (db:bugs-by-severity level) fs)))
 315                ((whatever term)
 316                 `(#:terms ,(cons (clean-term term) terms)
 317                   #:sets ,fs))
 318                (_
 319                 `(#:terms ,(cons (clean-term term) terms)
 320                   #:sets ,fs))))))
 321         '(#:terms () #:sets ())
 322         (string-tokenize query)))