summaryrefslogtreecommitdiff
path: root/mumi/web/view/html.scm
diff options
context:
space:
mode:
Diffstat (limited to 'mumi/web/view/html.scm')
-rw-r--r--mumi/web/view/html.scm415
1 files changed, 268 insertions, 147 deletions
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)))))))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 00:05:53 +0000