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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
TypeFamilies, ViewPatterns, LambdaCase, EmptyDataDecls,
FlexibleContexts, GADTs, GeneralizedNewtypeDeriving,
MultiParamTypeClasses, DerivingStrategies, StandaloneDeriving,
UndecidableInstances, DataKinds, FlexibleInstances, TypeOperators #-}
module Main (main) where
import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad (unless)
import Data.Char (isAlphaNum)
import Database.Persist.Sqlite
import Data.Function ((&))
import Data.Functor ((<&>))
import Network.Wai.Handler.Warp hiding (getPort, getHost)
import Yesod
import qualified Data.ByteString as BS
import qualified Data.Text as T
import BangState
import Config
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
PendingBang
name T.Text
url T.Text
displayName T.Text
UniqueBang name
deriving Show
|]
data Search = Search {
bangState :: BangState,
sqlPool :: ConnectionPool
}
mkYesod "Search" [parseRoutes|
/ HomeR GET
/bundle.js BundleR GET
/style.css StyleR GET
/bangs.json BangsR GET
/submitBang SubmitR POST
/search.xml OpenSearchR GET
|]
instance Yesod Search where
makeSessionBackend _ = return Nothing
instance YesodPersist Search where
type YesodPersistBackend Search = SqlBackend
runDB action = getYesod >>= runSqlPool action . sqlPool
getHomeR :: Handler ()
getHomeR = sendFile typeHtml "index.html"
getBundleR :: Handler ()
getBundleR = sendFile typeJavascript "bundle.js"
getStyleR :: Handler ()
getStyleR = sendFile typeCss "style.css"
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 ()
postSubmitR = sequence (map lookupPostParam ["bang", "url", "name"])
>>= \l -> case sequence l of
Just [bn, bu, bdp] -> do
unless (T.all isAlphaNum bn) $ invalidArgs []
unless (all ((<255) . T.length) [bn, bu, bdp]) $ invalidArgs []
runDB $ insert400_ $ PendingBang bn bu bdp
_ -> invalidArgs []
getOpenSearchR :: Handler TypedContent
getOpenSearchR = do
baseUrl <- liftIO getBaseUrl
url <- lookupGetParam "default" <&> \case
Nothing -> baseUrl <> "/#{searchTerms}"
Just b -> baseUrl <> "/#" <> b <> "#{searchTerms}"
liftIO $
TypedContent "application/opensearchdescription+xml"
. toContent
<$> makeOpenSearch url
main :: IO ()
main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
runResourceT $ flip runSqlPool pool $ runMigration migrateAll
s <- Search
<$> liftIO initBangState
<*> pure pool
sApp <- liftIO $ toWaiApp s -- includes middlewares
host <- liftIO getHost
port <- liftIO getPort
let settings = defaultSettings
& setHost host
& setPort port
liftIO $ runSettings settings sApp
|
