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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
TypeFamilies, LambdaCase, EmptyDataDecls #-}
{-# OPTIONS -Wno-unused-top-binds #-}
module Main (main) where
import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad (when, unless)
import Database.Persist.Sqlite
import Data.Function ((&))
import Network.Wai.Handler.Warp hiding (getPort, getHost)
import Yesod
import qualified Data.ByteString as BS
import qualified Data.Text as T
import Auth
import BangState
import Config
import Data.PendingBang
import BatchedRunner
data Search = Search {
bangState :: BangState,
sqlPool :: ConnectionPool,
config :: Config
}
mkYesod "Search" [parseRoutes|
/ HomeR GET
/bundle.js BundleR GET
/style.css StyleR GET
/bangs.json BangsR GET
/search.xml OpenSearchR GET
/submitBang SubmitR POST
/acceptBang AcceptR POST
/rejectBang RejectR POST
/pendingBangs PendingR GET
|]
instance Yesod Search where
makeSessionBackend _ = return Nothing
approot = ApprootStatic ""
instance YesodPersist Search where
type YesodPersistBackend Search = SqlBackend
runDB action = getYesod >>= runSqlPool action . sqlPool
getHomeR :: Handler ()
getHomeR = do
cacheSeconds $ 60 * 60 * 24 * 7
sendFile typeHtml "index.html"
getBundleR :: Handler ()
getBundleR = do
cacheSeconds $ 60 * 60 * 24 * 7
sendFile typeJavascript "bundle.js"
getStyleR :: Handler ()
getStyleR = do
cacheSeconds $ 60 * 60 * 24 * 7
sendFile typeCss "style.css"
getBangsR :: Handler TypedContent
getBangsR = do
st <- bangState <$> getYesod
-- changes here should propagate quicker, so we're using 1h.
-- besides, we're using an eTag as well.
cacheSeconds $ 60 * 60
setEtag =<< liftIO (getBangsHash st)
bs <- lookupHeader "accept-encoding" >>= \case
Just ae | "br" `BS.isInfixOf` ae -> do
addHeader "content-encoding" "br"
liftIO $ getBangsBrotli st
_ -> do
liftIO $ getBangsJSON st
return $ TypedContent typeJson $ toContent bs
postSubmitR :: Handler ()
postSubmitR = do
pb <- requireCheckJsonBody
unless (verifyPendingBang pb) $ invalidArgs []
runDB $ insert400_ pb
getOpenSearchR :: Handler TypedContent
getOpenSearchR = do
neverExpires
cfg <- config <$> getYesod
resXml <- makeOpenSearch cfg <$> lookupGetParam "default"
return $ TypedContent "application/opensearchdescription+xml" $ toContent resXml
postVerdictR :: Bool -> Handler ()
postVerdictR b = do
ensureAuth . config =<< getYesod
(PendingBang n u dp mayEm) <- requireCheckJsonBody
-- NOTE: known race condition: the bang bang may be deleted from the database
-- before the updated bangs are written to disk, leading to the loss of
-- a pending bang on very specific crash timing.
st <- bangState <$> getYesod
when b $ liftIO $ addBang n u dp st
--sendEmail mayEm $ "your bang was " <> bool b "rejected" "accepted" -- TODO
runDB $ deleteWhere [PendingBangBang ==. n]
return ()
postAcceptR, postRejectR :: Handler ()
postAcceptR = postVerdictR True
postRejectR = postVerdictR False
getPendingR :: Handler Value
getPendingR = do
ensureAuth . config =<< getYesod
pendingBangs <- runDB $ selectList [] []
return $ toJSON $ map entityVal (pendingBangs :: [Entity PendingBang])
main :: IO ()
main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
runResourceT $ flip runSqlPool pool $ runMigration migrateAll
bs <- liftIO initBangState
cfg <- liftIO getConfig
$(logInfo) $ "Using config: " <> T.pack (show cfg)
sApp <- liftIO $ toWaiApp $ Search bs pool cfg -- includes middlewares
let settings = defaultSettings
& setHost (confHost cfg)
& setPort (confPort cfg)
liftIO $ runSettings settings sApp
|
