f0d58c07a1c21160f9cf93eb21d6ba5a37166635
[software/mumi.git] / mumi / web / view / utils.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Affero General Public License
6 ;;; as published by the Free Software Foundation, either version 3 of
7 ;;; the License, or (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Affero General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Affero General Public
15 ;;; License along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 (define-module (mumi web view utils)
19 #:use-module (ice-9 rdelim)
20 #:use-module (ice-9 match)
21 #:use-module (srfi srfi-1)
22 #:use-module (debbugs email)
23 #:use-module (mumi messages)
24 #:export (prettify
25 avatar-color
26 display-message-body))
27
28 ;; TODO: at some point this should tokenize the text, then apply
29 ;; styles, then output sxml, but for now we keep it simple
30 (define (process line)
31 (cond
32 ((string-prefix? "--8<---------------cut here" line)
33 `(span (@ (class "line cut-here")) ,line))
34 ((string= "---" line)
35 `(span (@ (class "line diff separator")) ,line))
36 ((string-prefix? "diff --git" line)
37 `(span (@ (class "line diff file")) ,line))
38 ((string-prefix? "+" line)
39 `(span (@ (class "line diff addition")) ,line))
40 ((and (string-prefix? "-" line)
41 (not (string= "--" line))
42 (not (string= "-- " line)))
43 `(span (@ (class "line diff deletion")) ,line))
44 ((string-prefix? "@@" line)
45 `(span (@ (class "line diff range")) ,line))
46 ((string-prefix? ">" line)
47 `(span (@ (class "line quote")) ,line))
48 ((or (string-prefix? "Signed-off-by" line)
49 (string-prefix? "Co-authored-by" line))
50 `(span (@ (class "commit attribution")) ,line))
51 ((or (string-prefix? "From: " line)
52 (string-prefix? "Date: " line)
53 (string-prefix? "Subject: " line))
54 `(span (@ (class "commit header")) ,line))
55 ((or (string-prefix? "* " line)
56 (string-prefix? " * " line))
57 `(span (@ (class "commit changelog")) ,line))
58 (else
59 `(span (@ (class "line")) ,line))))
60
61 (define (prettify text)
62 "Read each line of TEXT and apply PROCESS to it."
63 (call-with-input-string text
64 (lambda (port)
65 (let loop ((line (read-line port))
66 (result '()))
67 (if (eof-object? line)
68 ;; Drop the first line break, because it's for an eof
69 ;; read.
70 (match (reverse result)
71 ((_ . rest) rest)
72 (() '()))
73 (loop (read-line port)
74 (cons (process line)
75 (cons '(br) result))))))))
76
77 (define colors
78 (circular-list "#8dd3c7" "#bebada" "#fb8072"
79 "#80b1d3" "#fdb462" "#b3de69"
80 "#fccde5" "#d9d9d9" "#bc80bd"
81 "#ccebc5" "#ffed6f"))
82
83 (define (avatar-color who participants)
84 (or (and=> (assoc-ref (zip participants colors) who)
85 first)
86 (first colors)))
87
88 (define (content-type->css-class value)
89 "Convert a content-type header value to a CSS class name."
90 (string-map (lambda (chr)
91 (cond
92 ((char-set-contains? char-set:letter chr) chr)
93 (else #\-)))
94 (string-take value (or (string-index value #\;)
95 (string-length value)))))
96
97 (define (display-multipart-chunk headers body)
98 (let ((classes
99 (string-join `("multipart"
100 ,(or (and=> (assoc-ref headers "content-type")
101 (lambda (value)
102 (content-type->css-class (first value))))
103 "")))))
104 `(div (@ (class ,classes))
105 ,(prettify body))))
106
107 (define (display-message-body message)
108 "Convenience procedure to render MESSAGE, even when it is a
109 multipart message."
110 (cond
111 ((multipart-message? message)
112 => (lambda (attributes)
113 (match (split-multipart-message attributes message)
114 (()
115 (cons
116 `(p (@ (class "error parse"))
117 "[Failed to process the following multipart message. Sorry!]")
118 (prettify (email-body message))))
119 (parts
120 (map (match-lambda
121 (() "")
122 ((#:headers hs #:body '()) "")
123 ((#:headers hs #:body (? string? body))
124 (display-multipart-chunk hs body))
125 ;; Message parts can be nested.
126 ((#:headers hs #:body sub-parts)
127 (map (match-lambda
128 ((#:headers hs #:body body)
129 (display-multipart-chunk hs body)))
130 sub-parts)))
131 parts)))))
132 ;; Regular message with a simple body.
133 (else
134 (prettify (email-body message)))))