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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
TypeFamilies, LambdaCase, EmptyDataDecls, ScopedTypeVariables #-}
{-# OPTIONS -Wno-unused-top-binds #-}
module Main (main) where
import Control.Monad.IO.Unlift (toIO)
import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad (when, unless)
import Database.Persist.Sqlite
import Data.Bool (bool)
import Data.FileEmbed (embedFile)
import Data.Function ((&))
import Data.Pool (Pool)
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,
notifyPbRunner :: Runner
}
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 TypedContent
getHomeR = do
cacheSeconds $ 60 * 60 * 24 * 7
respond typeHtml ($(embedFile "build/index.html"))
getBundleR :: Handler TypedContent
getBundleR = do
cacheSeconds $ 60 * 60 * 24 * 7
noEmbed <- confNoEmbed . config <$> getYesod
respond typeJavascript =<< if noEmbed
then liftIO $ BS.readFile "../build/bundle.js"
else pure ($(embedFile "build/bundle.js"))
getStyleR :: Handler TypedContent
getStyleR = do
cacheSeconds $ 60 * 60 * 24 * 7
noEmbed <- confNoEmbed . config <$> getYesod
respond typeCss =<< if noEmbed
then liftIO $ BS.readFile "../build/style.css"
else pure ($(embedFile "build/style.css"))
getBangsR :: Handler TypedContent
getBangsR = do
st <- getsYesod bangState
-- 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
respond typeJson bs
postSubmitR :: Handler ()
postSubmitR = do
pb <- requireCheckJsonBody
unless (verifyPendingBang pb) $ invalidArgs []
cnt <- runDB $ count ([] :: [Filter PendingBang])
unless (cnt < 1000) $ permissionDenied "Too many pending bangs already in database"
runDB $ insert400_ pb
liftIO . notifyRunner . notifyPbRunner =<< getYesod
getOpenSearchR :: Handler TypedContent
getOpenSearchR = do
neverExpires
cfg <- getsYesod config
resXml <- makeOpenSearch cfg <$> lookupGetParam "default"
respond "application/opensearchdescription+xml" resXml
postVerdictR :: Bool -> Handler ()
postVerdictR b = do
cfg <- getsYesod config
ensureAuth cfg
(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 <- getsYesod bangState
when b $ liftIO $ addBang n u dp st
runDB $ deleteWhere [PendingBangBang ==. n]
case mayEm of
Nothing -> return ()
Just em -> do
let e = T.unpack em
sendEmail cfg e ("Your bang was " <> bool "rejected" "accepted!" b) $
"Hello,\n" <>
"\n" <>
"We're " <> bool "sorry" "happy" b <> " to announce that your" <>
" submitted bang \"" <> T.unpack dp <> "\" (\"!" <> T.unpack n <>
"\", leading to " <> T.unpack u <> ") has been " <>
bool "rejected" "accepted" b <>
" by an administrator. Good look with your future banging!\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])
sendPendingBangs :: forall m. (MonadLogger m, MonadUnliftIO m)
=> Config -> Pool SqlBackend -> m ()
sendPendingBangs cfg pool = do
n <- length <$> (runSqlPool (selectList [] []) pool :: m [Entity PendingBang])
when (n > 0) $ sendEmail cfg (confAdminEmail cfg) "Pending Bang notification" $
"There are currently " <> show n <> " pending bangs.\n" <>
"Please do something about it.\n"
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)
sendPbIO <- toIO $ sendPendingBangs cfg pool
notifyPb <- liftIO $ makeRunner sendPbIO 600000000 {- 10 min -}
sApp <- liftIO $ toWaiApp $ Search bs pool cfg notifyPb -- includes middlewares
let settings = defaultSettings
& setHost (confHost cfg)
& setPort (confPort cfg)
liftIO $ runSettings settings sApp
|
