mumi/web/view/utils.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
   4 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
   5 ;;;
   6 ;;; This program is free software: you can redistribute it and/or
   7 ;;; modify it under the terms of the GNU Affero General Public License
   8 ;;; as published by the Free Software Foundation, either version 3 of
   9 ;;; the License, or (at your option) any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; Affero General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Affero General Public
  17 ;;; License along with this program.  If not, see
  18 ;;; <http://www.gnu.org/licenses/>.
  19
  20 (define-module (mumi web view utils)
  21   #:use-module (ice-9 rdelim)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 regex)
  24   #:use-module (ice-9 iconv)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-9)
  27   #:use-module (srfi srfi-19)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (syntax-highlight)
  30   #:use-module (syntax-highlight scheme)
  31   #:use-module (email email)
  32   #:use-module (mumi messages)
  33   #:use-module (rnrs bytevectors)
  34   #:export (prettify
  35             avatar-color
  36             display-message-body
  37             time->string))
  38
  39 (define-record-type <block>
  40   (make-block type lines)
  41   block?
  42   (type   block-type)
  43   (lines  block-raw-lines set-block-lines!))
  44
  45 (define (block-lines block)
  46   (reverse (block-raw-lines block)))
  47
  48 (define (add-block-line! block line)
  49   (set-block-lines! block
  50                     (cons line (block-raw-lines block)))
  51   block)
  52
  53 (define (process line blocks context)
  54   "Process the current LINE.  Add it to the latest block in BLOCKS or
  55 add it to a new block, dependent on CONTEXT.  Return the blocks along
  56 with the next context."
  57   (match blocks
  58     ((block . other-blocks)
  59      (cond
  60       ((string-null? line)
  61        (values (cons (add-block-line! block `(br))
  62                      other-blocks)
  63                context))
  64       ((eq? context 'snippet)
  65        (values (cons (add-block-line! block
  66                                       `(span (@ (class "line")) ,line))
  67                      other-blocks)
  68                (if (string-prefix? "--8<---------------cut here" line)
  69                    #f context)))
  70       ((eq? context 'diff)
  71        (if (string= "--" line)
  72            ;; Retry
  73            (process line blocks #f)
  74            ;; Format line and add to current block
  75            (let ((formatted-line
  76                   (cond
  77                    ((string= "---" line)
  78                     `(span (@ (class "line diff separator")) ,line))
  79                    ((string-prefix? "+" line)
  80                     `(span (@ (class "line diff addition")) ,line))
  81                    ((and (string-prefix? "-" line)
  82                          (not (string= "--" line))
  83                          (not (string= "-- " line)))
  84                     `(span (@ (class "line diff deletion")) ,line))
  85                    ((string-prefix? "@@" line)
  86                     `(span (@ (class "line diff range")) ,line))
  87                    (else
  88                     `(span (@ (class "line")) ,line)))))
  89              (values (cons (add-block-line! block formatted-line)
  90                            other-blocks)
  91                      context))))
  92       ((eq? context 'quote)
  93        (if (string-prefix? ">" line)
  94            ;; Add line to current block
  95            (values (cons (add-block-line! block
  96                                           `(span (@ (class "line")) ,line))
  97                          other-blocks)
  98                    context)
  99            ;; Retry
 100            (process line blocks #f)))
 101       (else
 102        (let ((new-context
 103               (cond
 104                ((string-prefix? "diff --git" line)
 105                 'diff)
 106                ((string-prefix? ">" line)
 107                 'quote)
 108                ((string-prefix? "--8<---------------cut here" line)
 109                 'snippet)
 110                (else 'text)))
 111              (formatted-line
 112               (cond
 113                ((or (string-prefix? "Signed-off-by" line)
 114                     (string-prefix? "Co-authored-by" line))
 115                 `(span (@ (class "line commit attribution")) ,line))
 116                ((or (string-prefix? "From: " line)
 117                     (string-prefix? "Date: " line)
 118                     (string-prefix? "Subject: " line))
 119                 `(span (@ (class "line commit header")) ,line))
 120                ((or (string-prefix? "* " line)
 121                     (string-prefix? " * " line))
 122                 `(span (@ (class "line commit changelog")) ,line))
 123                ((string-prefix? "diff --git" line)
 124                 `(span (@ (class "line diff file")) ,line))
 125                (else
 126                 `(span (@ (class "line")) ,line)))))
 127          (if (eq? new-context context)
 128              (values (cons (add-block-line! block formatted-line)
 129                            other-blocks)
 130                      context)
 131              (values (cons (make-block new-context (list formatted-line))
 132                            blocks)
 133                      new-context))))))))
 134
 135 (define (prettify text)
 136   "Read each line of TEXT and apply PROCESS to it."
 137   (let ((res (fold (lambda (line acc)
 138                      (call-with-values
 139                          (lambda ()
 140                            (process line
 141                                     (cadr (memq #:blocks acc))
 142                                     (cadr (memq #:context acc))))
 143                        (lambda (new-blocks new-context)
 144                          `(#:blocks ,new-blocks #:context ,new-context))))
 145                    (list #:blocks (list (make-block 'text '()))
 146                          #:context 'text)
 147                    (string-split text #\newline))))
 148     (map (lambda (block)
 149            (if (eq? 'text (block-type block))
 150                `(div (@ (class ,(format #f "block ~a" (block-type block))))
 151                      ,(block-lines block))
 152                `(details (@ (class ,(format #f "block ~a" (block-type block)))
 153                             (open "open"))
 154                          (summary ,(format #f "Toggle ~a (~a lines)" (block-type block)
 155                                            (length (block-raw-lines block))))
 156                          ,(block-lines block))))
 157          (reverse (cadr (memq #:blocks res))))))
 158
 159 (define colors
 160   (circular-list "#8dd3c7" "#bebada" "#fb8072"
 161                  "#80b1d3" "#fdb462" "#b3de69"
 162                  "#fccde5" "#d9d9d9" "#bc80bd"
 163                  "#ccebc5" "#ffed6f"))
 164
 165 (define (avatar-color who participants)
 166   (or (and=> (assoc-ref (zip participants colors) who)
 167              first)
 168       (first colors)))
 169
 170 (define (content-type->css-class value)
 171   "Convert a content-type header value to a CSS class name."
 172   (string-append (symbol->string (assoc-ref value 'type))
 173                  "-"
 174                  (symbol->string (assoc-ref value 'subtype))))
 175
 176 ;; https://icons.getbootstrap.com/icons/download/
 177 (define download-icon
 178   '(svg (@ (class "bi bi-download")
 179            (width "1em")
 180            (height "1em")
 181            (viewBox "0 0 16 16")
 182            (fill "currentColor")
 183            (xmlns "http://www.w3.org/2000/svg"))
 184         (title "Download")
 185         (path (@ (fill-rule "evenodd")
 186                  (clip-rule "evenodd")
 187                  (d "M.5 8a.5.5 0 01.5.5V12a1 1 0 001 1h12a1 1 0 001-1\
 188 V8.5a.5.5 0 011 0V12a2 2 0 01-2 2H2a2 2 0 01-2-2V8.5A.5.5 0 01.5 8z")) "")
 189         (path (@ (fill-rule "evenodd")
 190                  (clip-rule "evenodd")
 191                  (d "M5 7.5a.5.5 0 01.707 0L8 9.793 10.293 7.5a.5.5 0 \
 192 11.707.707l-2.646 2.647a.5.5 0 01-.708 0L5 8.207A.5.5 0 015 7.5z")) "")
 193         (path (@ (fill-rule "evenodd")
 194                  (clip-rule "evenodd")
 195                  (d "M8 1a.5.5 0 01.5.5v8a.5.5 0 01-1 0v-8A.5.5 0 018 1z")) "")))
 196
 197 (define (display-message-body bug-num message-number message)
 198   "Convenience procedure to render MESSAGE (part of bug with number
 199 BUG-NUM), even when it is a multipart message."
 200   (define (display-multipart-chunk headers body path)
 201     (define (attachment-url)
 202       (string-append "/issue/"
 203                      (number->string bug-num)
 204                      "/attachment/"
 205                      (number->string message-number)
 206                      "/" (string-join (map number->string path) "/")))
 207     (let* ((content-type (assoc-ref headers 'content-type))
 208            (html?
 209             (and content-type
 210                  (eq? 'html (assoc-ref content-type 'subtype))))
 211            (attachment?
 212             (and (and=> (assoc-ref headers 'content-disposition)
 213                         (cut assoc-ref <> 'type))
 214                  content-type
 215                  (assoc-ref content-type 'type)))
 216            (binary-attachment? (and attachment?
 217                                     (member (assoc-ref content-type 'type)
 218                                             '(application image))))
 219            (attachment-name
 220             (or (and=> (assoc-ref headers 'content-disposition)
 221                        (cut assoc-ref <> 'filename))
 222                 "file")))
 223       (cond
 224        ((or html? binary-attachment?)
 225         `(div (@ (class "attachment"))
 226               "Attachment: "
 227               (a (@ (href ,(attachment-url))) ,attachment-name)))
 228        ((string-suffix? ".scm" attachment-name)
 229         `(div (@ (class "multipart scheme"))
 230               (div (@ (class "download-part"))
 231                    (a (@ (href ,(attachment-url)))
 232                       ,download-icon))
 233               ,(highlights->sxml (highlight lex-scheme body))))
 234        (else
 235         `(div (@ (class ,(string-join
 236                           (list "multipart" (or (and content-type
 237                                                      (content-type->css-class content-type))
 238                                                 "")))))
 239               (div (@ (class "download-part"))
 240                    (a (@ (href ,(attachment-url)))
 241                       ,download-icon))
 242               ,(prettify body))))))
 243   (define (display-mime-entity entity . path)
 244     (match entity
 245       (($ <mime-entity> headers (? string? body))
 246        (apply display-multipart-chunk `(,headers ,body ,path)))
 247       ;; Message parts can be nested.
 248       (($ <mime-entity> headers (? list? sub-parts))
 249        (map (lambda (part sub-part-num)
 250               (apply display-mime-entity part
 251                      (append path (list sub-part-num))))
 252             sub-parts
 253             (iota (length sub-parts))))
 254       ;; XXX: Sometimes we get an unparseable bytevector.  Convert it
 255       ;; when that happens.
 256       (($ <mime-entity> headers (? bytevector? raw))
 257        (apply display-multipart-chunk
 258               `(,headers
 259                 ,(bytevector->string raw "ISO-8859-1")
 260                 ,path)))))
 261   (cond
 262    ((multipart-message? message)
 263     (let ((parts (email-body message)))
 264       (map (lambda (part part-num)
 265              (display-mime-entity part part-num))
 266            parts
 267            (iota (length parts)))))
 268    ;; Regular message with a simple body.
 269    (else
 270     (display-mime-entity
 271      (make-mime-entity (email-headers message)
 272                        (email-body message))))))
 273
 274 (define (time->string time)
 275   "Return a string representing TIME in a concise, human-readable way."
 276   (define seconds
 277     (time-second
 278      (if (date? time)
 279          (date->time-utc time)
 280          time)))
 281
 282   (define now*
 283     (current-time time-utc))
 284
 285   (define now
 286     (time-second now*))
 287
 288   (define elapsed
 289     (- now seconds))
 290
 291   (cond ((< elapsed 120)
 292          "seconds ago")
 293         ((< elapsed 7200)
 294          (let ((minutes (inexact->exact
 295                          (round (/ elapsed 60)))))
 296            (format #f "~a minutes ago" minutes)))
 297         ((< elapsed (* 48 3600))
 298          (let ((hours (inexact->exact
 299                        (round (/ elapsed 3600)))))
 300            (format #f "~a hours ago" hours)))
 301         ((< elapsed (* 3600 24 7))
 302          (let ((days (inexact->exact
 303                       (round (/ elapsed 3600 24)))))
 304            (format #f "~a days ago" days)))
 305         (else
 306          (let* ((time    (make-time time-utc 0 seconds))
 307                 (date    (time-utc->date time))
 308                 (year    (date-year date))
 309                 (current (date-year (time-utc->date now*)))
 310                 (format  (if (= year current)
 311                              "~e ~b ~H:~M ~z"
 312                              "~e ~b ~Y ~H:~M")))
 313            (string-append "on " (date->string date format))))))