Goodbye mu, hello guile-debbugs!
[software/mumi.git] / mumi / web / view / html.scm
index ca209827147be8154f5a4fb56abe55b32c5d80ba..e6c429b53ecedcf88b5a3cee2ba00cd604a23a04 100644 (file)
@@ -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
 ;;; <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)))))))