mumi/web/view/html.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2018, 2019 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 (mumi web util)
  26   #:use-module (ice-9 match)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-19)
  29   #:export (index
  30             help
  31             unknown
  32             error-page
  33             issue-page
  34             list-of-matching-bugs
  35             list-of-recent-issues))
  36
  37 (define (bug-subject* bug)
  38   (or (bug-subject bug) "(no subject)"))
  39
  40 (define (status-tag bug)
  41   "Return a colored tag indicating the BUG status."
  42   (let ((status (if (bug-done bug) "Done" "Open")))
  43     `(span (@ (class ,(string-append "status-tag "
  44                                      (string-downcase status))))
  45            ,status)))
  46
  47 (define* (layout #:key
  48                  (head '())
  49                  (body '())
  50                  (title "Guix issue tracker"))
  51   `((doctype "html")
  52     (html
  53      (head
  54       (title ,title)
  55       (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
  56       (meta (@ (http-equiv "Content-Language") (content "en")))
  57       (meta (@ (name "author") (content "Ricardo Wurmus")))
  58       (meta (@ (name "viewport")
  59                (content "width=device-width, initial-scale=1")))
  60       (link
  61        (@ (rel "stylesheet")
  62           (media "screen")
  63           (type "text/css")
  64           (href "/css/reset.css")))
  65       (link
  66        (@ (rel "stylesheet")
  67           (media "screen")
  68           (type "text/css")
  69           (href "/css/bootstrap.css")))
  70       ,@head
  71       (link
  72        (@ (rel "stylesheet")
  73           (media "screen")
  74           (type "text/css")
  75           (href "/css/screen.css")))
  76       (link
  77        (@ (rel "stylesheet")
  78           (media "screen")
  79           (type "text/css")
  80           (href "/css/code.css"))))
  81      (body ,@body
  82            (footer (@ (class "text-center"))
  83                    (p "Copyright © 2016—2020 by the GNU Guix community."
  84                       (br)
  85                       "Now with even more " (span (@ (class "lambda")) "λ") "! ")
  86                    (p "This is free software.  Download the "
  87                       (a (@ (href "https://git.elephly.net/software/mumi.git"))
  88                          "source code here") ".")))
  89      (script
  90       (@ (type "text/javascript")
  91          (src "/js/sort-table.js"))))))
  92
  93 (define* (search-form #:key (standalone? #f) (text ""))
  94   `(form (@ (id "search")
  95             ,(if standalone?
  96                  '(class "")
  97                  '(class "form-inline"))
  98             (action "/search"))
  99          (div
 100           (@ (class ,(if standalone?
 101                          "input-group input-group-lg"
 102                          "input-group")))
 103           (input (@ (type "text")
 104                     (class "form-control")
 105                     (id   "query")
 106                     (name "query")
 107                     (value ,text)
 108                     (placeholder "Input your search query...")))
 109           (span (@ (class "input-group-append"))
 110                     (button
 111                      (@ (type "submit")
 112                         (class ,(string-append (if standalone? "btn-lg " "")
 113                                                "btn btn-primary")))
 114                      ;; This SVG is part of Bootstrap and is available
 115                      ;; under the Expat license.
 116                      (svg
 117                       (@ (class "bi bi-search")
 118                          (width "1em")
 119                          (height "1em")
 120                          (viewBox "0 0 16 16")
 121                          (fill "currentColor")
 122                          (xmlns "http://www.w3.org/2000/svg"))
 123                       (title "Search")
 124                       (path (@ (fill-rule "evenodd")
 125                                (d "M10.442 10.442a1 1 0 011.415 0l3.85 3.85a1 1 0 01-1.414 1.415l-3.85-3.85a1 1 0 010-1.415z")
 126                                (clip-rule "evenodd")) "")
 127                       (path (@ (fill-rule "evenodd")
 128                                (d "M6.5 12a5.5 5.5 0 100-11 5.5 5.5 0 000 11zM13 6.5a6.5 6.5 0 11-13 0 6.5 6.5 0 0113 0z")
 129                                (clip-rule "evenodd")) "")))))))
 130
 131
 132 (define* (search-widget #:key (text ""))
 133   `(div
 134     (@ (class "card mb-3"))
 135     (div (@ (class "card-body bg-light"))
 136          ,(search-form #:standalone? #t #:text text)
 137          (details
 138           (summary (strong "Hint"))
 139           (p
 140            "Refine your search with filters like "
 141            (span (@ (class "filter"))
 142                  "is:open")
 143            ", "
 144            (span (@ (class "filter"))
 145                  "author:me")
 146            ", "
 147            (span (@ (class "filter"))
 148                  "submitter:me")
 149            ", "
 150            (span (@ (class "filter"))
 151                  "date:2d..now")
 152            ", "
 153            (span (@ (class "filter"))
 154                  "date:2018-04-01..2018-04-02")
 155            ", "
 156            (span (@ (class "filter"))
 157                  "date:1m..today")
 158            ", and "
 159            (a (@ (href "help#search"))
 160               "many more!"))))))
 161
 162 (define* (header #:key (search-bar? #t))
 163   `(nav
 164     (@ (class "navbar navbar-expand navbar-light bg-light"))
 165     (a (@ (href "/") (class "navbar-brand pt-0 logo navbar-collapse"))
 166        (img (@ (src "/img/logo.png") (alt "logo") (height "25"))))
 167     ,@(if search-bar?
 168           `(,(search-form))
 169           '())))
 170
 171 (define (index)
 172   (layout
 173    #:body
 174    `(,(header #:search-bar? #f)
 175      (main
 176       (@ (class "container"))
 177       (h1 "Guix issue tracker")
 178       (p (@ (class "lead"))
 179          "This is a web frontend to the Guix patch and bug trackers.  Send email to "
 180          (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
 181             ,(%config 'submission-email-address))
 182          " to submit a patch, or email "
 183          (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
 184             ,(%config 'submission-bug-email-address))
 185          " to submit a bug report.")
 186       ,(search-widget)
 187
 188       (div (@ (class "mt-4 h4")) "Recent activity")
 189       (table
 190        (@ (class "table table-borderless table-hover js-sort-table"))
 191        (thead
 192         (tr (@ (class "heading"))
 193             (th (@ (class "js-sort-number")) "ID")
 194             (th "Subject")
 195             (th "Date submitted")
 196             (th "Status")))
 197        (tbody
 198         ,@(list-of-bugs (recent-bugs 10))))
 199
 200       (div (@ (class "mt-4 h4")) "Priority bugs")
 201       (table
 202        (@ (class "table table-borderless table-hover js-sort-table"))
 203        (thead
 204         (tr (@ (class "heading"))
 205             (th (@ (class "js-sort-number")) "ID")
 206             (th "Subject")
 207             (th "Date submitted")
 208             (th "Status")))
 209        (tbody
 210         ,@(priority-bugs)))))))
 211
 212 (define (help)
 213   (layout
 214    #:body
 215    `(,(header #:search-bar? #f)
 216      (div
 217       (@ (class "container"))
 218       (h1 "Help")
 219       (a (@ (href "search")))
 220       (p "You can improve the search results by making use of the
 221 simple query language.  Here is a list of supported query terms with
 222 some examples.")
 223       (table
 224        (@ (class "table"))
 225        (thead
 226         (tr
 227          (th (@ (class "col-md-3")) "Filter")
 228          (th (@ (class "col-md-9")) "Description")))
 229        (tbody
 230         (tr
 231          (td (span (@ (class "filter")) "is:open") ", "
 232              (span (@ (class "filter")) "is:pending"))
 233          (td "Open issues."))
 234         (tr
 235          (td (span (@ (class "filter")) "is:closed") ", "
 236              (span (@ (class "filter")) "is:done"))
 237          (td "Issues marked as done."))
 238         (tr
 239          (td (span (@ (class "filter")) "submitter:<who>"))
 240          (td "Issues submitted by a person named " (strong "who")
 241              ", e.g. "
 242              (span (@ (class "filter")) "submitter:ludo")
 243              " for all issues submitted by ludo. "
 244              "The filter matches both the email address and the name."))
 245         (tr
 246          (td (span (@ (class "filter")) "author:<who>"))
 247          (td "Issues where a person named " (strong "who")
 248              " has commented, e.g. "
 249              (span (@ (class "filter")) "author:rekado")
 250              " for all messages where rekado has commented. "
 251              "The filter matches both the email address and the name."))
 252         (tr
 253          (td (span (@ (class "filter")) "date:<start>..<end>"))
 254          (td "Issues submitted within the provided range.  "
 255              (strong "start") " and " (strong "end") " can be one of "
 256              (strong "now") ", " (strong "today")
 257              ", a date in the formats "
 258              (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
 259              ", or an amount and a unit for a point in the past, such as "
 260              (strong "12d..") " for 12 days ago. "
 261              "Supported units are: "
 262              (strong "h") " (hours), "
 263              (strong "d") " (days), "
 264              (strong "w") " (weeks), "
 265              (strong "m") " (months), and "
 266              (strong "y") " (years)."))
 267         (tr
 268          (td (span (@ (class "filter")) "mdate:<start>..<end>"))
 269          (td "This is just like " (span (@ (class "filter")) "date")
 270              " except that it also includes comments."))))))))
 271
 272 (define (unknown id)
 273   (layout
 274    #:body
 275    `(,(header)
 276      (div (@ (class "container"))
 277           (h1 "Issue not found")
 278           (p "There is no submission with id " (strong ,id) ", or we
 279 failed to process associated messages.")
 280           (p (a (@ (href "/")) "Try another one?"))))))
 281
 282 (define (error-page message)
 283   (layout
 284    #:body
 285    `(,(header)
 286      (div (@ (class "container"))
 287           (h1 "Error")
 288           (p "An error occurred.  Sorry about that!")
 289           ,message
 290           (p (a (@ (href "/")) "Try something else?"))))))
 291
 292 (define* (issue-page bug #:optional flash-message)
 293   "Render the conversation for the given BUG."
 294   (define id (bug-num bug))
 295   (define messages (patch-messages id))
 296   (define parties (sort (filter (compose (negate bot?) extract-email)
 297                                 (participants (filter identity messages)))
 298                         (lambda (a b)
 299                           (string< (extract-email a)
 300                                    (extract-email b)))))
 301   (define (show-message message-number message previous-subject)
 302     `((div (@ (class "mb-5"))
 303        (a (@ (id ,(number->string message-number))))
 304        (div
 305         (@ (class "avatar")
 306            (style ,(string-append "background-color:"
 307                                   (avatar-color (sender-email message)
 308                                                 (map extract-email parties)))))
 309         ,(string-upcase (string-take (sender-name message) 1)))
 310        (div
 311         (@ (class "message"))
 312         (div
 313          (@ (class "card"))
 314          (div
 315           (@ (class "card-header"))
 316           (div
 317            (@ (class "from"))
 318            (div
 319             (@ (class "avatar")
 320                (style ,(string-append "background-color:"
 321                                       (avatar-color (sender-email message)
 322                                                     (map extract-email parties)))))
 323             ,(string-upcase (string-take (sender-name message) 1)))
 324            (span (@ (class "address")) ,(sender-name message))
 325            " wrote on "
 326            (span (@ (class "date"))
 327                  (a (@ (href ,(string-append "#" (number->string
 328                                                   message-number))))
 329                     ,(date->string (date message)))))
 330           ,@(if (string-suffix? previous-subject (subject message))
 331                 '()
 332                 `((div (@ (class "subject")) ,(subject message))))
 333           (div
 334            (@ (class "details"))
 335            (div
 336             (@ (class "recipients"))
 337             (label "Recipients:")
 338             ,(map (lambda (address)
 339                     `(span (@ (class "address")) ,address))
 340                   (recipients message)))
 341            (div
 342             (@ (class "message-id"))
 343             (label "Message-ID:")
 344             ,(message-id message))))
 345          (div
 346           (@ (class "body card-body"))
 347           ,(display-message-body id message-number message)))))
 348       ,@(if (closing? message id)
 349             '((div
 350                (@ (class "row event"))
 351                (div
 352                 (@ (class "col-11 offset-1 text-center"))
 353                 (div (@ (class "badge badge-primary closed")) "Closed"))))
 354             '())))
 355   (if (null? messages) #f
 356       (layout
 357        #:title (bug-subject* bug)
 358        #:body
 359        `(,(header)
 360          (div
 361           (@ (class "container"))
 362           ,@(match flash-message
 363               (('error . text)
 364                `((div (@ (class "alert alert-danger")
 365                          (role "alert"))
 366                       ,text)))
 367               (('info . text)
 368                `((div (@ (class "alert alert-info")
 369                          (role "alert"))
 370                       ,text)))
 371               (_ '()))
 372           (div
 373            (@ (class "title col-12"))
 374            (h1 ,(bug-subject* bug))
 375            (span (@ (class "details"))
 376                  ,(status-tag bug)
 377                  ,(string-append "Submitted by "
 378                                  ;; We don't use bug-originator here
 379                                  ;; because it includes the email address.
 380                                  ;; We cannot use extract-name on the
 381                                  ;; return value, because it swallows
 382                                  ;; non-ASCII characters.
 383                                  (sender-name (first messages))
 384                                  ".")
 385                  ,@(if (bug-mergedwith bug)
 386                        `((ul (@ (class "merged"))
 387                              "Merged with: "
 388                              ,(map (lambda (id)
 389                                      `(li (a (@ (href ,(string-append "/issue/" id)))
 390                                              ,id)))
 391                                    ;; XXX: This field can either hold a
 392                                    ;; string of multiple ids, or a single
 393                                    ;; number.  Deal with this mess.
 394                                    (match (bug-mergedwith bug)
 395                                      ((? string? str)
 396                                       (string-split str #\space))
 397                                      ((? number? n)
 398                                       (list (number->string n)))))))
 399                        '())
 400                  ,@(if (bug-blocks bug)
 401                        `((ul (@ (class "blocks"))
 402                              "Blocks: "
 403                              ,(map (lambda (id)
 404                                      `(li (a (@ (href ,(string-append "/issue/" id)))
 405                                              ,id)))
 406                                    ;; XXX: This field can either hold a
 407                                    ;; string of multiple ids, or a single
 408                                    ;; number.  Deal with this mess.
 409                                    (match (bug-blocks bug)
 410                                      ((? string? str)
 411                                       (string-split str #\space))
 412                                      ((? number? n)
 413                                       (list (number->string n)))))))
 414                        '())
 415                  ,@(if (bug-blockedby bug)
 416                        `((ul (@ (class "blockedby"))
 417                              "Blocked by: "
 418                              ,(map (lambda (id)
 419                                      `(li (a (@ (href ,(string-append "/issue/" id)))
 420                                              ,id)))
 421                                    ;; XXX: This field can either hold a
 422                                    ;; string of multiple ids, or a single
 423                                    ;; number.  Deal with this mess.
 424                                    (match (bug-blockedby bug)
 425                                      ((? string? str)
 426                                       (string-split str #\space))
 427                                      ((? number? n)
 428                                       (list (number->string n)))))))
 429                        '())))
 430           (div (@ (class "row"))
 431                (div
 432                 (@ (class "conversation col-lg-9"))
 433                 ,(let ((msgs (filter (lambda (msg)
 434                                        ;; Ignore messages
 435                                        ;; without body, and
 436                                        ;; internal messages.
 437                                        (and msg
 438                                             (email-body msg)
 439                                             (not (internal-message? msg))))
 440                                      messages)))
 441                    (map (lambda (message-number msg previous-subject)
 442                           (show-message message-number msg previous-subject))
 443                         (iota (length msgs))
 444                         msgs
 445                         (cons (bug-subject* bug)
 446                               (map subject msgs))))
 447                 (div
 448                  (@ (class "comment-box"))
 449                  (a (@ (id "comment")))
 450                  (div
 451                   (@ (class "avatar")
 452                      (style "background-color:#bc80bd")) "?")
 453                  (div
 454                   (@ (class "message"))
 455                   (div
 456                    (@ (class "card"))
 457                    ,@(if (mailer-enabled?)
 458                          `((form
 459                             (@ (action ,(format #f "/issue/~a/comment"
 460                                                 (number->string id)))
 461                                (enctype "multipart/form-data")
 462                                (method "POST"))
 463                             (input (@ (style "display:none")
 464                                       (name "validation")
 465                                       (placeholder "Please leave this empty.")) "")
 466                             (input (@ (type "hidden")
 467                                       (name "timestamp")
 468                                       (value ,(timestamp!))) "")
 469                             (div
 470                              (@ (class "card-header"))
 471                              (div (@ (class "from"))
 472                                   (input (@ (class "address form-control")
 473                                             (name "from")
 474                                             (required "required")
 475                                             (placeholder "Your name")) "")))
 476                             (div
 477                              (@ (class "body card-body"))
 478                              (textarea (@ (name "text")
 479                                           (required "required")
 480                                           (class "form-control")
 481                                           (placeholder "Please input your comment..."))
 482                                        ""))
 483                             (div
 484                              (@ (class "card-footer"))
 485                              (button (@ (class "btn btn-primary")
 486                                         (type "submit"))
 487                                      "Send"))))
 488                          `((div
 489                             (@ (class "card-header"))
 490                             (div (@ (class "from"))
 491                                  (span (@ (class "address")) "Your comment")))
 492                            (div
 493                             (@ (class "body card-body"))
 494                             (p "Comments via the web interface are not currently
 495 supported.  To comment on this conversation "
 496                                (a (@ (href ,(string-append "mailto:"
 497                                                            (number->string id) "@" (%config 'debbugs-domain)
 498                                                            "?subject=" (bug-subject* bug))))
 499                                   ,(string-append "send email to "
 500                                                   (number->string id) "@" (%config 'debbugs-domain)))))))))))
 501
 502                (div
 503                 (@ (class "info col-lg-3"))
 504                 (dl
 505                  (@ (class "stat"))
 506                  ,@(let ((num (length parties)))
 507                      `((dt ,(if (= num 1)
 508                                 "One participant"
 509                                 (string-append (number->string num)
 510                                                " participants")))
 511                        (dd
 512                         (ul ,(map (lambda (name)
 513                                     `(li (span (@ (class "name")))
 514                                          ,name))
 515                                   (map extract-name parties)))))))
 516                 (dl
 517                  (@ (class "stat"))
 518                  (dt "Owner")
 519                  (dd
 520                   ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
 521                 (dl
 522                  (@ (class "stat"))
 523                  (dt "Severity")
 524                  (dd ,(bug-severity bug)))
 525                 (dl
 526                  (@ (class "stat"))
 527                  (dt "Status")
 528                  (dd ,(status-tag bug))))))))))
 529
 530 (define (list-of-bugs bugs)
 531   "Return table rows for all BUGS."
 532   (map (lambda (bug)
 533          (let ((id (number->string (bug-num bug))))
 534            `(tr (@ (class ,(bug-severity bug)))
 535                 (td ,(or id "-"))
 536                 (td
 537                  ,@(if (member (bug-severity bug) '("serious" "important"))
 538                        `((svg (@ (xmlns"http://www.w3.org/2000/svg")
 539                                  (xmlns:xlink "http://www.w3.org/1999/xlink")
 540                                  (viewBox "0 0 14 16")
 541                                  (version "1.1")
 542                                  (height "1rem")
 543                                  (width "1rem")
 544                                  (aria-hidden "true"))
 545                               (title ,(bug-severity bug))
 546                               (path (@ (fill-rule "evenodd")
 547                                        (d "\
 548 M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
 549 s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
 550 c0-3.14 2.56-5.7 5.7-5.7z\
 551 M7 1C3.14 1 0 4.14 0 8\
 552 s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
 553 m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
 554                        '())
 555                  ,(if id
 556                          `(a (@ (href ,(string-append "/issue/" id)))
 557                              ,(bug-subject* bug))
 558                          (bug-subject* bug)))
 559                 (td ,(date->string (bug-date bug)))
 560                 (td ,(status-tag bug)))))
 561        bugs))
 562
 563 (define (priority-bugs)
 564   (list-of-bugs (sort
 565                  (append
 566                   (bugs-by-severity "serious" "open")
 567                   (bugs-by-severity "important" "open"))
 568                  (lambda (a b) (< (bug-num a) (bug-num b))))))
 569
 570 (define* (list-of-recent-issues #:optional (max 100))
 571   (layout
 572    #:body
 573    `(,(header #:search-bar? #f)
 574      (div
 575       (@ (class "container"))
 576       (h1 "Recent issues")
 577       (table
 578        (@ (class "table table-borderless table-hover js-sort-table"))
 579        (thead
 580         (tr (@ (class "heading"))
 581             (th (@ (class "js-sort-number")) "ID")
 582             (th "Subject")
 583             (th "Date submitted")
 584             (th "Status")))
 585        (tbody
 586         ,@(list-of-bugs (recent-bugs max))))))))
 587
 588 (define (list-of-matching-bugs query bugs)
 589   (layout
 590    #:body
 591    `(,(header #:search-bar? #f)
 592      (div
 593       (@ (class "container"))
 594       (h1 "Your search for " (code ,query))
 595       ,(search-widget #:text query)
 596       ,(if (null? bugs)
 597            `(div
 598              (@ (class "alert alert-warning")
 599                 (role "alert"))
 600              (h4
 601               (@ (class "alert-heading"))
 602               "Nothing found!")
 603              (p "We could not find any issues matching your query "
 604                 (code ,query) ". "
 605                 (a (@ (href "/"))
 606                    "Try searching for something else?")))
 607            `(table
 608              (@ (class "table table-borderless table-hover js-sort-table"))
 609              (thead
 610               (tr (@ (class "heading"))
 611                   (th (@ (class "js-sort-number")) "ID")
 612                   (th "Subject")
 613                   (th "Date submitted")
 614                   (th "Status")))
 615              (tbody
 616               ,@(list-of-bugs bugs))))))))