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 (mumimu)
  35   #:export (search-bugs
  36             fetch-bug
  37             recent-bugs
  38             easy-bugs
  39             bugs-by-severity
  40
  41             download-message
  42
  43             multipart-message?
  44             extract-attachment))
  45
  46 (define (status-with-cache ids)
  47   "Invoke GET-STATUS, but only on those IDS that have not been cached
  48 yet.  Return new results alongside cached results."
  49   (let* ((cached (filter-map cached? ids))
  50          (uncached-ids (lset-difference eq?
  51                                         ids
  52                                         (map bug-num cached)))
  53          (new (soap-invoke* (%config 'debbugs) get-status uncached-ids)))
  54     ;; Cache new things
  55     (map (lambda (bug) (cache! (bug-num bug) bug)) new)
  56     ;; Return everything from cache
  57     (sort (append cached new) (lambda (a b) (< (bug-num a) (bug-num b))))))
  58
  59 (define-public (extract-name address)
  60   (or (assoc-ref address 'name)
  61       (and=> (assoc-ref address 'address)
  62              (lambda (address)
  63                (string-take address (string-index address #\@))))
  64       "Somebody"))
  65
  66 (define-public (extract-email address)
  67   (assoc-ref address 'address))
  68
  69 (define (header message key)
  70   (assoc-ref (email-headers message) key))
  71
  72 (define-public (sender message)
  73   (first (header message 'from)))
  74
  75 (define-public sender-email
  76   (compose extract-email sender))
  77
  78 (define-public (sender-name message)
  79   (extract-name (sender message)))
  80
  81 (define-public (date message)
  82   (header message 'date))
  83
  84 (define-public (subject message)
  85   (or (header message 'subject) "(no subject)"))
  86
  87 (define-public (message-id message)
  88   (header message 'message-id))
  89
  90 (define-public (participants messages)
  91   "Return a list of unique senders in the conversion."
  92   (apply lset-adjoin (lambda (a b)
  93                        (string= (extract-email a)
  94                                 (extract-email b)))
  95          '() (map sender messages)))
  96
  97 (define-public (recipients message)
  98   "Return a list of recipient email addresses for the given MESSAGE."
  99   (let ((headers (email-headers message)))
 100     (filter-map (match-lambda
 101                   (((or 'cc 'bcc 'to) val) val)
 102                   (_ #f)) headers)))
 103
 104 (define-public (closing? message id)
 105   "Is this MESSAGE closing this bug ID?"
 106   (let ((done (string-append (number->string id)
 107                              "-done")))
 108     (string= (header message 'x-debbugs-envelope-to) done)))
 109
 110 (define-public (bot? address)
 111   (string= "help-debbugs@gnu.org" address))
 112
 113 (define-public (internal-message? message)
 114   (bot? (sender-email message)))
 115
 116 \f
 117 (define (multipart-message? message)
 118   (eq? (assoc-ref (header message 'content-type)
 119                   'type)
 120        'multipart))
 121
 122 (define (extract-attachment id msg-num path)
 123   "Extract attachment from message number MSG-NUM in the thread for
 124 the bug with the given ID.  Follow PATH to get to the correct
 125 multipart chunk containing the attachment.  This is absolutely
 126 horrible because Debbugs does not let us access messages directly, so
 127 we have to do this in a very convoluted way."
 128   (define (nth n lst)
 129     (and (< n (length lst))
 130          (list-ref lst n)))
 131   (define (traverse path parts)
 132     (let loop ((path path)
 133                (parts parts))
 134       (match path
 135         ((pos) (nth pos parts))
 136         ((pos . rest)
 137          (loop rest
 138                (and=> (nth pos parts)
 139                       mime-entity-body))))))
 140   (and=> (fetch-bug id)
 141          (lambda (bug)
 142            (and=> (nth msg-num (patch-messages id))
 143                   (lambda (msg)
 144                     (cond
 145                      ((multipart-message? msg)
 146                       (traverse path (email-body msg)))
 147                      (else
 148                       (match path
 149                         (() msg)
 150                         (_ #f)))))))))
 151
 152 \f
 153 (define (download-message bug-id msg-num)
 154   "Download message number MSG-NUM of bug BUG-ID and store it in the
 155 mail directory if it's not already there.  Return the name of the
 156 target file."
 157   (let ((key (list 'download-message bug-id msg-num)))
 158     (or (cached? key)
 159         (cache! key
 160                 (let ((file-name (format #f "~a/cur/~a-~a"
 161                                          (%config 'mail-dir)
 162                                          bug-id msg-num)))
 163                   (if (file-exists? file-name) file-name
 164                       (begin
 165                         (format (current-error-port)
 166                                 "downloading ~a~%" file-name)
 167                         (call-with-values
 168                             (lambda ()
 169                               (fetch-mbox (%config 'debbugs)
 170                                           bug-id msg-num #:streaming? #t))
 171                           (lambda (response port)
 172                             (with-output-to-file file-name
 173                               (lambda ()
 174                                 (put-bytevector (current-output-port)
 175                                                 (get-bytevector-all port))))
 176                             (close-port port)))
 177                         file-name)))))))
 178
 179 ;; We would like to use get-bug-log here, but it often returns
 180 ;; truncated messages.  This is a known bug upstream.
 181 (define-public (patch-messages bug-id)
 182   "Return list of messages relating to the bug BUG-ID.  Cache the
 183 result for a while."
 184   (let ((key (list 'patch-messages bug-id)))
 185     (or (cached? key)
 186         (cache! key
 187                 (match
 188                     (soap-invoke* (%config 'debbugs) get-bug-message-numbers bug-id)
 189                   ((msg-nums . _)
 190                    (map (lambda (msg-num)
 191                           (with-input-from-file (download-message bug-id msg-num)
 192                             (lambda ()
 193                               (match (mbox->emails (current-input-port))
 194                                 ((email) (parse-email email))
 195                                 (_ #f)))))
 196                         msg-nums)))))))
 197
 198 (define* (search-bugs query #:key (attributes '()) (max 100))
 199   "Return a list of all bugs matching the given QUERY string."
 200   (let* ((matches (soap-invoke* (%config 'debbugs)
 201                                 search-est
 202                                 query
 203                                 #:max max
 204                                 #:attributes
 205                                 (append attributes
 206                                         '((package string-prefix "guix")))))
 207          (ids (filter-map (lambda (item)
 208                             (assoc-ref item "id"))
 209                           matches)))
 210     (status-with-cache ids)))
 211
 212 ;; TODO: This returns *any* matching debbugs bug, even if it is not
 213 ;; part of the default packages.
 214 (define (fetch-bug id)
 215   "Return the bug matching ID or #F."
 216   (match (soap-invoke* (%config 'debbugs) get-status (list id))
 217     (() #f)
 218     ((bug) bug)))
 219
 220 (define (recent-bugs amount)
 221   "Return up to AMOUNT bugs with most recent activity."
 222   (let* ((recent-ids
 223           (delete-duplicates
 224            (map mu:bugid (mu:message-list (string-append "date:1m..")))))
 225          (ids (take recent-ids (min amount (length recent-ids)))))
 226     (status-with-cache ids)))
 227
 228 (define (easy-bugs)
 229   "Return all bugs that have been tagged \"easy\"."
 230   (let ((ids
 231          (soap-invoke* (%config 'debbugs)
 232                        get-bugs
 233                        '((package . "guix") (tag . "easy")))))
 234     (status-with-cache ids)))
 235
 236 (define* (bugs-by-severity severity #:optional status)
 237   "Return severe bugs."
 238   (let* ((ids
 239           (soap-invoke* (%config 'debbugs)
 240                         get-bugs
 241                         `((package . "guix")
 242                           (severity . ,severity)
 243                           ,@(if status `((status . ,status)) '())))))
 244     (status-with-cache ids)))
 245
 246 (define (ago unit amount)
 247   "Return the point in time that lies AMOUNT UNITs in the past."
 248   (let ((amount* (match unit
 249                    ('hours amount)
 250                    ('days (* 24 amount))
 251                    ('weeks (* 24 7 amount))
 252                    ('months (* 24 30 amount))
 253                    ('years (* 24 365 amount)))))
 254     (subtract-duration (date->time-utc (current-date))
 255                        (make-time time-duration 0 (* 60 60 amount*)))))
 256
 257 (define (date-term->epoch-seconds term)
 258   "Convert a date search term string into seconds since the epoch, or
 259 return #F if the term is invalid."
 260   (match term
 261     ("now" 'now)
 262     ("today" (time-second (ago 'days 1)))
 263     ("yesterday" (time-second (ago 'days 2)))
 264     (_
 265      (cond
 266       ;; TODO: support more date template strings
 267       ((or (false-if-exception (string->date term "~Y~m~d"))
 268            (false-if-exception (string->date term "~Y-~m-~d")))
 269        => (lambda (date)
 270             (time-second (date->time-utc date))))
 271       ;; e.g. "12h" meaning "12 hours ago"
 272       ((string->number (string-drop-right term 1))
 273        => (lambda (amount)
 274             (match (string-take-right term 1)
 275               ("h"
 276                (time-second (ago 'hours amount)))
 277               ("d"
 278                (time-second (ago 'days amount)))
 279               ("w"
 280                (time-second (ago 'weeks amount)))
 281               ("m"
 282                (time-second (ago 'months amount)))
 283               ("y"
 284                (time-second (ago 'years amount)))
 285               (_ #f))))
 286       (else #f)))))
 287
 288 (define-public (process-query query)
 289   "Process the QUERY string and return two values: the remaining
 290 unprocessed query string and an alist of search attributes."
 291   (fold (lambda (term acc)
 292           (match acc
 293             ((#:terms terms
 294               #:attributes attrs
 295               #:filters fs)
 296              (match (string-split term #\:)
 297                ;; This is not supported by the Debbugs SOAP service,
 298                ;; so we filter locally.
 299                (("is" (or "done" "closed"))
 300                 `(#:terms ,terms
 301                   #:attributes ,attrs
 302                   #:filters
 303                   ,(cons bug-done fs)))
 304                (("is" (or "open" "pending"))
 305                 `(#:terms ,terms
 306                   #:attributes ,attrs
 307                   #:filters
 308                   ,(cons (negate bug-done) fs)))
 309                ;; "date" for submission date, "mdate" for message date.
 310                (((and (or "date" "mdate") type) when)
 311                 (let ((date-attribute (match type
 312                                         ("date" 'date)
 313                                         ("mdate" '@cdate)))
 314                       (pat "(yesterday|today|now|[1-9][0-9]*(h|d|w|m|y)|[0-9]+)"))
 315                   (or (match (map (compose date-term->epoch-seconds
 316                                            match:substring)
 317                                   (list-matches pat when))
 318                         ((and ((? number? start)
 319                                (? number? end))
 320                               range)
 321                          (match (sort range <)
 322                            ((start end)
 323                             `(#:terms ,terms
 324                               #:attributes ,(cons `(,date-attribute >< ,start ,end) attrs)
 325                               #:filters ,fs))))
 326                         ((or ('now (? number? since))
 327                              ((? number? since) 'now))
 328                          `(#:terms ,terms
 329                            #:attributes ,(cons `(,date-attribute > ,since) attrs)
 330                            #:filters ,fs))
 331                         (_ #f))
 332                       ;; Invalid, don't do anything.
 333                       `(#:terms ,terms
 334                         #:attributes ,attrs
 335                         #:filters ,fs))))
 336                (("title" title)
 337                 `(#:terms ,terms
 338                   #:attributes ,(cons `(subject string-contains ,title) attrs)
 339                   #:filters ,fs))
 340                (("tag" tag)
 341                 `(#:terms ,terms
 342                   #:attributes ,(cons `(tags string= ,tag) attrs)
 343                   #:filters ,fs))
 344                (("author" who)
 345                 `(#:terms ,terms
 346                   #:attributes ,(cons `(@author string-contains ,who) attrs)
 347                   #:filters ,fs))
 348                ;; This is not supported by the Debbugs SOAP service,
 349                ;; so we filter locally.  At least we know that we need
 350                ;; bugs where the author is "who".
 351                (("submitter" who)
 352                 `(#:terms ,terms
 353                   #:attributes ,(cons `(@author string-contains ,who) attrs)
 354                   #:filters ,(cons (lambda (bug)
 355                                      (string-contains-ci (bug-originator bug)
 356                                                          who))
 357                                    fs)))
 358                (("severity" level)
 359                 `(#:terms ,terms
 360                   #:attributes ,(cons `(severity string= ,level) attrs)
 361                   #:filters ,fs))
 362                (_
 363                 `(#:terms ,(cons term terms)
 364                   #:attributes ,attrs
 365                   #:filters ,fs))))))
 366         '(#:terms () #:attributes () #:filters ())
 367         (string-tokenize query)))