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