css: Draw multipart separator also when following an attachment.
[software/mumi.git] / mumi / web / view / html.scm
index da3b519c25551e150aded809556d45e9eead4d77..f6d50e94797ef413f6786568d2d62bc470334815 100644 (file)
@@ -17,9 +17,9 @@
 ;;; <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)
@@ -32,7 +32,8 @@
             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."
@@ -161,6 +157,12 @@ simple query language.  Here is a list of supported query terms:")
            (span (@ (class "filter"))
                  "submitter:me")
            ", "
+           (span (@ (class "filter"))
+                 "severity:serious")
+           ", "
+           (span (@ (class "filter"))
+                 "tag:easy")
+           ", "
            (span (@ (class "filter"))
                  "date:2d..now")
            ", "
@@ -215,6 +217,19 @@ simple query language.  Here is a list of supported query terms:")
        (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"))
@@ -267,6 +282,36 @@ some examples.")
              (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.  "
@@ -310,12 +355,35 @@ failed to process associated messages.")
 (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)
@@ -399,9 +467,77 @@ failed to process associated messages.")
                                      ((? 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:"
@@ -423,11 +559,16 @@ failed to process associated messages.")
                                                         (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))))
@@ -453,6 +594,7 @@ failed to process associated messages.")
                 (@ (class "col-11 offset-1 text-center"))
                 (div (@ (class "badge badge-primary closed")) "Closed"))))
             '())))
+
   (if (null? messages) #f
       (layout
        #:title (bug-subject* bug)
@@ -470,6 +612,7 @@ failed to process associated messages.")
                          (role "alert"))
                       ,text)))
               (_ '()))
+          ,sidebar
           (div
            (@ (class "title col-12"))
            (h1 (@ (class "h3")) ,(bug-subject* bug))
@@ -477,74 +620,12 @@ failed to process associated messages.")
           (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."
@@ -571,6 +652,16 @@ 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))
@@ -604,6 +695,24 @@ m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
        (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