Goodbye mu, hello guile-debbugs!
[software/mumi.git] / 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)))