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