mumi/messages.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
   3 ;;;
   4 ;;; This program is free software: you can redistribute it and/or
   5 ;;; modify it under the terms of the GNU Affero General Public License
   6 ;;; as published by the Free Software Foundation, either version 3 of
   7 ;;; the License, or (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Affero General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Affero General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 (define-module (mumi messages)
  19   #:use-module (srfi srfi-1)
  20   #:use-module (srfi srfi-19)
  21   #:use-module (srfi srfi-26)
  22   #:use-module (ice-9 optargs)
  23   #:use-module (ice-9 regex)
  24   #:use-module (ice-9 match)
  25   #:use-module (debbugs soap)
  26   #:use-module (debbugs operations)
  27   #:use-module (debbugs email)
  28   #:use-module (debbugs bug)
  29   #:use-module (mumi config)
  30   #:use-module (mailutils mailutils)
  31   #:export (search-bugs fetch-bug recent-bugs))
  32
  33 ;; TODO: mu-address-get-personal skips non ASCII characters
  34 ;; ex: (mu-address-get-personal "ludo@gnu.org (Ludovic Courtès)")
  35 ;; => "Ludovic Courts"
  36 (define-public (extract-name address)
  37   (let ((name (mu-header-decode (mu-address-get-personal address))))
  38     (if (string-null? name) "Somebody" name)))
  39
  40 (define-public extract-email mu-address-get-email)
  41
  42 (define (header message key)
  43   (first (assoc-ref (email-headers message) key)))
  44
  45 (define-public (sender message)
  46   (header message "from"))
  47
  48 (define-public sender-email
  49   (compose mu-address-get-email sender))
  50
  51 (define-public (sender-name message)
  52   (extract-name (sender message)))
  53
  54 (define-public (date message)
  55   (header message "date"))
  56
  57 (define-public (subject message)
  58   (header message "subject"))
  59
  60 (define-public (message-id message)
  61   (header message "message-id"))
  62
  63 (define-public (participants messages)
  64   "Return a list of unique senders in the conversion."
  65   (apply lset-adjoin (lambda (a b)
  66                        (string= (mu-address-get-email a)
  67                                 (mu-address-get-email b)))
  68          '() (map sender messages)))
  69
  70 (define-public (recipients message)
  71   "Return a list of recipient email addresses for the given MESSAGE."
  72   (let ((headers (email-headers message)))
  73     (filter-map (match-lambda
  74                   (((or "cc" "bcc" "to") val) val)
  75                   (_ #f)) headers)))
  76
  77 (define-public (closing? message id)
  78   "Is this MESSAGE closing this bug ID?"
  79   (let ((done (string-append (number->string id)
  80                              "-done")))
  81     (string= (header message "x-debbugs-envelope-to") done)))
  82
  83 (define-public (bot? address)
  84   (string= "help-debbugs@gnu.org" address))
  85
  86 (define-public (internal-message? message)
  87   (bot? (sender-email message)))
  88
  89 (define-public (patch-messages id)
  90   "Return list of messages relating to the bug ID."
  91   ;; TODO: sort by date necessary?
  92   (soap-invoke* (%config 'debbugs) get-bug-log id))
  93
  94 \f
  95 (define* (search-bugs query #:key (attributes '()) (max 100))
  96   "Return a list of all bugs matching the given QUERY string."
  97   (let* ((matches (soap-invoke* (%config 'debbugs)
  98                                 search-est
  99                                 query
 100                                 #:max max
 101                                 #:attributes
 102                                 (append attributes
 103                                         '((package string-prefix "guix")))))
 104          (ids (filter-map (lambda (item)
 105                             (assoc-ref item "id"))
 106                           matches)))
 107     (soap-invoke* (%config 'debbugs) get-status ids)))
 108
 109 ;; TODO: This returns *any* matching debbugs bug, even if it is not
 110 ;; part of the default packages.
 111 (define (fetch-bug id)
 112   "Return the bug matching ID or #F."
 113   (match (soap-invoke* (%config 'debbugs) get-status (list id))
 114     (() #f)
 115     ((bug) bug)))
 116
 117 (define (recent-bugs amount)
 118   "Return up to AMOUNT bugs with most recent activity."
 119   ;; "search-est" does not return unique items, so we have to take
 120   ;; more and then filter the results.  To allow for caching we round
 121   ;; off the current time to the start of the hour.
 122   (let* ((matches
 123           (soap-invoke* (%config 'debbugs)
 124                         search-est
 125                         ""
 126                         #:max 50
 127                         #:attributes
 128                         `((package string-prefix "guix")
 129                           (@cdate >= ,(let ((this-hour
 130                                              (date->time-utc (let ((now (current-date)))
 131                                                                (make-date 0 0 0 (date-hour now)
 132                                                                           (date-day now)
 133                                                                           (date-month now)
 134                                                                           (date-year now) 0))))
 135                                             (one-month
 136                                              (make-time time-duration 0 (* 60 60 24 30))))
 137                                         (time-second (subtract-duration this-hour one-month)))))))
 138          (ids (take (delete-duplicates
 139                      (filter-map (lambda (item)
 140                                    (assoc-ref item "id"))
 141                                  matches)) amount)))
 142     (soap-invoke* (%config 'debbugs) get-status ids)))
 143
 144 (define-public (process-query query)
 145   "Process the QUERY string and return two values: the remaining
 146 unprocessed query string and an alist of search attributes."
 147   (fold (lambda (term acc)
 148           (match acc
 149             ((#:terms terms
 150               #:attributes attrs
 151               #:filters fs)
 152              (match (string-split term #\:)
 153                ;; This is not supported by the Debbugs SOAP service,
 154                ;; so we filter locally.
 155                (("is" (or "done" "closed"))
 156                 `(#:terms ,terms
 157                   #:attributes ,attrs
 158                   #:filters
 159                   ,(cons bug-done fs)))
 160                (("is" (or "open" "pending"))
 161                 `(#:terms ,terms
 162                   #:attributes ,attrs
 163                   #:filters
 164                   ,(cons (negate bug-done) fs)))
 165                (("title" title)
 166                 `(#:terms ,terms
 167                   #:attributes ,(cons `(subject string-contains ,title) attrs)
 168                   #:filters ,fs))
 169                (("tag" tag)
 170                 `(#:terms ,terms
 171                   #:attributes ,(cons `(tags string= ,tag) attrs)
 172                   #:filters ,fs))
 173                (("author" who)
 174                 `(#:terms ,terms
 175                   #:attributes ,(cons `(@author string-contains ,who) attrs)
 176                   #:filters ,fs))
 177                ;; This is not supported by the Debbugs SOAP service,
 178                ;; so we filter locally.
 179                (("submitter" who)
 180                 `(#:terms ,terms
 181                   #:attributes ,attrs
 182                   #:filters ,(cons (lambda (bug)
 183                                      (string-contains-ci (bug-originator bug)
 184                                                          who))
 185                                    fs)))
 186                (("severity" level)
 187                 `(#:terms ,terms
 188                   #:attributes ,(cons `(severity string= ,level) attrs)
 189                   #:filters ,fs))
 190                (_
 191                 `(#:terms ,(cons term terms)
 192                   #:attributes ,attrs
 193                   #:filters ,fs))))))
 194         '(#:terms () #:attributes () #:filters ())
 195         (string-tokenize query)))