summaryrefslogtreecommitdiff
path: root/mumi
diff options
context:
space:
mode:
Diffstat (limited to 'mumi')
-rw-r--r--mumi/commands.scm23
-rw-r--r--mumi/config.scm.in36
-rw-r--r--mumi/messages.scm122
-rw-r--r--mumi/queries.scm43
-rw-r--r--mumi/web/controller.scm68
-rw-r--r--mumi/web/render.scm97
-rw-r--r--mumi/web/server.scm47
-rw-r--r--mumi/web/sxml.scm370
-rw-r--r--mumi/web/util.scm44
-rw-r--r--mumi/web/view/html.scm190
-rw-r--r--mumi/web/view/utils.scm76
11 files changed, 1116 insertions, 0 deletions
diff --git a/mumi/commands.scm b/mumi/commands.scm
new file mode 100644
index 0000000..729f3ce
--- /dev/null
+++ b/mumi/commands.scm
@@ -0,0 +1,23 @@
+;;; 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
new file mode 100644
index 0000000..0cb9242
--- /dev/null
+++ b/mumi/config.scm.in
@@ -0,0 +1,36 @@
+;;; 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 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")))
diff --git a/mumi/messages.scm b/mumi/messages.scm
new file mode 100644
index 0000000..258b02d
--- /dev/null
+++ b/mumi/messages.scm
@@ -0,0 +1,122 @@
+;;; 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 messages)
+ #:use-module (mu)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 optargs)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #:use-module (mumi queries))
+
+(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)))
+
+(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 sender (compose extract-address mu:from))
+
+(define-public (participants messages)
+ "Return a list of unique email addresses in the conversion."
+ (apply lset-adjoin string= '()
+ (map sender messages)))
+
+;; TODO: build a different version of "mu index" to also index
+;; X-GNU-PR-* headers?
+
+(define-public (action message)
+ "Return the debbugs action MESSAGE."
+ (mu:header message "X-GNU-PR-Message"))
+
+(define-public (report? message)
+ (let ((action (action message)))
+ (and action (string-prefix? "report " action))))
+
+;; 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 (owner? message)
+ (let ((action (action message)))
+ (and action (string-prefix? "owner " action))))
+
+(define-public (owner messages)
+ "Return the owner of this patch or #F if unassigned."
+ (and=> (find owner? messages)
+ sender))
+
+(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))))
diff --git a/mumi/queries.scm b/mumi/queries.scm
new file mode 100644
index 0000000..876a1f0
--- /dev/null
+++ b/mumi/queries.scm
@@ -0,0 +1,43 @@
+;;; 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
new file mode 100644
index 0000000..efc6358
--- /dev/null
+++ b/mumi/web/controller.scm
@@ -0,0 +1,68 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2016, 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 web controller)
+ #:use-module (ice-9 match)
+ #: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)
+ #:use-module (mumi web view html)
+ #:export (controller))
+
+(define-syntax-rule (-> target functions ...)
+ (fold (lambda (f val) (and=> val f))
+ target
+ (list functions ...)))
+
+(define (controller request body)
+ (match-lambda
+ ((GET)
+ (render-html (index)))
+ ((GET "search")
+ (let ((query (-> request
+ request-uri
+ uri-query
+ parse-query-string
+ (cut assoc-ref <> "query"))))
+ (cond
+ ;; TODO: query should not be empty!
+ ((or (not query)
+ (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.
+ (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)))
+ ((GET path ...)
+ (render-static-asset path))))
diff --git a/mumi/web/render.scm b/mumi/web/render.scm
new file mode 100644
index 0000000..cc1f35e
--- /dev/null
+++ b/mumi/web/render.scm
@@ -0,0 +1,97 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2014 David Thompson <davet@gnu.org>
+;;;
+;;; 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/>.
+
+;; This code was snarfed from David Thompson's guix-web.
+
+(define-module (mumi web render)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:use-module (json)
+ #:use-module (mumi config)
+ #:use-module (mumi web sxml)
+ #:use-module (mumi web util)
+ #:export (render-static-asset
+ render-html
+ render-json
+ not-found
+ unprocessable-entity
+ created
+ redirect))
+
+(define file-mime-types
+ '(("css" . (text/css))
+ ("js" . (text/javascript))
+ ("png" . (image/png))
+ ("gif" . (image/gif))
+ ("woff" . (application/font-woff))
+ ("ttf" . (application/octet-stream))
+ ("html" . (text/html))))
+
+(define (render-static-asset path)
+ (render-static-file (assoc-ref %config 'assets-dir) path))
+
+(define (render-static-file root path)
+ ;; PATH is a list of path components
+ (let ((file-name (string-join (cons* root path) "/")))
+ (if (and (not (any (cut string-contains <> "..") path))
+ (file-exists? file-name)
+ (not (directory? file-name)))
+ (list `((content-type . ,(assoc-ref file-mime-types
+ (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)
+ #:path (string-join path "/" 'prefix))))))
+
+(define (render-html sxml)
+ (list '((content-type . (text/html)))
+ (lambda (port)
+ (sxml->html sxml port))))
+
+(define (render-json json)
+ (list '((content-type . (application/json)))
+ (lambda (port)
+ (scm->json json port))))
+
+(define (not-found uri)
+ (list (build-response #:code 404)
+ (string-append "Resource not found: " (uri->string uri))))
+
+(define (unprocessable-entity)
+ (list (build-response #:code 422)
+ ""))
+
+(define (created)
+ (list (build-response #:code 201)
+ ""))
+
+(define (redirect path)
+ (let ((uri (build-uri 'http
+ #:host (assoc-ref %config 'host)
+ #:port (assoc-ref %config 'port)
+ #:path (string-append
+ "/" (encode-and-join-uri-path path)))))
+ (list (build-response
+ #:code 301
+ #:headers `((content-type . (text/html))
+ (location . ,uri)))
+ (format #f "Redirect to ~a" (uri->string uri)))))
diff --git a/mumi/web/server.scm b/mumi/web/server.scm
new file mode 100644
index 0000000..0c1f662
--- /dev/null
+++ b/mumi/web/server.scm
@@ -0,0 +1,47 @@
+;;; 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 web server)
+ #:use-module (srfi srfi-1)
+ #:use-module (web http)
+ #:use-module (web request)
+ #:use-module (web server)
+ #:use-module (web uri)
+ #:use-module (mumi web controller)
+ #:use-module (mumi web util)
+ #:export (start-mumi-web-server))
+
+(define (run-controller controller request body)
+ ((controller request body)
+ (cons (request-method request)
+ (request-path-components request))))
+
+(define (handler request body controller)
+ (format #t "~a ~a\n"
+ (request-method request)
+ (uri-path (request-uri request)))
+ (apply values
+ (append
+ (run-controller controller request body)
+ (list controller))))
+
+(define (start-mumi-web-server port)
+ (run-server (lambda args (apply handler args))
+ 'http
+ `(#:addr ,INADDR_ANY
+ #:port ,port)
+ controller))
diff --git a/mumi/web/sxml.scm b/mumi/web/sxml.scm
new file mode 100644
index 0000000..a3d1056
--- /dev/null
+++ b/mumi/web/sxml.scm
@@ -0,0 +1,370 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; 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/>.
+
+;;; Commentary:
+;;
+;; SXML to HTML conversion.
+;;
+;;; Code:
+
+(define-module (mumi web sxml)
+ #:use-module (sxml simple)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 hash-table)
+ #:export (sxml->html))
+
+(define %self-closing-tags
+ '(area
+ base
+ br
+ col
+ command
+ embed
+ hr
+ img
+ input
+ keygen
+ link
+ meta
+ param
+ source
+ track
+ wbr))
+
+(define (self-closing-tag? tag)
+ "Return #t if TAG is self-closing."
+ (pair? (memq tag %self-closing-tags)))
+
+(define %escape-chars
+ (alist->hash-table
+ '((#\" . "quot")
+ (#\& . "amp")
+ (#\' . "apos")
+ (#\< . "lt")
+ (#\> . "gt")
+ (#\¡ . "iexcl")
+ (#\¢ . "cent")
+ (#\£ . "pound")
+ (#\¤ . "curren")
+ (#\¥ . "yen")
+ (#\¦ . "brvbar")
+ (#\§ . "sect")
+ (#\¨ . "uml")
+ (#\© . "copy")
+ (#\ª . "ordf")
+ (#\« . "laquo")
+ (#\¬ . "not")
+ (#\® . "reg")
+ (#\¯ . "macr")
+ (#\° . "deg")
+ (#\± . "plusmn")
+ (#\² . "sup2")
+ (#\³ . "sup3")
+ (#\´ . "acute")
+ (#\µ . "micro")
+ (#\¶ . "para")
+ (#\· . "middot")
+ (#\¸ . "cedil")
+ (#\¹ . "sup1")
+ (#\º . "ordm")
+ (#\» . "raquo")
+ (#\¼ . "frac14")
+ (#\½ . "frac12")
+ (#\¾ . "frac34")
+ (#\¿ . "iquest")
+ (#\À . "Agrave")
+ (#\Á . "Aacute")
+ (#\Â . "Acirc")
+ (#\Ã . "Atilde")
+ (#\Ä . "Auml")
+ (#\Å . "Aring")
+ (#\Æ . "AElig")
+ (#\Ç . "Ccedil")
+ (#\È . "Egrave")
+ (#\É . "Eacute")
+ (#\Ê . "Ecirc")
+ (#\Ë . "Euml")
+ (#\Ì . "Igrave")
+ (#\Í . "Iacute")
+ (#\Î . "Icirc")
+ (#\Ï . "Iuml")
+ (#\Ð . "ETH")
+ (#\Ñ . "Ntilde")
+ (#\Ò . "Ograve")
+ (#\Ó . "Oacute")
+ (#\Ô . "Ocirc")
+ (#\Õ . "Otilde")
+ (#\Ö . "Ouml")
+ (#\× . "times")
+ (#\Ø . "Oslash")
+ (#\Ù . "Ugrave")
+ (#\Ú . "Uacute")
+ (#\Û . "Ucirc")
+ (#\Ü . "Uuml")
+ (#\Ý . "Yacute")
+ (#\Þ . "THORN")
+ (#\ß . "szlig")
+ (#\à . "agrave")
+ (#\á . "aacute")
+ (#\â . "acirc")
+ (#\ã . "atilde")
+ (#\ä . "auml")
+ (#\å . "aring")
+ (#\æ . "aelig")
+ (#\ç . "ccedil")
+ (#\è . "egrave")
+ (#\é . "eacute")
+ (#\ê . "ecirc")
+ (#\ë . "euml")
+ (#\ì . "igrave")
+ (#\í . "iacute")
+ (#\î . "icirc")
+ (#\ï . "iuml")
+ (#\ð . "eth")
+ (#\ñ . "ntilde")
+ (#\ò . "ograve")
+ (#\ó . "oacute")
+ (#\ô . "ocirc")
+ (#\õ . "otilde")
+ (#\ö . "ouml")
+ (#\÷ . "divide")
+ (#\ø . "oslash")
+ (#\ù . "ugrave")
+ (#\ú . "uacute")
+ (#\û . "ucirc")
+ (#\ü . "uuml")
+ (#\ý . "yacute")
+ (#\þ . "thorn")
+ (#\ÿ . "yuml")
+ (#\Π. "OElig")
+ (#\œ . "oelig")
+ (#\Š . "Scaron")
+ (#\š . "scaron")
+ (#\Ÿ . "Yuml")
+ (#\ƒ . "fnof")
+ (#\ˆ . "circ")
+ (#\˜ . "tilde")
+ (#\Α . "Alpha")
+ (#\Β . "Beta")
+ (#\Γ . "Gamma")
+ (#\Δ . "Delta")
+ (#\Ε . "Epsilon")
+ (#\Ζ . "Zeta")
+ (#\Η . "Eta")
+ (#\Θ . "Theta")
+ (#\Ι . "Iota")
+ (#\Κ . "Kappa")
+ (#\Λ . "Lambda")
+ (#\Μ . "Mu")
+ (#\Ν . "Nu")
+ (#\Ξ . "Xi")
+ (#\Ο . "Omicron")
+ (#\Π . "Pi")
+ (#\Ρ . "Rho")
+ (#\Σ . "Sigma")
+ (#\Τ . "Tau")
+ (#\Υ . "Upsilon")
+ (#\Φ . "Phi")
+ (#\Χ . "Chi")
+ (#\Ψ . "Psi")
+ (#\Ω . "Omega")
+ (#\α . "alpha")
+ (#\β . "beta")
+ (#\γ . "gamma")
+ (#\δ . "delta")
+ (#\ε . "epsilon")
+ (#\ζ . "zeta")
+ (#\η . "eta")
+ (#\θ . "theta")
+ (#\ι . "iota")
+ (#\κ . "kappa")
+ (#\λ . "lambda")
+ (#\μ . "mu")
+ (#\ν . "nu")
+ (#\ξ . "xi")
+ (#\ο . "omicron")
+ (#\π . "pi")
+ (#\ρ . "rho")
+ (#\ς . "sigmaf")
+ (#\σ . "sigma")
+ (#\τ . "tau")
+ (#\υ . "upsilon")
+ (#\φ . "phi")
+ (#\χ . "chi")
+ (#\ψ . "psi")
+ (#\ω . "omega")
+ (#\ϑ . "thetasym")
+ (#\ϒ . "upsih")
+ (#\ϖ . "piv")
+ (#\  . "ensp")
+ (#\  . "emsp")
+ (#\  . "thinsp")
+ (#\– . "ndash")
+ (#\— . "mdash")
+ (#\‘ . "lsquo")
+ (#\’ . "rsquo")
+ (#\‚ . "sbquo")
+ (#\“ . "ldquo")
+ (#\” . "rdquo")
+ (#\„ . "bdquo")
+ (#\† . "dagger")
+ (#\‡ . "Dagger")
+ (#\• . "bull")
+ (#\… . "hellip")
+ (#\‰ . "permil")
+ (#\′ . "prime")
+ (#\″ . "Prime")
+ (#\‹ . "lsaquo")
+ (#\› . "rsaquo")
+ (#\‾ . "oline")
+ (#\⁄ . "frasl")
+ (#\€ . "euro")
+ (#\ℑ . "image")
+ (#\℘ . "weierp")
+ (#\ℜ . "real")
+ (#\™ . "trade")
+ (#\ℵ . "alefsym")
+ (#\← . "larr")
+ (#\↑ . "uarr")
+ (#\→ . "rarr")
+ (#\↓ . "darr")
+ (#\↔ . "harr")
+ (#\↵ . "crarr")
+ (#\⇐ . "lArr")
+ (#\⇑ . "uArr")
+ (#\⇒ . "rArr")
+ (#\⇓ . "dArr")
+ (#\⇔ . "hArr")
+ (#\∀ . "forall")
+ (#\∂ . "part")
+ (#\∃ . "exist")
+ (#\∅ . "empty")
+ (#\∇ . "nabla")
+ (#\∈ . "isin")
+ (#\∉ . "notin")
+ (#\∋ . "ni")
+ (#\∏ . "prod")
+ (#\∑ . "sum")
+ (#\− . "minus")
+ (#\∗ . "lowast")
+ (#\√ . "radic")
+ (#\∝ . "prop")
+ (#\∞ . "infin")
+ (#\∠ . "ang")
+ (#\∧ . "and")
+ (#\∨ . "or")
+ (#\∩ . "cap")
+ (#\∪ . "cup")
+ (#\∫ . "int")
+ (#\∴ . "there4")
+ (#\∼ . "sim")
+ (#\≅ . "cong")
+ (#\≈ . "asymp")
+ (#\≠ . "ne")
+ (#\≡ . "equiv")
+ (#\≤ . "le")
+ (#\≥ . "ge")
+ (#\⊂ . "sub")
+ (#\⊃ . "sup")
+ (#\⊄ . "nsub")
+ (#\⊆ . "sube")
+ (#\⊇ . "supe")
+ (#\⊕ . "oplus")
+ (#\⊗ . "otimes")
+ (#\⊥ . "perp")
+ (#\⋅ . "sdot")
+ (#\⋮ . "vellip")
+ (#\⌈ . "lceil")
+ (#\⌉ . "rceil")
+ (#\⌊ . "lfloor")
+ (#\⌋ . "rfloor")
+ (#\〈 . "lang")
+ (#\〉 . "rang")
+ (#\◊ . "loz")
+ (#\♠ . "spades")
+ (#\♣ . "clubs")
+ (#\♥ . "hearts")
+ (#\♦ . "diams"))))
+
+(define (string->escaped-html s port)
+ "Write the HTML escaped form of S to PORT."
+ (define (escape c)
+ (let ((escaped (hash-ref %escape-chars c)))
+ (if escaped
+ (format port "&~a;" escaped)
+ (display c port))))
+ (string-for-each escape s))
+
+(define (object->escaped-html obj port)
+ "Write the HTML escaped form of OBJ to PORT."
+ (string->escaped-html
+ (call-with-output-string (cut display obj <>))
+ port))
+
+(define (attribute-value->html value port)
+ "Write the HTML escaped form of VALUE to PORT."
+ (if (string? value)
+ (string->escaped-html value port)
+ (object->escaped-html value port)))
+
+(define (attribute->html attr value port)
+ "Write ATTR and VALUE to PORT."
+ (format port "~a=\"" attr)
+ (attribute-value->html value port)
+ (display #\" port))
+
+(define (element->html tag attrs body port)
+ "Write the HTML TAG to PORT, where TAG has the attributes in the
+list ATTRS and the child nodes in BODY."
+ (format port "<~a" tag)
+ (for-each (match-lambda
+ ((attr value)
+ (display #\space port)
+ (attribute->html attr value port)))
+ attrs)
+ (if (and (null? body) (self-closing-tag? tag))
+ (display " />" port)
+ (begin
+ (display #\> port)
+ (for-each (cut sxml->html <> port) body)
+ (format port "</~a>" tag))))
+
+(define (doctype->html doctype port)
+ (format port "<!DOCTYPE ~a>" doctype))
+
+(define* (sxml->html tree #:optional (port (current-output-port)))
+ "Write the serialized HTML form of TREE to PORT."
+ (match tree
+ (() *unspecified*)
+ (('doctype type)
+ (doctype->html type port))
+ ;; Unescaped, raw HTML output
+ (('raw html)
+ (display html port))
+ (((? symbol? tag) ('@ attrs ...) body ...)
+ (element->html tag attrs body port))
+ (((? symbol? tag) body ...)
+ (element->html tag '() body port))
+ ((nodes ...)
+ (for-each (cut sxml->html <> port) nodes))
+ ((? string? text)
+ (string->escaped-html text port))
+ ;; Render arbitrary Scheme objects, too.
+ (obj (object->escaped-html obj port))))
diff --git a/mumi/web/util.scm b/mumi/web/util.scm
new file mode 100644
index 0000000..79c8c37
--- /dev/null
+++ b/mumi/web/util.scm
@@ -0,0 +1,44 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2014 David Thompson <davet@gnu.org>
+;;;
+;;; 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 web util)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (web request)
+ #:use-module (web uri)
+ #:export (parse-query-string
+ request-path-components
+ file-extension
+ directory?))
+
+(define (parse-query-string query)
+ "Parse and decode the URI query string QUERY and return an alist."
+ (let lp ((lst (map uri-decode (string-split query (char-set #\& #\=)))))
+ (match lst
+ ((key value . rest)
+ (cons (cons key value) (lp rest)))
+ (() '()))))
+
+(define (request-path-components request)
+ (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (file-extension file-name)
+ (last (string-split file-name #\.)))
+
+(define (directory? filename)
+ (string=? filename (dirname filename)))
diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
new file mode 100644
index 0000000..ca20982
--- /dev/null
+++ b/mumi/web/view/html.scm
@@ -0,0 +1,190 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2016, 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 web view html)
+ #:use-module (mu)
+ #:use-module (mumi messages)
+ #:use-module (mumi web view utils)
+ #:use-module (srfi srfi-1)
+ #:export (index
+ unknown
+ patch-page
+ patch-list))
+
+(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 header
+ '(div (@ (id "header"))
+ (div (@ (class "container"))
+ (div (@ (class "row"))
+ (a (@ (href "/"))
+ "Guix patches")))))
+
+(define (index)
+ (layout
+ #: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"))))))
+
+(define (unknown id)
+ (layout
+ #:body
+ `(,header
+ (div (@ (class "container"))
+ (h1 "Patch not found")
+ (p "There is no patch 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")))
+ '())))
+ (layout
+ #:body
+ `(,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"))))))))
+
+(define (patch-list query messages)
+ (layout
+ #:body
+ `(,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))))))))
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
new file mode 100644
index 0000000..b210bfc
--- /dev/null
+++ b/mumi/web/view/utils.scm
@@ -0,0 +1,76 @@
+;;; 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 web view utils)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
+ #:export (prettify
+ avatar-color))
+
+;; TODO: at some point this should tokenize the text, then apply
+;; styles, then output sxml, but for now we keep it simple
+(define (process line)
+ (cond
+ ((string= "---" line)
+ `(span (@ (class "line diff separator")) ,line))
+ ((string-prefix? "diff --git" line)
+ `(span (@ (class "line diff file")) ,line))
+ ((string-prefix? "+" line)
+ `(span (@ (class "line diff addition")) ,line))
+ ((and (string-prefix? "-" line)
+ (not (string= "--" line))
+ (not (string= "-- " line)))
+ `(span (@ (class "line diff deletion")) ,line))
+ ((string-prefix? "@@" line)
+ `(span (@ (class "line diff range")) ,line))
+ ((string-prefix? ">" line)
+ `(span (@ (class "line quote")) ,line))
+ ((or (string-prefix? "Signed-off-by" line)
+ (string-prefix? "Co-authored-by" line))
+ `(span (@ (class "commit attribution")) ,line))
+ ((or (string-prefix? "From: " line)
+ (string-prefix? "Date: " line)
+ (string-prefix? "Subject: " line))
+ `(span (@ (class "commit header")) ,line))
+ ((or (string-prefix? "* " line)
+ (string-prefix? " * " line))
+ `(span (@ (class "commit changelog")) ,line))
+ (else
+ `(span (@ (class "line")) ,line))))
+
+(define (prettify text)
+ (define result '())
+ (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))))))))
+
+(define colors
+ (circular-list "#8dd3c7" "#bebada" "#fb8072"
+ "#80b1d3" "#fdb462" "#b3de69"
+ "#fccde5" "#d9d9d9" "#bc80bd"
+ "#ccebc5" "#ffed6f"))
+
+(define (avatar-color who participants)
+ (or (and=> (assoc-ref (zip participants colors) who)
+ first)
+ (first colors)))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 03:46:18 +0000