mumi/web/view/html.scm

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