mumi/messages.scm

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