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        (if (string-prefix? "--8<---------------cut here" line)
  66            (values blocks #f)
  67            (values (cons (add-block-line! block
  68                                           `(span (@ (class "line")) ,line))
  69                          other-blocks)
  70                    context)))
  71       ((eq? context 'diff)
  72        (if (string= "--" line)
  73            ;; Retry
  74            (process line blocks #f)
  75            ;; Format line and add to current block
  76            (let ((formatted-line
  77                   (cond
  78                    ((string= "---" line)
  79                     `(span (@ (class "line diff separator")) ,line))
  80                    ((string-prefix? "+" line)
  81                     `(span (@ (class "line diff addition")) ,line))
  82                    ((and (string-prefix? "-" line)
  83                          (not (string= "--" line))
  84                          (not (string= "-- " line)))
  85                     `(span (@ (class "line diff deletion")) ,line))
  86                    ((string-prefix? "@@" line)
  87                     `(span (@ (class "line diff range")) ,line))
  88                    (else
  89                     `(span (@ (class "line")) ,line)))))
  90              (values (cons (add-block-line! block formatted-line)
  91                            other-blocks)
  92                      context))))
  93       ((eq? context 'quote)
  94        (if (string-prefix? ">" line)
  95            ;; Add line to current block
  96            (values (cons (add-block-line! block
  97                                           `(span (@ (class "line")) ,line))
  98                          other-blocks)
  99                    context)
 100            ;; Retry
 101            (process line blocks #f)))
 102       (else
 103        (let ((new-context
 104               (cond
 105                ((string-prefix? "diff --git" line)
 106                 'diff)
 107                ((string-prefix? ">" line)
 108                 'quote)
 109                ((string-prefix? "--8<---------------cut here" line)
 110                 'snippet)
 111                (else 'text)))
 112              (formatted-line
 113               (cond
 114                ((or (string-prefix? "Signed-off-by" line)
 115                     (string-prefix? "Co-authored-by" line))
 116                 `(span (@ (class "line commit attribution")) ,line))
 117                ((or (string-prefix? "From: " line)
 118                     (string-prefix? "Date: " line)
 119                     (string-prefix? "Subject: " line))
 120                 `(span (@ (class "line commit header")) ,line))
 121                ((or (string-prefix? "* " line)
 122                     (string-prefix? " * " line))
 123                 `(span (@ (class "line commit changelog")) ,line))
 124                ((string-prefix? "diff --git" line)
 125                 `(span (@ (class "line diff file")) ,line))
 126                ((string-prefix? "--8<---------------cut here" line)
 127                 "")
 128                (else
 129                 `(span (@ (class "line")) ,line)))))
 130          (if (eq? new-context context)
 131              (values (cons (add-block-line! block formatted-line)
 132                            other-blocks)
 133                      context)
 134              (values (cons (make-block new-context (list formatted-line))
 135                            blocks)
 136                      new-context))))))))
 137
 138 (define (prettify text)
 139   "Read each line of TEXT and apply PROCESS to it."
 140   (let ((res (fold (lambda (line acc)
 141                      (call-with-values
 142                          (lambda ()
 143                            (process line
 144                                     (cadr (memq #:blocks acc))
 145                                     (cadr (memq #:context acc))))
 146                        (lambda (new-blocks new-context)
 147                          `(#:blocks ,new-blocks #:context ,new-context))))
 148                    (list #:blocks (list (make-block 'text '()))
 149                          #:context 'text)
 150                    (string-split text #\newline))))
 151     (map (lambda (block)
 152            (if (eq? 'text (block-type block))
 153                `(div (@ (class ,(format #f "block ~a" (block-type block))))
 154                      ,(block-lines block))
 155                `(details (@ (class ,(format #f "block ~a" (block-type block)))
 156                             (open "open"))
 157                          (summary ,(format #f "Toggle ~a (~a lines)" (block-type block)
 158                                            (length (block-raw-lines block))))
 159                          ,(block-lines block))))
 160          (reverse (cadr (memq #:blocks res))))))
 161
 162 (define colors
 163   (circular-list "#8dd3c7" "#bebada" "#fb8072"
 164                  "#80b1d3" "#fdb462" "#b3de69"
 165                  "#fccde5" "#d9d9d9" "#bc80bd"
 166                  "#ccebc5" "#ffed6f"))
 167
 168 (define (avatar-color who participants)
 169   (or (and=> (assoc-ref (zip participants colors) who)
 170              first)
 171       (first colors)))
 172
 173 (define (content-type->css-class value)
 174   "Convert a content-type header value to a CSS class name."
 175   (string-append (symbol->string (assoc-ref value 'type))
 176                  "-"
 177                  (symbol->string (assoc-ref value 'subtype))))
 178
 179 ;; https://icons.getbootstrap.com/icons/download/
 180 (define download-icon
 181   '(svg (@ (class "bi bi-download")
 182            (width "1em")
 183            (height "1em")
 184            (viewBox "0 0 16 16")
 185            (fill "currentColor")
 186            (xmlns "http://www.w3.org/2000/svg"))
 187         (title "Download")
 188         (path (@ (fill-rule "evenodd")
 189                  (clip-rule "evenodd")
 190                  (d "M.5 8a.5.5 0 01.5.5V12a1 1 0 001 1h12a1 1 0 001-1\
 191 V8.5a.5.5 0 011 0V12a2 2 0 01-2 2H2a2 2 0 01-2-2V8.5A.5.5 0 01.5 8z")) "")
 192         (path (@ (fill-rule "evenodd")
 193                  (clip-rule "evenodd")
 194                  (d "M5 7.5a.5.5 0 01.707 0L8 9.793 10.293 7.5a.5.5 0 \
 195 11.707.707l-2.646 2.647a.5.5 0 01-.708 0L5 8.207A.5.5 0 015 7.5z")) "")
 196         (path (@ (fill-rule "evenodd")
 197                  (clip-rule "evenodd")
 198                  (d "M8 1a.5.5 0 01.5.5v8a.5.5 0 01-1 0v-8A.5.5 0 018 1z")) "")))
 199
 200 (define (display-message-body bug-num message-number message)
 201   "Convenience procedure to render MESSAGE (part of bug with number
 202 BUG-NUM), even when it is a multipart message."
 203   (define (display-multipart-chunk headers body path)
 204     (define (attachment-url)
 205       (string-append "/issue/"
 206                      (number->string bug-num)
 207                      "/attachment/"
 208                      (number->string message-number)
 209                      "/" (string-join (map number->string path) "/")))
 210     (let* ((content-type (assoc-ref headers 'content-type))
 211            (html?
 212             (and content-type
 213                  (eq? 'html (assoc-ref content-type 'subtype))))
 214            (attachment?
 215             (and (and=> (assoc-ref headers 'content-disposition)
 216                         (cut assoc-ref <> 'type))
 217                  content-type
 218                  (assoc-ref content-type 'type)))
 219            (binary-attachment? (and attachment?
 220                                     (member (assoc-ref content-type 'type)
 221                                             '(application image))))
 222            (attachment-name
 223             (or (and=> (assoc-ref headers 'content-disposition)
 224                        (cut assoc-ref <> 'filename))
 225                 "file")))
 226       (cond
 227        ((or html? binary-attachment?)
 228         `(div (@ (class "attachment"))
 229               "Attachment: "
 230               (a (@ (href ,(attachment-url))) ,attachment-name)))
 231        ((string-suffix? ".scm" attachment-name)
 232         `(div (@ (class "multipart scheme"))
 233               (div (@ (class "download-part"))
 234                    (a (@ (href ,(attachment-url)))
 235                       ,download-icon))
 236               ,(highlights->sxml (highlight lex-scheme body))))
 237        (else
 238         `(div (@ (class ,(string-join
 239                           (list "multipart" (or (and content-type
 240                                                      (content-type->css-class content-type))
 241                                                 "")))))
 242               (div (@ (class "download-part"))
 243                    (a (@ (href ,(attachment-url)))
 244                       ,download-icon))
 245               ,(prettify body))))))
 246   (define (display-mime-entity entity . path)
 247     (match entity
 248       (($ <mime-entity> headers (? string? body))
 249        (apply display-multipart-chunk `(,headers ,body ,path)))
 250       ;; Message parts can be nested.
 251       (($ <mime-entity> headers (? list? sub-parts))
 252        (map (lambda (part sub-part-num)
 253               (apply display-mime-entity part
 254                      (append path (list sub-part-num))))
 255             sub-parts
 256             (iota (length sub-parts))))
 257       ;; XXX: Sometimes we get an unparseable bytevector.  Convert it
 258       ;; when that happens.
 259       (($ <mime-entity> headers (? bytevector? raw))
 260        (apply display-multipart-chunk
 261               `(,headers
 262                 ,(bytevector->string raw "ISO-8859-1")
 263                 ,path)))))
 264   (cond
 265    ((multipart-message? message)
 266     (let ((parts (email-body message)))
 267       (map (lambda (part part-num)
 268              (display-mime-entity part part-num))
 269            parts
 270            (iota (length parts)))))
 271    ;; Regular message with a simple body.
 272    (else
 273     (display-mime-entity
 274      (make-mime-entity (email-headers message)
 275                        (email-body message))))))
 276
 277 (define (time->string time)
 278   "Return a string representing TIME in a concise, human-readable way."
 279   (define seconds
 280     (time-second
 281      (if (date? time)
 282          (date->time-utc time)
 283          time)))
 284
 285   (define now*
 286     (current-time time-utc))
 287
 288   (define now
 289     (time-second now*))
 290
 291   (define elapsed
 292     (- now seconds))
 293
 294   (cond ((< elapsed 120)
 295          "seconds ago")
 296         ((< elapsed 7200)
 297          (let ((minutes (inexact->exact
 298                          (round (/ elapsed 60)))))
 299            (format #f "~a minutes ago" minutes)))
 300         ((< elapsed (* 48 3600))
 301          (let ((hours (inexact->exact
 302                        (round (/ elapsed 3600)))))
 303            (format #f "~a hours ago" hours)))
 304         ((< elapsed (* 3600 24 7))
 305          (let ((days (inexact->exact
 306                       (round (/ elapsed 3600 24)))))
 307            (format #f "~a days ago" days)))
 308         (else
 309          (let* ((time    (make-time time-utc 0 seconds))
 310                 (date    (time-utc->date time))
 311                 (year    (date-year date))
 312                 (current (date-year (time-utc->date now*)))
 313                 (format  (if (= year current)
 314                              "~e ~b ~H:~M ~z"
 315                              "~e ~b ~Y ~H:~M")))
 316            (string-append "on " (date->string date format))))))