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                                        #:attributes attrs
  85                                        #:filters '())
  86                                       (search-bugs (string-join terms)
  87                                                    #:attributes attrs))
  88                                      ;; Fetch more messages if there
  89                                      ;; are local filters to increase
  90                                      ;; the chance of finding some
  91                                      ;; that pass the filter.
  92                                      ((#:terms terms
  93                                        #:attributes attrs
  94                                        #:filters fs)
  95                                       (let ((str (string-join terms)))
  96                                         (filter (lambda (bug)
  97                                                   (every (lambda (f) (f bug)) fs))
  98                                                 (search-bugs (string-join terms)
  99                                                              #:attributes attrs
 100                                                              #:max 800)))))))
 101           `(p "Could not search for " (strong ,query) "."))))))
 102     (('GET "issue" (? string->number id))
 103      (render-with-error-handling
 104       (lambda () (or (and=> (fetch-bug id) issue-page)
 105                 (unknown id)))
 106       `(p "Could not access issue #" (strong ,id) ".")))
 107     (('GET "issue" (? string->number id)
 108           "attachment" (? string->number msg-num)
 109           (? string->number path) ...)
 110      (handle-download (string->number id)
 111                       (string->number msg-num)
 112                       (map string->number path)))
 113     (('GET "issue" not-an-id)
 114      (apply render-html (unknown not-an-id)))
 115     (('GET "snippet" "recent")
 116      (apply render-html (list #:sxml (list-of-bugs (recent-bugs 10)))))
 117     (('GET "snippet" "priority")
 118      (apply render-html (list #:sxml (priority-bugs))))
 119     (('GET "help")
 120      (apply render-html (help)))
 121     (('GET path ...)
 122      (render-static-asset request))))