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   "Return a colored tag indicating the BUG status."
  34   (let ((status (if (bug-done bug) "Done" "Open")))
  35     `(span (@ (class ,(string-append "status-tag "
  36                                      (string-downcase status))))
  37            ,status)))
  38
  39 (define* (layout #:key
  40                  (head '())
  41                  (body '())
  42                  (title "Guix issue tracker")
  43                  (extra-headers '()))
  44   `(#:sxml ((doctype "html")
  45             (html
  46              (head
  47               (title ,title)
  48               (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
  49               (meta (@ (http-equiv "Content-Language") (content "en")))
  50               (meta (@ (name "author") (content "Ricardo Wurmus")))
  51               (meta (@ (name "viewport")
  52                        (content "width=device-width, initial-scale=1")))
  53               (link
  54                (@ (rel "stylesheet")
  55                   (media "screen")
  56                   (type "text/css")
  57                   (href "/css/reset.css")))
  58               (link
  59                (@ (rel "stylesheet")
  60                   (media "screen")
  61                   (type "text/css")
  62                   (href "/css/bootstrap.css")))
  63               ,@head
  64               (link
  65                (@ (rel "stylesheet")
  66                   (media "screen")
  67                   (type "text/css")
  68                   (href "/css/screen.css"))))
  69              (body ,@body)))
  70     #:extra-headers ,extra-headers))
  71
  72 (define* (search-form #:key (standalone? #f))
  73   `(form (@ (id "search")
  74             ,(if standalone?
  75                  '(class "row")
  76                  '(class "navbar-form navbar-right"))
  77             (action "/search"))
  78          (div
  79           (@ (class ,(if standalone?
  80                          "input-group input-group-lg"
  81                          "input-group")))
  82           (input (@ (type "text")
  83                     (class "form-control")
  84                     (id   "query")
  85                     (name "query")
  86                     (placeholder "input search query")))
  87                (span (@ (class "input-group-btn"))
  88                     (button
  89                      (@ (type "submit")
  90                         (class ,(string-append (if standalone? "btn-lg " "")
  91                                                "btn btn-primary")))
  92                      "Search")))))
  93
  94 (define* (header #:key (search-bar? #t))
  95   `(nav
  96     (@ (id "header") (class "navbar navbar-default"))
  97     (div
  98      (@ (class "container-fluid"))
  99      (div
 100       (@ (class "navbar-header"))
 101       (div (@ (class "navbar-brand"))
 102            (a (@ (href "/") (class "logo"))
 103               (img (@ (src "/img/logo.png")
 104                       (alt "Guix patch tracker"))))))
 105      ,@(if search-bar?
 106            `(,(search-form))
 107            '()))))
 108
 109 (define (index)
 110   (layout
 111    #:extra-headers
 112    '((cache-control . ((max-age . 60))))
 113    #:body
 114    `(,(header #:search-bar? #f)
 115      (div
 116       (@ (class "container"))
 117       (h1 "Guix patch tracker")
 118       (div
 119        (@ (id "about")
 120           (class "row"))
 121        (p "This is a web frontend to the Guix patch tracker.  Send email to "
 122           (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
 123              ,(%config 'submission-email-address))
 124           " to submit your patches."))
 125       ,(search-form #:standalone? #t)
 126       ;; TODO: do this via JS?
 127       ,@(let ((bugs (recent-bugs 5)))
 128           (if (null? bugs)
 129               '()
 130               `((h2 "Recent activity")
 131                 ,(list-of-bugs bugs))))))))
 132
 133 (define (unknown id)
 134   (layout
 135    #:body
 136    `(,(header)
 137      (div (@ (class "container"))
 138           (h1 "Patch not found")
 139           (p "There is no submission with id " (strong ,id))
 140           (p (a (@ (href "/")) "Try another one?"))))))
 141
 142 (define (error-page message)
 143   (layout
 144    #:body
 145    `(,(header)
 146      (div (@ (class "container"))
 147           (h1 "Error")
 148           (p "An error occurred.  Sorry about that!")
 149           ,message
 150           (p (a (@ (href "/")) "Try something else?"))))))
 151
 152 (define (issue-page bug)
 153   "Render the conversation for the given BUG."
 154   (define id (bug-num bug))
 155   (define messages (patch-messages id))
 156   (define parties (filter (compose (negate bot?) extract-email)
 157                           (participants messages)))
 158   (define (show-message message)
 159     `((div
 160        (@ (class "row"))
 161        (a (@ (id ,(number->string (email-msg-num message)))))
 162        (div
 163         (@ (class "avatar col-md-1")
 164            (style ,(string-append "background-color:"
 165                                   (avatar-color (sender-email message)
 166                                                 (map extract-email parties)))))
 167         ,(string-upcase (string-take (sender-name message) 1)))
 168        (div
 169         (@ (class "message col-md-11"))
 170         (div
 171          (@ (class "panel panel-default"))
 172          (div
 173           (@ (class "panel-heading"))
 174           (div
 175            (@ (class "from"))
 176            (span (@ (class "address")) ,(sender-name message))
 177            " wrote on "
 178            (span (@ (class "date"))
 179                  (a (@ (href ,(string-append "#" (number->string
 180                                                   (email-msg-num message)))))
 181                     ,(date message))))
 182           (div
 183            (@ (class "details"))
 184            (div
 185             (@ (class "recipients"))
 186             (label "Recipients:")
 187             ,(map (lambda (address)
 188                     `(span (@ (class "address")) ,address))
 189                   (recipients message)))
 190            (div
 191             (@ (class "message-id"))
 192             (label "Message-ID:")
 193             ,(message-id message))))
 194          (div
 195           (@ (class "body panel-body"))
 196           ,(display-message-body message)))))
 197       ,@(if (closing? message id)
 198             '((div
 199                (@ (class "row event"))
 200                (div
 201                 (@ (class "col-md-offset-1 col-md-11 text-center"))
 202                 (div (@ (class "label label-primary closed")) "Closed"))))
 203             '())))
 204   (layout
 205    #:title (bug-subject bug)
 206    #:extra-headers
 207    (cond
 208     ((bug-archived bug)
 209      ;; Tell browser to cache this for 12 hours.
 210      '((cache-control . ((max-age . 43200)))))
 211     ((bug-done bug)
 212      ;; Tell browser to cache this for 1 hour.
 213      '((cache-control . ((max-age . 3600)))))
 214     (else '()))
 215    #:body
 216    `(,(header)
 217      (div
 218       (@ (class "container"))
 219       (div
 220        (@ (class "row title col-md-12"))
 221        (h1 ,(bug-subject bug))
 222        (span (@ (class "details"))
 223              ,(status-tag bug)
 224              ,(string-append "Submitted by "
 225                              ;; We don't use bug-originator here
 226                              ;; because it includes the email address.
 227                              ;; We cannot use extract-name on the
 228                              ;; return value, because it swallows
 229                              ;; non-ASCII characters.
 230                              (sender-name (first messages))
 231                              ".")))
 232       (div
 233        (@ (class "row"))
 234        (div
 235         (@ (class "conversation col-md-9"))
 236         ,(map show-message (filter (lambda (msg)
 237                                      ;; Ignore messages
 238                                      ;; without body, and
 239                                      ;; internal messages.
 240                                      (and (email-body msg)
 241                                           (not (internal-message? msg))))
 242                                    messages))
 243         (div
 244          (@ (class "row comment-box"))
 245          (a (@ (id "comment")))
 246          (div
 247           (@ (class "avatar col-md-1")
 248              (style "background-color:#bc80bd")) "?")
 249              (div
 250           (@ (class "message col-md-11"))
 251           (div
 252            (@ (class "panel panel-default"))
 253            (div
 254             (@ (class "panel-heading"))
 255             (div (@ (class "from"))
 256                  (span (@ (class "address")) "Your comment")))
 257            (div
 258             (@ (class "body panel-body"))
 259             (p "Comments via the web interface are not currently
 260 supported.  To comment on this conversation "
 261                (a (@ (href ,(string-append "mailto:"
 262                                            (number->string id) "@" (%config 'debbugs-domain)
 263                                            "?subject=" (bug-subject bug))))
 264                   ,(string-append "send email to "
 265                                   (number->string id) "@" (%config 'debbugs-domain)))))))))
 266
 267        (div
 268         (@ (class "info col-md-3"))
 269         (div
 270          (@ (class "stat"))
 271          ,@(let ((num (length parties)))
 272              `((label ,(if (= num 1)
 273                            "One participant"
 274                            (string-append (number->string num)
 275                                           " participants")))
 276                (ul ,(map (lambda (name)
 277                            `(li (span (@ (class "name")))
 278                                 ,name))
 279                          (map extract-name parties))))))
 280         (div
 281          (@ (class "stat"))
 282          (label "Owner")
 283          ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
 284         (div
 285          (@ (class "stat"))
 286          (label "Severity")
 287          ,(bug-severity bug))
 288         (div
 289          (@ (class "stat"))
 290          (label "Status")
 291          ,(status-tag bug))))))))
 292
 293 (define (list-of-bugs bugs)
 294   "Return a table of BUGS."
 295   (if (null? bugs)
 296       `(p "Nothing to see here. "
 297           (a (@ (href "/"))
 298              "Look for something else?"))
 299       `(table (@ (class "table-condensed"))
 300               (thead
 301                (tr (th "ID")
 302                    (th "Subject")
 303                    (th "Date submitted")
 304                    (th "Status")))
 305               (tbody
 306                ,@(map (lambda (bug)
 307                         (let ((id (number->string (bug-num bug))))
 308                           `(tr
 309                             (td ,(or id "-"))
 310                             (td ,(if id
 311                                      `(a (@ (href ,(string-append "/issue/" id)))
 312                                          ,(bug-subject bug))
 313                                      (bug-subject bug)))
 314                             (td ,(date->string (bug-date bug)))
 315                             (td ,(status-tag bug)))))
 316                       bugs)))))
 317
 318 (define (list-of-matching-bugs query bugs)
 319   (layout
 320    #:body
 321    `(,(header)
 322      (div (@ (class "container"))
 323           ,@(if (null? bugs)
 324                 `((h1 "No issues found")
 325                   (p "We could not find any issues matching your query "
 326                      (code ,query) ". "
 327                      (a (@ (href "/"))
 328                         "Try searching for something else?")))
 329                 `((h1 "Submissions matching " (code ,query))
 330                   ,(list-of-bugs bugs)))))))