css: Draw multipart separator also when following an attachment.
[software/mumi.git] / mumi / web / controller.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 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 controller)
19 #:use-module (ice-9 match)
20 #:use-module (ice-9 pretty-print)
21 #:use-module (srfi srfi-1)
22 #:use-module (srfi srfi-26)
23 #:use-module (web request)
24 #:use-module (web uri)
25 #:use-module (webutils sessions)
26 #:use-module (gcrypt base64)
27 #:use-module (gcrypt mac)
28 #:use-module (mumi config)
29 #:use-module ((mumi debbugs)
30 #:select (bug-status bug-archived bug-subject bug-done))
31 #:use-module (mumi jobs)
32 #:use-module (mumi messages)
33 #:use-module (mumi web render)
34 #:use-module (mumi web download)
35 #:use-module (mumi web util)
36 #:use-module (mumi web view html)
37 #:export (controller))
38
39 (define-syntax-rule (-> target functions ...)
40 (fold (lambda (f val) (and=> val f))
41 target
42 (list functions ...)))
43
44 (define (%session-manager)
45 (let ((key-file (string-append (%config 'key-dir) "/signing-key")))
46 (unless (file-exists? key-file)
47 (with-output-to-file key-file
48 (lambda () (write (base64-encode (generate-signing-key))))))
49 (make-session-manager
50 (with-input-from-file key-file read)
51 ;; expire session after 30 mins
52 #:expire-delta '(0 0 30))))
53
54 (define (controller request body)
55 (match-lambda
56 (('GET)
57 (render-html (index)
58 #:extra-headers
59 '((cache-control . ((max-age . 60))))))
60 (('GET "easy")
61 (render-html (list-of-matching-bugs "tag:easy" (easy-bugs))))
62 (('GET "recent")
63 (render-html (list-of-recent-issues)))
64 (('GET "forgotten")
65 (render-html (list-of-forgotten-issues)))
66 (('GET "wishlist")
67 (render-html
68 (list-of-matching-bugs "severity:wishlist is:open"
69 (bugs-by-severity "wishlist" "open"))))
70 (('GET "search")
71 (let ((query (-> request
72 request-uri
73 uri-query
74 parse-query-string
75 (cut assoc-ref <> "query"))))
76 (cond
77 ;; TODO: query should not be empty!
78 ((or (not query)
79 (string-null? (string-trim query)))
80 (redirect '()))
81
82 ;; For convenience
83 ((string-prefix? "id:" query) =>
84 (lambda _ (redirect (list "issue" (string-drop query (string-length "id:"))))))
85 ((string-prefix? "#" query) =>
86 (lambda _ (redirect (list "issue" (string-drop query (string-length "#"))))))
87 ((string->number query) =>
88 (lambda _ (redirect (list "issue" query))))
89
90 ;; Search for matching messages and return list of bug reports
91 ;; that belong to them.
92 (else
93 (render-html
94 (list-of-matching-bugs query
95 (search-bugs (string-join
96 (process-query query)))))))))
97 ((or ('GET "issue" (? string->number id))
98 ('GET (? string->number id)))
99 (let ((bug (bug-status id))
100 (message (match (uri-query (request-uri request))
101 ("comment-ok"
102 '(info . "Your comment has been submitted!"))
103 ("comment-error"
104 '(error . "There was an error submitting your comment!"))
105 (_ #f))))
106 (if bug
107 ;; Record the current issue id in an encrypted cookie.
108 ;; This will be verified when posting a comment.
109 (let* ((cookie-header
110 (set-session (%session-manager) `((issue-id . ,id))))
111 (headers
112 (cond
113 ((bug-archived bug)
114 ;; Tell browser to cache this for 12 hours.
115 (cons cookie-header
116 '((cache-control . ((max-age . 43200))))))
117 ((bug-done bug)
118 ;; Tell browser to cache this for 1 hour.
119 (cons cookie-header
120 '((cache-control . ((max-age . 3600))))))
121 (else (list cookie-header))))
122 (page (issue-page bug message)))
123 (if page
124 (render-html page #:extra-headers headers)
125 (render-html (unknown id))))
126 (render-html (unknown id)))))
127 (('POST "issue" (? string->number id) "comment")
128 (if (mailer-enabled?)
129 (let ((headers (request-headers request))
130 (form-data (parse-form-submission request body))
131 (cookie (or (session-data (%session-manager) request)
132 '()))
133 (bug (bug-status id)))
134 (if (and
135 bug
136 ;; The encrypted cookie must be fresh and contain the
137 ;; current issue id.
138 (and=> (assoc-ref cookie 'issue-id)
139 (cut string=? id <>))
140 ;; The honeypot field "validation" must remain empty
141 (let ((val (assoc-ref form-data 'validation)))
142 (and val (string-null? (string-trim-both val))))
143 ;; Submission may not have happened too quickly
144 (let ((time (assoc-ref form-data 'timestamp)))
145 (and time (reasonable-timestamp? time)))
146 ;; Message must not be too short
147 (and=> (assoc-ref form-data 'text)
148 (lambda (text)
149 (> (string-length (string-trim-both text)) 10)))
150 ;; Message must have sender
151 (and=> (assoc-ref form-data 'from)
152 (compose (negate string-null?) string-trim-both)))
153 (begin
154 ;; Send comment to list
155 (enqueue 'mail
156 `((from . ,(string-trim-both (assoc-ref form-data 'from)))
157 (subject . ,(bug-subject bug))
158 (to . ,(format #f "~a@~a"
159 id (%config 'debbugs-domain)))
160 (text . ,(assoc-ref form-data 'text))))
161 (redirect (list "issue" id) "comment-ok"))
162 (redirect (list "issue" id) "comment-error")))
163 (redirect (list "issue" id) "comment-error")))
164 (('GET "issue" (? string->number id)
165 "attachment" (? string->number msg-num)
166 (? string->number path) ...)
167 (handle-download (string->number id)
168 (string->number msg-num)
169 (map string->number path)))
170 (('GET "issue" (? string->number id)
171 "raw" (? string->number msg-num))
172 (download-raw (string->number id)
173 (string->number msg-num)))
174 (('GET "issue" not-an-id)
175 (render-html (unknown not-an-id)))
176 (('GET "help")
177 (render-html (help)
178 ;; Cache for 24 hours.
179 #:extra-headers
180 '((cache-control . ((max-age . 86400))))))
181 (('GET path ...)
182 (render-static-asset request))))