;;; <http://www.gnu.org/licenses/>.
(define-module (mumi web view html)
- #:use-module (debbugs bug)
#:use-module (email email)
#:use-module (mumi config)
+ #:use-module (mumi debbugs)
#:use-module (mumi messages)
#:use-module (mumi web view utils)
#:use-module (mumi web util)
error-page
issue-page
list-of-matching-bugs
- list-of-recent-issues))
+ list-of-recent-issues
+ list-of-forgotten-issues))
(define (bug-subject* bug)
(or (bug-subject bug) "(no subject)"))
(@ (rel "stylesheet")
(media "screen")
(type "text/css")
- (href "/css/screen.css")))
- (link
- (@ (rel "stylesheet")
- (media "screen")
- (type "text/css")
- (href "/css/code.css"))))
+ (href "/css/screen.css?202005160000"))))
(body ,@body
(footer (@ (class "text-center"))
(p "Copyright © 2016—2020 by the GNU Guix community."
(span (@ (class "filter"))
"submitter:me")
", "
+ (span (@ (class "filter"))
+ "severity:serious")
+ ", "
+ (span (@ (class "filter"))
+ "tag:easy")
+ ", "
(span (@ (class "filter"))
"date:2d..now")
", "
(define* (header #:key (search-bar? #t) title)
`(nav
- (@ (class "fixed-top navbar navbar-expand navbar-light bg-light"))
+ (@ (class "sticky-top navbar navbar-expand navbar-light bg-light"))
(a (@ (href "/") (class "navbar-brand pt-0 logo navbar-collapse"))
(img (@ (src "/img/logo.png") (alt "logo") (height "25"))))
,@(if title
- `((span (@ (class "navbar-text navbar-collapse")) ,title))
+ `((span (@ (class "navbar-text")) ,title))
'())
,@(if search-bar?
`(,(search-form))
(tbody
,@(list-of-bugs (recent-bugs 10))))
+ (div (@ (class "mt-4 h4")) "Forgotten issues "
+ (small (a (@ (href "forgotten")) "(More)")))
+ (table
+ (@ (class "table table-borderless table-hover js-sort-table"))
+ (thead
+ (tr (@ (class "heading"))
+ (th (@ (class "js-sort-number")) "ID")
+ (th "Subject")
+ (th "Date submitted")
+ (th "Status")))
+ (tbody
+ ,@(list-of-bugs (forgotten-issues 10))))
+
(div (@ (class "mt-4 h4")) "Priority bugs")
(table
(@ (class "table table-borderless table-hover js-sort-table"))
(span (@ (class "filter")) "author:rekado")
" for all messages where rekado has commented. "
"The filter matches both the email address and the name."))
+ (tr
+ (td (span (@ (class "filter")) "severity:<type>"))
+ (td "Issues that have been marked with the given severity, e.g. "
+ (span (@ (class "filter")) "severity:serious")
+ " for all issues that have been labelled as serious bugs. "
+ "The following severities are recognized: "
+ (strong "critical") ", "
+ (strong "grave") ", "
+ (strong "serious") ", "
+ (strong "important") ", "
+ (strong "normal") ", "
+ (strong "minor") ", and "
+ (strong "wishlist") "."))
+ (tr
+ (td (span (@ (class "filter")) "tag:<type>"))
+ (td "Issues that have been tagged with the given tag, e.g. "
+ (span (@ (class "filter")) "tag:easy")
+ " for all easy issues that are suitable for newcomers. "
+ "The following tags are recognized: "
+ (strong "patch") ", "
+ (strong "wontfix") ", "
+ (strong "moreinfo") ", "
+ (strong "unreproducible") ", "
+ (strong "fixed") ", "
+ (strong "notabug") ", "
+ (strong "pending") ", "
+ (strong "help") ", "
+ (strong "security") ", "
+ (strong "confirmed") ", and "
+ (strong "easy") "."))
(tr
(td (span (@ (class "filter")) "date:<start>..<end>"))
(td "Issues submitted within the provided range. "
(define* (issue-page bug #:optional flash-message)
"Render the conversation for the given BUG."
(define id (bug-num bug))
- (define messages (issue-messages id))
+ (define messages
+ (filter (lambda (msg)
+ ;; Ignore messages without body, and internal messages.
+ (and msg
+ (email-body msg)
+ (not (internal-message? msg))))
+ (issue-messages id)))
(define parties (sort (filter (compose (negate bot?) extract-email)
(participants (filter identity messages)))
(lambda (a b)
(string< (extract-email a)
(extract-email b)))))
+ (define sidebar
+ `(ul (@ (id "sidebar")
+ (class "sticky-top flex-column"))
+ ,(map (lambda (message message-number)
+ `(li
+ (div
+ (@ (class "avatar")
+ (style ,(string-append "background-color:"
+ (avatar-color (sender-email message)
+ (map extract-email parties)))))
+ ,(string-upcase (string-take (sender-name message) 1)))
+ (span (@ (class "date"))
+ (a (@ (href ,(string-append "#" (number->string
+ message-number))))
+ ,(time->string (date message))))))
+ messages
+ (iota (length messages)))))
+ (define issue-details
+ `(span (@ (class "details"))
+ ,(status-tag bug)
+ ,(string-append "Submitted by "
+ ;; We don't use bug-originator here
+ ;; because it includes the email address.
+ ;; We cannot use extract-name on the
+ ;; return value, because it swallows
+ ;; non-ASCII characters.
+ (sender-name (first messages))
+ ".")
+ (details
+ (@ (class "info"))
+ (summary "Details")
+ (dl
+ (@ (class "stat"))
+ ,@(let ((num (length parties)))
+ `((dt ,(if (= num 1)
+ "One participant"
+ (string-append (number->string num)
+ " participants")))
+ (dd
+ (ul ,(map (lambda (name)
+ `(li (span (@ (class "name")))
+ ,name))
+ (map extract-name parties)))))))
+ (dl
+ (@ (class "stat"))
+ (dt "Owner")
+ (dd
+ ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
+ (dl
+ (@ (class "stat"))
+ (dt "Severity")
+ (dd ,(bug-severity bug)))
+ ,@(if (bug-mergedwith bug)
+ `((dl
+ (@ (class "stat"))
+ (dt "Merged with")
+ (dd (ul ,(map (lambda (id)
+ `(li (a (@ (href ,(string-append "/" id)))
+ ,id)))
+ ;; XXX: This field can either hold a
+ ;; string of multiple ids, or a single
+ ;; number. Deal with this mess.
+ (match (bug-mergedwith bug)
+ ((? string? str)
+ (string-split str #\space))
+ ((? number? n)
+ (list (number->string n)))))))))
+ '())
+ ,@(if (bug-blocks bug)
+ `((dl
+ (@ (class "stat"))
+ (dt "Blocks")
+ (dd (ul ,(map (lambda (id)
+ `(li (a (@ (href ,(string-append "/" id)))
+ ,id)))
+ ;; XXX: This field can either hold a
+ ;; string of multiple ids, or a single
+ ;; number. Deal with this mess.
+ (match (bug-blocks bug)
+ ((? string? str)
+ (string-split str #\space))
+ ((? number? n)
+ (list (number->string n)))))))))
+ '())
+ ,@(if (bug-blockedby bug)
+ `((dl
+ (@ (class "stat"))
+ (dt "Blocked by")
+ (dd (ul ,(map (lambda (id)
+ `(li (a (@ (href ,(string-append "/" id)))
+ ,id)))
+ ;; XXX: This field can either hold a
+ ;; string of multiple ids, or a single
+ ;; number. Deal with this mess.
+ (match (bug-blockedby bug)
+ ((? string? str)
+ (string-split str #\space))
+ ((? number? n)
+ (list (number->string n)))))))))
+ '()))))
+ (define comment-box
+ `(div
+ (@ (class "comment-box"))
+ (a (@ (id "comment")))
+ (div
+ (@ (class "avatar")
+ (style "background-color:#bc80bd")) "?")
+ (div
+ (@ (class "message"))
+ (div
+ (@ (class "card"))
+ ,@(if (and (mailer-enabled?)
+ (not (bug-archived bug)))
+ `((form
+ (@ (action ,(format #f "/issue/~a/comment"
+ (number->string id)))
+ (enctype "multipart/form-data")
+ (method "POST"))
+ (input (@ (style "display:none")
+ (name "validation")
+ (placeholder "Please leave this empty.")) "")
+ (input (@ (type "hidden")
+ (name "timestamp")
+ (value ,(timestamp!))) "")
+ (div
+ (@ (class "card-header"))
+ (div (@ (class "from"))
+ (input (@ (class "address form-control")
+ (name "from")
+ (required "required")
+ (placeholder "Your name")) "")))
+ (div
+ (@ (class "body card-body"))
+ (textarea (@ (name "text")
+ (required "required")
+ (class "form-control")
+ (placeholder "Please input your comment..."))
+ ""))
+ (div
+ (@ (class "card-footer"))
+ (button (@ (class "btn btn-primary")
+ (type "submit"))
+ "Send")
+ (span (@ (class "ml-3"))
+ "Your may also "
+ (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)))
+ " to comment."))))
+ `((div
+ (@ (class "card-header"))
+ (div (@ (class "from"))
+ (span (@ (class "address")) "Your comment")))
+ (div
+ (@ (class "body card-body"))
+ ,(if (bug-archived bug)
+ '(p "This issue is archived.")
+ '(p "Commenting via the web interface is
+currently disabled."))
+ (p "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)))))))))))
(define (show-message message-number message previous-subject)
`((div (@ (class "mb-5"))
- (a (@ (id ,(number->string message-number))))
+ (a (@ (class "message-anchor")
+ (id ,(number->string message-number))))
(div
(@ (class "avatar")
(style ,(string-append "background-color:"
(map extract-email parties)))))
,(string-upcase (string-take (sender-name message) 1)))
(span (@ (class "address")) ,(sender-name message))
- " wrote on "
+ " wrote "
(span (@ (class "date"))
(a (@ (href ,(string-append "#" (number->string
- message-number))))
- ,(date->string (date message)))))
+ message-number)))
+ (title ,(date->string (date message))))
+ ,(time->string (date message)))))
+ (div (@ (class "download-message"))
+ (a (@ (href ,(format #f "issue/~a/raw/~a"
+ id message-number)))
+ ,download-icon))
,@(if (string-suffix? previous-subject (subject message))
'()
`((div (@ (class "subject")) ,(subject message))))
(@ (class "col-11 offset-1 text-center"))
(div (@ (class "badge badge-primary closed")) "Closed"))))
'())))
+
(if (null? messages) #f
(layout
#:title (bug-subject* bug)
(role "alert"))
,text)))
(_ '()))
+ ,sidebar
(div
(@ (class "title col-12"))
- (h1 ,(bug-subject* bug))
- (span (@ (class "details"))
- ,(status-tag bug)
- ,(string-append "Submitted by "
- ;; We don't use bug-originator here
- ;; because it includes the email address.
- ;; We cannot use extract-name on the
- ;; return value, because it swallows
- ;; non-ASCII characters.
- (sender-name (first messages))
- ".")
- (details
- (@ (class "info"))
- (summary "Details")
- (dl
- (@ (class "stat"))
- ,@(let ((num (length parties)))
- `((dt ,(if (= num 1)
- "One participant"
- (string-append (number->string num)
- " participants")))
- (dd
- (ul ,(map (lambda (name)
- `(li (span (@ (class "name")))
- ,name))
- (map extract-name parties)))))))
- (dl
- (@ (class "stat"))
- (dt "Owner")
- (dd
- ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
- (dl
- (@ (class "stat"))
- (dt "Severity")
- (dd ,(bug-severity bug)))
- ,@(if (bug-mergedwith bug)
- `((dl
- (@ (class "stat"))
- (dt "Merged with")
- (dd (ul ,(map (lambda (id)
- `(li (a (@ (href ,(string-append "/" id)))
- ,id)))
- ;; XXX: This field can either hold a
- ;; string of multiple ids, or a single
- ;; number. Deal with this mess.
- (match (bug-mergedwith bug)
- ((? string? str)
- (string-split str #\space))
- ((? number? n)
- (list (number->string n)))))))))
- '())
- ,@(if (bug-blocks bug)
- `((dl
- (@ (class "stat"))
- (dt "Blocks")
- (dd (ul ,(map (lambda (id)
- `(li (a (@ (href ,(string-append "/" id)))
- ,id)))
- ;; XXX: This field can either hold a
- ;; string of multiple ids, or a single
- ;; number. Deal with this mess.
- (match (bug-blocks bug)
- ((? string? str)
- (string-split str #\space))
- ((? number? n)
- (list (number->string n)))))))))
- '())
- ,@(if (bug-blockedby bug)
- `((dl
- (@ (class "stat"))
- (dt "Blocked by")
- (dd (ul ,(map (lambda (id)
- `(li (a (@ (href ,(string-append "/" id)))
- ,id)))
- ;; XXX: This field can either hold a
- ;; string of multiple ids, or a single
- ;; number. Deal with this mess.
- (match (bug-blockedby bug)
- ((? string? str)
- (string-split str #\space))
- ((? number? n)
- (list (number->string n)))))))))
- '()))))
+ (h1 (@ (class "h3")) ,(bug-subject* bug))
+ ,issue-details)
(div (@ (class "row"))
(div
(@ (class "conversation col-12"))
- ,(let ((msgs (filter (lambda (msg)
- ;; Ignore messages
- ;; without body, and
- ;; internal messages.
- (and msg
- (email-body msg)
- (not (internal-message? msg))))
- messages)))
- (map (lambda (message-number msg previous-subject)
- (show-message message-number msg previous-subject))
- (iota (length msgs))
- msgs
- (cons (bug-subject* bug)
- (map subject msgs))))
- (div
- (@ (class "comment-box"))
- (a (@ (id "comment")))
- (div
- (@ (class "avatar")
- (style "background-color:#bc80bd")) "?")
- (div
- (@ (class "message"))
- (div
- (@ (class "card"))
- ,@(if (mailer-enabled?)
- `((form
- (@ (action ,(format #f "/issue/~a/comment"
- (number->string id)))
- (enctype "multipart/form-data")
- (method "POST"))
- (input (@ (style "display:none")
- (name "validation")
- (placeholder "Please leave this empty.")) "")
- (input (@ (type "hidden")
- (name "timestamp")
- (value ,(timestamp!))) "")
- (div
- (@ (class "card-header"))
- (div (@ (class "from"))
- (input (@ (class "address form-control")
- (name "from")
- (required "required")
- (placeholder "Your name")) "")))
- (div
- (@ (class "body card-body"))
- (textarea (@ (name "text")
- (required "required")
- (class "form-control")
- (placeholder "Please input your comment..."))
- ""))
- (div
- (@ (class "card-footer"))
- (button (@ (class "btn btn-primary")
- (type "submit"))
- "Send"))))
- `((div
- (@ (class "card-header"))
- (div (@ (class "from"))
- (span (@ (class "address")) "Your comment")))
- (div
- (@ (class "body card-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)))))))))))))))))
+ ,(map show-message
+ (iota (length messages))
+ messages
+ (cons (bug-subject* bug)
+ (map subject messages)))
+ ,comment-box)))))))
(define (list-of-bugs bugs)
"Return table rows for all BUGS."
s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
'())
+ ,@(or (and=> (bug-tags bug)
+ (lambda (tags)
+ (map (lambda (tag)
+ `(a (@ (href ,(string-append "search?query=tag:" tag)))
+ (span
+ (@ (class ,(string-append "badge badge-info mr-1 "
+ tag)))
+ ,tag)))
+ (string-split tags #\space))))
+ '())
,(if id
`(a (@ (href ,(string-append "/" id)))
,(bug-subject* bug))
(tbody
,@(list-of-bugs (recent-bugs max))))))))
+(define* (list-of-forgotten-issues #:optional (max 100))
+ (layout
+ #:body
+ `(,(header #:search-bar? #f)
+ (div
+ (@ (class "container"))
+ (h1 "Forgotten issues")
+ (table
+ (@ (class "table table-borderless table-hover js-sort-table"))
+ (thead
+ (tr (@ (class "heading"))
+ (th (@ (class "js-sort-number")) "ID")
+ (th "Subject")
+ (th "Date submitted")
+ (th "Status")))
+ (tbody
+ ,@(list-of-bugs (forgotten-issues max))))))))
+
(define (list-of-matching-bugs query bugs)
(layout
#:body
projects / software / mumi.git / blobdiff