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