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