summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRicardo Wurmus <rekado@elephly.net>2018-08-28 23:21:38 +0200
committerRicardo Wurmus <rekado@elephly.net>2018-08-28 23:21:38 +0200
commit0c57ea2ee68fe9930304351797f2091199fafdbb (patch)
tree9476b8d07fc29aa430c92b73b491161032e496d1
parent49e627f99c6b25582a5d2ba4f7db1b66278c9b78 (diff)
Goodbye mu, hello guile-debbugs!
-rw-r--r--Makefile.am11
-rw-r--r--assets/css/screen.css73
-rw-r--r--configure.ac9
-rw-r--r--guix.scm98
-rw-r--r--mumi.scm28
-rw-r--r--mumi/commands.scm23
-rw-r--r--mumi/config.scm.in36
-rw-r--r--mumi/messages.scm249
-rw-r--r--mumi/queries.scm43
-rw-r--r--mumi/web/controller.scm62
-rw-r--r--mumi/web/render.scm15
-rw-r--r--mumi/web/view/html.scm415
-rw-r--r--mumi/web/view/utils.scm20
-rw-r--r--scripts/mumi.in3
14 files changed, 686 insertions, 399 deletions
diff --git a/Makefile.am b/Makefile.am
index 4cbec8d..2083aef 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,5 +1,5 @@
# mumi - Mediocre, uh, mail interface
-# Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+# Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
#
# This file is part of mumi.
#
@@ -29,12 +29,9 @@ SOURCES = \
mumi/web/server.scm \
mumi/web/render.scm \
mumi/web/controller.scm \
- mumi/web/view/html.scm \
- mumi/web/view/utils.scm \
mumi/web/sxml.scm \
mumi/web/util.scm \
+ mumi/web/view/html.scm \
+ mumi/web/view/utils.scm \
mumi/messages.scm \
- mumi/commands.scm \
- mumi/config.scm \
- mumi/queries.scm \
- mumi.scm
+ mumi/config.scm
diff --git a/assets/css/screen.css b/assets/css/screen.css
index 4d2f744..21c55a4 100644
--- a/assets/css/screen.css
+++ b/assets/css/screen.css
@@ -12,14 +12,31 @@ html, body {
h1 {
clear: both;
- line-height: 125%;
+ font-size: 32px;
+ line-height: 105%;
margin-top: 1.3rem;
+ margin-bottom: 0.5rem;
+ padding: 0px;
+ display: block;
+ font-weight: 400;
+ color: #333;
+}
+
+.title {
+ clear: both;
+ font-size: 16px;
margin-bottom: 1rem;
border-bottom: 1px dashed #ddd;
padding: 0px;
padding-bottom: 1rem;
- display: block;
- font-weight: 800;
+ color: #586069;
+}
+
+.comment-box {
+ margin-top: 1rem;
+ margin-bottom: 2rem;
+ border-top: 1px dashed #ddd;
+ padding-top: 1rem;
}
h2 {
@@ -61,23 +78,46 @@ tr td:nth-child(3){
#header {
background: #333333;
- color: #fff;
+ border-color: #1A1A1A1A;
+ border-style: none none solid none;
+ border-width: thin;
width: 100%;
- box-shadow: 0 3px 8px #ccc;
margin-bottom: 1rem;
padding: .5em;
- font-size: 1.2em;
- font-weight: bold;
color: #fff;
+ position: relative;
+ display: block;
}
#header a {
color: #fff;
text-decorations: none;
}
+#header .flex {
+ display: flex;
+}
+
+#header .flex .logo {
+ display: inline-block;
+ float: left;
+}
+
+#header .flex form {
+ display: inline-block;
+}
+
input#query {
+ box-sizing: border-box;
width: 100%;
- padding: .5rem;
+ padding: .2rem;
+ color: #111;
+ border-radius: 3px;
+}
+
+#header input#query {
+ width: auto;
+ position: absolute;
+ right: 1rem;
}
/* messages */
@@ -88,6 +128,7 @@ input#query {
.info .stat {
display: block;
+ color: #586069;
}
.info .stat .label {
display: block;
@@ -164,3 +205,19 @@ input#query {
margin-left: 1em;
color: #3868cc;
}
+
+.status-tag {
+ display: inline-block;
+ color: #fff;
+ text-align: center;
+ padding: 4px;
+ border-radius: 3px;
+ margin-right: 8px;
+}
+
+.status-tag.done {
+ background: #cb2431;
+}
+.status-tag.open {
+ background: #2cbe4e;
+}
diff --git a/configure.ac b/configure.ac
index a63c8d1..330b5f1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -11,6 +11,15 @@ if test "x$GUILD" = "x"; then
AC_MSG_ERROR(['guild' binary not found; please check your guile-2.2 installation.])
fi
+GUILE_MODULE_AVAILABLE([have_guile_debbugs], [(debbugs soap)])
+if test "x$have_guile_debbugs" != "xyes"; then
+ AC_MSG_ERROR([Guile-Debbugs is missing; please install it.])
+fi
+
+GUILE_MODULE_AVAILABLE([have_mailutils], [(mailutils mailutils)])
+if test "x$have_mailutils" != "xyes"; then
+ AC_MSG_ERROR([Guile bindings to mailutils are missing; please install them.])
+fi
guilemoduledir="${datarootdir}/guile/site/${GUILE_EFFECTIVE_VERSION}"
AC_SUBST([guilemoduledir])
diff --git a/guix.scm b/guix.scm
index e7d3da2..8982ec6 100644
--- a/guix.scm
+++ b/guix.scm
@@ -1,5 +1,5 @@
;;; mumi - Mediocre, uh, mail interface
-;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of mumi.
;;;
@@ -24,13 +24,102 @@
(use-modules ((guix licenses) #:prefix license:)
(guix packages)
(guix download)
+ (guix git-download)
(guix utils)
(guix build-system gnu)
(gnu packages)
(gnu packages autotools)
+ (gnu packages gettext)
(gnu packages guile)
+ (gnu packages gsasl)
(gnu packages mail)
- (gnu packages pkg-config))
+ (gnu packages pkg-config)
+ (srfi srfi-1))
+
+(define-public mailutils-next
+ ;; This version of Mailutils supports Guile 2.2, unlike version <= 3.4.
+ (let ((commit "ce5b13e92b6e2f7af243654fe0673646f00dc3a6")
+ (revision "1"))
+ (package
+ (inherit mailutils)
+ (version (string-append (package-version mailutils)
+ "-" revision "." (string-take commit 7)))
+ (source (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.savannah.gnu.org/git/mailutils.git")
+ (commit commit)
+ (recursive? #t))) ;for Gnulib & co.
+ (sha256
+ (base32
+ "15vbj5by7qg8zmh3scr3k9pymls6ijk1s85y1skclsln172r9p33"))
+ (file-name (string-append "mailutils-" version "-checkout"))))
+ (outputs '("out" "debug"))
+ (inputs
+ `(("guile" ,guile-2.2)
+ ("gsasl" ,gsasl) ;for SMTP authentication
+ ,@(alist-delete "guile" (package-inputs mailutils))))
+ (native-inputs
+ `(("autoconf" ,autoconf-wrapper)
+ ("automake" ,automake)
+ ("libtool" ,libtool)
+ ("gettext" ,gnu-gettext)
+ ,@(package-native-inputs mailutils)))
+ (arguments
+ (substitute-keyword-arguments (package-arguments mailutils)
+ ((#:modules modules %gnu-build-system-modules)
+ `((srfi srfi-1) ,@modules))
+ ((#:configure-flags flags ''())
+ `(cons* "--disable-radius"
+
+ ;; Add "/2.2" to the installation directory.
+ (string-append "--with-guile-site-dir="
+ (assoc-ref %outputs "out")
+ "/share/guile/site/2.2")
+ ,flags))
+ ((#:phases phases)
+ `(modify-phases ,phases
+ (replace 'bootstrap
+ (lambda* (#:key inputs #:allow-other-keys)
+ (for-each patch-shebang
+ '("bootstrap" "gnulib/gnulib-tool"))
+ (substitute* "bootstrap.conf"
+ (("git submodule" all)
+ (string-append "#" all)))
+ (for-each make-file-writable (find-files "gnulib"))
+ (substitute* "configure.ac"
+ (("AM_GNU_RADIUS") ""))
+ (invoke "./bootstrap" "--no-git" "--skip-po"
+ (string-append "--gnulib-srcdir=gnulib"))
+ #t))
+ (delete 'prepare-test-suite)))
+ ((#:parallel-build? _ #f) ;due to parser.y
+ #f)
+ ((#:tests? _ #f) ;XXX
+ #f))))))
+
+(define-public guile-debbugs-next
+ (package
+ (name "guile-debbugs")
+ (version "0.0.3")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://gnu/guile-debbugs/"
+ "guile-debbugs-" version ".tar.gz"))
+ (sha256
+ (base32
+ "1lwrj2hmncc4ks05c2yfh8z93bcwcynplqi3cvm6kdblcv4yr2rl"))))
+ (build-system gnu-build-system)
+ (native-inputs
+ `(("pkg-config" ,pkg-config)))
+ (inputs
+ `(("guile" ,guile-2.2.4)
+ ("mailutils" ,mailutils-next)))
+ (home-page "https://www.gnu.org/software/guile-debbugs")
+ (synopsis "Guile bindings for the Debbugs bug tracker")
+ (description "This package provides a Guile library to communicate with a
+Debbugs bug tracker's SOAP service.")
+ (license license:gpl3+)))
(package
(name "mumi")
@@ -38,8 +127,9 @@
(source #f)
(build-system gnu-build-system)
(inputs
- `(("mu" ,mu)
- ("guile" ,guile-2.2)))
+ `(("guile-debbugs" ,guile-debbugs-next)
+ ("mailutils" ,mailutils-next)
+ ("guile" ,guile-2.2.4)))
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
diff --git a/mumi.scm b/mumi.scm
deleted file mode 100644
index 229cdc6..0000000
--- a/mumi.scm
+++ /dev/null
@@ -1,28 +0,0 @@
-;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2017 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
-;;; as published by the Free Software Foundation, either version 3 of
-;;; the License, or (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Affero General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Affero General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(define-module (mumi)
- #:use-module (mu)
- #:use-module (mumi config)
- #:use-module (mumi queries)
- #:use-module (ice-9 optargs)
- #:export (init))
-
-(define* (init #:optional (db %mu-database-directory))
- (mu:initialize db))
-
-(set! %load-path (cons "/home/rekado/.guix-profile/lib" %load-path))
diff --git a/mumi/commands.scm b/mumi/commands.scm
deleted file mode 100644
index 729f3ce..0000000
--- a/mumi/commands.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2017 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
-;;; as published by the Free Software Foundation, either version 3 of
-;;; the License, or (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Affero General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Affero General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(define-module (mumi commands)
- #:use-module (mu))
-
-(define-public (done? msg)
- ;; TODO
- (mu:body-txt msg))
diff --git a/mumi/config.scm.in b/mumi/config.scm.in
index 0cb9242..8a00d27 100644
--- a/mumi/config.scm.in
+++ b/mumi/config.scm.in
@@ -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
@@ -18,19 +18,23 @@
(define-module (mumi config)
#:export (%config))
-(define-public %mu-database-directory
- (string-append (getenv "HOME") "/dev/mumi/muhome/"))
-
(define %config
- ;; Try to find the "assets" directory relative to the executable
- ;; first. This is useful when using "pre-inst-env".
- `((assets-dir . ,(let ((maybe-dir
- (string-append (getcwd) "/assets")))
- (if (and (getenv "MUMI_UNINSTALLED")
- (file-exists? maybe-dir))
- maybe-dir
- ;; TODO: use @assetsdir@ variable here
- "@prefix@/share/mumi/assets")))
- (host . "localhost")
- (port . 1234)
- (list . "guix-patches@gnu.org")))
+ (let ((config
+ ;; Try to find the "assets" directory relative to the executable
+ ;; first. This is useful when using "pre-inst-env".
+ `((assets-dir . ,(let ((maybe-dir
+ (string-append (getcwd) "/assets")))
+ (if (and (getenv "MUMI_UNINSTALLED")
+ (file-exists? maybe-dir))
+ maybe-dir
+ ;; TODO: use @assetsdir@ variable here
+ "@prefix@/share/mumi/assets")))
+ (host . "localhost")
+ (port . 1234)
+ (submission-email-address . "guix-patches@gnu.org")
+ (lists . '("guix-patches@gnu.org" "bug-guix@gnu.org"))
+ (packages . '("guix-patches" "guix"))
+ (debbugs . "https://debbugs.gnu.org/cgi/soap.cgi")
+ (debbugs-domain . "debbugs.gnu.org"))))
+ (lambda (key)
+ (assoc-ref config key))))
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)))
diff --git a/mumi/queries.scm b/mumi/queries.scm
deleted file mode 100644
index 876a1f0..0000000
--- a/mumi/queries.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2017 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
-;;; as published by the Free Software Foundation, either version 3 of
-;;; the License, or (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Affero General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Affero General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(define-module (mumi queries)
- #:use-module (mumi config)
- #:use-module (mu)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:export (query-and
- query-or))
-
-(define-public (group s)
- (string-append "(" s ")"))
-
-(define-syntax-rule (query-and e ...)
- (group (string-join (list e ...) " ")))
-
-(define-syntax-rule (query-or e ...)
- (group (string-join (list e ...) " OR ")))
-
-(define-public (msgid id)
- (string-append "msgid:" id))
-
-(define-public (messages-in-thread id)
- (append
- (mu:message-list (msgid id))
- (filter (lambda (msg)
- (member id (mu:references msg)))
- (mu:message-list (assoc-ref %config 'list)))))
diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm
index efc6358..0b2ff73 100644
--- a/mumi/web/controller.scm
+++ b/mumi/web/controller.scm
@@ -1,5 +1,5 @@
;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016, 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
@@ -17,11 +17,11 @@
(define-module (mumi web controller)
#:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (web request)
#:use-module (web uri)
- #:use-module (mu)
#:use-module (mumi messages)
#:use-module (mumi web render)
#:use-module (mumi web util)
@@ -33,10 +33,23 @@
target
(list functions ...)))
+(define (render-with-error-handling page message)
+ (apply render-html (page))
+ ;; (catch #t
+ ;; (lambda ()
+ ;; (receive (sxml headers)
+ ;; (pretty-print (page))
+ ;; (render-html sxml headers)))
+ ;; (lambda (key . args)
+ ;; (format #t "ERROR: ~a ~a\n"
+ ;; key args)
+ ;; (render-html (error-page message))))
+ )
+
(define (controller request body)
(match-lambda
((GET)
- (render-html (index)))
+ (apply render-html (index)))
((GET "search")
(let ((query (-> request
request-uri
@@ -49,20 +62,35 @@
(string-null? (string-trim query)))
(redirect '()))
- ((string-prefix? "patch:" query) =>
- (lambda _ (redirect (list "patch" (string-drop query 6)))))
-
- ;; Search for matching messages and return list of patch
- ;; reports that belong to them.
+ ;; For convenience
+ ((string-prefix? "id:" query) =>
+ (lambda _ (redirect (list "issue" (string-drop query (string-length "id:"))))))
+ ((string-prefix? "#" query) =>
+ (lambda _ (redirect (list "issue" (string-drop query (string-length "#"))))))
+ ((string->number query) =>
+ (lambda _ (redirect (list "issue" query))))
+
+ ;; Search for matching messages and return list of bug reports
+ ;; that belong to them.
(else
- (let ((messages (unique-reports (mu:message-list query 100))))
- (render-html (patch-list query messages)))))))
- ((GET "patch" (? string->number id))
- (let ((messages (patch-messages id)))
- (if (null? messages)
- (render-html (unknown id))
- (render-html (patch-page id messages)))))
- ((GET "patch" not-an-id)
- (render-html (unknown not-an-id)))
+ (render-with-error-handling
+ (lambda ()
+ (list-of-matching-bugs query
+ (match (process-query query)
+ ((#:terms terms
+ #:attributes attrs
+ #:filters fs)
+ (filter (lambda (bug)
+ (every (lambda (f) (f bug)) fs))
+ (search-bugs (string-join terms)
+ #:attributes attrs))))))
+ `(p "Could not search for " (strong ,query) "."))))))
+ ((GET "issue" (? string->number id))
+ (render-with-error-handling
+ (lambda () (or (and=> (fetch-bug id) issue-page)
+ (unknown id)))
+ `(p "Could not access issue #" (strong ,id) ".")))
+ ((GET "issue" not-an-id)
+ (apply render-html (unknown not-an-id)))
((GET path ...)
(render-static-asset path))))
diff --git a/mumi/web/render.scm b/mumi/web/render.scm
index cc1f35e..c67a124 100644
--- a/mumi/web/render.scm
+++ b/mumi/web/render.scm
@@ -46,7 +46,7 @@
("html" . (text/html))))
(define (render-static-asset path)
- (render-static-file (assoc-ref %config 'assets-dir) path))
+ (render-static-file (%config 'assets-dir) path))
(define (render-static-file root path)
;; PATH is a list of path components
@@ -58,12 +58,13 @@
(file-extension file-name))))
(call-with-input-file file-name get-bytevector-all))
(not-found (build-uri 'http
- #:host (assoc-ref %config 'host)
- #:port (assoc-ref %config 'port)
+ #:host (%config 'host)
+ #:port (%config 'port)
#:path (string-join path "/" 'prefix))))))
-(define (render-html sxml)
- (list '((content-type . (text/html)))
+(define* (render-html #:key sxml (extra-headers '()))
+ (list (append extra-headers
+ '((content-type . (text/html))))
(lambda (port)
(sxml->html sxml port))))
@@ -86,8 +87,8 @@
(define (redirect path)
(let ((uri (build-uri 'http
- #:host (assoc-ref %config 'host)
- #:port (assoc-ref %config 'port)
+ #:host (%config 'host)
+ #:port (%config 'port)
#:path (string-append
"/" (encode-and-join-uri-path path)))))
(list (build-response
diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
index ca20982..e6c429b 100644
--- a/mumi/web/view/html.scm
+++ b/mumi/web/view/html.scm
@@ -1,5 +1,5 @@
;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016, 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,175 +16,296 @@
;;; <http://www.gnu.org/licenses/>.
(define-module (mumi web view html)
- #:use-module (mu)
+ #:use-module (debbugs email)
+ #:use-module (debbugs bug)
+ #:use-module (mumi config)
#:use-module (mumi messages)
#:use-module (mumi web view utils)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
#:export (index
unknown
- patch-page
- patch-list))
+ error-page
+ issue-page
+ list-of-matching-bugs))
-(define* (layout #:key (head '()) (body '()))
- `((doctype "html")
- (html
- (head
- (title "Guix patches")
- (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
- (meta (@ (http-equiv "Content-Language") (content "en")))
- (meta (@ (name "author") (content "Ricardo Wurmus")))
- (meta (@ (name "viewport")
- (content "width=device-width, initial-scale=1")))
- (link
- (@ (rel "stylesheet")
- (media "screen")
- (type "text/css")
- (href "/css/reset.css")))
- (link
- (@ (rel "stylesheet")
- (media "screen")
- (type "text/css")
- (href "/css/bootstrap.css")))
- ,@head
- (link
- (@ (rel "stylesheet")
- (media "screen")
- (type "text/css")
- (href "/css/screen.css"))))
- (body ,@body))))
+(define (status-tag bug)
+ (let ((status (if (bug-done bug) "Done" "Open")))
+ `(span (@ (class ,(string-append "status-tag "
+ (string-downcase status))))
+ ,status)))
-(define header
- '(div (@ (id "header"))
- (div (@ (class "container"))
- (div (@ (class "row"))
- (a (@ (href "/"))
- "Guix patches")))))
+(define* (layout #:key
+ (head '())
+ (body '())
+ (title "Guix issue tracker")
+ (extra-headers '()))
+ `(#:sxml ((doctype "html")
+ (html
+ (head
+ (title ,title)
+ (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
+ (meta (@ (http-equiv "Content-Language") (content "en")))
+ (meta (@ (name "author") (content "Ricardo Wurmus")))
+ (meta (@ (name "viewport")
+ (content "width=device-width, initial-scale=1")))
+ (link
+ (@ (rel "stylesheet")
+ (media "screen")
+ (type "text/css")
+ (href "/css/reset.css")))
+ (link
+ (@ (rel "stylesheet")
+ (media "screen")
+ (type "text/css")
+ (href "/css/bootstrap.css")))
+ ,@head
+ (link
+ (@ (rel "stylesheet")
+ (media "screen")
+ (type "text/css")
+ (href "/css/screen.css"))))
+ (body ,@body)))
+ #:extra-headers ,extra-headers))
+
+(define* (search-form #:key (standalone? #f))
+ `(form (@ (id "search")
+ ,@(if standalone?
+ '((class "row"))
+ '())
+ (action "/search"))
+ (div
+ (@ (class "form-group"))
+ (input (@ (type "text")
+ (id "query")
+ (name "query")
+ (placeholder "input search query"))))
+ (button
+ (@ (type "submit")
+ (class "btn btn-lg btn-primary btn-block")
+ ,@(if standalone? '() '((style "display:none"))))
+ "Search")))
+
+(define* (header #:key (search-bar? #t))
+ `(div
+ (@ (id "header"))
+ (div
+ (@ (class "flex"))
+ (a (@ (href "/") (class "logo"))
+ (img (@ (src "/img/logo.png")
+ (alt "Guix patch tracker"))))
+ ,@(if search-bar? (list (search-form)) '()))))
(define (index)
(layout
+ #:extra-headers
+ '((cache-control . ((max-age . 60))))
#:body
- `(,header
- (div (@ (class "container"))
- (div (@ (id "about")
- (class "row"))
- (p "This is a web frontend to the Guix patch submission tracker. Send email to "
- (a (@ (href "mailto:guix-packages@gnu.org"))
- "guix-packages@gnu.org")
- " to submit your patches.")
- (p "This frontend is powered by "
- (a (@ (href "http://www.djcbsoftware.nl/code/mu"))
- "mu")
- "."))
- (form (@ (id "search-patches")
- (class "row")
- (action "/search"))
- (div (@ (class "form-group"))
- (input (@ (type "text")
- (id "query")
- (name "query")
- (placeholder "input search query"))))
- (button (@ (type "submit")
- (class "btn btn-lg btn-primary btn-block"))
- "Search"))))))
+ `(,(header #:search-bar? #f)
+ (div
+ (@ (class "container"))
+ (h1 "Guix patch tracker")
+ (div
+ (@ (id "about")
+ (class "row"))
+ (p "This is a web frontend to the Guix patch tracker. Send email to "
+ (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
+ ,(%config 'submission-email-address))
+ " to submit your patches."))
+ ,(search-form #:standalone? #t)
+ ;; TODO: do this via JS?
+ ,@(let ((bugs (recent-bugs 5)))
+ (if (null? bugs)
+ '()
+ `((h2 "Recent issues")
+ ,(list-of-bugs bugs))))))))
(define (unknown id)
(layout
#:body
- `(,header
+ `(,(header)
(div (@ (class "container"))
(h1 "Patch not found")
- (p "There is no patch with id " (strong ,id))
+ (p "There is no submission with id " (strong ,id))
(p (a (@ (href "/")) "Try another one?"))))))
-(define (patch-page id messages)
- (define parts (participants messages))
- (define (show-message message)
- `((div (@ (class "row"))
- (div (@ (class "avatar col-md-1")
- (style ,(string-append "background-color:"
- (avatar-color (sender message) parts))))
- ,(string-upcase (string-take (sender message) 1)))
- (div (@ (class "message col-md-11"))
- (div (@ (class "panel panel-default"))
- (div (@ (class "panel-heading"))
- (div (@ (class "from"))
- (span (@ (class "address"))
- ,(mu:from message))
- " commented on "
- (span (@ (class "date"))
- ,(strftime "%B %d, %Y" (localtime (mu:timestamp message)))))
- (div (@ (class "details"))
- (div (@ (class "recipients"))
- (label "Recipients:")
- ,(map (lambda (address)
- `(span (@ (class "address")) ,address))
- (recipients message)))
- (div (@ (class "message-id"))
- (label "Message-ID:")
- ,(mu:message-id message))))
- (div (@ (class "body panel-body"))
- ,(prettify (mu:body-txt message))))))
- ,(if (closing? message)
- '(div (@ (class "row event"))
- (div (@ (class "col-md-offset-1 col-md-11 text-center"))
- (div (@ (class "label label-primary closed"))
- "Closed")))
- '())))
+(define (error-page message)
(layout
#:body
- `(,header
+ `(,(header)
(div (@ (class "container"))
- (div (@ (class "row"))
- (h1 ,(mu:subject (car messages))))
- (div (@ (class "row"))
- (div (@ (class "conversation col-md-9"))
- ,(map show-message (filter mu:body-txt messages)))
- (div (@ (class "info col-md-3"))
- (div (@ (class "stat"))
- ,@(let ((num (length parts)))
- `((label ,(if (= num 1)
- "One participant"
- (string-append (number->string num)
- " participants")))
- (ul ,(map (lambda (address)
- `(li (span (@ (class "address")))
- ,address))
- parts)))))
- (div (@ (class "stat"))
- (label "Owner")
- ,(or (owner messages) "unassigned"))
- (div (@ (class "stat"))
- (label "Status")
- ,(status messages))))
- (div (@ (class "row"))
- (p "To comment on this conversation "
- (a (@ (href ,(string-append "mailto:" id "@debbugs.gnu.org?subject="
- (mu:subject (last messages)))))
- ,(string-append "send email to "
- id "@debbugs.gnu.org"))))))))
+ (h1 "Error")
+ (p "An error occurred. Sorry about that!")
+ ,message
+ (p (a (@ (href "/")) "Try something else?"))))))
+
+(define (issue-page bug)
+ "Render the conversation for the given BUG."
+ (define id (bug-num bug))
+ (define messages (patch-messages id))
+ (define parties (filter (compose (negate bot?) extract-email)
+ (participants messages)))
+ (define (show-message message)
+ `((div
+ (@ (class "row"))
+ (a (@ (id ,(number->string (email-msg-num message)))))
+ (div
+ (@ (class "avatar col-md-1")
+ (style ,(string-append "background-color:"
+ (avatar-color (sender-email message)
+ (map extract-email parties)))))
+ ,(string-upcase (string-take (sender-name message) 1)))
+ (div
+ (@ (class "message col-md-11"))
+ (div
+ (@ (class "panel panel-default"))
+ (div
+ (@ (class "panel-heading"))
+ (div
+ (@ (class "from"))
+ (span (@ (class "address")) ,(sender-name message))
+ " wrote on "
+ (span (@ (class "date"))
+ (a (@ (href ,(string-append "#" (number->string
+ (email-msg-num message)))))
+ ,(date message))))
+ (div
+ (@ (class "details"))
+ (div
+ (@ (class "recipients"))
+ (label "Recipients:")
+ ,(map (lambda (address)
+ `(span (@ (class "address")) ,address))
+ (recipients message)))
+ (div
+ (@ (class "message-id"))
+ (label "Message-ID:")
+ ,(message-id message))))
+ (div
+ (@ (class "body panel-body"))
+ ,(prettify (email-body message))))))
+ ,@(if (closing? message id)
+ '((div
+ (@ (class "row event"))
+ (div
+ (@ (class "col-md-offset-1 col-md-11 text-center"))
+ (div (@ (class "label label-primary closed")) "Closed"))))
+ '())))
+ (layout
+ #:title (bug-subject bug)
+ #:extra-headers
+ (cond
+ ((bug-archived bug)
+ ;; Tell browser to cache this for 12 hours.
+ '((cache-control . ((max-age . 43200)))))
+ ((bug-done bug)
+ ;; Tell browser to cache this for 1 hour.
+ '((cache-control . ((max-age . 3600)))))
+ (else '()))
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row title col-md-12"))
+ (h1 ,(bug-subject bug))
+ (span (@ (class "details"))
+ ,(status-tag bug)
+ ,(string-append "Submitted by "
+ (extract-name (bug-originator bug))
+ ".")))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "conversation col-md-9"))
+ ,(map show-message (filter (lambda (msg)
+ ;; Ignore messages
+ ;; without body, and
+ ;; internal messages.
+ (and (email-body msg)
+ (not (internal-message? msg))))
+ messages))
+ (div
+ (@ (class "row comment-box"))
+ (a (@ (id "comment")))
+ (div
+ (@ (class "avatar col-md-1")
+ (style "background-color:#bc80bd")) "?")
+ (div
+ (@ (class "message col-md-11"))
+ (div
+ (@ (class "panel panel-default"))
+ (div
+ (@ (class "panel-heading"))
+ (div (@ (class "from"))
+ (span (@ (class "address")) "Your comment")))
+ (div
+ (@ (class "body panel-body"))
+ (p "Comments via the web interface are not currently
+supported. To comment on this conversation "
+ (a (@ (href ,(string-append "mailto:"
+ (number->string id) "@" (%config 'debbugs-domain)
+ "?subject=" (bug-subject bug))))
+ ,(string-append "send email to "
+ (number->string id) "@" (%config 'debbugs-domain)))))))))
+
+ (div
+ (@ (class "info col-md-3"))
+ (div
+ (@ (class "stat"))
+ ,@(let ((num (length parties)))
+ `((label ,(if (= num 1)
+ "One participant"
+ (string-append (number->string num)
+ " participants")))
+ (ul ,(map (lambda (name)
+ `(li (span (@ (class "name")))
+ ,name))
+ (map extract-name parties))))))
+ (div
+ (@ (class "stat"))
+ (label "Owner")
+ ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
+ (div
+ (@ (class "stat"))
+ (label "Status")
+ ,(status-tag bug))))))))
+
+(define (list-of-bugs bugs)
+ "Return a table of BUGS."
+ (if (null? bugs)
+ `(p "Nothing to see here. "
+ (a (@ (href "/"))
+ "Look for something else?"))
+ `(table (@ (class "table-condensed"))
+ (thead
+ (tr (th "ID")
+ (th "Subject")
+ (th "Date submitted")
+ (th "Status")))
+ (tbody
+ ,@(map (lambda (bug)
+ (let ((id (number->string (bug-num bug))))
+ `(tr
+ (td ,(or id "-"))
+ (td ,(if id
+ `(a (@ (href ,(string-append "/issue/" id)))
+ ,(bug-subject bug))
+ (bug-subject bug)))
+ (td ,(date->string (bug-date bug)))
+ (td ,(status-tag bug)))))
+ bugs)))))
-(define (patch-list query messages)
+(define (list-of-matching-bugs query bugs)
(layout
#:body
- `(,header
+ `(,(header)
(div (@ (class "container"))
- (h1 "Patches matching " (code ,query))
- ,(if (null? messages)
- `(p (a (@ (href "/"))
- "There are no patches matching your query, but we have many more!"))
- `(table (@ (class "table-condensed"))
- (thead
- (tr (th "ID")
- (th "Subject")
- (th "Date submitted")))
- (tbody
- ,@(map (lambda (msg)
- (let ((id (patch-id msg)))
- `(tr
- (td ,(or id "-"))
- (td ,(if id
- `(a (@ (href ,(string-append "/patch/" id)))
- ,(mu:subject msg))
- (mu:subject msg)))
- (td ,(strftime "%B %d, %Y" (localtime (mu:timestamp msg)))))))
- messages))))))))
+ ,@(if (zero? bugs)
+ `((h1 "No issues found")
+ (p "We could not find any issues matching your query "
+ (code ,query) ". "
+ (a (@ (href "/"))
+ "Try searching for something else?")))
+ `((h1 "Submissions matching " (code ,query))
+ ,(list-of-bugs bugs)))))))
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
index b210bfc..73a5969 100644
--- a/mumi/web/view/utils.scm
+++ b/mumi/web/view/utils.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
@@ -53,16 +53,18 @@
`(span (@ (class "line")) ,line))))
(define (prettify text)
- (define result '())
+ "Read each line of TEXT and apply PROCESS to it."
(call-with-input-string text
(lambda (port)
- (let loop ((line (read-line port)))
- (if (eof-object? line) (reverse result)
- (begin
- (set! result
- (cons (process line)
- (cons '(br) result)))
- (loop (read-line port))))))))
+ (let loop ((line (read-line port))
+ (result '()))
+ (if (eof-object? line)
+ ;; Drop the first line break, because it's for an eof
+ ;; read.
+ (cdr (reverse result))
+ (loop (read-line port)
+ (cons (process line)
+ (cons '(br) result))))))))
(define colors
(circular-list "#8dd3c7" "#bebada" "#fb8072"
diff --git a/scripts/mumi.in b/scripts/mumi.in
index 86677d6..f5ade22 100644
--- a/scripts/mumi.in
+++ b/scripts/mumi.in
@@ -2,7 +2,7 @@
-*- scheme -*-
-*- geiser-scheme-implementation: guile -*-
!#
-;;; mumi -- Mailing list processor
+;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of mumi.
@@ -20,6 +20,5 @@
;;; You should have received a copy of the GNU General Public License
;;; along with mumi. If not, see <http://www.gnu.org/licenses/>.
-(use-modules (mumi)) (init)
(use-modules (mumi web server))
(start-mumi-web-server 1234)