summaryrefslogtreecommitdiff
path: root/mumi/messages.scm
diff options
context:
space:
mode:
Diffstat (limited to 'mumi/messages.scm')
-rw-r--r--mumi/messages.scm249
1 files changed, 161 insertions, 88 deletions
diff --git a/mumi/messages.scm b/mumi/messages.scm
index 258b02d..9614852 100644
--- a/mumi/messages.scm
+++ b/mumi/messages.scm
@@ -1,5 +1,5 @@
;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
@@ -16,107 +16,180 @@
;;; <http://www.gnu.org/licenses/>.
(define-module (mumi messages)
- #:use-module (mu)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 optargs)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
- #:use-module (mumi queries))
+ #:use-module (debbugs soap)
+ #:use-module (debbugs operations)
+ #:use-module (debbugs email)
+ #:use-module (debbugs bug)
+ #:use-module (mumi config)
+ #:use-module (mailutils mailutils)
+ #:export (search-bugs fetch-bug recent-bugs))
-(define-public (extract-address str)
- "Extract an email address from an address string."
- (let ((m (string-match ".*<([^@]+@[^>]+)>" str)))
- (if m (match:substring m 1) str)))
+;; TODO: mu-address-get-personal skips non ASCII characters
+;; ex: (mu-address-get-personal "ludo@gnu.org (Ludovic Courtès)")
+;; => "Ludovic Courts"
+(define-public (extract-name address)
+ (let ((name (mu-header-decode (mu-address-get-personal address))))
+ (if (string-null? name) "Somebody" name)))
-(define-public (recipients message)
- "Return a list of recipient email addresses for the given MESSAGE."
- (append-map (lambda (address-string)
- (map (compose extract-address string-trim)
- (string-split address-string #\,)))
- (filter identity (list (mu:to message)
- (mu:cc message)
- (mu:bcc message)))))
+(define-public extract-email mu-address-get-email)
-(define-public sender (compose extract-address mu:from))
+(define (header message key)
+ (first (assoc-ref (email-headers message) key)))
-(define-public (participants messages)
- "Return a list of unique email addresses in the conversion."
- (apply lset-adjoin string= '()
- (map sender messages)))
+(define-public (sender message)
+ (header message "from"))
+
+(define-public sender-email
+ (compose mu-address-get-email sender))
+
+(define-public (sender-name message)
+ (extract-name (sender message)))
-;; TODO: build a different version of "mu index" to also index
-;; X-GNU-PR-* headers?
+(define-public (date message)
+ (header message "date"))
-(define-public (action message)
- "Return the debbugs action MESSAGE."
- (mu:header message "X-GNU-PR-Message"))
+(define-public (subject message)
+ (header message "subject"))
-(define-public (report? message)
- (let ((action (action message)))
- (and action (string-prefix? "report " action))))
+(define-public (message-id message)
+ (header message "message-id"))
+
+(define-public (participants messages)
+ "Return a list of unique senders in the conversion."
+ (apply lset-adjoin (lambda (a b)
+ (string= (mu-address-get-email a)
+ (mu-address-get-email b)))
+ '() (map sender messages)))
+
+(define-public (recipients message)
+ "Return a list of recipient email addresses for the given MESSAGE."
+ (let ((headers (email-headers message)))
+ (filter-map (match-lambda
+ (((or "cc" "bcc" "to") val) val)
+ (_ #f)) headers)))
-;; We cannot rely on the action header alone.
-(define-public (closing? message)
- (let ((action (action message)))
- (or (and action (string-prefix? "cc-closed " action))
- (find (cut string-suffix? "-done@debbugs.gnu.org" <>)
- (recipients message)))))
+(define-public (closing? message id)
+ "Is this MESSAGE closing this bug ID?"
+ (let ((done (string-append (number->string id)
+ "-done")))
+ (string= (header message "x-debbugs-envelope-to") done)))
-(define-public (owner? message)
- (let ((action (action message)))
- (and action (string-prefix? "owner " action))))
+(define-public (bot? address)
+ (string= "help-debbugs@gnu.org" address))
-(define-public (owner messages)
- "Return the owner of this patch or #F if unassigned."
- (and=> (find owner? messages)
- sender))
+(define-public (internal-message? message)
+ (bot? (sender-email message)))
(define-public (patch-messages id)
- "Return list of messages relating to the patch ID."
- (let ((address (string-append id "@debbugs.gnu.org"))
- (done (string-append id "-done@debbugs.gnu.org")))
- (sort-list (mu:message-list (query-or (string-append "recip:" address)
- (string-append "recip:" done)))
- (lambda (a b) (< (mu:date a) (mu:date b))))))
-
-(define-public (patch-report id)
- "Return the original report for the MESSAGE associated with the
-given patch ID, or return #F."
- (let* ((address (string-append id "@debbugs.gnu.org"))
- (reports (filter report? (mu:message-list
- (string-append "to:" address)))))
- (if (null? reports) #f (car reports))))
-
-(define-public (unique-reports messages)
- "Return a list of original reports for all given MESSAGES."
- (let ((unique-ids (apply lset-adjoin string= '()
- (map patch-id messages))))
- (sort-list (filter-map patch-report unique-ids)
- ;; Newest first
- (lambda (a b) (> (mu:date a) (mu:date b))))))
-
-(define-public (patch-id message)
- "Return the patch number from the given MESSAGE."
- (or (and=> (action message)
- (compose number->string string->number last string-tokenize))
- (let ((address (find (cut string-suffix? "@debbugs.gnu.org" <>)
- (recipients message))))
- (and=> address
- (lambda (address)
- (first (string-split (first (string-split address #\@)) #\-)))))
- "UNKNOWN"))
-
-(define*-public (patch-actions messages)
- "Return a list of actions for the given patch ID or the set of
-MESSAGES. Ignore follow events."
- (filter (cut string-prefix? "followup " <>)
- (filter-map action messages)))
-
-;; TODO: can a bug be reopened again?
-(define-public (status messages)
- (if (find closing? messages) "closed" "open"))
-
-(define*-public (all-patches #:optional messages)
- "Return all messages that are of the report action type."
- (filter report? (or messages (mu:message-list))))
+ "Return list of messages relating to the bug ID."
+ ;; TODO: sort by date necessary?
+ (soap-invoke* (%config 'debbugs) get-bug-log id))
+
+
+(define* (search-bugs query #:key (attributes '()) (max 100))
+ "Return a list of all bugs matching the given QUERY string."
+ (let* ((matches (soap-invoke* (%config 'debbugs)
+ search-est
+ query
+ #:max max
+ #:attributes
+ (append attributes
+ '((package string-prefix "guix")))))
+ (ids (filter-map (lambda (item)
+ (assoc-ref item "id"))
+ matches)))
+ (soap-invoke* (%config 'debbugs) get-status ids)))
+
+;; TODO: This returns *any* matching debbugs bug, even if it is not
+;; part of the default packages.
+(define (fetch-bug id)
+ "Return the bug matching ID or #F."
+ (match (soap-invoke* (%config 'debbugs) get-status (list id))
+ (() #f)
+ ((bug) bug)))
+
+(define (recent-bugs amount)
+ "Return up to AMOUNT bugs with most recent activity."
+ ;; "search-est" does not return unique items, so we have to take
+ ;; more and then filter the results. To allow for caching we round
+ ;; off the current time to the start of the hour.
+ (let* ((matches
+ (soap-invoke* (%config 'debbugs)
+ search-est
+ ""
+ #:max 50
+ #:attributes
+ `((package string-prefix "guix")
+ (@cdate >= ,(let ((this-hour
+ (date->time-utc (let ((now (current-date)))
+ (make-date 0 0 0 (date-hour now)
+ (date-day now)
+ (date-month now)
+ (date-year now) 0))))
+ (one-month
+ (make-time time-duration 0 (* 60 60 24 30))))
+ (time-second (subtract-duration this-hour one-month)))))))
+ (ids (take (delete-duplicates
+ (filter-map (lambda (item)
+ (assoc-ref item "id"))
+ matches)) amount)))
+ (soap-invoke* (%config 'debbugs) get-status ids)))
+
+(define-public (process-query query)
+ "Process the QUERY string and return two values: the remaining
+unprocessed query string and an alist of search attributes."
+ (fold (lambda (term acc)
+ (match acc
+ ((#:terms terms
+ #:attributes attrs
+ #:filters fs)
+ (match (string-split term #\:)
+ ;; This is not supported by the Debbugs SOAP service,
+ ;; so we filter locally.
+ (("is" (or "done" "closed"))
+ `(#:terms ,terms
+ #:attributes ,attrs
+ #:filters
+ ,(cons bug-done fs)))
+ (("is" (or "open" "pending"))
+ `(#:terms ,terms
+ #:attributes ,attrs
+ #:filters
+ ,(cons (negate bug-done) fs)))
+ (("title" title)
+ `(#:terms ,terms
+ #:attributes ,(cons `(subject string-contains ,title) attrs)
+ #:filters ,fs))
+ (("tag" tag)
+ `(#:terms ,terms
+ #:attributes ,(cons `(tags string= ,tag) attrs)
+ #:filters ,fs))
+ (("author" who)
+ `(#:terms ,terms
+ #:attributes ,(cons `(@author string-contains ,who) attrs)
+ #:filters ,fs))
+ ;; This is not supported by the Debbugs SOAP service,
+ ;; so we filter locally.
+ (("submitter" who)
+ `(#:terms ,terms
+ #:attributes ,attrs
+ #:filters ,(cons (lambda (bug)
+ (string-contains-ci (bug-originator bug)
+ who))
+ fs)))
+ (("severity" level)
+ `(#:terms ,terms
+ #:attributes ,(cons `(severity string= ,level) attrs)
+ #:filters ,fs))
+ (_
+ `(#:terms ,(cons term terms)
+ #:attributes ,attrs
+ #:filters ,fs))))))
+ '(#:terms () #:attributes () #:filters ())
+ (string-tokenize query)))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 00:54:39 +0000