debbugs: Add bug-status.

* mumi/debbugs.scm (<bug-status>): New record type.
(qp-pattern): New variable.
(bug-status, bug-status?, bug-num, bug-archived, bug-blockedby,
bug-blocks, bug-date, bug-done, bug-mergedwith, bug-originator,
bug-owner, bug-severity, bug-subject, bug-tags): New procedures.

1 files changed, 82 insertions, 1 deletions

diff --git a/mumi/debbugs.scm b/mumi/debbugs.scm
index f292ecc..005d16b 100644
--- a/mumi/debbugs.scm
+++ b/mumi/debbugs.scm
@@ -19,16 +19,37 @@
   #:use-module (mumi config)
   #:use-module (debbugs cache)
   #:use-module (email email)
+  #:use-module (email quoted-printable)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
   #:export (read-emails-from-bug-log
             extract-bug-numbers
             forgotten-bug-numbers
             bug-id->log-file
-            bug-id->summary-file))
+            bug-id->summary-file
+
+            bug-status
+            bug-status?
+
+            bug-num
+            bug-archived
+            bug-blockedby
+            bug-blocks
+            bug-date
+            bug-done
+            bug-mergedwith
+            bug-originator
+            bug-owner
+            bug-severity
+            bug-subject
+            bug-tags))
 
 (define* (read-emails-from-bug-log port
                                    #:optional (keep '(incoming-recv)))
@@ -204,3 +225,63 @@ defaults to 30 days."
     (find file-exists?
           (list (candidate #f)
                 (candidate #t)))))
+
+
+(define-record-type <bug-status>
+  (make-bug-status num
+                   archived blockedby blocks date done mergedwith
+                   originator owner severity subject tags)
+  bug-status?
+  (num bug-num)
+  (archived bug-archived)
+  (blockedby bug-blockedby)
+  (blocks bug-blocks)
+  (date bug-date)
+  (done bug-done)
+  (mergedwith bug-mergedwith)
+  (originator bug-originator)
+  (owner bug-owner)
+  (severity bug-severity)
+  (subject bug-subject)
+  (tags bug-tags))
+
+(define qp-pattern "=\\?UTF-8\\?Q\\?([^?]+)\\?=")
+(define (bug-status bug-id)
+  (and-let* ((bug-id (if (number? bug-id) bug-id
+                         (string->number bug-id)))
+             (file (bug-id->summary-file bug-id))
+             (properties
+              (call-with-input-file file
+                (lambda (port)
+                  (let loop ((props '()))
+                    (let ((line (read-line port)))
+                      (if (eof-object? line) props
+                          (let* ((split-point (string-index line #\:))
+                                 (key (string-take line split-point))
+                                 (value (string-drop line (1+ split-point))))
+                            (loop (cons (cons key
+                                              (string-trim-both value))
+                                        props))))))))))
+    (make-bug-status bug-id
+                     (string-contains "/archive/" file)
+                     (assoc-ref properties "Blocked-By")
+                     (assoc-ref properties "Blocks")
+                     (time-monotonic->date
+                      (make-time time-monotonic
+                                 0
+                                 (string->number (assoc-ref properties "Date"))))
+                     (assoc-ref properties "Done")
+                     (assoc-ref properties "Merged-With")
+                     (assoc-ref properties "Submitter")
+                     (assoc-ref properties "Owner")
+                     (assoc-ref properties "Severity")
+                     (let ((subject (assoc-ref properties "Subject")))
+                       (if (string-contains subject "=?UTF-8?Q?")
+                           (or (false-if-exception
+                                (utf8->string
+                                 (quoted-printable-decode
+                                  (regexp-substitute/global #f qp-pattern
+                                                            subject 'pre 1 'post))))
+                               subject)
+                           subject))
+                     (assoc-ref properties "Tags"))))