mumi/web/view/html.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2016, 2017, 2018, 2019 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             list-of-bugs
  35             priority-bugs))
  36
  37 (define (status-tag bug)
  38   "Return a colored tag indicating the BUG status."
  39   (let ((status (if (bug-done bug) "Done" "Open")))
  40     `(span (@ (class ,(string-append "status-tag "
  41                                      (string-downcase status))))
  42            ,status)))
  43
  44 (define* (layout #:key
  45                  (head '())
  46                  (body '())
  47                  (title "Guix issue tracker")
  48                  (extra-headers '()))
  49   `(#:sxml ((doctype "html")
  50             (html
  51              (head
  52               (title ,title)
  53               (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
  54               (meta (@ (http-equiv "Content-Language") (content "en")))
  55               (meta (@ (name "author") (content "Ricardo Wurmus")))
  56               (meta (@ (name "viewport")
  57                        (content "width=device-width, initial-scale=1")))
  58               (link
  59                (@ (rel "stylesheet")
  60                   (media "screen")
  61                   (type "text/css")
  62                   (href "/css/reset.css")))
  63               (link
  64                (@ (rel "stylesheet")
  65                   (media "screen")
  66                   (type "text/css")
  67                   (href "/css/bootstrap.css")))
  68               ,@head
  69               (link
  70                (@ (rel "stylesheet")
  71                   (media "screen")
  72                   (type "text/css")
  73                   (href "/css/screen.css")))
  74               (link
  75                (@ (rel "stylesheet")
  76                   (media "screen")
  77                   (type "text/css")
  78                   (href "/css/code.css"))))
  79              (body ,@body
  80                    (footer
  81                     (p "Copyright © 2016—2019 by the GNU Guix community."
  82                        (br)
  83                        "Now with even more " (span (@ (class "lambda")) "λ") "! ")
  84                     (p "This is free software.  Download the "
  85                        (a (@ (href "https://git.elephly.net/software/mumi.git"))
  86                           "source code here") ".")))))
  87     #:extra-headers ,extra-headers))
  88
  89 (define* (search-form #:key (standalone? #f))
  90   `(form (@ (id "search")
  91             ,(if standalone?
  92                  '(class "row")
  93                  '(class "navbar-form navbar-right"))
  94             (action "/search"))
  95          (div
  96           (@ (class ,(if standalone?
  97                          "input-group input-group-lg"
  98                          "input-group")))
  99           (input (@ (type "text")
 100                     (class "form-control")
 101                     (id   "query")
 102                     (name "query")
 103                     (placeholder "input search query")))
 104                (span (@ (class "input-group-btn"))
 105                     (button
 106                      (@ (type "submit")
 107                         (class ,(string-append (if standalone? "btn-lg " "")
 108                                                "btn btn-primary")))
 109                      "Search")))))
 110
 111 (define* (header #:key (search-bar? #t))
 112   `(nav
 113     (@ (id "header") (class "navbar navbar-default"))
 114     (div
 115      (@ (class "container-fluid"))
 116      (div
 117       (@ (class "navbar-header"))
 118       (div (@ (class "navbar-brand"))
 119            (a (@ (href "/") (class "logo")))))
 120      ,@(if search-bar?
 121            `(,(search-form))
 122            '()))))
 123
 124 (define (index)
 125   (layout
 126    #:extra-headers
 127    '((cache-control . ((max-age . 60))))
 128    #:body
 129    `(,(header #:search-bar? #f)
 130      (div
 131       (@ (class "container"))
 132       (h1 "Guix patch tracker")
 133       (p (@ (class "row"))
 134          "This is a web frontend to the Guix patch tracker.  Send email to "
 135          (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
 136             ,(%config 'submission-email-address))
 137          " to submit your patches.")
 138       ,(search-form #:standalone? #t)
 139       (div
 140        (@ (class "row"))
 141        (div
 142         (@ (class "panel panel-default"))
 143         (p (@ (class "panel-body"))
 144            (strong "Hint: ")
 145            "Refine your search with filters like "
 146            (span (@ (class "filter"))
 147                  "is:open")
 148            ", "
 149            (span (@ (class "filter"))
 150                  "author:me")
 151            ", "
 152            (span (@ (class "filter"))
 153                  "submitter:me")
 154            ", "
 155            (span (@ (class "filter"))
 156                  "date:yesterday..now")
 157            ", "
 158            (span (@ (class "filter"))
 159                  "date:2018-04-01..2018-04-02")
 160            ", "
 161            (span (@ (class "filter"))
 162                  "date:1m..today")
 163            ", "
 164            (span (@ (class "filter"))
 165                  "mdate:2w..12h")
 166            ", and "
 167            (a (@ (href "help#search"))
 168               "many more!"))))
 169       (h2 "Recent activity")
 170       (div (@ (id "snippet-recent"))
 171            (img (@ (src "/img/spin.gif"))))
 172       (h2 "Priority bugs")
 173       (div (@ (id "snippet-priority"))
 174            (img (@ (src "/img/spin.gif"))))
 175       (script
 176        (@ (type "text/javascript")
 177           (src "/js/mumi.js")))))))
 178
 179 (define (help)
 180   (layout
 181    #:extra-headers
 182    ;; Cache for 24 hours.
 183    '((cache-control . ((max-age . 86400))))
 184    #:body
 185    `(,(header #:search-bar? #f)
 186      (div
 187       (@ (class "container"))
 188       (h1 "Help")
 189       (a (@ (href "search")))
 190       (p "You can improve the search results by making use of the
 191 simple query language.  Here is a list of supported query terms with
 192 some examples.")
 193       (table
 194        (@ (class "table"))
 195        (thead
 196         (tr
 197          (th (@ (class "col-md-3")) "Filter")
 198          (th (@ (class "col-md-9")) "Description")))
 199        (tbody
 200         (tr
 201          (td (span (@ (class "filter")) "is:open") ", "
 202              (span (@ (class "filter")) "is:pending"))
 203          (td "Open issues."))
 204         (tr
 205          (td (span (@ (class "filter")) "is:closed") ", "
 206              (span (@ (class "filter")) "is:done"))
 207          (td "Issues marked as done."))
 208         (tr
 209          (td (span (@ (class "filter")) "submitter:<who>"))
 210          (td "Issues submitted by a person named " (strong "who")
 211              ", e.g. "
 212              (span (@ (class "filter")) "submitter:ludo")
 213              " for all issues submitted by ludo. "
 214              "The filter matches both the email address and the name."))
 215         (tr
 216          (td (span (@ (class "filter")) "author:<who>"))
 217          (td "Issues where a person named " (strong "who")
 218              " has commented, e.g. "
 219              (span (@ (class "filter")) "author:rekado")
 220              " for all messages where rekado has commented. "
 221              "The filter matches both the email address and the name."))
 222         (tr
 223          (td (span (@ (class "filter")) "date:<start>..<end>"))
 224          (td "Issues submitted within the provided range.  "
 225              (strong "start") " and " (strong "end") " can be one of "
 226              (strong "now") ", " (strong "today") ", " (strong "yesterday")
 227              ", a date in the formats "
 228              (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
 229              ", or an amount and a unit for a point in the past, such as "
 230              (strong "12d") " for 12 days ago. "
 231              "Supported units are: "
 232              (strong "h") " (hours), "
 233              (strong "d") " (days), "
 234              (strong "w") " (weeks), "
 235              (strong "m") " (months), and "
 236              (strong "y") " (years)."))
 237         (tr
 238          (td (span (@ (class "filter")) "mdate:<start>..<end>"))
 239          (td "Issues with comments submitted within the provided
 240 range.  The supported arguments are the same as for "
 241              (span (@ (class "filter")) "date:") "."))))))))
 242
 243 (define (unknown id)
 244   (layout
 245    #:body
 246    `(,(header)
 247      (div (@ (class "container"))
 248           (h1 "Patch not found")
 249           (p "There is no submission with id " (strong ,id))
 250           (p (a (@ (href "/")) "Try another one?"))))))
 251
 252 (define (error-page message)
 253   (layout
 254    #:body
 255    `(,(header)
 256      (div (@ (class "container"))
 257           (h1 "Error")
 258           (p "An error occurred.  Sorry about that!")
 259           ,message
 260           (p (a (@ (href "/")) "Try something else?"))))))
 261
 262 (define (issue-page bug)
 263   "Render the conversation for the given BUG."
 264   (define id (bug-num bug))
 265   (define messages (patch-messages id))
 266   (define parties (sort (filter (compose (negate bot?) extract-email)
 267                                 (participants messages))
 268                         (lambda (a b)
 269                           (string< (extract-email a)
 270                                    (extract-email b)))))
 271   (define (show-message message-number message previous-subject)
 272     `((div
 273        (@ (class "row"))
 274        (a (@ (id ,(number->string message-number))))
 275        (div
 276         (@ (class "avatar col-md-1")
 277            (style ,(string-append "background-color:"
 278                                   (avatar-color (sender-email message)
 279                                                 (map extract-email parties)))))
 280         ,(string-upcase (string-take (sender-name message) 1)))
 281        (div
 282         (@ (class "message col-md-11"))
 283         (div
 284          (@ (class "panel panel-default"))
 285          (div
 286           (@ (class "panel-heading"))
 287           (div
 288            (@ (class "from"))
 289            (span (@ (class "address")) ,(sender-name message))
 290            " wrote on "
 291            (span (@ (class "date"))
 292                  (a (@ (href ,(string-append "#" (number->string
 293                                                   message-number))))
 294                     ,(date->string (date message)))))
 295           ,@(if (or (string-suffix? (or previous-subject "")
 296                                     (or (subject message) ""))
 297                     (not (subject message)))
 298                 '()
 299                 `((div (@ (class "subject")) ,(subject message))))
 300           (div
 301            (@ (class "details"))
 302            (div
 303             (@ (class "recipients"))
 304             (label "Recipients:")
 305             ,(map (lambda (address)
 306                     `(span (@ (class "address")) ,address))
 307                   (recipients message)))
 308            (div
 309             (@ (class "message-id"))
 310             (label "Message-ID:")
 311             ,(message-id message))))
 312          (div
 313           (@ (class "body panel-body"))
 314           ,(display-message-body id message-number message)))))
 315       ,@(if (closing? message id)
 316             '((div
 317                (@ (class "row event"))
 318                (div
 319                 (@ (class "col-md-offset-1 col-md-11 text-center"))
 320                 (div (@ (class "label label-primary closed")) "Closed"))))
 321             '())))
 322   (layout
 323    #:title (bug-subject bug)
 324    #:extra-headers
 325    (cond
 326     ((bug-archived bug)
 327      ;; Tell browser to cache this for 12 hours.
 328      '((cache-control . ((max-age . 43200)))))
 329     ((bug-done bug)
 330      ;; Tell browser to cache this for 1 hour.
 331      '((cache-control . ((max-age . 3600)))))
 332     (else '()))
 333    #:body
 334    `(,(header)
 335      (div
 336       (@ (class "container"))
 337       (div
 338        (@ (class "row title col-md-12"))
 339        (h1 ,(bug-subject bug))
 340        (span (@ (class "details"))
 341              ,(status-tag bug)
 342              ,(string-append "Submitted by "
 343                              ;; We don't use bug-originator here
 344                              ;; because it includes the email address.
 345                              ;; We cannot use extract-name on the
 346                              ;; return value, because it swallows
 347                              ;; non-ASCII characters.
 348                              (sender-name (first messages))
 349                              ".")
 350              ,@(if (bug-mergedwith bug)
 351                    `((ul (@ (class "merged"))
 352                          "Merged with: "
 353                          ,(map (lambda (id)
 354                                  `(li (a (@ (href ,(string-append "/issue/" id)))
 355                                          ,id)))
 356                                ;; XXX: This field can either hold a
 357                                ;; string of multiple ids, or a single
 358                                ;; number.  Deal with this mess.
 359                                (match (bug-mergedwith bug)
 360                                  ((? string? str)
 361                                   (string-split str #\space))
 362                                  ((? number? n)
 363                                   (list (number->string n)))))))
 364                    '())
 365              ,@(if (bug-blocks bug)
 366                    `((ul (@ (class "blocks"))
 367                          "Blocks: "
 368                          ,(map (lambda (id)
 369                                  `(li (a (@ (href ,(string-append "/issue/" id)))
 370                                          ,id)))
 371                                ;; XXX: This field can either hold a
 372                                ;; string of multiple ids, or a single
 373                                ;; number.  Deal with this mess.
 374                                (match (bug-blocks bug)
 375                                  ((? string? str)
 376                                   (string-split str #\space))
 377                                  ((? number? n)
 378                                   (list (number->string n)))))))
 379                    '())
 380              ,@(if (bug-blockedby bug)
 381                    `((ul (@ (class "blockedby"))
 382                          "Blocked by: "
 383                          ,(map (lambda (id)
 384                                  `(li (a (@ (href ,(string-append "/issue/" id)))
 385                                          ,id)))
 386                                ;; XXX: This field can either hold a
 387                                ;; string of multiple ids, or a single
 388                                ;; number.  Deal with this mess.
 389                                (match (bug-blockedby bug)
 390                                  ((? string? str)
 391                                   (string-split str #\space))
 392                                  ((? number? n)
 393                                   (list (number->string n)))))))
 394                    '())))
 395       (div
 396        (@ (class "row"))
 397        (div
 398         (@ (class "conversation col-md-9"))
 399         ,(let ((msgs (filter (lambda (msg)
 400                                ;; Ignore messages
 401                                ;; without body, and
 402                                ;; internal messages.
 403                                (and (email-body msg)
 404                                     (not (internal-message? msg))))
 405                              messages)))
 406            (map (lambda (message-number msg previous-subject)
 407                   (show-message message-number msg previous-subject))
 408                 (iota (length msgs))
 409                 msgs
 410                 (cons (bug-subject bug)
 411                       (map subject msgs))))
 412         (div
 413          (@ (class "row comment-box"))
 414          (a (@ (id "comment")))
 415          (div
 416           (@ (class "avatar col-md-1")
 417              (style "background-color:#bc80bd")) "?")
 418              (div
 419           (@ (class "message col-md-11"))
 420           (div
 421            (@ (class "panel panel-default"))
 422            (div
 423             (@ (class "panel-heading"))
 424             (div (@ (class "from"))
 425                  (span (@ (class "address")) "Your comment")))
 426            (div
 427             (@ (class "body panel-body"))
 428             (p "Comments via the web interface are not currently
 429 supported.  To comment on this conversation "
 430                (a (@ (href ,(string-append "mailto:"
 431                                            (number->string id) "@" (%config 'debbugs-domain)
 432                                            "?subject=" (bug-subject bug))))
 433                   ,(string-append "send email to "
 434                                   (number->string id) "@" (%config 'debbugs-domain)))))))))
 435
 436        (div
 437         (@ (class "info col-md-3"))
 438         (div
 439          (@ (class "stat"))
 440          ,@(let ((num (length parties)))
 441              `((label ,(if (= num 1)
 442                            "One participant"
 443                            (string-append (number->string num)
 444                                           " participants")))
 445                (ul ,(map (lambda (name)
 446                            `(li (span (@ (class "name")))
 447                                 ,name))
 448                          (map extract-name parties))))))
 449         (div
 450          (@ (class "stat"))
 451          (label "Owner")
 452          ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
 453         (div
 454          (@ (class "stat"))
 455          (label "Severity")
 456          ,(bug-severity bug))
 457         (div
 458          (@ (class "stat"))
 459          (label "Status")
 460          ,(status-tag bug))))))))
 461
 462 (define (list-of-bugs bugs)
 463   "Return a table of BUGS."
 464   (if (null? bugs)
 465       `(p "Nothing to see here. "
 466           (a (@ (href "/"))
 467              "Look for something else?"))
 468       `(table (@ (class "table-condensed"))
 469               (thead
 470                (tr (th "ID")
 471                    (th "Subject")
 472                    (th "Date submitted")
 473                    (th "Status")))
 474               (tbody
 475                ,@(map (lambda (bug)
 476                         (let ((id (number->string (bug-num bug))))
 477                           `(tr (@ (class ,(bug-severity bug)))
 478                             (td ,(or id "-"))
 479                             (td ,(if id
 480                                      `(a (@ (href ,(string-append "/issue/" id)))
 481                                          ,(bug-subject bug))
 482                                      (bug-subject bug)))
 483                             (td ,(date->string (bug-date bug)))
 484                             (td ,(status-tag bug)))))
 485                       bugs)))))
 486
 487 (define (priority-bugs)
 488   (list #:sxml
 489         (list-of-bugs
 490          (sort
 491           (append
 492            (bugs-by-severity "serious" "open")
 493            (bugs-by-severity "important" "open"))
 494           (lambda (a b) (< (bug-num a) (bug-num b)))))))
 495
 496 (define (list-of-matching-bugs query bugs)
 497   (layout
 498    #:body
 499    `(,(header)
 500      (div (@ (class "container"))
 501           ,@(if (null? bugs)
 502                 `((h1 "No issues found")
 503                   (p "We could not find any issues matching your query "
 504                      (code ,query) ". "
 505                      (a (@ (href "/"))
 506                         "Try searching for something else?")))
 507                 `((h1 "Submissions matching " (code ,query))
 508                   ,(list-of-bugs bugs)))))))