web: Implement GraphQL endpoint.
[software/mumi.git] / mumi / web / controller.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Affero General Public License
7 ;;; as published by the Free Software Foundation, either version 3 of
8 ;;; the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Affero General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Affero General Public
16 ;;; License along with this program. If not, see
17 ;;; <http://www.gnu.org/licenses/>.
18
19 (define-module (mumi web controller)
20 #:use-module (ice-9 match)
21 #:use-module (ice-9 format)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-26)
24 #:use-module (web request)
25 #:use-module (web uri)
26 #:use-module (webutils sessions)
27 #:use-module (gcrypt base64)
28 #:use-module (gcrypt mac)
29 #:use-module (mumi config)
30 #:use-module ((mumi debbugs)
31 #:select (bug-status bug-archived bug-subject bug-done))
32 #:use-module (mumi jobs)
33 #:use-module (mumi messages)
34 #:use-module (mumi web render)
35 #:use-module (mumi web download)
36 #:use-module (mumi web graphql)
37 #:use-module (mumi web util)
38 #:use-module (mumi web view html)
39 #:export (controller))
40
41 (define-syntax-rule (-> target functions ...)
42 (fold (lambda (f val) (and=> val f))
43 target
44 (list functions ...)))
45
46 (define (%session-manager)
47 (let ((key-file (string-append (%config 'key-dir) "/signing-key")))
48 (unless (file-exists? key-file)
49 (with-output-to-file key-file
50 (lambda () (write (base64-encode (generate-signing-key))))))
51 (make-session-manager
52 (with-input-from-file key-file read)
53 ;; expire session after 30 mins
54 #:expire-delta '(0 0 30))))
55
56 (define (controller request body)
57 (match-lambda
58 (('GET)
59 (render-html (index)
60 #:extra-headers
61 '((cache-control . ((max-age . 60))))))
62 (('GET "easy")
63 (render-html (list-of-matching-bugs "tag:easy" (easy-bugs))))
64 (('GET "recent")
65 (render-html (list-of-recent-issues)))
66 (('GET "forgotten")
67 (render-html (list-of-forgotten-issues)))
68 (('GET "wishlist")
69 (render-html
70 (list-of-matching-bugs "severity:wishlist is:open"
71 (bugs-by-severity "wishlist" "open"))))
72 (((or 'GET 'POST) "graphql")
73 (handle-graphql request body))
74 (('GET "search")
75 (let ((query (-> request
76 request-uri
77 uri-query
78 parse-query-string
79 (cut assoc-ref <> "query"))))
80 (cond
81 ;; TODO: query should not be empty!
82 ((or (not query)
83 (string-null? (string-trim query)))
84 (redirect '()))
85
86 ;; For convenience
87 ((string-prefix? "id:" query) =>
88 (lambda _ (redirect (list "issue" (string-drop query (string-length "id:"))))))
89 ((string-prefix? "#" query) =>
90 (lambda _ (redirect (list "issue" (string-drop query (string-length "#"))))))
91 ((string->number query) =>
92 (lambda _ (redirect (list "issue" query))))
93
94 ;; Search for matching messages and return list of bug reports
95 ;; that belong to them.
96 (else
97 (render-html
98 (list-of-matching-bugs query
99 (search-bugs (string-join
100 (process-query query)))))))))
101 ((or ('GET "issue" (? string->number id))
102 ('GET (? string->number id)))
103 (let ((bug (bug-status id))
104 (message (match (uri-query (request-uri request))
105 ("comment-ok"
106 '(info . "Your comment has been submitted!"))
107 ("comment-error"
108 '(error . "There was an error submitting your comment!"))
109 (_ #f))))
110 (if bug
111 ;; Record the current issue id in an encrypted cookie.
112 ;; This will be verified when posting a comment.
113 (let* ((cookie-header
114 (set-session (%session-manager) `((issue-id . ,id))))
115 (headers
116 (cond
117 ((bug-archived bug)
118 ;; Tell browser to cache this for 12 hours.
119 (cons cookie-header
120 '((cache-control . ((max-age . 43200))))))
121 ((bug-done bug)
122 ;; Tell browser to cache this for 1 hour.
123 (cons cookie-header
124 '((cache-control . ((max-age . 3600))))))
125 (else (list cookie-header))))
126 (page (issue-page bug message)))
127 (if page
128 (render-html page #:extra-headers headers)
129 (render-html (unknown id))))
130 (render-html (unknown id)))))
131 (('POST "issue" (? string->number id) "comment")
132 (if (mailer-enabled?)
133 (let ((headers (request-headers request))
134 (form-data (parse-form-submission request body))
135 (cookie (or (session-data (%session-manager) request)
136 '()))
137 (bug (bug-status id)))
138 (if (and
139 bug
140 ;; The encrypted cookie must be fresh and contain the
141 ;; current issue id.
142 (and=> (assoc-ref cookie 'issue-id)
143 (cut string=? id <>))
144 ;; The honeypot field "validation" must remain empty
145 (let ((val (assoc-ref form-data 'validation)))
146 (and val (string-null? (string-trim-both val))))
147 ;; Submission may not have happened too quickly
148 (let ((time (assoc-ref form-data 'timestamp)))
149 (and time (reasonable-timestamp? time)))
150 ;; Message must not be too short
151 (and=> (assoc-ref form-data 'text)
152 (lambda (text)
153 (> (string-length (string-trim-both text)) 10)))
154 ;; Message must have sender
155 (and=> (assoc-ref form-data 'from)
156 (compose (negate string-null?) string-trim-both)))
157 (begin
158 ;; Send comment to list
159 (enqueue 'mail
160 `((from . ,(string-trim-both (assoc-ref form-data 'from)))
161 (subject . ,(bug-subject bug))
162 (to . ,(format #f "~a@~a"
163 id (%config 'debbugs-domain)))
164 (text . ,(assoc-ref form-data 'text))))
165 (redirect (list "issue" id) "comment-ok"))
166 (redirect (list "issue" id) "comment-error")))
167 (redirect (list "issue" id) "comment-error")))
168 (('GET "issue" (? string->number id)
169 "attachment" (? string->number msg-num)
170 (? string->number path) ...)
171 (handle-download (string->number id)
172 (string->number msg-num)
173 (map string->number path)))
174 (('GET "issue" (? string->number id)
175 "patch-set" . patch-set-num)
176 (let* ((patch-set-num* (match patch-set-num
177 (() #false)
178 ((f . rest) f)))
179 (content (patch-messages id patch-set-num*)))
180 (if content
181 (list `((content-type text)
182 (content-disposition
183 text/plain
184 (filename
185 . ,(format #f "~a-patch-set~:[-~a~;~].mbox"
186 id patch-set-num* patch-set-num*))))
187 content)
188 (not-found (request-uri request)))))
189 (('GET "issue" (? string->number id)
190 "raw" (? string->number msg-num))
191 (download-raw (string->number id)
192 (string->number msg-num)))
193 (('GET "issue" not-an-id)
194 (render-html (unknown not-an-id)))
195 (('GET "help")
196 (render-html (help)
197 ;; Cache for 24 hours.
198 #:extra-headers
199 '((cache-control . ((max-age . 86400))))))
200 (('GET path ...)
201 (render-static-asset request))))