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