;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (mumi web view html)
  #:use-module (email email)
  #:use-module (mumi config)
  #:use-module (mumi debbugs)
  #:use-module (mumi messages)
  #:use-module (mumi web view utils)
  #:use-module (mumi web util)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:export (index
            help
            unknown
            error-page
            issue-page
            list-of-matching-bugs
            list-of-recent-issues
            list-of-forgotten-issues))

(define (bug-subject* bug)
  (or (bug-subject bug) "(no subject)"))

(define (status-tag bug)
  "Return a colored tag indicating the BUG status."
  (let ((status (if (bug-done bug) "Done" "Open")))
    `(span (@ (class ,(string-append "status-tag "
                                     (string-downcase status))))
           ,status)))

(define* (layout #:key
                 (head '())
                 (body '())
                 (title "Guix issue tracker"))
  `((doctype "html")
    (html (@ (lang "en"))
     (head
      (title ,title)
      (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
      (meta (@ (name "author") (content "Ricardo Wurmus")))
      (meta (@ (name "viewport")
               (content "width=device-width, initial-scale=1")))
      (link
       (@ (rel "stylesheet")
          (media "screen")
          (type "text/css")
          (href "/css/reset.css")))
      (link
       (@ (rel "stylesheet")
          (media "screen")
          (type "text/css")
          (href "/css/bootstrap.css")))
      ,@head
      (link
       (@ (rel "stylesheet")
          (media "screen")
          (type "text/css")
          (href "/css/screen.css?202005120000"))))
     (body ,@body
           (footer (@ (class "text-center"))
                   (p "Copyright © 2016—2020 by the GNU Guix community."
                      (br)
                      "Now with even more " (span (@ (class "lambda")) "λ") "! ")
                   (p "This is free software.  Download the "
                      (a (@ (href "https://git.elephly.net/software/mumi.git"))
                         "source code here") "."))
           (script
            (@ (src "/js/sort-table.js")))))))

(define* (search-form #:key (standalone? #f) (text ""))
  `(form (@ (id "search")
            ,(if standalone?
                 '(class "")
                 '(class "form-inline"))
            (action "/search"))
         (div
          (@ (class ,(if standalone?
                         "input-group input-group-lg"
                         "input-group")))
          (input (@ (type "text")
                    (class "form-control")
                    (id   "query")
                    (name "query")
                    (value ,text)
                    (placeholder "Input your search query...")))
          (span (@ (class "input-group-append"))
                    (button
                     (@ (type "submit")
                        (class ,(string-append (if standalone? "btn-lg " "")
                                               "btn btn-primary")))
                     ;; This SVG is part of Bootstrap and is available
                     ;; under the Expat license.
                     (svg
                      (@ (class "bi bi-search")
                         (width "1em")
                         (height "1em")
                         (viewBox "0 0 16 16")
                         (fill "currentColor")
                         (xmlns "http://www.w3.org/2000/svg"))
                      (title "Search")
                      (path (@ (fill-rule "evenodd")
                               (d "M10.442 10.442a1 1 0 011.415 0l3.85 3.85a1 1 0 01-1.414 1.415l-3.85-3.85a1 1 0 010-1.415z")
                               (clip-rule "evenodd")) "")
                      (path (@ (fill-rule "evenodd")
                               (d "M6.5 12a5.5 5.5 0 100-11 5.5 5.5 0 000 11zM13 6.5a6.5 6.5 0 11-13 0 6.5 6.5 0 0113 0z")
                               (clip-rule "evenodd")) ""))))
          (div
           (@ (id "search-hints"))
           (p "You can improve the search results by making use of the
simple query language.  Here is a list of supported query terms:")
           (table
            (@ (class "table table-sm table-borderless"))
            (tbody
             ,@(map (match-lambda
                      ((term description)
                       `(tr (td (span (@ (class "filter")) ,term))
                            (td ,description))))
                    '(("is:open" "open issues")
                      ("is:done" "closed issues")
                      ("submitter:<who>" "search issue submitter")
                      ("author:<who>" "search by message author")
                      ("date:yesterday..now" "search by issue date")
                      ("mdate:3m..2d" "search by message date")))))))))

(define* (search-widget #:key (text ""))
  `(div
    (@ (class "card mb-3"))
    (div (@ (class "card-body bg-light"))
         ,(search-form #:standalone? #t #:text text)
         (details
          (summary (strong "Hint"))
          (p
           "Refine your search with filters like "
           (span (@ (class "filter"))
                 "is:open")
           ", "
           (span (@ (class "filter"))
                 "author:me")
           ", "
           (span (@ (class "filter"))
                 "submitter:me")
           ", "
           (span (@ (class "filter"))
                 "severity:serious")
           ", "
           (span (@ (class "filter"))
                 "tag:easy")
           ", "
           (span (@ (class "filter"))
                 "date:2d..now")
           ", "
           (span (@ (class "filter"))
                 "date:2018-04-01..2018-04-02")
           ", "
           (span (@ (class "filter"))
                 "date:1m..today")
           ", and "
           (a (@ (href "help#search"))
              "many more!"))))))

(define* (header #:key (search-bar? #t) title)
  `(nav
    (@ (class "sticky-top navbar navbar-expand navbar-light bg-light"))
    (a (@ (href "/") (class "navbar-brand pt-0 logo navbar-collapse"))
       (img (@ (src "/img/logo.png") (alt "logo") (height "25"))))
    ,@(if title
          `((span (@ (class "navbar-text")) ,title))
          '())
    ,@(if search-bar?
          `(,(search-form))
          '())))

(define (index)
  (layout
   #:body
   `(,(header #:search-bar? #f)
     (main
      (@ (class "container"))
      (h1 "Guix issue tracker")
      (p (@ (class "lead"))
         "This is a web frontend to the Guix patch and bug trackers.  Send email to "
         (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
            ,(%config 'submission-email-address))
         " to submit a patch, or email "
         (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
            ,(%config 'submission-bug-email-address))
         " to submit a bug report.")
      ,(search-widget)

      (div (@ (class "mt-4 h4")) "Recent activity "
           (small (a (@ (href "recent")) "(More)")))
      (table
       (@ (class "table table-borderless table-hover js-sort-table"))
       (thead
        (tr (@ (class "heading"))
            (th (@ (class "js-sort-number")) "ID")
            (th "Subject")
            (th "Date submitted")
            (th "Status")))
       (tbody
        ,@(list-of-bugs (recent-bugs 10))))

      (div (@ (class "mt-4 h4")) "Forgotten issues "
           (small (a (@ (href "forgotten")) "(More)")))
      (table
       (@ (class "table table-borderless table-hover js-sort-table"))
       (thead
        (tr (@ (class "heading"))
            (th (@ (class "js-sort-number")) "ID")
            (th "Subject")
            (th "Date submitted")
            (th "Status")))
       (tbody
        ,@(list-of-bugs (forgotten-issues 10))))

      (div (@ (class "mt-4 h4")) "Priority bugs")
      (table
       (@ (class "table table-borderless table-hover js-sort-table"))
       (thead
        (tr (@ (class "heading"))
            (th (@ (class "js-sort-number")) "ID")
            (th "Subject")
            (th "Date submitted")
            (th "Status")))
       (tbody
        ,@(priority-bugs)))))))

(define (help)
  (layout
   #:body
   `(,(header #:search-bar? #f)
     (div
      (@ (class "container"))
      (h1 "Help")
      (a (@ (href "search")))
      (p "You can improve the search results by making use of the
simple query language.  Here is a list of supported query terms with
some examples.")
      (table
       (@ (class "table"))
       (thead
        (tr
         (th (@ (class "col-md-3")) "Filter")
         (th (@ (class "col-md-9")) "Description")))
       (tbody
        (tr
         (td (span (@ (class "filter")) "is:open") ", "
             (span (@ (class "filter")) "is:pending"))
         (td "Open issues."))
        (tr
         (td (span (@ (class "filter")) "is:closed") ", "
             (span (@ (class "filter")) "is:done"))
         (td "Issues marked as done."))
        (tr
         (td (span (@ (class "filter")) "submitter:<who>"))
         (td "Issues submitted by a person named " (strong "who")
             ", e.g. "
             (span (@ (class "filter")) "submitter:ludo")
             " for all issues submitted by ludo. "
             "The filter matches both the email address and the name."))
        (tr
         (td (span (@ (class "filter")) "author:<who>"))
         (td "Issues where a person named " (strong "who")
             " has commented, e.g. "
             (span (@ (class "filter")) "author:rekado")
             " for all messages where rekado has commented. "
             "The filter matches both the email address and the name."))
        (tr
         (td (span (@ (class "filter")) "severity:<type>"))
         (td "Issues that have been marked with the given severity, e.g. "
             (span (@ (class "filter")) "severity:serious")
             " for all issues that have been labelled as serious bugs. "
             "The following severities are recognized: "
             (strong "critical") ", "
             (strong "grave") ", "
             (strong "serious") ", "
             (strong "important") ", "
             (strong "normal") ", "
             (strong "minor") ", and "
             (strong "wishlist") "."))
        (tr
         (td (span (@ (class "filter")) "tag:<type>"))
         (td "Issues that have been tagged with the given tag, e.g. "
             (span (@ (class "filter")) "tag:easy")
             " for all easy issues that are suitable for newcomers. "
             "The following tags are recognized: "
             (strong "patch") ", "
             (strong "wontfix") ", "
             (strong "moreinfo") ", "
             (strong "unreproducible") ", "
             (strong "fixed") ", "
             (strong "notabug") ", "
             (strong "pending") ", "
             (strong "help") ", "
             (strong "security") ", "
             (strong "confirmed") ", and "
             (strong "easy") "."))
        (tr
         (td (span (@ (class "filter")) "date:<start>..<end>"))
         (td "Issues submitted within the provided range.  "
             (strong "start") " and " (strong "end") " can be one of "
             (strong "now") ", " (strong "today")
             ", a date in the formats "
             (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
             ", or an amount and a unit for a point in the past, such as "
             (strong "12d..") " for 12 days ago. "
             "Supported units are: "
             (strong "h") " (hours), "
             (strong "d") " (days), "
             (strong "w") " (weeks), "
             (strong "m") " (months), and "
             (strong "y") " (years)."))
        (tr
         (td (span (@ (class "filter")) "mdate:<start>..<end>"))
         (td "This is just like " (span (@ (class "filter")) "date")
             " except that it also includes comments."))))))))

(define (unknown id)
  (layout
   #:body
   `(,(header)
     (div (@ (class "container"))
          (h1 "Issue not found")
          (p "There is no submission with id " (strong ,id) ", or we
failed to process associated messages.")
          (p (a (@ (href "/")) "Try another one?"))))))

(define (error-page message)
  (layout
   #:body
   `(,(header)
     (div (@ (class "container"))
          (h1 "Error")
          (p "An error occurred.  Sorry about that!")
          ,message
          (p (a (@ (href "/")) "Try something else?"))))))

(define* (issue-page bug #:optional flash-message)
  "Render the conversation for the given BUG."
  (define id (bug-num bug))
  (define messages
    (filter (lambda (msg)
              ;; Ignore messages without body, and internal messages.
              (and msg
                   (email-body msg)
                   (not (internal-message? msg))))
            (issue-messages id)))
  (define parties (sort (filter (compose (negate bot?) extract-email)
                                (participants (filter identity messages)))
                        (lambda (a b)
                          (string< (extract-email a)
                                   (extract-email b)))))
  (define sidebar
    `(ul (@ (id "sidebar")
             (class "sticky-top flex-column"))
         ,(map (lambda (message message-number)
                 `(li
                   (div
                    (@ (class "avatar")
                       (style ,(string-append "background-color:"
                                              (avatar-color (sender-email message)
                                                            (map extract-email parties)))))
                    ,(string-upcase (string-take (sender-name message) 1)))
                   (span (@ (class "date"))
                         (a (@ (href ,(string-append "#" (number->string
                                                          message-number))))
                            ,(time->string (date message))))))
               messages
               (iota (length messages)))))
  (define issue-details
    `(span (@ (class "details"))
           ,(status-tag bug)
           ,(string-append "Submitted by "
                           ;; We don't use bug-originator here
                           ;; because it includes the email address.
                           ;; We cannot use extract-name on the
                           ;; return value, because it swallows
                           ;; non-ASCII characters.
                           (sender-name (first messages))
                           ".")
           (details
            (@ (class "info"))
            (summary "Details")
            (dl
             (@ (class "stat"))
             ,@(let ((num (length parties)))
                 `((dt ,(if (= num 1)
                            "One participant"
                            (string-append (number->string num)
                                           " participants")))
                   (dd
                    (ul ,(map (lambda (name)
                                `(li (span (@ (class "name")))
                                     ,name))
                              (map extract-name parties)))))))
            (dl
             (@ (class "stat"))
             (dt "Owner")
             (dd
              ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
            (dl
             (@ (class "stat"))
             (dt "Severity")
             (dd ,(bug-severity bug)))
            ,@(if (bug-mergedwith bug)
                  `((dl
                     (@ (class "stat"))
                     (dt "Merged with")
                     (dd (ul ,(map (lambda (id)
                                     `(li (a (@ (href ,(string-append "/" id)))
                                             ,id)))
                                   ;; XXX: This field can either hold a
                                   ;; string of multiple ids, or a single
                                   ;; number.  Deal with this mess.
                                   (match (bug-mergedwith bug)
                                     ((? string? str)
                                      (string-split str #\space))
                                     ((? number? n)
                                      (list (number->string n)))))))))
                  '())
            ,@(if (bug-blocks bug)
                  `((dl
                     (@ (class "stat"))
                     (dt "Blocks")
                     (dd (ul ,(map (lambda (id)
                                     `(li (a (@ (href ,(string-append "/" id)))
                                             ,id)))
                                   ;; XXX: This field can either hold a
                                   ;; string of multiple ids, or a single
                                   ;; number.  Deal with this mess.
                                   (match (bug-blocks bug)
                                     ((? string? str)
                                      (string-split str #\space))
                                     ((? number? n)
                                      (list (number->string n)))))))))
                  '())
            ,@(if (bug-blockedby bug)
                  `((dl
                     (@ (class "stat"))
                     (dt "Blocked by")
                     (dd (ul ,(map (lambda (id)
                                     `(li (a (@ (href ,(string-append "/" id)))
                                             ,id)))
                                   ;; XXX: This field can either hold a
                                   ;; string of multiple ids, or a single
                                   ;; number.  Deal with this mess.
                                   (match (bug-blockedby bug)
                                     ((? string? str)
                                      (string-split str #\space))
                                     ((? number? n)
                                      (list (number->string n)))))))))
                  '()))))
  (define comment-box
    `(div
      (@ (class "comment-box"))
      (a (@ (id "comment")))
      (div
       (@ (class "avatar")
          (style "background-color:#bc80bd")) "?")
      (div
       (@ (class "message"))
       (div
        (@ (class "card"))
        ,@(if (and (mailer-enabled?)
                   (not (bug-archived bug)))
              `((form
                 (@ (action ,(format #f "/issue/~a/comment"
                                     (number->string id)))
                    (enctype "multipart/form-data")
                    (method "POST"))
                 (input (@ (style "display:none")
                           (name "validation")
                           (placeholder "Please leave this empty.")) "")
                 (input (@ (type "hidden")
                           (name "timestamp")
                           (value ,(timestamp!))) "")
                 (div
                  (@ (class "card-header"))
                  (div (@ (class "from"))
                       (input (@ (class "address form-control")
                                 (name "from")
                                 (required "required")
                                 (placeholder "Your name")) "")))
                 (div
                  (@ (class "body card-body"))
                  (textarea (@ (name "text")
                               (required "required")
                               (class "form-control")
                               (placeholder "Please input your comment..."))
                            ""))
                 (div
                  (@ (class "card-footer"))
                  (button (@ (class "btn btn-primary")
                             (type "submit"))
                          "Send")
                  (span (@ (class "ml-3"))
                   "Your may also "
                   (a (@ (href ,(string-append "mailto:"
                                               (number->string id) "@" (%config 'debbugs-domain)
                                               "?subject=" (bug-subject* bug))))
                      ,(string-append "send email to "
                                      (number->string id) "@" (%config 'debbugs-domain)))
                   " to comment."))))
              `((div
                 (@ (class "card-header"))
                 (div (@ (class "from"))
                      (span (@ (class "address")) "Your comment")))
                (div
                 (@ (class "body card-body"))
                 ,(if (bug-archived bug)
                      '(p "This issue is archived.")
                      '(p "Commenting via the web interface is
currently disabled."))
                 (p "To comment on this conversation "
                    (a (@ (href ,(string-append "mailto:"
                                                (number->string id) "@" (%config 'debbugs-domain)
                                                "?subject=" (bug-subject* bug))))
                       ,(string-append "send email to "
                                       (number->string id) "@" (%config 'debbugs-domain)))))))))))
  (define (show-message message-number message previous-subject)
    `((div (@ (class "mb-5"))
           (a (@ (class "message-anchor")
                 (id ,(number->string message-number))))
           (div
            (@ (class "avatar")
               (style ,(string-append "background-color:"
                                      (avatar-color (sender-email message)
                                                    (map extract-email parties)))))
            ,(string-upcase (string-take (sender-name message) 1)))
           (div
            (@ (class "message"))
            (div
             (@ (class "card"))
             (div
              (@ (class "card-header"))
              (div
               (@ (class "from"))
               (div
                (@ (class "avatar")
                   (style ,(string-append "background-color:"
                                          (avatar-color (sender-email message)
                                                        (map extract-email parties)))))
                ,(string-upcase (string-take (sender-name message) 1)))
               (span (@ (class "address")) ,(sender-name message))
               " wrote "
               (span (@ (class "date"))
                     (a (@ (href ,(string-append "#" (number->string
                                                      message-number)))
                           (title ,(date->string (date message))))
                        ,(time->string (date message)))))
              ,@(if (string-suffix? previous-subject (subject message))
                    '()
                    `((div (@ (class "subject")) ,(subject message))))
              (div
               (@ (class "details"))
               (div
                (@ (class "recipients"))
                (label "Recipients:")
                ,(map (lambda (address)
                        `(span (@ (class "address")) ,address))
                      (recipients message)))
               (div
                (@ (class "message-id"))
                (label "Message-ID:")
                ,(message-id message))))
             (div
              (@ (class "body card-body"))
              ,(display-message-body id message-number message)))))
      ,@(if (closing? message id)
            '((div
               (@ (class "row event"))
               (div
                (@ (class "col-11 offset-1 text-center"))
                (div (@ (class "badge badge-primary closed")) "Closed"))))
            '())))

  (if (null? messages) #f
      (layout
       #:title (bug-subject* bug)
       #:body
       `(,(header #:title (bug-subject* bug))
         (div
          (@ (class "container"))
          ,@(match flash-message
              (('error . text)
               `((div (@ (class "alert alert-danger")
                         (role "alert"))
                      ,text)))
              (('info . text)
               `((div (@ (class "alert alert-info")
                         (role "alert"))
                      ,text)))
              (_ '()))
          ,sidebar
          (div
           (@ (class "title col-12"))
           (h1 (@ (class "h3")) ,(bug-subject* bug))
           ,issue-details)
          (div (@ (class "row"))
               (div
                (@ (class "conversation col-12"))
                ,(map show-message
                      (iota (length messages))
                      messages
                      (cons (bug-subject* bug)
                            (map subject messages)))
                ,comment-box)))))))

(define (list-of-bugs bugs)
  "Return table rows for all BUGS."
  (map (lambda (bug)
         (let ((id (number->string (bug-num bug))))
           `(tr (@ (class ,(bug-severity bug)))
                (td ,(or id "-"))
                (td
                 ,@(if (member (bug-severity bug) '("serious" "important"))
                       `((svg (@ (xmlns"http://www.w3.org/2000/svg")
                                 (xmlns:xlink "http://www.w3.org/1999/xlink")
                                 (viewBox "0 0 14 16")
                                 (version "1.1")
                                 (height "1rem")
                                 (width "1rem")
                                 (aria-hidden "true"))
                              (title ,(bug-severity bug))
                              (path (@ (fill-rule "evenodd")
                                       (d "\
M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
c0-3.14 2.56-5.7 5.7-5.7z\
M7 1C3.14 1 0 4.14 0 8\
s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
                       '())
                 ,@(or (and=> (bug-tags bug)
                              (lambda (tags)
                                (map (lambda (tag)
                                       `(a (@ (href ,(string-append "search?query=tag:" tag)))
                                           (span
                                            (@ (class ,(string-append "badge badge-info mr-1 "
                                                                      tag)))
                                            ,tag)))
                                     (string-split tags #\space))))
                       '())
                 ,(if id
                         `(a (@ (href ,(string-append "/" id)))
                             ,(bug-subject* bug))
                         (bug-subject* bug)))
                (td ,(date->string (bug-date bug)))
                (td ,(status-tag bug)))))
       bugs))

(define (priority-bugs)
  (list-of-bugs (sort
                 (append
                  (bugs-by-severity "serious" "open")
                  (bugs-by-severity "important" "open"))
                 (lambda (a b) (< (bug-num a) (bug-num b))))))

(define* (list-of-recent-issues #:optional (max 100))
  (layout
   #:body
   `(,(header #:search-bar? #f)
     (div
      (@ (class "container"))
      (h1 "Recent issues")
      (table
       (@ (class "table table-borderless table-hover js-sort-table"))
       (thead
        (tr (@ (class "heading"))
            (th (@ (class "js-sort-number")) "ID")
            (th "Subject")
            (th "Date submitted")
            (th "Status")))
       (tbody
        ,@(list-of-bugs (recent-bugs max))))))))

(define* (list-of-forgotten-issues #:optional (max 100))
  (layout
   #:body
   `(,(header #:search-bar? #f)
     (div
      (@ (class "container"))
      (h1 "Forgotten issues")
      (table
       (@ (class "table table-borderless table-hover js-sort-table"))
       (thead
        (tr (@ (class "heading"))
            (th (@ (class "js-sort-number")) "ID")
            (th "Subject")
            (th "Date submitted")
            (th "Status")))
       (tbody
        ,@(list-of-bugs (forgotten-issues max))))))))

(define (list-of-matching-bugs query bugs)
  (layout
   #:body
   `(,(header #:search-bar? #f)
     (div
      (@ (class "container"))
      (h1 "Your search for " (code ,query))
      ,(search-widget #:text query)
      ,(if (null? bugs)
           `(div
             (@ (class "alert alert-warning")
                (role "alert"))
             (h4
              (@ (class "alert-heading"))
              "Nothing found!")
             (p "We could not find any issues matching your query "
                (code ,query) ". "
                (a (@ (href "/"))
                   "Try searching for something else?")))
           `(table
             (@ (class "table table-borderless table-hover js-sort-table"))
             (thead
              (tr (@ (class "heading"))
                  (th (@ (class "js-sort-number")) "ID")
                  (th "Subject")
                  (th "Date submitted")
                  (th "Status")))
             (tbody
              ,@(list-of-bugs bugs))))))))