Support downloading of attachments.
[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 (ice-9 regex)
22 #:use-module (srfi srfi-1)
23 #:use-module (debbugs email)
24 #:use-module (mumi messages)
25 #:export (prettify
26 avatar-color
27 display-message-body))
28
29 ;; TODO: at some point this should tokenize the text, then apply
30 ;; styles, then output sxml, but for now we keep it simple
31 (define (process line)
32 (cond
33 ((string-prefix? "--8<---------------cut here" line)
34 `(span (@ (class "line cut-here")) ,line))
35 ((string= "---" line)
36 `(span (@ (class "line diff separator")) ,line))
37 ((string-prefix? "diff --git" line)
38 `(span (@ (class "line diff file")) ,line))
39 ((string-prefix? "+" line)
40 `(span (@ (class "line diff addition")) ,line))
41 ((and (string-prefix? "-" line)
42 (not (string= "--" line))
43 (not (string= "-- " line)))
44 `(span (@ (class "line diff deletion")) ,line))
45 ((string-prefix? "@@" line)
46 `(span (@ (class "line diff range")) ,line))
47 ((string-prefix? ">" line)
48 `(span (@ (class "line quote")) ,line))
49 ((or (string-prefix? "Signed-off-by" line)
50 (string-prefix? "Co-authored-by" line))
51 `(span (@ (class "commit attribution")) ,line))
52 ((or (string-prefix? "From: " line)
53 (string-prefix? "Date: " line)
54 (string-prefix? "Subject: " line))
55 `(span (@ (class "commit header")) ,line))
56 ((or (string-prefix? "* " line)
57 (string-prefix? " * " line))
58 `(span (@ (class "commit changelog")) ,line))
59 (else
60 `(span (@ (class "line")) ,line))))
61
62 (define (prettify text)
63 "Read each line of TEXT and apply PROCESS to it."
64 (call-with-input-string text
65 (lambda (port)
66 (let loop ((line (read-line port))
67 (result '()))
68 (if (eof-object? line)
69 ;; Drop the first line break, because it's for an eof
70 ;; read.
71 (match (reverse result)
72 ((_ . rest) rest)
73 (() '()))
74 (loop (read-line port)
75 (cons (process line)
76 (cons '(br) result))))))))
77
78 (define colors
79 (circular-list "#8dd3c7" "#bebada" "#fb8072"
80 "#80b1d3" "#fdb462" "#b3de69"
81 "#fccde5" "#d9d9d9" "#bc80bd"
82 "#ccebc5" "#ffed6f"))
83
84 (define (avatar-color who participants)
85 (or (and=> (assoc-ref (zip participants colors) who)
86 first)
87 (first colors)))
88
89 (define (content-type->css-class value)
90 "Convert a content-type header value to a CSS class name."
91 (string-map (lambda (chr)
92 (cond
93 ((char-set-contains? char-set:letter chr) chr)
94 (else #\-)))
95 (string-take value (or (string-index value #\;)
96 (string-length value)))))
97
98 (define (display-message-body bug-num message)
99 "Convenience procedure to render MESSAGE (part of bug with number
100 BUG-NUM), even when it is a multipart message."
101 (define (display-multipart-chunk headers body . path)
102 (let* ((type
103 (and=> (assoc-ref headers "content-type")
104 (lambda (value)
105 (content-type->css-class (first value)))))
106 (binary-attachment?
107 (and (and=> (assoc-ref headers "content-disposition")
108 (lambda (value)
109 (string-contains (first value) "attachment")))
110 type
111 (string-contains type "application")
112 (first (assoc-ref headers "content-disposition"))))
113 (attachment-name
114 (or (and=> binary-attachment?
115 (lambda (value)
116 (and=> (string-match "filename=([^ ;]+)" value)
117 (lambda (m)
118 (match:substring m 1)))))
119 "file")))
120 (if binary-attachment?
121 `(div (@ (class "attachment"))
122 "Attachment: "
123 (a (@ (href ,(string-append "/issue/"
124 (number->string bug-num)
125 "/attachment/"
126 (number->string (email-msg-num message))
127 "/" (string-join (map number->string path) "/"))))
128 ,attachment-name))
129 `(div (@ (class ,(string-join `("multipart" ,(or type "")))))
130 ,(prettify body)))))
131 (cond
132 ((multipart-message? message)
133 => (lambda (attributes)
134 (match (split-multipart-message attributes message)
135 (()
136 (cons
137 `(p (@ (class "error parse"))
138 "[Failed to process the following multipart message. Sorry!]")
139 (prettify (email-body message))))
140 (parts
141 (map (lambda (part part-num)
142 (match part
143 (() "")
144 ((#:headers hs #:body '()) "")
145 ((#:headers hs #:body (? string? body))
146 (display-multipart-chunk hs body part-num))
147 ;; Message parts can be nested.
148 ((#:headers hs #:body sub-parts)
149 (map (lambda (part sub-part-num)
150 (match part
151 ((#:headers hs #:body body)
152 (display-multipart-chunk hs body part-num sub-part-num))))
153 sub-parts
154 (iota (length parts))))))
155 parts
156 (iota (length parts)))))))
157 ;; Regular message with a simple body.
158 (else
159 (prettify (email-body message)))))