;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2016, 2017, 2018, 2019 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 (debbugs bug)
  #:use-module (email email)
  #:use-module (mumi config)
  #:use-module (mumi messages)
  #:use-module (mumi web view utils)
  #: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-bugs
            priority-bugs))

(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")
                 (extra-headers '()))
  `(#:sxml ((doctype "html")
            (html
             (head
              (title ,title)
              (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
              (meta (@ (http-equiv "Content-Language") (content "en")))
              (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")))
              (link
               (@ (rel "stylesheet")
                  (media "screen")
                  (type "text/css")
                  (href "/css/code.css"))))
             (body ,@body
                   (footer
                    (p "Copyright © 2016—2019 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") ".")))))
    #:extra-headers ,extra-headers))

(define* (search-form #:key (standalone? #f))
  `(form (@ (id "search")
            ,(if standalone?
                 '(class "row")
                 '(class "navbar-form navbar-right"))
            (action "/search"))
         (div
          (@ (class ,(if standalone?
                         "input-group input-group-lg"
                         "input-group")))
          (input (@ (type "text")
                    (class "form-control")
                    (id   "query")
                    (name "query")
                    (placeholder "input search query")))
               (span (@ (class "input-group-btn"))
                    (button
                     (@ (type "submit")
                        (class ,(string-append (if standalone? "btn-lg " "")
                                               "btn btn-primary")))
                     "Search")))))

(define* (header #:key (search-bar? #t))
  `(nav
    (@ (id "header") (class "navbar navbar-default"))
    (div
     (@ (class "container-fluid"))
     (div
      (@ (class "navbar-header"))
      (div (@ (class "navbar-brand"))
           (a (@ (href "/") (class "logo")))))
     ,@(if search-bar?
           `(,(search-form))
           '()))))

(define (index)
  (layout
   #:extra-headers
   '((cache-control . ((max-age . 60))))
   #:body
   `(,(header #:search-bar? #f)
     (div
      (@ (class "container"))
      (h1 "Guix patch tracker")
      (p (@ (class "row"))
         "This is a web frontend to the Guix patch tracker.  Send email to "
         (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
            ,(%config 'submission-email-address))
         " to submit your patches.")
      ,(search-form #:standalone? #t)
      (div
       (@ (class "row"))
       (div
        (@ (class "panel panel-default"))
        (p (@ (class "panel-body"))
           (strong "Hint: ")
           "Refine your search with filters like "
           (span (@ (class "filter"))
                 "is:open")
           ", "
           (span (@ (class "filter"))
                 "author:me")
           ", "
           (span (@ (class "filter"))
                 "submitter:me")
           ", "
           (span (@ (class "filter"))
                 "date:yesterday..now")
           ", "
           (span (@ (class "filter"))
                 "date:2018-04-01..2018-04-02")
           ", "
           (span (@ (class "filter"))
                 "date:1m..today")
           ", "
           (span (@ (class "filter"))
                 "mdate:2w..12h")
           ", and "
           (a (@ (href "help#search"))
              "many more!"))))
      (h2 "Recent activity")
      (div (@ (id "snippet-recent"))
           (img (@ (src "/img/spin.gif"))))
      (h2 "Priority bugs")
      (div (@ (id "snippet-priority"))
           (img (@ (src "/img/spin.gif"))))
      (script
       (@ (type "text/javascript")
          (src "/js/mumi.js")))))))

(define (help)
  (layout
   #:extra-headers
   ;; Cache for 24 hours.
   '((cache-control . ((max-age . 86400))))
   #: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")) "date:<start>..<end>"))
         (td "Issues submitted within the provided range.  "
             (strong "start") " and " (strong "end") " can be one of "
             (strong "now") ", " (strong "today") ", " (strong "yesterday")
             ", 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 "Issues with comments submitted within the provided
range.  The supported arguments are the same as for "
             (span (@ (class "filter")) "date:") "."))))))))

(define (unknown id)
  (layout
   #:body
   `(,(header)
     (div (@ (class "container"))
          (h1 "Patch not found")
          (p "There is no submission with id " (strong ,id))
          (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)
  "Render the conversation for the given BUG."
  (define id (bug-num bug))
  (define messages (patch-messages id))
  (define parties (sort (filter (compose (negate bot?) extract-email)
                                (participants messages))
                        (lambda (a b)
                          (string< (extract-email a)
                                   (extract-email b)))))
  (define (show-message message-number message previous-subject)
    `((div
       (@ (class "row"))
       (a (@ (id ,(number->string message-number))))
       (div
        (@ (class "avatar col-md-1")
           (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 col-md-11"))
        (div
         (@ (class "panel panel-default"))
         (div
          (@ (class "panel-heading"))
          (div
           (@ (class "from"))
           (span (@ (class "address")) ,(sender-name message))
           " wrote on "
           (span (@ (class "date"))
                 (a (@ (href ,(string-append "#" (number->string
                                                  message-number))))
                    ,(date->string (date message)))))
          ,@(if (or (string-suffix? (or previous-subject "")
                                    (or (subject message) ""))
                    (not (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 panel-body"))
          ,(display-message-body id message-number message)))))
      ,@(if (closing? message id)
            '((div
               (@ (class "row event"))
               (div
                (@ (class "col-md-offset-1 col-md-11 text-center"))
                (div (@ (class "label label-primary closed")) "Closed"))))
            '())))
  (layout
   #:title (bug-subject bug)
   #:extra-headers
   (cond
    ((bug-archived bug)
     ;; Tell browser to cache this for 12 hours.
     '((cache-control . ((max-age . 43200)))))
    ((bug-done bug)
     ;; Tell browser to cache this for 1 hour.
     '((cache-control . ((max-age . 3600)))))
    (else '()))
   #:body
   `(,(header)
     (div
      (@ (class "container"))
      (div
       (@ (class "row title col-md-12"))
       (h1 ,(bug-subject bug))
       (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))
                             ".")
             ,@(if (bug-mergedwith bug)
                   `((ul (@ (class "merged"))
                         "Merged with: "
                         ,(map (lambda (id)
                                 `(li (a (@ (href ,(string-append "/issue/" 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)
                   `((ul (@ (class "blocks"))
                         "Blocks: "
                         ,(map (lambda (id)
                                 `(li (a (@ (href ,(string-append "/issue/" 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)
                   `((ul (@ (class "blockedby"))
                         "Blocked by: "
                         ,(map (lambda (id)
                                 `(li (a (@ (href ,(string-append "/issue/" 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)))))))
                   '())))
      (div
       (@ (class "row"))
       (div
        (@ (class "conversation col-md-9"))
        ,(let ((msgs (filter (lambda (msg)
                               ;; Ignore messages
                               ;; without body, and
                               ;; internal messages.
                               (and (email-body msg)
                                    (not (internal-message? msg))))
                             messages)))
           (map (lambda (message-number msg previous-subject)
                  (show-message message-number msg previous-subject))
                (iota (length msgs))
                msgs
                (cons (bug-subject bug)
                      (map subject msgs))))
        (div
         (@ (class "row comment-box"))
         (a (@ (id "comment")))
         (div
          (@ (class "avatar col-md-1")
             (style "background-color:#bc80bd")) "?")
	     (div
          (@ (class "message col-md-11"))
          (div
           (@ (class "panel panel-default"))
           (div
            (@ (class "panel-heading"))
            (div (@ (class "from"))
                 (span (@ (class "address")) "Your comment")))
           (div
            (@ (class "body panel-body"))
            (p "Comments via the web interface are not currently
supported.  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)))))))))

       (div
        (@ (class "info col-md-3"))
        (div
         (@ (class "stat"))
         ,@(let ((num (length parties)))
             `((label ,(if (= num 1)
                           "One participant"
                           (string-append (number->string num)
                                          " participants")))
               (ul ,(map (lambda (name)
                           `(li (span (@ (class "name")))
                                ,name))
                         (map extract-name parties))))))
        (div
         (@ (class "stat"))
         (label "Owner")
         ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
        (div
         (@ (class "stat"))
         (label "Severity")
         ,(bug-severity bug))
        (div
         (@ (class "stat"))
         (label "Status")
         ,(status-tag bug))))))))

(define (list-of-bugs bugs)
  "Return a table of BUGS."
  (if (null? bugs)
      `(p "Nothing to see here. "
          (a (@ (href "/"))
             "Look for something else?"))
      `(table (@ (class "table-condensed"))
              (thead
               (tr (th "ID")
                   (th "Subject")
                   (th "Date submitted")
                   (th "Status")))
              (tbody
               ,@(map (lambda (bug)
                        (let ((id (number->string (bug-num bug))))
                          `(tr (@ (class ,(bug-severity bug)))
                            (td ,(or id "-"))
                            (td ,(if id
                                     `(a (@ (href ,(string-append "/issue/" id)))
                                         ,(bug-subject bug))
                                     (bug-subject bug)))
                            (td ,(date->string (bug-date bug)))
                            (td ,(status-tag bug)))))
                      bugs)))))

(define (priority-bugs)
  (list #:sxml
        (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-matching-bugs query bugs)
  (layout
   #:body
   `(,(header)
     (div (@ (class "container"))
          ,@(if (null? bugs)
                `((h1 "No issues found")
                  (p "We could not find any issues matching your query "
                     (code ,query) ". "
                     (a (@ (href "/"))
                        "Try searching for something else?")))
                `((h1 "Submissions matching " (code ,query))
                  ,(list-of-bugs bugs)))))))