mumi/web/view/utils.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
   4 ;;;
   5 ;;; This program is free software: you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Affero General Public License
   7 ;;; as published by the Free Software Foundation, either version 3 of
   8 ;;; the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This program is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Affero General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Affero General Public
  16 ;;; License along with this program.  If not, see
  17 ;;; <http://www.gnu.org/licenses/>.
  18
  19 (define-module (mumi web view utils)
  20   #:use-module (ice-9 rdelim)
  21   #:use-module (ice-9 match)
  22   #:use-module (ice-9 regex)
  23   #:use-module (ice-9 receive)
  24   #:use-module (ice-9 iconv)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (syntax-highlight)
  28   #:use-module (syntax-highlight scheme)
  29   #:use-module (email email)
  30   #:use-module (mumi messages)
  31   #:use-module (rnrs bytevectors)
  32   #:export (prettify
  33             avatar-color
  34             display-message-body))
  35
  36 ;; TODO: at some point this should tokenize the text, then apply
  37 ;; styles, then output sxml, but for now we keep it simple
  38 (define (process line context)
  39   (cond
  40    ((string-prefix? "--8<---------------cut here" line)
  41     (values `(span (@ (class "line cut-here")) ,line) #f))
  42    ((and (member 'diff context)
  43          (string= "---" line))
  44     (values `(span (@ (class "line diff separator")) ,line) #f))
  45    ((string-prefix? "diff --git" line)
  46     (values `(span (@ (class "line diff file")) ,line) 'diff))
  47    ((and (member 'diff context)
  48          (string-prefix? "+" line))
  49     (values `(span (@ (class "line diff addition")) ,line) #f))
  50    ((and (member 'diff context)
  51          (string-prefix? "-" line)
  52          (not (string= "--" line))
  53          (not (string= "-- " line)))
  54     (values `(span (@ (class "line diff deletion")) ,line) #f))
  55    ((and (member 'diff context)
  56          (string-prefix? "@@" line))
  57     (values `(span (@ (class "line diff range")) ,line) #f))
  58    ((string-prefix? ">" line)
  59     (values `(span (@ (class "line quote")) ,line) #f))
  60    ((or (string-prefix? "Signed-off-by" line)
  61         (string-prefix? "Co-authored-by" line))
  62     (values `(span (@ (class "commit attribution")) ,line) #f))
  63    ((or (string-prefix? "From: " line)
  64         (string-prefix? "Date: " line)
  65         (string-prefix? "Subject: " line))
  66     (values `(span (@ (class "commit header")) ,line) 'commit))
  67    ((and (member 'commit context)
  68          (or (string-prefix? "* " line)
  69              (string-prefix? " * " line)))
  70     (values `(span (@ (class "commit changelog")) ,line) #f))
  71    (else
  72     (values `(span (@ (class "line")) ,line) #f))))
  73
  74 (define (prettify text)
  75   "Read each line of TEXT and apply PROCESS to it."
  76   (let ((res (fold (lambda (line acc)
  77                      (match acc
  78                        ((#:result res #:context context)
  79                         (receive (processed new-context)
  80                             (process line context)
  81                           `(#:result ,(append (list processed '(br)) res)
  82                             #:context ,(if new-context
  83                                            (cons new-context context)
  84                                            context))))))
  85                    '(#:result () #:context ())
  86                    (string-split text #\newline))))
  87     ;; Drop the first line break, because it's for an eof
  88     ;; read.
  89     (match (reverse (cadr (find-tail (cut eq? #:result <>) res)))
  90       ((_ . rest) rest)
  91       (() '()))))
  92
  93 (define colors
  94   (circular-list "#8dd3c7" "#bebada" "#fb8072"
  95                  "#80b1d3" "#fdb462" "#b3de69"
  96                  "#fccde5" "#d9d9d9" "#bc80bd"
  97                  "#ccebc5" "#ffed6f"))
  98
  99 (define (avatar-color who participants)
 100   (or (and=> (assoc-ref (zip participants colors) who)
 101              first)
 102       (first colors)))
 103
 104 (define (content-type->css-class value)
 105   "Convert a content-type header value to a CSS class name."
 106   (string-append (symbol->string (assoc-ref value 'type))
 107                  "-"
 108                  (symbol->string (assoc-ref value 'subtype))))
 109
 110 (define (display-message-body bug-num message-number message)
 111   "Convenience procedure to render MESSAGE (part of bug with number
 112 BUG-NUM), even when it is a multipart message."
 113   (define (display-multipart-chunk headers body path)
 114     (define (attachment-url)
 115       (string-append "/issue/"
 116                      (number->string bug-num)
 117                      "/attachment/"
 118                      (number->string message-number)
 119                      "/" (string-join (map number->string path) "/")))
 120     (let* ((content-type (assoc-ref headers 'content-type))
 121            (attachment?
 122             (and (and=> (assoc-ref headers 'content-disposition)
 123                         (cut assoc-ref <> 'type))
 124                  content-type
 125                  (assoc-ref content-type 'type)))
 126            (binary-attachment? (and attachment?
 127                                     (eq? (assoc-ref content-type 'type) 'application)))
 128            (attachment-name
 129             (or (and=> (assoc-ref headers 'content-disposition)
 130                        (cut assoc-ref <> 'filename))
 131                 "file")))
 132       (cond
 133        (binary-attachment?
 134         `(div (@ (class "attachment"))
 135               "Attachment: "
 136               (a (@ (href ,(attachment-url))) ,attachment-name)))
 137        ((string-suffix? ".scm" attachment-name)
 138         `(div (@ (class "multipart scheme"))
 139               (div (@ (class "download-part"))
 140                    (a (@ (href ,(attachment-url)))
 141                       "Download"))
 142               ,(highlights->sxml (highlight lex-scheme body))))
 143        (else
 144         `(div (@ (class ,(string-join
 145                           (list "multipart" (or (and content-type
 146                                                      (content-type->css-class content-type))
 147                                                 "")))))
 148               (div (@ (class "download-part"))
 149                    (a (@ (href ,(attachment-url)))
 150                       "Download"))
 151               ,(prettify body))))))
 152   (define (display-mime-entity entity . path)
 153     (match entity
 154       (($ <mime-entity> headers (? string? body))
 155        (apply display-multipart-chunk `(,headers ,body ,path)))
 156       ;; Message parts can be nested.
 157       (($ <mime-entity> headers (? list? sub-parts))
 158        (map (lambda (part sub-part-num)
 159               (apply display-mime-entity part
 160                      (append path (list sub-part-num))))
 161             sub-parts
 162             (iota (length sub-parts))))
 163       ;; XXX: Sometimes we get an unparseable bytevector.  Convert it
 164       ;; when that happens.
 165       (($ <mime-entity> headers (? bytevector? raw))
 166        (apply display-multipart-chunk
 167               `(,headers
 168                 ,(bytevector->string raw "ISO-8859-1")
 169                 ,path)))))
 170   (cond
 171    ((multipart-message? message)
 172     (let ((parts (email-body message)))
 173       (map (lambda (part part-num)
 174              (display-mime-entity part part-num))
 175            parts
 176            (iota (length parts)))))
 177    ;; Regular message with a simple body.
 178    (else
 179     (display-mime-entity
 180      (make-mime-entity (email-headers message)
 181                        (email-body message))))))
 182