messages: Implement search with mu.
[software/mumi.git] / mumi / web / controller.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018, 2019 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 "easy")
55 (apply render-html (list-of-matching-bugs "tag:easy" (easy-bugs))))
56 (('GET "search")
57 (let ((query (-> request
58 request-uri
59 uri-query
60 parse-query-string
61 (cut assoc-ref <> "query"))))
62 (cond
63 ;; TODO: query should not be empty!
64 ((or (not query)
65 (string-null? (string-trim query)))
66 (redirect '()))
67
68 ;; For convenience
69 ((string-prefix? "id:" query) =>
70 (lambda _ (redirect (list "issue" (string-drop query (string-length "id:"))))))
71 ((string-prefix? "#" query) =>
72 (lambda _ (redirect (list "issue" (string-drop query (string-length "#"))))))
73 ((string->number query) =>
74 (lambda _ (redirect (list "issue" query))))
75
76 ;; Search for matching messages and return list of bug reports
77 ;; that belong to them.
78 (else
79 (render-with-error-handling
80 (lambda ()
81 (list-of-matching-bugs query
82 (match (process-query query)
83 ((#:terms terms
84 #:sets s)
85 (search-bugs (string-join terms)
86 #:sets s)))))
87 `(p "Could not search for " (strong ,query) "."))))))
88 (('GET "issue" (? string->number id))
89 (render-with-error-handling
90 (lambda () (or (and=> (fetch-bug id) issue-page)
91 (unknown id)))
92 `(p "Could not access issue #" (strong ,id) ".")))
93 (('GET "issue" (? string->number id)
94 "attachment" (? string->number msg-num)
95 (? string->number path) ...)
96 (handle-download (string->number id)
97 (string->number msg-num)
98 (map string->number path)))
99 (('GET "issue" not-an-id)
100 (apply render-html (unknown not-an-id)))
101 (('GET "snippet" "recent")
102 (apply render-html (list #:sxml (list-of-bugs (recent-bugs 10)))))
103 (('GET "snippet" "priority")
104 (apply render-html (list #:sxml (priority-bugs))))
105 (('GET "help")
106 (apply render-html (help)))
107 (('GET path ...)
108 (render-static-asset request))))