;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; <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)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
unknown
error-page
issue-page
- list-of-matching-bugs))
+ list-of-matching-bugs
+ list-of-recent-issues
+ list-of-forgotten-issues))
(define (bug-subject* bug)
(or (bug-subject bug) "(no subject)"))
(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")))
- (link
- (@ (rel "stylesheet")
- (media "screen")
- (type "text/css")
- (href "/css/code.css"))))
- (body ,@body
- (footer (@ (class "text-center"))
- (p "Copyright © 2016—2020 by the GNU Guix community."
- (br)
- "Now with even more " (span (@ (class "lambda")) "λ") "! ")
- (p "This is free software. Download the "
- (a (@ (href "https://git.elephly.net/software/mumi.git"))
- "source code here") ".")))))
- #:extra-headers ,extra-headers))
+ (title "Guix issue tracker"))
+ `((doctype "html")
+ (html (@ (lang "en"))
+ (head
+ (title ,title)
+ (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
+ (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?202005160000"))))
+ (body ,@body
+ (footer (@ (class "text-center"))
+ (p "Copyright © 2016—2020 by the GNU Guix community."
+ (br)
+ "Now with even more " (span (@ (class "lambda")) "λ") "! ")
+ (p "This is free software. Download the "
+ (a (@ (href "https://git.elephly.net/software/mumi.git"))
+ "source code here") "."))
+ (script
+ (@ (src "/js/sort-table.js")))))))
-(define* (search-form #:key (standalone? #f))
+(define* (search-form #:key (standalone? #f) (text ""))
`(form (@ (id "search")
,(if standalone?
'(class "")
(class "form-control")
(id "query")
(name "query")
- (placeholder "input search query")))
+ (value ,text)
+ (placeholder "Input your search query...")))
(span (@ (class "input-group-append"))
(button
(@ (type "submit")
(clip-rule "evenodd")) "")
(path (@ (fill-rule "evenodd")
(d "M6.5 12a5.5 5.5 0 100-11 5.5 5.5 0 000 11zM13 6.5a6.5 6.5 0 11-13 0 6.5 6.5 0 0113 0z")
- (clip-rule "evenodd")) "")))))))
-
-(define* (header #:key (search-bar? #t))
- `(nav
- (@ (class "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 search-bar?
- `(,(search-form))
- '())))
+ (clip-rule "evenodd")) ""))))
+ (div
+ (@ (id "search-hints"))
+ (p "You can improve the search results by making use of the
+simple query language. Here is a list of supported query terms:")
+ (table
+ (@ (class "table table-sm table-borderless"))
+ (tbody
+ ,@(map (match-lambda
+ ((term description)
+ `(tr (td (span (@ (class "filter")) ,term))
+ (td ,description))))
+ '(("is:open" "open issues")
+ ("is:done" "closed issues")
+ ("submitter:<who>" "search issue submitter")
+ ("author:<who>" "search by message author")
+ ("date:yesterday..now" "search by issue date")
+ ("mdate:3m..2d" "search by message date")))))))))
-(define (index)
- (layout
- #:extra-headers
- '((cache-control . ((max-age . 60))))
- #:body
- `(,(header #:search-bar? #f)
- (main
- (@ (class "container"))
- (h1 "Guix patch tracker")
- (p (@ (class "lead"))
- "This is a web frontend to the Guix issue trackers. Send email to "
- (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
- ,(%config 'submission-email-address))
- " to submit your patches or email "
- (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
- ,(%config 'submission-bug-email-address))
- " to open a new issue.")
- (div
- (@ (class "card mb-5"))
- (div (@ (class "card-body bg-light"))
- ,(search-form #:standalone? #t)
- (p (@ (class "card-text"))
- (strong "Hint: ")
+(define* (search-widget #:key (text ""))
+ `(div
+ (@ (class "card mb-3"))
+ (div (@ (class "card-body bg-light"))
+ ,(search-form #:standalone? #t #:text text)
+ (details
+ (summary (strong "Hint"))
+ (p
"Refine your search with filters like "
(span (@ (class "filter"))
"is:open")
"submitter:me")
", "
(span (@ (class "filter"))
- "date:yesterday..now")
+ "severity:serious")
+ ", "
+ (span (@ (class "filter"))
+ "tag:easy")
+ ", "
+ (span (@ (class "filter"))
+ "date:2d..now")
", "
(span (@ (class "filter"))
"date:2018-04-01..2018-04-02")
"date:1m..today")
", and "
(a (@ (href "help#search"))
- "many more!"))))
- (h1 "Issues of interest")
- (table (@ (class "table table-condensed table-sm table-hover"))
- (thead
- (tr (th "ID")
- (th "Subject")
- (th "Date submitted")
- (th "Status")))
- (tbody
- (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Recent activity"))
- ,@(list-of-bugs (recent-bugs 10))
- (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Priority bugs"))
- ,@(priority-bugs)))))))
+ "many more!"))))))
+
+(define* (header #:key (search-bar? #t) title)
+ `(nav
+ (@ (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")) ,title))
+ '())
+ ,@(if search-bar?
+ `(,(search-form))
+ '())))
+
+(define (index)
+ (layout
+ #:body
+ `(,(header #:search-bar? #f)
+ (main
+ (@ (class "container"))
+ (h1 "Guix issue tracker")
+ (p (@ (class "lead"))
+ "This is a web frontend to the Guix patch and bug trackers. Send email to "
+ (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
+ ,(%config 'submission-email-address))
+ " to submit a patch, or email "
+ (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
+ ,(%config 'submission-bug-email-address))
+ " to submit a bug report.")
+ ,(search-widget)
+
+ (div (@ (class "mt-4 h4")) "Recent activity "
+ (small (a (@ (href "recent")) "(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 (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"))
+ (thead
+ (tr (@ (class "heading"))
+ (th (@ (class "js-sort-number")) "ID")
+ (th "Subject")
+ (th "Date submitted")
+ (th "Status")))
+ (tbody
+ ,@(priority-bugs)))))))
(define (help)
(layout
- #:extra-headers
- ;; Cache for 24 hours.
- '((cache-control . ((max-age . 86400))))
#:body
`(,(header #:search-bar? #f)
(div
(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 or comments submitted within the provided range. "
+ (td "Issues submitted within the provided range. "
(strong "start") " and " (strong "end") " can be one of "
- (strong "now") ", " (strong "today") ", " (strong "yesterday")
+ (strong "now") ", " (strong "today")
", a date in the formats "
(strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
", or an amount and a unit for a point in the past, such as "
- (strong "12d") " for 12 days ago. "
+ (strong "12d..") " for 12 days ago. "
"Supported units are: "
(strong "h") " (hours), "
(strong "d") " (days), "
(strong "w") " (weeks), "
(strong "m") " (months), and "
- (strong "y") " (years)."))))))))
+ (strong "y") " (years)."))
+ (tr
+ (td (span (@ (class "filter")) "mdate:<start>..<end>"))
+ (td "This is just like " (span (@ (class "filter")) "date")
+ " except that it also includes comments."))))))))
(define (unknown id)
(layout
#:body
`(,(header)
(div (@ (class "container"))
- (h1 "Patch not found")
- (p "There is no submission with id " (strong ,id))
+ (h1 "Issue not found")
+ (p "There is no submission with id " (strong ,id) ", or we
+failed to process associated messages.")
(p (a (@ (href "/")) "Try another one?"))))))
(define (error-page message)
,message
(p (a (@ (href "/")) "Try something else?"))))))
-(define (issue-page bug)
+(define* (issue-page bug #:optional flash-message)
"Render the conversation for the given BUG."
(define id (bug-num bug))
- (define messages (patch-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 messages))
+ (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))))
- (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)))
- (div
- (@ (class "message"))
- (div
- (@ (class "card"))
- (div
- (@ (class "card-header"))
- (div
- (@ (class "from"))
+ (a (@ (class "message-anchor")
+ (id ,(number->string message-number))))
(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 "address")) ,(sender-name message))
- " wrote on "
- (span (@ (class "date"))
- (a (@ (href ,(string-append "#" (number->string
- message-number))))
- ,(date->string (date message)))))
- ,@(if (string-suffix? previous-subject (subject message))
- '()
- `((div (@ (class "subject")) ,(subject 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 card-body"))
- ,(display-message-body id message-number message)))))
+ (@ (class "message"))
+ (div
+ (@ (class "card"))
+ (div
+ (@ (class "card-header"))
+ (div
+ (@ (class "from"))
+ (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 "address")) ,(sender-name message))
+ " wrote "
+ (span (@ (class "date"))
+ (a (@ (href ,(string-append "#" (number->string
+ 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))))
+ (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 card-body"))
+ ,(display-message-body id message-number message)))))
,@(if (closing? message id)
'((div
(@ (class "row event"))
(div
- (@ (class "col-md-11 offset-md-1 text-center"))
+ (@ (class "col-11 offset-1 text-center"))
(div (@ (class "badge badge-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 "title col-md-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))
- ".")
- ,@(if (bug-mergedwith bug)
- `((ul (@ (class "merged"))
- "Merged with: "
- ,(map (lambda (id)
- `(li (a (@ (href ,(string-append "/issue/" 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)
- `((ul (@ (class "blocks"))
- "Blocks: "
- ,(map (lambda (id)
- `(li (a (@ (href ,(string-append "/issue/" 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)
- `((ul (@ (class "blockedby"))
- "Blocked by: "
- ,(map (lambda (id)
- `(li (a (@ (href ,(string-append "/issue/" 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)))))))
- '())))
- (div (@ (class "row"))
- (div
- (@ (class "conversation col-md"))
- ,(let ((msgs (filter (lambda (msg)
- ;; Ignore messages
- ;; without body, and
- ;; internal messages.
- (and (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")))
+
+ (if (null? messages) #f
+ (layout
+ #:title (bug-subject* bug)
+ #:body
+ `(,(header #:title (bug-subject* bug))
(div
- (@ (class "avatar")
- (style "background-color:#bc80bd")) "?")
- (div
- (@ (class "message"))
+ (@ (class "container"))
+ ,@(match flash-message
+ (('error . text)
+ `((div (@ (class "alert alert-danger")
+ (role "alert"))
+ ,text)))
+ (('info . text)
+ `((div (@ (class "alert alert-info")
+ (role "alert"))
+ ,text)))
+ (_ '()))
+ ,sidebar
(div
- (@ (class "card"))
- (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)))))))))
-
- (div
- (@ (class "info col-md-3"))
- (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)))
- (dl
- (@ (class "stat"))
- (dt "Status")
- (dd ,(status-tag bug)))))))))
+ (@ (class "title col-12"))
+ (h1 (@ (class "h3")) ,(bug-subject* bug))
+ ,issue-details)
+ (div (@ (class "row"))
+ (div
+ (@ (class "conversation col-12"))
+ ,(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."
(let ((id (number->string (bug-num bug))))
`(tr (@ (class ,(bug-severity bug)))
(td ,(or id "-"))
- (td ,(if id
- `(a (@ (href ,(string-append "/issue/" id)))
+ (td
+ ,@(if (member (bug-severity bug) '("serious" "important"))
+ `((svg (@ (xmlns"http://www.w3.org/2000/svg")
+ (xmlns:xlink "http://www.w3.org/1999/xlink")
+ (viewBox "0 0 14 16")
+ (version "1.1")
+ (height "1rem")
+ (width "1rem")
+ (aria-hidden "true"))
+ (title ,(bug-severity bug))
+ (path (@ (fill-rule "evenodd")
+ (d "\
+M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
+s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
+c0-3.14 2.56-5.7 5.7-5.7z\
+M7 1C3.14 1 0 4.14 0 8\
+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))
(bug-subject* bug)))
(td ,(date->string (bug-date bug)))
(bugs-by-severity "important" "open"))
(lambda (a b) (< (bug-num a) (bug-num b))))))
+(define* (list-of-recent-issues #:optional (max 100))
+ (layout
+ #:body
+ `(,(header #:search-bar? #f)
+ (div
+ (@ (class "container"))
+ (h1 "Recent 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 (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
- `(,(header)
- (div (@ (class "container"))
- ,@(if (null? 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))
- (table (@ (class "table table-condensed table-sm table-hover"))
- (thead
- (tr (th "ID")
- (th "Subject")
- (th "Date submitted")
- (th "Status")))
- (tbody
- ,@(list-of-bugs bugs)))))))))
+ `(,(header #:search-bar? #f)
+ (div
+ (@ (class "container"))
+ (h1 "Your search for " (code ,query))
+ ,(search-widget #:text query)
+ ,(if (null? bugs)
+ `(div
+ (@ (class "alert alert-warning")
+ (role "alert"))
+ (h4
+ (@ (class "alert-heading"))
+ "Nothing found!")
+ (p "We could not find any issues matching your query "
+ (code ,query) ". "
+ (a (@ (href "/"))
+ "Try searching for something else?")))
+ `(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 bugs))))))))
projects / software / mumi.git / blobdiff