584b9a9ae64fdd114c6bfb04e8ff27e5664e6769
[software/mumi.git] / 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