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