mumi/web/view/html.scm

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