blob: 5ab2322f15621014038be8441391f1a0e9d044e4 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
TypeFamilies, ViewPatterns, LambdaCase #-}
module Main (main) where
import Yesod
import Network.Wai.Handler.Warp
import Data.Function ((&))
import Data.Functor ((<&>))
import qualified Data.ByteString as BS
import Bangs
import BangState
import Config
data Search = Search {
bangState :: BangState
}
mkYesod "Search" [parseRoutes|
/ HomeR GET
/bundle.js BundleR GET
/bangs.json BangsR GET
/submitBang SubmitR POST
/search.xml OpenSearchR GET
|]
instance Yesod Search where
makeSessionBackend _ = return Nothing
getHomeR :: Handler ()
getHomeR = sendFile typeHtml "frontend/index.html"
getBundleR :: Handler ()
getBundleR = sendFile typeJavascript "frontend/bundle.js"
getBangsR :: Handler TypedContent
getBangsR = do
bangsAccessor <- lookupHeader "accept-encoding" >>= \case
Just ae | "br" `BS.isInfixOf` ae -> do
addHeader "content-encoding" "br"
return getBangsBrotli
_ -> do
return getBangsJSON
bs <- liftIO . bangsAccessor . bangState =<< getYesod
return $ TypedContent typeJson $ toContent bs
postSubmitR :: Handler String
postSubmitR = return "TODO"
getOpenSearchR :: Handler TypedContent
getOpenSearchR = do
url <- lookupGetParam "default" <&> \case
Nothing -> baseUrl <> "/#{searchTerms}"
Just b -> baseUrl <> "/#" <> b <> "#{searchTerms}"
return
$ TypedContent "application/opensearchdescription+xml"
$ toContent
$ makeOpenSearch url
main :: IO ()
main = do
s <- Search
<$> initBangState
sApp <- toWaiApp s -- includes middlewares
let settings = defaultSettings
-- currently, "*" seems to bind only to ipv4 while "*6" binds to both
& setHost "*6"
& setPort 20546
runSettings settings sApp
|
