Initial commit.
[software/mumi.git] / mumi / web / controller.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017 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 (srfi srfi-1)
21 #:use-module (srfi srfi-26)
22 #:use-module (web request)
23 #:use-module (web uri)
24 #:use-module (mu)
25 #:use-module (mumi messages)
26 #:use-module (mumi web render)
27 #:use-module (mumi web util)
28 #:use-module (mumi web view html)
29 #:export (controller))
30
31 (define-syntax-rule (-> target functions ...)
32 (fold (lambda (f val) (and=> val f))
33 target
34 (list functions ...)))
35
36 (define (controller request body)
37 (match-lambda
38 ((GET)
39 (render-html (index)))
40 ((GET "search")
41 (let ((query (-> request
42 request-uri
43 uri-query
44 parse-query-string
45 (cut assoc-ref <> "query"))))
46 (cond
47 ;; TODO: query should not be empty!
48 ((or (not query)
49 (string-null? (string-trim query)))
50 (redirect '()))
51
52 ((string-prefix? "patch:" query) =>
53 (lambda _ (redirect (list "patch" (string-drop query 6)))))
54
55 ;; Search for matching messages and return list of patch
56 ;; reports that belong to them.
57 (else
58 (let ((messages (unique-reports (mu:message-list query 100))))
59 (render-html (patch-list query messages)))))))
60 ((GET "patch" (? string->number id))
61 (let ((messages (patch-messages id)))
62 (if (null? messages)
63 (render-html (unknown id))
64 (render-html (patch-page id messages)))))
65 ((GET "patch" not-an-id)
66 (render-html (unknown not-an-id)))
67 ((GET path ...)
68 (render-static-asset path))))