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            (small (a (@ (href "recent")) "(More)")))
 190       (table
 191        (@ (class "table table-borderless table-hover js-sort-table"))
 192        (thead
 193         (tr (@ (class "heading"))
 194             (th (@ (class "js-sort-number")) "ID")
 195             (th "Subject")
 196             (th "Date submitted")
 197             (th "Status")))
 198        (tbody
 199         ,@(list-of-bugs (recent-bugs 10))))
 200
 201       (div (@ (class "mt-4 h4")) "Priority bugs")
 202       (table
 203        (@ (class "table table-borderless table-hover js-sort-table"))
 204        (thead
 205         (tr (@ (class "heading"))
 206             (th (@ (class "js-sort-number")) "ID")
 207             (th "Subject")
 208             (th "Date submitted")
 209             (th "Status")))
 210        (tbody
 211         ,@(priority-bugs)))))))
 212
 213 (define (help)
 214   (layout
 215    #:body
 216    `(,(header #:search-bar? #f)
 217      (div
 218       (@ (class "container"))
 219       (h1 "Help")
 220       (a (@ (href "search")))
 221       (p "You can improve the search results by making use of the
 222 simple query language.  Here is a list of supported query terms with
 223 some examples.")
 224       (table
 225        (@ (class "table"))
 226        (thead
 227         (tr
 228          (th (@ (class "col-md-3")) "Filter")
 229          (th (@ (class "col-md-9")) "Description")))
 230        (tbody
 231         (tr
 232          (td (span (@ (class "filter")) "is:open") ", "
 233              (span (@ (class "filter")) "is:pending"))
 234          (td "Open issues."))
 235         (tr
 236          (td (span (@ (class "filter")) "is:closed") ", "
 237              (span (@ (class "filter")) "is:done"))
 238          (td "Issues marked as done."))
 239         (tr
 240          (td (span (@ (class "filter")) "submitter:<who>"))
 241          (td "Issues submitted by a person named " (strong "who")
 242              ", e.g. "
 243              (span (@ (class "filter")) "submitter:ludo")
 244              " for all issues submitted by ludo. "
 245              "The filter matches both the email address and the name."))
 246         (tr
 247          (td (span (@ (class "filter")) "author:<who>"))
 248          (td "Issues where a person named " (strong "who")
 249              " has commented, e.g. "
 250              (span (@ (class "filter")) "author:rekado")
 251              " for all messages where rekado has commented. "
 252              "The filter matches both the email address and the name."))
 253         (tr
 254          (td (span (@ (class "filter")) "date:<start>..<end>"))
 255          (td "Issues submitted within the provided range.  "
 256              (strong "start") " and " (strong "end") " can be one of "
 257              (strong "now") ", " (strong "today")
 258              ", a date in the formats "
 259              (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
 260              ", or an amount and a unit for a point in the past, such as "
 261              (strong "12d..") " for 12 days ago. "
 262              "Supported units are: "
 263              (strong "h") " (hours), "
 264              (strong "d") " (days), "
 265              (strong "w") " (weeks), "
 266              (strong "m") " (months), and "
 267              (strong "y") " (years)."))
 268         (tr
 269          (td (span (@ (class "filter")) "mdate:<start>..<end>"))
 270          (td "This is just like " (span (@ (class "filter")) "date")
 271              " except that it also includes comments."))))))))
 272
 273 (define (unknown id)
 274   (layout
 275    #:body
 276    `(,(header)
 277      (div (@ (class "container"))
 278           (h1 "Issue not found")
 279           (p "There is no submission with id " (strong ,id) ", or we
 280 failed to process associated messages.")
 281           (p (a (@ (href "/")) "Try another one?"))))))
 282
 283 (define (error-page message)
 284   (layout
 285    #:body
 286    `(,(header)
 287      (div (@ (class "container"))
 288           (h1 "Error")
 289           (p "An error occurred.  Sorry about that!")
 290           ,message
 291           (p (a (@ (href "/")) "Try something else?"))))))
 292
 293 (define* (issue-page bug #:optional flash-message)
 294   "Render the conversation for the given BUG."
 295   (define id (bug-num bug))
 296   (define messages (patch-messages id))
 297   (define parties (sort (filter (compose (negate bot?) extract-email)
 298                                 (participants (filter identity messages)))
 299                         (lambda (a b)
 300                           (string< (extract-email a)
 301                                    (extract-email b)))))
 302   (define (show-message message-number message previous-subject)
 303     `((div (@ (class "mb-5"))
 304        (a (@ (id ,(number->string message-number))))
 305        (div
 306         (@ (class "avatar")
 307            (style ,(string-append "background-color:"
 308                                   (avatar-color (sender-email message)
 309                                                 (map extract-email parties)))))
 310         ,(string-upcase (string-take (sender-name message) 1)))
 311        (div
 312         (@ (class "message"))
 313         (div
 314          (@ (class "card"))
 315          (div
 316           (@ (class "card-header"))
 317           (div
 318            (@ (class "from"))
 319            (div
 320             (@ (class "avatar")
 321                (style ,(string-append "background-color:"
 322                                       (avatar-color (sender-email message)
 323                                                     (map extract-email parties)))))
 324             ,(string-upcase (string-take (sender-name message) 1)))
 325            (span (@ (class "address")) ,(sender-name message))
 326            " wrote on "
 327            (span (@ (class "date"))
 328                  (a (@ (href ,(string-append "#" (number->string
 329                                                   message-number))))
 330                     ,(date->string (date message)))))
 331           ,@(if (string-suffix? previous-subject (subject message))
 332                 '()
 333                 `((div (@ (class "subject")) ,(subject message))))
 334           (div
 335            (@ (class "details"))
 336            (div
 337             (@ (class "recipients"))
 338             (label "Recipients:")
 339             ,(map (lambda (address)
 340                     `(span (@ (class "address")) ,address))
 341                   (recipients message)))
 342            (div
 343             (@ (class "message-id"))
 344             (label "Message-ID:")
 345             ,(message-id message))))
 346          (div
 347           (@ (class "body card-body"))
 348           ,(display-message-body id message-number message)))))
 349       ,@(if (closing? message id)
 350             '((div
 351                (@ (class "row event"))
 352                (div
 353                 (@ (class "col-11 offset-1 text-center"))
 354                 (div (@ (class "badge badge-primary closed")) "Closed"))))
 355             '())))
 356   (if (null? messages) #f
 357       (layout
 358        #:title (bug-subject* bug)
 359        #:body
 360        `(,(header)
 361          (div
 362           (@ (class "container"))
 363           ,@(match flash-message
 364               (('error . text)
 365                `((div (@ (class "alert alert-danger")
 366                          (role "alert"))
 367                       ,text)))
 368               (('info . text)
 369                `((div (@ (class "alert alert-info")
 370                          (role "alert"))
 371                       ,text)))
 372               (_ '()))
 373           (div
 374            (@ (class "title col-12"))
 375            (h1 ,(bug-subject* bug))
 376            (span (@ (class "details"))
 377                  ,(status-tag bug)
 378                  ,(string-append "Submitted by "
 379                                  ;; We don't use bug-originator here
 380                                  ;; because it includes the email address.
 381                                  ;; We cannot use extract-name on the
 382                                  ;; return value, because it swallows
 383                                  ;; non-ASCII characters.
 384                                  (sender-name (first messages))
 385                                  ".")
 386                  ,@(if (bug-mergedwith bug)
 387                        `((ul (@ (class "merged"))
 388                              "Merged with: "
 389                              ,(map (lambda (id)
 390                                      `(li (a (@ (href ,(string-append "/issue/" id)))
 391                                              ,id)))
 392                                    ;; XXX: This field can either hold a
 393                                    ;; string of multiple ids, or a single
 394                                    ;; number.  Deal with this mess.
 395                                    (match (bug-mergedwith bug)
 396                                      ((? string? str)
 397                                       (string-split str #\space))
 398                                      ((? number? n)
 399                                       (list (number->string n)))))))
 400                        '())
 401                  ,@(if (bug-blocks bug)
 402                        `((ul (@ (class "blocks"))
 403                              "Blocks: "
 404                              ,(map (lambda (id)
 405                                      `(li (a (@ (href ,(string-append "/issue/" id)))
 406                                              ,id)))
 407                                    ;; XXX: This field can either hold a
 408                                    ;; string of multiple ids, or a single
 409                                    ;; number.  Deal with this mess.
 410                                    (match (bug-blocks bug)
 411                                      ((? string? str)
 412                                       (string-split str #\space))
 413                                      ((? number? n)
 414                                       (list (number->string n)))))))
 415                        '())
 416                  ,@(if (bug-blockedby bug)
 417                        `((ul (@ (class "blockedby"))
 418                              "Blocked by: "
 419                              ,(map (lambda (id)
 420                                      `(li (a (@ (href ,(string-append "/issue/" id)))
 421                                              ,id)))
 422                                    ;; XXX: This field can either hold a
 423                                    ;; string of multiple ids, or a single
 424                                    ;; number.  Deal with this mess.
 425                                    (match (bug-blockedby bug)
 426                                      ((? string? str)
 427                                       (string-split str #\space))
 428                                      ((? number? n)
 429                                       (list (number->string n)))))))
 430                        '())))
 431           (div (@ (class "row"))
 432                (div
 433                 (@ (class "conversation col-lg-9"))
 434                 ,(let ((msgs (filter (lambda (msg)
 435                                        ;; Ignore messages
 436                                        ;; without body, and
 437                                        ;; internal messages.
 438                                        (and msg
 439                                             (email-body msg)
 440                                             (not (internal-message? msg))))
 441                                      messages)))
 442                    (map (lambda (message-number msg previous-subject)
 443                           (show-message message-number msg previous-subject))
 444                         (iota (length msgs))
 445                         msgs
 446                         (cons (bug-subject* bug)
 447                               (map subject msgs))))
 448                 (div
 449                  (@ (class "comment-box"))
 450                  (a (@ (id "comment")))
 451                  (div
 452                   (@ (class "avatar")
 453                      (style "background-color:#bc80bd")) "?")
 454                  (div
 455                   (@ (class "message"))
 456                   (div
 457                    (@ (class "card"))
 458                    ,@(if (mailer-enabled?)
 459                          `((form
 460                             (@ (action ,(format #f "/issue/~a/comment"
 461                                                 (number->string id)))
 462                                (enctype "multipart/form-data")
 463                                (method "POST"))
 464                             (input (@ (style "display:none")
 465                                       (name "validation")
 466                                       (placeholder "Please leave this empty.")) "")
 467                             (input (@ (type "hidden")
 468                                       (name "timestamp")
 469                                       (value ,(timestamp!))) "")
 470                             (div
 471                              (@ (class "card-header"))
 472                              (div (@ (class "from"))
 473                                   (input (@ (class "address form-control")
 474                                             (name "from")
 475                                             (required "required")
 476                                             (placeholder "Your name")) "")))
 477                             (div
 478                              (@ (class "body card-body"))
 479                              (textarea (@ (name "text")
 480                                           (required "required")
 481                                           (class "form-control")
 482                                           (placeholder "Please input your comment..."))
 483                                        ""))
 484                             (div
 485                              (@ (class "card-footer"))
 486                              (button (@ (class "btn btn-primary")
 487                                         (type "submit"))
 488                                      "Send"))))
 489                          `((div
 490                             (@ (class "card-header"))
 491                             (div (@ (class "from"))
 492                                  (span (@ (class "address")) "Your comment")))
 493                            (div
 494                             (@ (class "body card-body"))
 495                             (p "Comments via the web interface are not currently
 496 supported.  To comment on this conversation "
 497                                (a (@ (href ,(string-append "mailto:"
 498                                                            (number->string id) "@" (%config 'debbugs-domain)
 499                                                            "?subject=" (bug-subject* bug))))
 500                                   ,(string-append "send email to "
 501                                                   (number->string id) "@" (%config 'debbugs-domain)))))))))))
 502
 503                (div
 504                 (@ (class "info col-lg-3"))
 505                 (dl
 506                  (@ (class "stat"))
 507                  ,@(let ((num (length parties)))
 508                      `((dt ,(if (= num 1)
 509                                 "One participant"
 510                                 (string-append (number->string num)
 511                                                " participants")))
 512                        (dd
 513                         (ul ,(map (lambda (name)
 514                                     `(li (span (@ (class "name")))
 515                                          ,name))
 516                                   (map extract-name parties)))))))
 517                 (dl
 518                  (@ (class "stat"))
 519                  (dt "Owner")
 520                  (dd
 521                   ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
 522                 (dl
 523                  (@ (class "stat"))
 524                  (dt "Severity")
 525                  (dd ,(bug-severity bug)))
 526                 (dl
 527                  (@ (class "stat"))
 528                  (dt "Status")
 529                  (dd ,(status-tag bug))))))))))
 530
 531 (define (list-of-bugs bugs)
 532   "Return table rows for all BUGS."
 533   (map (lambda (bug)
 534          (let ((id (number->string (bug-num bug))))
 535            `(tr (@ (class ,(bug-severity bug)))
 536                 (td ,(or id "-"))
 537                 (td
 538                  ,@(if (member (bug-severity bug) '("serious" "important"))
 539                        `((svg (@ (xmlns"http://www.w3.org/2000/svg")
 540                                  (xmlns:xlink "http://www.w3.org/1999/xlink")
 541                                  (viewBox "0 0 14 16")
 542                                  (version "1.1")
 543                                  (height "1rem")
 544                                  (width "1rem")
 545                                  (aria-hidden "true"))
 546                               (title ,(bug-severity bug))
 547                               (path (@ (fill-rule "evenodd")
 548                                        (d "\
 549 M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
 550 s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
 551 c0-3.14 2.56-5.7 5.7-5.7z\
 552 M7 1C3.14 1 0 4.14 0 8\
 553 s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
 554 m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
 555                        '())
 556                  ,(if id
 557                          `(a (@ (href ,(string-append "/issue/" id)))
 558                              ,(bug-subject* bug))
 559                          (bug-subject* bug)))
 560                 (td ,(date->string (bug-date bug)))
 561                 (td ,(status-tag bug)))))
 562        bugs))
 563
 564 (define (priority-bugs)
 565   (list-of-bugs (sort
 566                  (append
 567                   (bugs-by-severity "serious" "open")
 568                   (bugs-by-severity "important" "open"))
 569                  (lambda (a b) (< (bug-num a) (bug-num b))))))
 570
 571 (define* (list-of-recent-issues #:optional (max 100))
 572   (layout
 573    #:body
 574    `(,(header #:search-bar? #f)
 575      (div
 576       (@ (class "container"))
 577       (h1 "Recent issues")
 578       (table
 579        (@ (class "table table-borderless table-hover js-sort-table"))
 580        (thead
 581         (tr (@ (class "heading"))
 582             (th (@ (class "js-sort-number")) "ID")
 583             (th "Subject")
 584             (th "Date submitted")
 585             (th "Status")))
 586        (tbody
 587         ,@(list-of-bugs (recent-bugs max))))))))
 588
 589 (define (list-of-matching-bugs query bugs)
 590   (layout
 591    #:body
 592    `(,(header #:search-bar? #f)
 593      (div
 594       (@ (class "container"))
 595       (h1 "Your search for " (code ,query))
 596       ,(search-widget #:text query)
 597       ,(if (null? bugs)
 598            `(div
 599              (@ (class "alert alert-warning")
 600                 (role "alert"))
 601              (h4
 602               (@ (class "alert-heading"))
 603               "Nothing found!")
 604              (p "We could not find any issues matching your query "
 605                 (code ,query) ". "
 606                 (a (@ (href "/"))
 607                    "Try searching for something else?")))
 608            `(table
 609              (@ (class "table table-borderless table-hover js-sort-table"))
 610              (thead
 611               (tr (@ (class "heading"))
 612                   (th (@ (class "js-sort-number")) "ID")
 613                   (th "Subject")
 614                   (th "Date submitted")
 615                   (th "Status")))
 616              (tbody
 617               ,@(list-of-bugs bugs))))))))