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