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 format)
  22   #:use-module (ice-9 rdelim)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 regex)
  25   #:use-module (ice-9 iconv)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-9)
  28   #:use-module (srfi srfi-19)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (syntax-highlight)
  31   #:use-module (syntax-highlight scheme)
  32   #:use-module (email email)
  33   #:use-module (mumi messages)
  34   #:use-module (rnrs bytevectors)
  35   #:use-module (web uri)
  36   #:export (prettify
  37             avatar-color
  38             download-icon
  39             display-message-body
  40             time->string))
  41
  42 (define-record-type <block>
  43   (make-block type lines)
  44   block?
  45   (type   block-type)
  46   (lines  block-raw-lines set-block-lines!))
  47
  48 (define (block-lines block)
  49   (reverse (block-raw-lines block)))
  50
  51 (define (add-block-line! block line)
  52   (set-block-lines! block
  53                     (cons line (block-raw-lines block)))
  54   block)
  55
  56 (define (process line blocks context line-anchor)
  57   "Process the current LINE.  Add it to the latest block in BLOCKS or
  58 add it to a new block, dependent on CONTEXT.  Return the blocks along
  59 with the next context."
  60   (match blocks
  61     ((block . other-blocks)
  62      (cond
  63       ((string-null? line)
  64        (values (cons (add-block-line! block `(br))
  65                      other-blocks)
  66                context))
  67       ((eq? context 'snippet)
  68        (if (string-prefix? "--8<---------------cut here" line)
  69            (values blocks #f)
  70            (values (cons (add-block-line! block
  71                                           `(div (@ (class "line")) ,line))
  72                          other-blocks)
  73                    context)))
  74       ((eq? context 'diff)
  75        (if (string= "--" line)
  76            ;; Retry
  77            (process line blocks #f line-anchor)
  78            ;; Format line and add to current block
  79            (let ((formatted-line
  80                   (cond
  81                    ((string= "---" line)
  82                     `(div (@ (class "line diff separator"))
  83                           ,line-anchor ,line))
  84                    ((string-prefix? "+" line)
  85                     `(div (@ (class "line diff addition"))
  86                           ,line-anchor ,line))
  87                    ((and (string-prefix? "-" line)
  88                          (not (string= "--" line))
  89                          (not (string= "-- " line)))
  90                     `(div (@ (class "line diff deletion"))
  91                           ,line-anchor ,line))
  92                    ((string-prefix? "@@" line)
  93                     `(div (@ (class "line diff range"))
  94                           ,line-anchor ,line))
  95                    (else
  96                     `(div (@ (class "line"))
  97                           ,line-anchor
  98                           ,line)))))
  99              (values (cons (add-block-line! block formatted-line)
 100                            other-blocks)
 101                      context))))
 102       ((eq? context 'quote)
 103        (if (string-prefix? ">" line)
 104            ;; Add line to current block
 105            (values (cons (add-block-line! block
 106                                           `(div (@ (class "line"))
 107                                                 ,line-anchor
 108                                                 ,line))
 109                          other-blocks)
 110                    context)
 111            ;; Retry
 112            (process line blocks #f line-anchor)))
 113       (else
 114        (let ((new-context
 115               (cond
 116                ((string-prefix? "diff --git" line)
 117                 'diff)
 118                ((string-prefix? ">" line)
 119                 'quote)
 120                ((string-prefix? "--8<---------------cut here" line)
 121                 'snippet)
 122                (else 'text)))
 123              (formatted-line
 124               (cond
 125                ((or (string-contains line "https://")
 126                     (string-contains line "http://")) =>
 127                     (lambda (index)
 128                       (let* ((pre (string-take line index))
 129                              (post (string-drop line index))
 130                              (uri+ (string-split post (char-set #\< #\> #\space))))
 131                         (match uri+
 132                           ((uri-string . rest)
 133                            (or (and=> (string->uri uri-string)
 134                                       (lambda (uri)
 135                                         `(div (@ (class "line"))
 136                                               ,line-anchor
 137                                               ,(string-trim-right pre #\<)
 138                                               (a (@ (href ,uri-string))
 139                                                  ,uri-string)
 140                                               ,(string-join rest " "))))
 141                                `(div (@ (class "line"))
 142                                       ,line-anchor ,line)))))))
 143                ((or (string-prefix? "Signed-off-by" line)
 144                     (string-prefix? "Co-authored-by" line))
 145                 `(div (@ (class "line commit attribution"))
 146                       ,line-anchor ,line))
 147                ((or (string-prefix? "From: " line)
 148                     (string-prefix? "Date: " line)
 149                     (string-prefix? "Subject: " line))
 150                 `(div (@ (class "line commit header"))
 151                        ,line-anchor ,line))
 152                ((or (string-prefix? "* " line)
 153                     (string-prefix? " * " line))
 154                 `(div (@ (class "line commit changelog"))
 155                       ,line-anchor ,line))
 156                ((string-prefix? "diff --git" line)
 157                 `(div (@ (class "line diff file"))
 158                        ,line-anchor ,line))
 159                ((string-prefix? "--8<---------------cut here" line)
 160                 "")
 161                (else
 162                 `(div (@ (class "line")) ,line-anchor ,line)))))
 163          (if (eq? new-context context)
 164              (values (cons (add-block-line! block formatted-line)
 165                            other-blocks)
 166                      context)
 167              (values (cons (make-block new-context (list formatted-line))
 168                            blocks)
 169                      new-context))))))))
 170
 171 (define (prettify text message-number)
 172   "Read each line of TEXT and apply PROCESS to it.  Prefix line
 173 numbers with the given MESSAGE-NUMBER."
 174   (let* ((lines (string-split text #\newline))
 175          (res (fold (lambda (line line-number acc)
 176                       (call-with-values
 177                           (lambda ()
 178                             (process line
 179                                      (cadr (memq #:blocks acc))
 180                                      (cadr (memq #:context acc))
 181                                      `(a (@ (class "line-anchor")
 182                                             (id ,(format #false "~a-lineno~a"
 183                                                          message-number line-number))
 184                                             (href ,(format #false "#~a-lineno~a"
 185                                                            message-number line-number)))
 186                                          "#")))
 187                         (lambda (new-blocks new-context)
 188                           `(#:blocks ,new-blocks #:context ,new-context))))
 189                     (list #:blocks (list (make-block 'text '()))
 190                           #:context 'text)
 191                     lines
 192                     (iota (length lines)))))
 193     (map (lambda (block)
 194            (if (eq? 'text (block-type block))
 195                `(div (@ (class ,(format #f "block ~a" (block-type block))))
 196                      ,(block-lines block))
 197                `(details (@ (class ,(format #f "block ~a" (block-type block)))
 198                             (open "open"))
 199                          (summary ,(format #f "Toggle ~a (~a lines)" (block-type block)
 200                                            (length (block-raw-lines block))))
 201                          ,(block-lines block))))
 202          (reverse (cadr (memq #:blocks res))))))
 203
 204 (define colors
 205   (circular-list "#8dd3c7" "#bebada" "#fb8072"
 206                  "#80b1d3" "#fdb462" "#b3de69"
 207                  "#fccde5" "#d9d9d9" "#bc80bd"
 208                  "#ccebc5" "#ffed6f"))
 209
 210 (define (avatar-color who participants)
 211   (or (and=> (assoc-ref (zip participants colors) who)
 212              first)
 213       (first colors)))
 214
 215 (define (content-type->css-class value)
 216   "Convert a content-type header value to a CSS class name."
 217   (string-append (symbol->string (assoc-ref value 'type))
 218                  "-"
 219                  (symbol->string (assoc-ref value 'subtype))))
 220
 221 ;; https://icons.getbootstrap.com/icons/download/
 222 (define download-icon
 223   '(svg (@ (class "bi bi-download")
 224            (width "1em")
 225            (height "1em")
 226            (viewBox "0 0 16 16")
 227            (fill "currentColor")
 228            (xmlns "http://www.w3.org/2000/svg"))
 229         (title "Download")
 230         (path (@ (fill-rule "evenodd")
 231                  (clip-rule "evenodd")
 232                  (d "M.5 8a.5.5 0 01.5.5V12a1 1 0 001 1h12a1 1 0 001-1\
 233 V8.5a.5.5 0 011 0V12a2 2 0 01-2 2H2a2 2 0 01-2-2V8.5A.5.5 0 01.5 8z")) "")
 234         (path (@ (fill-rule "evenodd")
 235                  (clip-rule "evenodd")
 236                  (d "M5 7.5a.5.5 0 01.707 0L8 9.793 10.293 7.5a.5.5 0 \
 237 11.707.707l-2.646 2.647a.5.5 0 01-.708 0L5 8.207A.5.5 0 015 7.5z")) "")
 238         (path (@ (fill-rule "evenodd")
 239                  (clip-rule "evenodd")
 240                  (d "M8 1a.5.5 0 01.5.5v8a.5.5 0 01-1 0v-8A.5.5 0 018 1z")) "")))
 241
 242 (define (display-message-body bug-num message-number message)
 243   "Convenience procedure to render MESSAGE (part of bug with number
 244 BUG-NUM), even when it is a multipart message."
 245   (define (display-multipart-chunk headers body path)
 246     (define (attachment-url)
 247       (string-append "/issue/"
 248                      (number->string bug-num)
 249                      "/attachment/"
 250                      (number->string message-number)
 251                      "/" (string-join (map number->string path) "/")))
 252     (let* ((content-type (assoc-ref headers 'content-type))
 253            (html?
 254             (and content-type
 255                  (eq? 'html (assoc-ref content-type 'subtype))))
 256            (attachment?
 257             (and (and=> (assoc-ref headers 'content-disposition)
 258                         (cut assoc-ref <> 'type))
 259                  content-type
 260                  (assoc-ref content-type 'type)))
 261            (hide-attachment? (and attachment?
 262                                   (or (member (assoc-ref content-type 'type)
 263                                               '(application image video))
 264                                       (and=> (assoc-ref headers 'content-disposition)
 265                                              (lambda (disposition)
 266                                                (and=> (assoc-ref disposition 'size)
 267                                                       (lambda (size)
 268                                                         (> size 5000))))))))
 269            (attachment-name
 270             (or (and=> (assoc-ref headers 'content-disposition)
 271                        (cut assoc-ref <> 'filename))
 272                 "file")))
 273       (cond
 274        ((or html? hide-attachment?)
 275         `(div (@ (class "attachment"))
 276               "Attachment: "
 277               (a (@ (href ,(attachment-url))) ,attachment-name)
 278               ,(or (and=> (assoc-ref headers 'content-disposition)
 279                           (lambda (disposition)
 280                             (and=> (assoc-ref disposition 'size)
 281                                    (lambda (bytes)
 282                                      (format #f " (~1,2f MiB)"
 283                                              (exact->inexact
 284                                               (/ bytes 1024 1024)))))))
 285                    "")))
 286        ((string-suffix? ".scm" attachment-name)
 287         `(div (@ (class "multipart scheme"))
 288               (div (@ (class "download-part"))
 289                    (a (@ (href ,(attachment-url)))
 290                       ,download-icon))
 291               ,(highlights->sxml (highlight lex-scheme body))))
 292        (else
 293         `(div (@ (class ,(string-join
 294                           (list "multipart" (or (and content-type
 295                                                      (content-type->css-class content-type))
 296                                                 "")))))
 297               (div (@ (class "download-part"))
 298                    (a (@ (href ,(attachment-url)))
 299                       ,download-icon))
 300               ,(prettify body message-number))))))
 301   (define (display-mime-entity entity . path)
 302     (match entity
 303       (($ <mime-entity> headers (? string? body))
 304        (apply display-multipart-chunk `(,headers ,body ,path)))
 305       ;; Message parts can be nested.
 306       (($ <mime-entity> headers (? list? sub-parts))
 307        (map (lambda (part sub-part-num)
 308               (apply display-mime-entity part
 309                      (append path (list sub-part-num))))
 310             sub-parts
 311             (iota (length sub-parts))))
 312       ;; XXX: Sometimes we get an unparseable bytevector.  Convert it
 313       ;; when that happens.
 314       (($ <mime-entity> headers (? bytevector? raw))
 315        (apply display-multipart-chunk
 316               `(,headers
 317                 ,(bytevector->string raw "ISO-8859-1")
 318                 ,path)))))
 319   (cond
 320    ((multipart-message? message)
 321     (let ((parts (email-body message)))
 322       (map (lambda (part part-num)
 323              (display-mime-entity part part-num))
 324            parts
 325            (iota (length parts)))))
 326    ;; Regular message with a simple body.
 327    (else
 328     (display-mime-entity
 329      (make-mime-entity (email-headers message)
 330                        (email-body message))))))
 331
 332 (define (time->string time)
 333   "Return a string representing TIME in a concise, human-readable way."
 334   (define seconds
 335     (time-second
 336      (if (date? time)
 337          (date->time-utc time)
 338          time)))
 339
 340   (define now*
 341     (current-time time-utc))
 342
 343   (define now
 344     (time-second now*))
 345
 346   (define elapsed
 347     (- now seconds))
 348
 349   (cond ((< elapsed 120)
 350          "seconds ago")
 351         ((< elapsed 7200)
 352          (let ((minutes (inexact->exact
 353                          (round (/ elapsed 60)))))
 354            (format #f "~a minutes ago" minutes)))
 355         ((< elapsed (* 48 3600))
 356          (let ((hours (inexact->exact
 357                        (round (/ elapsed 3600)))))
 358            (format #f "~a hours ago" hours)))
 359         ((< elapsed (* 3600 24 7))
 360          (let ((days (inexact->exact
 361                       (round (/ elapsed 3600 24)))))
 362            (format #f "~a days ago" days)))
 363         (else
 364          (let* ((time    (make-time time-utc 0 seconds))
 365                 (date    (time-utc->date time))
 366                 (year    (date-year date))
 367                 (current (date-year (time-utc->date now*)))
 368                 (format  (if (= year current)
 369                              "~e ~b ~H:~M ~z"
 370                              "~e ~b ~Y ~H:~M")))
 371            (string-append "on " (date->string date format))))))