Goodbye mu, hello guile-debbugs!
[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 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 (render-with-error-handling page message)
37 (apply render-html (page))
38 ;; (catch #t
39 ;; (lambda ()
40 ;; (receive (sxml headers)
41 ;; (pretty-print (page))
42 ;; (render-html sxml headers)))
43 ;; (lambda (key . args)
44 ;; (format #t "ERROR: ~a ~a\n"
45 ;; key args)
46 ;; (render-html (error-page message))))
47 )
48
49 (define (controller request body)
50 (match-lambda
51 ((GET)
52 (apply render-html (index)))
53 ((GET "search")
54 (let ((query (-> request
55 request-uri
56 uri-query
57 parse-query-string
58 (cut assoc-ref <> "query"))))
59 (cond
60 ;; TODO: query should not be empty!
61 ((or (not query)
62 (string-null? (string-trim query)))
63 (redirect '()))
64
65 ;; For convenience
66 ((string-prefix? "id:" query) =>
67 (lambda _ (redirect (list "issue" (string-drop query (string-length "id:"))))))
68 ((string-prefix? "#" query) =>
69 (lambda _ (redirect (list "issue" (string-drop query (string-length "#"))))))
70 ((string->number query) =>
71 (lambda _ (redirect (list "issue" query))))
72
73 ;; Search for matching messages and return list of bug reports
74 ;; that belong to them.
75 (else
76 (render-with-error-handling
77 (lambda ()
78 (list-of-matching-bugs query
79 (match (process-query query)
80 ((#:terms terms
81 #:attributes attrs
82 #:filters fs)
83 (filter (lambda (bug)
84 (every (lambda (f) (f bug)) fs))
85 (search-bugs (string-join terms)
86 #:attributes attrs))))))
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" not-an-id)
94 (apply render-html (unknown not-an-id)))
95 ((GET path ...)
96 (render-static-asset path))))