mumi/web/view/html.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
   3 ;;;
   4 ;;; This program is free software: you can redistribute it and/or
   5 ;;; modify it under the terms of the GNU Affero General Public License
   6 ;;; as published by the Free Software Foundation, either version 3 of
   7 ;;; the License, or (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Affero General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Affero General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 (define-module (mumi web view html)
  19   #:use-module (debbugs email)
  20   #:use-module (debbugs bug)
  21   #:use-module (mumi config)
  22   #:use-module (mumi messages)
  23   #:use-module (mumi web view utils)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-19)
  26   #:export (index
  27             unknown
  28             error-page
  29             issue-page
  30             list-of-matching-bugs))
  31
  32 (define (status-tag bug)
  33   (let ((status (if (bug-done bug) "Done" "Open")))
  34     `(span (@ (class ,(string-append "status-tag "
  35                                      (string-downcase status))))
  36            ,status)))
  37
  38 (define* (layout #:key
  39                  (head '())
  40                  (body '())
  41                  (title "Guix issue tracker")
  42                  (extra-headers '()))
  43   `(#:sxml ((doctype "html")
  44             (html
  45              (head
  46               (title ,title)
  47               (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
  48               (meta (@ (http-equiv "Content-Language") (content "en")))
  49               (meta (@ (name "author") (content "Ricardo Wurmus")))
  50               (meta (@ (name "viewport")
  51                        (content "width=device-width, initial-scale=1")))
  52               (link
  53                (@ (rel "stylesheet")
  54                   (media "screen")
  55                   (type "text/css")
  56                   (href "/css/reset.css")))
  57               (link
  58                (@ (rel "stylesheet")
  59                   (media "screen")
  60                   (type "text/css")
  61                   (href "/css/bootstrap.css")))
  62               ,@head
  63               (link
  64                (@ (rel "stylesheet")
  65                   (media "screen")
  66                   (type "text/css")
  67                   (href "/css/screen.css"))))
  68              (body ,@body)))
  69     #:extra-headers ,extra-headers))
  70
  71 (define* (search-form #:key (standalone? #f))
  72   `(form (@ (id "search")
  73             ,@(if standalone?
  74                   '((class "row"))
  75                   '())
  76             (action "/search"))
  77          (div
  78           (@ (class "form-group"))
  79           (input (@ (type "text")
  80                     (id   "query")
  81                     (name "query")
  82                     (placeholder "input search query"))))
  83          (button
  84           (@ (type "submit")
  85              (class "btn btn-lg btn-primary btn-block")
  86              ,@(if standalone? '() '((style "display:none"))))
  87           "Search")))
  88
  89 (define* (header #:key (search-bar? #t))
  90   `(div
  91     (@ (id "header"))
  92     (div
  93      (@ (class "flex"))
  94      (a (@ (href "/") (class "logo"))
  95         (img (@ (src "/img/logo.png")
  96                 (alt "Guix patch tracker"))))
  97      ,@(if search-bar? (list (search-form)) '()))))
  98
  99 (define (index)
 100   (layout
 101    #:extra-headers
 102    '((cache-control . ((max-age . 60))))
 103    #:body
 104    `(,(header #:search-bar? #f)
 105      (div
 106       (@ (class "container"))
 107       (h1 "Guix patch tracker")
 108       (div
 109        (@ (id "about")
 110           (class "row"))
 111        (p "This is a web frontend to the Guix patch tracker.  Send email to "
 112           (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
 113              ,(%config 'submission-email-address))
 114           " to submit your patches."))
 115       ,(search-form #:standalone? #t)
 116       ;; TODO: do this via JS?
 117       ,@(let ((bugs (recent-bugs 5)))
 118           (if (null? bugs)
 119               '()
 120               `((h2 "Recent issues")
 121                 ,(list-of-bugs bugs))))))))
 122
 123 (define (unknown id)
 124   (layout
 125    #:body
 126    `(,(header)
 127      (div (@ (class "container"))
 128           (h1 "Patch not found")
 129           (p "There is no submission with id " (strong ,id))
 130           (p (a (@ (href "/")) "Try another one?"))))))
 131
 132 (define (error-page message)
 133   (layout
 134    #:body
 135    `(,(header)
 136      (div (@ (class "container"))
 137           (h1 "Error")
 138           (p "An error occurred.  Sorry about that!")
 139           ,message
 140           (p (a (@ (href "/")) "Try something else?"))))))
 141
 142 (define (issue-page bug)
 143   "Render the conversation for the given BUG."
 144   (define id (bug-num bug))
 145   (define messages (patch-messages id))
 146   (define parties (filter (compose (negate bot?) extract-email)
 147                           (participants messages)))
 148   (define (show-message message)
 149     `((div
 150        (@ (class "row"))
 151        (a (@ (id ,(number->string (email-msg-num message)))))
 152        (div
 153         (@ (class "avatar col-md-1")
 154            (style ,(string-append "background-color:"
 155                                   (avatar-color (sender-email message)
 156                                                 (map extract-email parties)))))
 157         ,(string-upcase (string-take (sender-name message) 1)))
 158        (div
 159         (@ (class "message col-md-11"))
 160         (div
 161          (@ (class "panel panel-default"))
 162          (div
 163           (@ (class "panel-heading"))
 164           (div
 165            (@ (class "from"))
 166            (span (@ (class "address")) ,(sender-name message))
 167            " wrote on "
 168            (span (@ (class "date"))
 169                  (a (@ (href ,(string-append "#" (number->string
 170                                                   (email-msg-num message)))))
 171                     ,(date message))))
 172           (div
 173            (@ (class "details"))
 174            (div
 175             (@ (class "recipients"))
 176             (label "Recipients:")
 177             ,(map (lambda (address)
 178                     `(span (@ (class "address")) ,address))
 179                   (recipients message)))
 180            (div
 181             (@ (class "message-id"))
 182             (label "Message-ID:")
 183             ,(message-id message))))
 184          (div
 185           (@ (class "body panel-body"))
 186           ,(prettify (email-body message))))))
 187       ,@(if (closing? message id)
 188             '((div
 189                (@ (class "row event"))
 190                (div
 191                 (@ (class "col-md-offset-1 col-md-11 text-center"))
 192                 (div (@ (class "label label-primary closed")) "Closed"))))
 193             '())))
 194   (layout
 195    #:title (bug-subject bug)
 196    #:extra-headers
 197    (cond
 198     ((bug-archived bug)
 199      ;; Tell browser to cache this for 12 hours.
 200      '((cache-control . ((max-age . 43200)))))
 201     ((bug-done bug)
 202      ;; Tell browser to cache this for 1 hour.
 203      '((cache-control . ((max-age . 3600)))))
 204     (else '()))
 205    #:body
 206    `(,(header)
 207      (div
 208       (@ (class "container"))
 209       (div
 210        (@ (class "row title col-md-12"))
 211        (h1 ,(bug-subject bug))
 212        (span (@ (class "details"))
 213              ,(status-tag bug)
 214              ,(string-append "Submitted by "
 215                              (extract-name (bug-originator bug))
 216                              ".")))
 217       (div
 218        (@ (class "row"))
 219        (div
 220         (@ (class "conversation col-md-9"))
 221         ,(map show-message (filter (lambda (msg)
 222                                      ;; Ignore messages
 223                                      ;; without body, and
 224                                      ;; internal messages.
 225                                      (and (email-body msg)
 226                                           (not (internal-message? msg))))
 227                                    messages))
 228         (div
 229          (@ (class "row comment-box"))
 230          (a (@ (id "comment")))
 231          (div
 232           (@ (class "avatar col-md-1")
 233              (style "background-color:#bc80bd")) "?")
 234              (div
 235           (@ (class "message col-md-11"))
 236           (div
 237            (@ (class "panel panel-default"))
 238            (div
 239             (@ (class "panel-heading"))
 240             (div (@ (class "from"))
 241                  (span (@ (class "address")) "Your comment")))
 242            (div
 243             (@ (class "body panel-body"))
 244             (p "Comments via the web interface are not currently
 245 supported.  To comment on this conversation "
 246                (a (@ (href ,(string-append "mailto:"
 247                                            (number->string id) "@" (%config 'debbugs-domain)
 248                                            "?subject=" (bug-subject bug))))
 249                   ,(string-append "send email to "
 250                                   (number->string id) "@" (%config 'debbugs-domain)))))))))
 251
 252        (div
 253         (@ (class "info col-md-3"))
 254         (div
 255          (@ (class "stat"))
 256          ,@(let ((num (length parties)))
 257              `((label ,(if (= num 1)
 258                            "One participant"
 259                            (string-append (number->string num)
 260                                           " participants")))
 261                (ul ,(map (lambda (name)
 262                            `(li (span (@ (class "name")))
 263                                 ,name))
 264                          (map extract-name parties))))))
 265         (div
 266          (@ (class "stat"))
 267          (label "Owner")
 268          ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
 269         (div
 270          (@ (class "stat"))
 271          (label "Status")
 272          ,(status-tag bug))))))))
 273
 274 (define (list-of-bugs bugs)
 275   "Return a table of BUGS."
 276   (if (null? bugs)
 277       `(p "Nothing to see here. "
 278           (a (@ (href "/"))
 279              "Look for something else?"))
 280       `(table (@ (class "table-condensed"))
 281               (thead
 282                (tr (th "ID")
 283                    (th "Subject")
 284                    (th "Date submitted")
 285                    (th "Status")))
 286               (tbody
 287                ,@(map (lambda (bug)
 288                         (let ((id (number->string (bug-num bug))))
 289                           `(tr
 290                             (td ,(or id "-"))
 291                             (td ,(if id
 292                                      `(a (@ (href ,(string-append "/issue/" id)))
 293                                          ,(bug-subject bug))
 294                                      (bug-subject bug)))
 295                             (td ,(date->string (bug-date bug)))
 296                             (td ,(status-tag bug)))))
 297                       bugs)))))
 298
 299 (define (list-of-matching-bugs query bugs)
 300   (layout
 301    #:body
 302    `(,(header)
 303      (div (@ (class "container"))
 304           ,@(if (zero? bugs)
 305                 `((h1 "No issues found")
 306                   (p "We could not find any issues matching your query "
 307                      (code ,query) ". "
 308                      (a (@ (href "/"))
 309                         "Try searching for something else?")))
 310                 `((h1 "Submissions matching " (code ,query))
 311                   ,(list-of-bugs bugs)))))))