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