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 or comments 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
 267 (define (unknown id)
 268   (layout
 269    #:body
 270    `(,(header)
 271      (div (@ (class "container"))
 272           (h1 "Patch not found")
 273           (p "There is no submission with id " (strong ,id))
 274           (p (a (@ (href "/")) "Try another one?"))))))
 275
 276 (define (error-page message)
 277   (layout
 278    #:body
 279    `(,(header)
 280      (div (@ (class "container"))
 281           (h1 "Error")
 282           (p "An error occurred.  Sorry about that!")
 283           ,message
 284           (p (a (@ (href "/")) "Try something else?"))))))
 285
 286 (define* (issue-page bug #:optional flash-message)
 287   "Render the conversation for the given BUG."
 288   (define id (bug-num bug))
 289   (define messages (patch-messages id))
 290   (define parties (sort (filter (compose (negate bot?) extract-email)
 291                                 (participants (filter identity messages)))
 292                         (lambda (a b)
 293                           (string< (extract-email a)
 294                                    (extract-email b)))))
 295   (define (show-message message-number message previous-subject)
 296     `((div (@ (class "mb-5"))
 297        (a (@ (id ,(number->string message-number))))
 298        (div
 299         (@ (class "avatar")
 300            (style ,(string-append "background-color:"
 301                                   (avatar-color (sender-email message)
 302                                                 (map extract-email parties)))))
 303         ,(string-upcase (string-take (sender-name message) 1)))
 304        (div
 305         (@ (class "message"))
 306         (div
 307          (@ (class "card"))
 308          (div
 309           (@ (class "card-header"))
 310           (div
 311            (@ (class "from"))
 312            (div
 313             (@ (class "avatar")
 314                (style ,(string-append "background-color:"
 315                                       (avatar-color (sender-email message)
 316                                                     (map extract-email parties)))))
 317             ,(string-upcase (string-take (sender-name message) 1)))
 318            (span (@ (class "address")) ,(sender-name message))
 319            " wrote on "
 320            (span (@ (class "date"))
 321                  (a (@ (href ,(string-append "#" (number->string
 322                                                   message-number))))
 323                     ,(date->string (date message)))))
 324           ,@(if (string-suffix? previous-subject (subject message))
 325                 '()
 326                 `((div (@ (class "subject")) ,(subject message))))
 327           (div
 328            (@ (class "details"))
 329            (div
 330             (@ (class "recipients"))
 331             (label "Recipients:")
 332             ,(map (lambda (address)
 333                     `(span (@ (class "address")) ,address))
 334                   (recipients message)))
 335            (div
 336             (@ (class "message-id"))
 337             (label "Message-ID:")
 338             ,(message-id message))))
 339          (div
 340           (@ (class "body card-body"))
 341           ,(display-message-body id message-number message)))))
 342       ,@(if (closing? message id)
 343             '((div
 344                (@ (class "row event"))
 345                (div
 346                 (@ (class "col-md-11 offset-md-1 text-center"))
 347                 (div (@ (class "badge badge-primary closed")) "Closed"))))
 348             '())))
 349   (layout
 350    #:title (bug-subject* bug)
 351    #:body
 352    `(,(header)
 353      (div
 354       (@ (class "container"))
 355       ,@(match flash-message
 356           (('error . text)
 357            `((div (@ (class "alert alert-danger")
 358                      (role "alert"))
 359                   ,text)))
 360           (('info . text)
 361            `((div (@ (class "alert alert-info")
 362                      (role "alert"))
 363                   ,text)))
 364           (_ '()))
 365       (div
 366        (@ (class "title col-md-12"))
 367        (h1 ,(bug-subject* bug))
 368        (span (@ (class "details"))
 369              ,(status-tag bug)
 370              ,(string-append "Submitted by "
 371                              ;; We don't use bug-originator here
 372                              ;; because it includes the email address.
 373                              ;; We cannot use extract-name on the
 374                              ;; return value, because it swallows
 375                              ;; non-ASCII characters.
 376                              (sender-name (first messages))
 377                              ".")
 378              ,@(if (bug-mergedwith bug)
 379                    `((ul (@ (class "merged"))
 380                          "Merged with: "
 381                          ,(map (lambda (id)
 382                                  `(li (a (@ (href ,(string-append "/issue/" id)))
 383                                          ,id)))
 384                                ;; XXX: This field can either hold a
 385                                ;; string of multiple ids, or a single
 386                                ;; number.  Deal with this mess.
 387                                (match (bug-mergedwith bug)
 388                                  ((? string? str)
 389                                   (string-split str #\space))
 390                                  ((? number? n)
 391                                   (list (number->string n)))))))
 392                    '())
 393              ,@(if (bug-blocks bug)
 394                    `((ul (@ (class "blocks"))
 395                          "Blocks: "
 396                          ,(map (lambda (id)
 397                                  `(li (a (@ (href ,(string-append "/issue/" id)))
 398                                          ,id)))
 399                                ;; XXX: This field can either hold a
 400                                ;; string of multiple ids, or a single
 401                                ;; number.  Deal with this mess.
 402                                (match (bug-blocks bug)
 403                                  ((? string? str)
 404                                   (string-split str #\space))
 405                                  ((? number? n)
 406                                   (list (number->string n)))))))
 407                    '())
 408              ,@(if (bug-blockedby bug)
 409                    `((ul (@ (class "blockedby"))
 410                          "Blocked by: "
 411                          ,(map (lambda (id)
 412                                  `(li (a (@ (href ,(string-append "/issue/" id)))
 413                                          ,id)))
 414                                ;; XXX: This field can either hold a
 415                                ;; string of multiple ids, or a single
 416                                ;; number.  Deal with this mess.
 417                                (match (bug-blockedby bug)
 418                                  ((? string? str)
 419                                   (string-split str #\space))
 420                                  ((? number? n)
 421                                   (list (number->string n)))))))
 422                    '())))
 423       (div (@ (class "row"))
 424        (div
 425         (@ (class "conversation col-md-9"))
 426         ,(let ((msgs (filter (lambda (msg)
 427                                ;; Ignore messages
 428                                ;; without body, and
 429                                ;; internal messages.
 430                                (and msg
 431                                     (email-body msg)
 432                                     (not (internal-message? msg))))
 433                              messages)))
 434            (map (lambda (message-number msg previous-subject)
 435                   (show-message message-number msg previous-subject))
 436                 (iota (length msgs))
 437                 msgs
 438                 (cons (bug-subject* bug)
 439                       (map subject msgs))))
 440         (div
 441          (@ (class "comment-box"))
 442          (a (@ (id "comment")))
 443          (div
 444           (@ (class "avatar")
 445              (style "background-color:#bc80bd")) "?")
 446              (div
 447           (@ (class "message"))
 448           (div
 449            (@ (class "card"))
 450            ,@(if (mailer-enabled?)
 451                  `((form
 452                     (@ (action ,(format #f "/issue/~a/comment"
 453                                         (number->string id)))
 454                        (enctype "multipart/form-data")
 455                        (method "POST"))
 456                     (input (@ (style "display:none")
 457                               (name "validation")
 458                               (placeholder "Please leave this empty.")) "")
 459                     (input (@ (type "hidden")
 460                               (name "timestamp")
 461                               (value ,(timestamp!))) "")
 462                     (div
 463                      (@ (class "card-header"))
 464                      (div (@ (class "from"))
 465                           (input (@ (class "address form-control")
 466                                     (name "from")
 467                                     (required "required")
 468                                     (placeholder "Your name")) "")))
 469                     (div
 470                      (@ (class "body card-body"))
 471                      (textarea (@ (name "text")
 472                                   (required "required")
 473                                   (class "form-control")
 474                                   (placeholder "Please input your comment..."))
 475                                ""))
 476                     (div
 477                      (@ (class "card-footer"))
 478                      (button (@ (class "btn btn-primary")
 479                                 (type "submit"))
 480                              "Send"))))
 481                  `((div
 482                     (@ (class "card-header"))
 483                     (div (@ (class "from"))
 484                          (span (@ (class "address")) "Your comment")))
 485                    (div
 486                     (@ (class "body card-body"))
 487                     (p "Comments via the web interface are not currently
 488 supported.  To comment on this conversation "
 489                        (a (@ (href ,(string-append "mailto:"
 490                                                    (number->string id) "@" (%config 'debbugs-domain)
 491                                                    "?subject=" (bug-subject* bug))))
 492                           ,(string-append "send email to "
 493                                           (number->string id) "@" (%config 'debbugs-domain)))))))))))
 494
 495        (div
 496         (@ (class "info col-md-3"))
 497         (dl
 498          (@ (class "stat"))
 499          ,@(let ((num (length parties)))
 500              `((dt ,(if (= num 1)
 501                            "One participant"
 502                            (string-append (number->string num)
 503                                           " participants")))
 504                (dd
 505                 (ul ,(map (lambda (name)
 506                             `(li (span (@ (class "name")))
 507                                  ,name))
 508                           (map extract-name parties)))))))
 509         (dl
 510          (@ (class "stat"))
 511          (dt "Owner")
 512          (dd
 513           ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
 514         (dl
 515          (@ (class "stat"))
 516          (dt "Severity")
 517          (dd ,(bug-severity bug)))
 518         (dl
 519          (@ (class "stat"))
 520          (dt "Status")
 521          (dd ,(status-tag bug)))))))))
 522
 523 (define (list-of-bugs bugs)
 524   "Return table rows for all BUGS."
 525   (map (lambda (bug)
 526          (let ((id (number->string (bug-num bug))))
 527            `(tr (@ (class ,(bug-severity bug)))
 528                 (td ,(or id "-"))
 529                 (td
 530                  ,@(if (member (bug-severity bug) '("serious" "important"))
 531                        `((svg (@ (xmlns"http://www.w3.org/2000/svg")
 532                                  (xmlns:xlink "http://www.w3.org/1999/xlink")
 533                                  (viewBox "0 0 14 16")
 534                                  (version "1.1")
 535                                  (height "1rem")
 536                                  (width "1rem")
 537                                  (aria-hidden "true"))
 538                               (title ,(bug-severity bug))
 539                               (path (@ (fill-rule "evenodd")
 540                                        (d "\
 541 M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
 542 s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
 543 c0-3.14 2.56-5.7 5.7-5.7z\
 544 M7 1C3.14 1 0 4.14 0 8\
 545 s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
 546 m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
 547                        '())
 548                  ,(if id
 549                          `(a (@ (href ,(string-append "/issue/" id)))
 550                              ,(bug-subject* bug))
 551                          (bug-subject* bug)))
 552                 (td ,(date->string (bug-date bug)))
 553                 (td ,(status-tag bug)))))
 554        bugs))
 555
 556 (define (priority-bugs)
 557   (list-of-bugs (sort
 558                  (append
 559                   (bugs-by-severity "serious" "open")
 560                   (bugs-by-severity "important" "open"))
 561                  (lambda (a b) (< (bug-num a) (bug-num b))))))
 562
 563 (define (list-of-matching-bugs query bugs)
 564   (layout
 565    #:body
 566    `(,(header #:search-bar? #f)
 567      (div
 568       (@ (class "container"))
 569       (h1 "Your search for " (code ,query))
 570       ,(search-widget #:text query)
 571       ,(if (null? bugs)
 572            `(div
 573              (@ (class "alert alert-warning")
 574                 (role "alert"))
 575              (h4
 576               (@ (class "alert-heading"))
 577               "Nothing found!")
 578              (p "We could not find any issues matching your query "
 579                 (code ,query) ". "
 580                 (a (@ (href "/"))
 581                    "Try searching for something else?")))
 582            `(table
 583              (@ (class "table table-borderless table-hover js-sort-table"))
 584              (thead
 585               (tr (@ (class "heading"))
 586                   (th (@ (class "js-sort-number")) "ID")
 587                   (th "Subject")
 588                   (th "Date submitted")
 589                   (th "Status")))
 590              (tbody
 591               ,@(list-of-bugs bugs))))))))