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 (ice-9 threads)
  29   #:use-module (email email)
  30   #:use-module (mumi cache)
  31   #:use-module (mumi config)
  32   #:use-module (mumi debbugs)
  33   #:use-module (mumi xapian)
  34   #:use-module ((mumi bugs) #:prefix db:)
  35   #:use-module (web client)
  36   #:export (search-bugs
  37             fetch-bug
  38             recent-bugs
  39             forgotten-issues
  40             easy-bugs
  41             bugs-by-severity
  42
  43             multipart-message?
  44             extract-attachment
  45
  46             extract-name
  47             extract-email
  48             sender
  49             sender-email
  50             sender-name
  51             date
  52             subject
  53             message-id
  54             participants
  55             recipients
  56             closing?
  57             bot?
  58             internal-message?
  59
  60             issue-messages
  61             process-query))
  62
  63 (define (status-with-cache ids)
  64   "Invoke GET-STATUS, but only on those IDS that have not been cached
  65 yet.  Return new results alongside cached results."
  66   (let* ((cached (filter-map cached? ids))
  67          (uncached-ids (lset-difference eq?
  68                                         ids
  69                                         (map bug-num cached)))
  70          (new (filter-map bug-status uncached-ids )))
  71     ;; Cache new things
  72     (map (lambda (bug) (cache! (bug-num bug) bug)) new)
  73     ;; Return everything from cache
  74     (sort (append cached new) (lambda (a b) (< (bug-num a) (bug-num b))))))
  75
  76 (define (extract-name address)
  77   (or (assoc-ref address 'name)
  78       (and=> (assoc-ref address 'address)
  79              (lambda (address)
  80                (string-take address (string-index address #\@))))
  81       "Somebody"))
  82
  83 (define (extract-email address)
  84   (assoc-ref address 'address))
  85
  86 (define (header message key)
  87   (assoc-ref (or (email-headers message) '()) key))
  88
  89 (define (sender message)
  90   (or (and=> (header message 'from) first)
  91       '((name . "Unknown sender")
  92         (address . "unknown"))))
  93
  94 (define sender-email
  95   (compose extract-email sender))
  96
  97 (define (sender-name message)
  98   (extract-name (sender message)))
  99
 100 (define (date message)
 101   (or (header message 'date) "unknown date"))
 102
 103 (define (subject message)
 104   (or (header message 'subject) "(no subject)"))
 105
 106 (define (message-id message)
 107   (header message 'message-id))
 108
 109 (define (participants messages)
 110   "Return a list of unique senders in the conversion."
 111   (apply lset-adjoin (lambda (a b)
 112                        (string= (extract-email a)
 113                                 (extract-email b)))
 114          '() (map sender messages)))
 115
 116 (define (recipients message)
 117   "Return a list of recipient email addresses for the given MESSAGE."
 118   (let ((headers (or (email-headers message) '())))
 119     (filter-map (match-lambda
 120                   (((or 'cc 'bcc 'to) val) val)
 121                   (_ #f)) headers)))
 122
 123 (define (closing? message id)
 124   "Is this MESSAGE closing this bug ID?"
 125   (let ((done (string-append (number->string id)
 126                              "-done")))
 127     (and=> (header message 'x-debbugs-envelope-to)
 128            (cut string= <> done))))
 129
 130 (define (bot? address)
 131   (string= "help-debbugs@gnu.org" address))
 132
 133 (define (internal-message? message)
 134   (bot? (sender-email message)))
 135
 136 \f
 137 (define (multipart-message? message)
 138   (eq? (assoc-ref (header message 'content-type)
 139                   'type)
 140        'multipart))
 141
 142 (define (extract-attachment id msg-num path)
 143   "Extract attachment from message number MSG-NUM in the thread for
 144 the bug with the given ID.  Follow PATH to get to the correct
 145 multipart chunk containing the attachment.  This is absolutely
 146 horrible because Debbugs does not let us access messages directly, so
 147 we have to do this in a very convoluted way."
 148   (define (nth n lst)
 149     (and (< n (length lst))
 150          (list-ref lst n)))
 151   (define (traverse path parts)
 152     (let loop ((path path)
 153                (parts parts))
 154       (match path
 155         ((pos) (nth pos parts))
 156         ((pos . rest)
 157          (loop rest
 158                (and=> (nth pos parts)
 159                       mime-entity-body))))))
 160   (and=> (nth msg-num (issue-messages id))
 161          (lambda (msg)
 162            (cond
 163             ((multipart-message? msg)
 164              (traverse path (email-body msg)))
 165             (else
 166              (match path
 167                (() msg)
 168                (_ #f)))))))
 169
 170 \f
 171 ;; We would like to use get-bug-log here, but it often returns
 172 ;; truncated messages.  This is a known bug upstream.
 173 (define (issue-messages bug-id)
 174   "Return list of messages relating to the issue BUG-ID.  Cache the
 175 result for a while."
 176   (define archived-log
 177     (bug-id->log-file bug-id #:archived? #t))
 178   (define active-log
 179     (bug-id->log-file bug-id))
 180   (define file
 181     (or (and (file-exists? archived-log) archived-log)
 182         (and (file-exists? active-log) active-log)))
 183   (if file
 184       (let ((key (list 'issue-messages bug-id)))
 185         (or (cached? key)
 186             (cache! key
 187                     (call-with-input-file file
 188                       read-emails-from-bug-log))))
 189       '()))
 190
 191 (define* (search-bugs query #:key (sets '()) (max 400))
 192   "Return a list of all bugs matching the given QUERY string.
 193 Intersect the result with the id sets in the list SETS."
 194   (let* ((ids (delete-duplicates
 195                (map string->number
 196                     (search query))))
 197          (filtered (match sets
 198                      (() ids)
 199                      (_ (apply lset-intersection eq? ids sets)))))
 200     (status-with-cache (if (> (length filtered) max)
 201                            (take filtered max) filtered))))
 202
 203 (define fetch-bug bug-status)
 204
 205 (define (recent-bugs amount)
 206   "Return up to AMOUNT bugs with most recent activity."
 207   (let* ((recent-ids
 208           (sort
 209            (delete-duplicates
 210             (map string->number
 211                  (search "mdate:1m..")))
 212            <))
 213          (ids (take (reverse recent-ids)
 214                     (min amount (length recent-ids)))))
 215     (status-with-cache ids)))
 216
 217 (define (forgotten-issues amount)
 218   "Return up to AMOUNT issues that appear to have been forgotten
 219 about."
 220   (let* ((forgotten-ids (forgotten-bug-numbers (%config 'packages)))
 221          (ids (take (reverse forgotten-ids)
 222                     (min amount (length forgotten-ids)))))
 223     (status-with-cache ids)))
 224
 225 (define (easy-bugs)
 226   "Return all bugs that have been tagged \"easy\"."
 227   (let ((ids (db:bugs-by-tag "easy")))
 228     (status-with-cache ids)))
 229
 230 (define* (bugs-by-severity severity #:optional status)
 231   "Return severe bugs."
 232   (let* ((severity-ids (db:bugs-by-severity severity))
 233          (ids (if status
 234                   (let ((status-ids (db:bugs-by-status status)))
 235                     (lset-intersection eq? severity-ids status-ids))
 236                   severity-ids)))
 237     (status-with-cache ids)))
 238
 239 (define punctuation?
 240   (cut char-set-contains? char-set:punctuation <>))
 241
 242 (define (process-query query)
 243   "Process the QUERY string and return a list of query terms and
 244 sets that need to overlap the result set."
 245   ;; Xapian doesn't like punctuation.  Replace with spaces.  Leave
 246   ;; hyphens and quotes.
 247   (define (clean-term term)
 248     (string-map (match-lambda
 249                   ((and (or #\" #\-) c) c)
 250                   ((? punctuation? c) #\space)
 251                   (c c))
 252                 term))
 253   (fold (lambda (term terms)
 254           (match (string-split term #\:)
 255             (("is" (or "done" "closed"))
 256              (cons "status:done" terms))
 257             (("is" (or "open" "pending"))
 258              (cons "status:open" terms))
 259             (((and (or "date" "subject" "tag"
 260                        "author" "owner" "submitter"
 261                        "severity")
 262                    prefix) value)
 263              (cons (string-append prefix ":"
 264                                   (clean-term value))
 265                    terms))
 266             ;; TODO: this should only be the title of the bug, not
 267             ;; the subject.
 268             (("title" title)
 269              (cons (string-append "subject:" (clean-term title))
 270                    terms))
 271             (_
 272              (cons (clean-term term) terms))))
 273         '()
 274         (tokenize query)))