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