diff options
author | Ricardo Wurmus <rekado@elephly.net> | 2018-08-28 23:21:38 +0200 |
---|---|---|
committer | Ricardo Wurmus <rekado@elephly.net> | 2018-08-28 23:21:38 +0200 |
commit | 0c57ea2ee68fe9930304351797f2091199fafdbb (patch) | |
tree | 9476b8d07fc29aa430c92b73b491161032e496d1 | |
parent | 49e627f99c6b25582a5d2ba4f7db1b66278c9b78 (diff) |
Goodbye mu, hello guile-debbugs!
-rw-r--r-- | Makefile.am | 11 | ||||
-rw-r--r-- | assets/css/screen.css | 73 | ||||
-rw-r--r-- | configure.ac | 9 | ||||
-rw-r--r-- | guix.scm | 98 | ||||
-rw-r--r-- | mumi.scm | 28 | ||||
-rw-r--r-- | mumi/commands.scm | 23 | ||||
-rw-r--r-- | mumi/config.scm.in | 36 | ||||
-rw-r--r-- | mumi/messages.scm | 249 | ||||
-rw-r--r-- | mumi/queries.scm | 43 | ||||
-rw-r--r-- | mumi/web/controller.scm | 62 | ||||
-rw-r--r-- | mumi/web/render.scm | 15 | ||||
-rw-r--r-- | mumi/web/view/html.scm | 415 | ||||
-rw-r--r-- | mumi/web/view/utils.scm | 20 | ||||
-rw-r--r-- | scripts/mumi.in | 3 |
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]) @@ -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) |