Support downloading of attachments.
[software/mumi.git] / mumi / web / controller.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018 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 (mumi messages)
26 #:use-module (mumi web render)
27 #:use-module (mumi web download)
28 #:use-module (mumi web util)
29 #:use-module (mumi web view html)
30 #:export (controller))
31
32 (define-syntax-rule (-> target functions ...)
33 (fold (lambda (f val) (and=> val f))
34 target
35 (list functions ...)))
36
37 (define (render-with-error-handling page message)
38 (apply render-html (page))
39 ;; (catch #t
40 ;; (lambda ()
41 ;; (receive (sxml headers)
42 ;; (pretty-print (page))
43 ;; (render-html sxml headers)))
44 ;; (lambda (key . args)
45 ;; (format #t "ERROR: ~a ~a\n"
46 ;; key args)
47 ;; (render-html (error-page message))))
48 )
49
50 (define (controller request body)
51 (match-lambda
52 ((GET)
53 (apply render-html (index)))
54 ((GET "search")
55 (let ((query (-> request
56 request-uri
57 uri-query
58 parse-query-string
59 (cut assoc-ref <> "query"))))
60 (cond
61 ;; TODO: query should not be empty!
62 ((or (not query)
63 (string-null? (string-trim query)))
64 (redirect '()))
65
66 ;; For convenience
67 ((string-prefix? "id:" query) =>
68 (lambda _ (redirect (list "issue" (string-drop query (string-length "id:"))))))
69 ((string-prefix? "#" query) =>
70 (lambda _ (redirect (list "issue" (string-drop query (string-length "#"))))))
71 ((string->number query) =>
72 (lambda _ (redirect (list "issue" query))))
73
74 ;; Search for matching messages and return list of bug reports
75 ;; that belong to them.
76 (else
77 (render-with-error-handling
78 (lambda ()
79 (list-of-matching-bugs query
80 (match (process-query query)
81 ((#:terms terms
82 #:attributes attrs
83 #:filters '())
84 (search-bugs (string-join terms)
85 #:attributes attrs))
86 ;; Fetch more messages if there
87 ;; are local filters to increase
88 ;; the chance of finding some
89 ;; that pass the filter.
90 ((#:terms terms
91 #:attributes attrs
92 #:filters fs)
93 (let ((str (string-join terms)))
94 (filter (lambda (bug)
95 (every (lambda (f) (f bug)) fs))
96 (search-bugs (string-join terms)
97 #:attributes attrs
98 #:max 800)))))))
99 `(p "Could not search for " (strong ,query) "."))))))
100 ((GET "issue" (? string->number id))
101 (render-with-error-handling
102 (lambda () (or (and=> (fetch-bug id) issue-page)
103 (unknown id)))
104 `(p "Could not access issue #" (strong ,id) ".")))
105 ((GET "issue" (? string->number id)
106 "attachment" (? string->number msg-num)
107 (? string->number path) ...)
108 (handle-download (string->number id)
109 (string->number msg-num)
110 (map string->number path)))
111 ((GET "issue" not-an-id)
112 (apply render-html (unknown not-an-id)))
113 ((GET "help")
114 (apply render-html (help)))
115 ((GET path ...)
116 (render-static-asset request))))