mumi/web/view/html.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2016, 2017 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 (mu)
  20   #:use-module (mumi messages)
  21   #:use-module (mumi web view utils)
  22   #:use-module (srfi srfi-1)
  23   #:export (index
  24             unknown
  25             patch-page
  26             patch-list))
  27
  28 (define* (layout #:key (head '()) (body '()))
  29   `((doctype "html")
  30     (html
  31      (head
  32       (title "Guix patches")
  33       (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
  34       (meta (@ (http-equiv "Content-Language") (content "en")))
  35       (meta (@ (name "author") (content "Ricardo Wurmus")))
  36       (meta (@ (name "viewport")
  37                (content "width=device-width, initial-scale=1")))
  38       (link
  39        (@ (rel "stylesheet")
  40           (media "screen")
  41           (type "text/css")
  42           (href "/css/reset.css")))
  43       (link
  44        (@ (rel "stylesheet")
  45           (media "screen")
  46           (type "text/css")
  47           (href "/css/bootstrap.css")))
  48       ,@head
  49       (link
  50        (@ (rel "stylesheet")
  51           (media "screen")
  52           (type "text/css")
  53           (href "/css/screen.css"))))
  54      (body ,@body))))
  55
  56 (define header
  57   '(div (@ (id "header"))
  58         (div (@ (class "container"))
  59              (div (@ (class "row"))
  60                   (a (@ (href "/"))
  61                      "Guix patches")))))
  62
  63 (define (index)
  64   (layout
  65    #:body
  66    `(,header
  67      (div (@ (class "container"))
  68           (div (@ (id "about")
  69                   (class "row"))
  70                (p "This is a web frontend to the Guix patch submission tracker.  Send email to "
  71                   (a (@ (href "mailto:guix-packages@gnu.org"))
  72                      "guix-packages@gnu.org")
  73                   " to submit your patches.")
  74                (p "This frontend is powered by "
  75                   (a (@ (href "http://www.djcbsoftware.nl/code/mu"))
  76                      "mu")
  77                   "."))
  78           (form (@ (id "search-patches")
  79                    (class "row")
  80                    (action "/search"))
  81                 (div (@ (class "form-group"))
  82                      (input (@ (type "text")
  83                                (id   "query")
  84                                (name "query")
  85                                (placeholder "input search query"))))
  86                 (button (@ (type "submit")
  87                            (class "btn btn-lg btn-primary btn-block"))
  88                         "Search"))))))
  89
  90 (define (unknown id)
  91   (layout
  92    #:body
  93    `(,header
  94      (div (@ (class "container"))
  95           (h1 "Patch not found")
  96           (p "There is no patch with id " (strong ,id))
  97           (p (a (@ (href "/")) "Try another one?"))))))
  98
  99 (define (patch-page id messages)
 100   (define parts (participants messages))
 101   (define (show-message message)
 102     `((div (@ (class "row"))
 103            (div (@ (class "avatar col-md-1")
 104                    (style ,(string-append "background-color:"
 105                                           (avatar-color (sender message) parts))))
 106                 ,(string-upcase (string-take (sender message) 1)))
 107            (div (@ (class "message col-md-11"))
 108                 (div (@ (class "panel panel-default"))
 109                      (div (@ (class "panel-heading"))
 110                           (div (@ (class "from"))
 111                                (span (@ (class "address"))
 112                                      ,(mu:from message))
 113                                " commented on "
 114                                (span (@ (class "date"))
 115                                      ,(strftime "%B %d, %Y" (localtime (mu:timestamp message)))))
 116                           (div (@ (class "details"))
 117                                (div (@ (class "recipients"))
 118                                     (label "Recipients:")
 119                                     ,(map (lambda (address)
 120                                             `(span (@ (class "address")) ,address))
 121                                           (recipients message)))
 122                                (div (@ (class "message-id"))
 123                                     (label "Message-ID:")
 124                                     ,(mu:message-id message))))
 125                      (div (@ (class "body panel-body"))
 126                           ,(prettify (mu:body-txt message))))))
 127       ,(if (closing? message)
 128            '(div (@ (class "row event"))
 129                  (div (@ (class "col-md-offset-1 col-md-11 text-center"))
 130                       (div (@ (class "label label-primary closed"))
 131                            "Closed")))
 132            '())))
 133   (layout
 134    #:body
 135    `(,header
 136      (div (@ (class "container"))
 137           (div (@ (class "row"))
 138                (h1 ,(mu:subject (car messages))))
 139           (div (@ (class "row"))
 140                (div (@ (class "conversation col-md-9"))
 141                     ,(map show-message (filter mu:body-txt messages)))
 142                (div (@ (class "info col-md-3"))
 143                     (div (@ (class "stat"))
 144                          ,@(let ((num (length parts)))
 145                              `((label ,(if (= num 1)
 146                                            "One participant"
 147                                            (string-append (number->string num)
 148                                                           " participants")))
 149                                (ul ,(map (lambda (address)
 150                                            `(li (span (@ (class "address")))
 151                                                 ,address))
 152                                          parts)))))
 153                     (div (@ (class "stat"))
 154                          (label "Owner")
 155                          ,(or (owner messages) "unassigned"))
 156                     (div (@ (class "stat"))
 157                          (label "Status")
 158                          ,(status messages))))
 159           (div (@ (class "row"))
 160                (p "To comment on this conversation "
 161                   (a (@ (href ,(string-append "mailto:" id "@debbugs.gnu.org?subject="
 162                                               (mu:subject (last messages)))))
 163                      ,(string-append "send email to "
 164                                      id "@debbugs.gnu.org"))))))))
 165
 166 (define (patch-list query messages)
 167   (layout
 168    #:body
 169    `(,header
 170      (div (@ (class "container"))
 171           (h1 "Patches matching " (code ,query))
 172           ,(if (null? messages)
 173                `(p (a (@ (href "/"))
 174                       "There are no patches matching your query, but we have many more!"))
 175                `(table (@ (class "table-condensed"))
 176                        (thead
 177                         (tr (th "ID")
 178                             (th "Subject")
 179                             (th "Date submitted")))
 180                        (tbody
 181                         ,@(map (lambda (msg)
 182                                  (let ((id (patch-id msg)))
 183                                    `(tr
 184                                      (td ,(or id "-"))
 185                                      (td ,(if id
 186                                               `(a (@ (href ,(string-append "/patch/" id)))
 187                                                   ,(mu:subject msg))
 188                                               (mu:subject msg)))
 189                                      (td ,(strftime "%B %d, %Y" (localtime (mu:timestamp msg)))))))
 190                                messages))))))))