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