messages: Simplify search-bugs.
[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 (search-bugs (string-join
95 (process-query query)))))))))
96 ((or ('GET "issue" (? string->number id))
97 ('GET (? string->number id)))
98 (let ((bug (fetch-bug id))
99 (message (match (uri-query (request-uri request))
100 ("comment-ok"
101 '(info . "Your comment has been submitted!"))
102 ("comment-error"
103 '(error . "There was an error submitting your comment!"))
104 (_ #f))))
105 (if bug
106 ;; Record the current issue id in an encrypted cookie.
107 ;; This will be verified when posting a comment.
108 (let* ((cookie-header
109 (set-session (%session-manager) `((issue-id . ,id))))
110 (headers
111 (cond
112 ((bug-archived bug)
113 ;; Tell browser to cache this for 12 hours.
114 (cons cookie-header
115 '((cache-control . ((max-age . 43200))))))
116 ((bug-done bug)
117 ;; Tell browser to cache this for 1 hour.
118 (cons cookie-header
119 '((cache-control . ((max-age . 3600))))))
120 (else (list cookie-header))))
121 (page (issue-page bug message)))
122 (if page
123 (render-html page #:extra-headers headers)
124 (render-html (unknown id))))
125 (render-html (unknown id)))))
126 (('POST "issue" (? string->number id) "comment")
127 (if (mailer-enabled?)
128 (let ((headers (request-headers request))
129 (form-data (parse-form-submission request body))
130 (cookie (or (session-data (%session-manager) request)
131 '()))
132 (bug (fetch-bug id)))
133 (if (and
134 bug
135 ;; The encrypted cookie must be fresh and contain the
136 ;; current issue id.
137 (and=> (assoc-ref cookie 'issue-id)
138 (cut string=? id <>))
139 ;; The honeypot field "validation" must remain empty
140 (let ((val (assoc-ref form-data 'validation)))
141 (and val (string-null? (string-trim-both val))))
142 ;; Submission may not have happened too quickly
143 (let ((time (assoc-ref form-data 'timestamp)))
144 (and time (reasonable-timestamp? time)))
145 ;; Message must not be too short
146 (and=> (assoc-ref form-data 'text)
147 (lambda (text)
148 (> (string-length (string-trim-both text)) 10)))
149 ;; Message must have sender
150 (and=> (assoc-ref form-data 'from)
151 (compose (negate string-null?) string-trim-both)))
152 (begin
153 ;; Send comment to list
154 (enqueue 'mail
155 `((from . ,(string-trim-both (assoc-ref form-data 'from)))
156 (subject . ,(bug-subject bug))
157 (to . ,(format #f "~a@~a"
158 id (%config 'debbugs-domain)))
159 (text . ,(assoc-ref form-data 'text))))
160 (redirect (list "issue" id) "comment-ok"))
161 (redirect (list "issue" id) "comment-error")))
162 (redirect (list "issue" id) "comment-error")))
163 (('GET "issue" (? string->number id)
164 "attachment" (? string->number msg-num)
165 (? string->number path) ...)
166 (handle-download (string->number id)
167 (string->number msg-num)
168 (map string->number path)))
169 (('GET "issue" not-an-id)
170 (render-html (unknown not-an-id)))
171 (('GET "help")
172 (render-html (help)
173 ;; Cache for 24 hours.
174 #:extra-headers
175 '((cache-control . ((max-age . 86400))))))
176 (('GET path ...)
177 (render-static-asset request))))