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
|
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
TypeFamilies, ViewPatterns, LambdaCase, EmptyDataDecls,
FlexibleContexts, GADTs, GeneralizedNewtypeDeriving,
MultiParamTypeClasses, DerivingStrategies, StandaloneDeriving,
UndecidableInstances, DataKinds, FlexibleInstances, TypeOperators #-}
{-# 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 Data.Aeson
import Database.Persist.Sqlite
import Data.Char (isAlphaNum)
import Data.Function ((&))
import Data.Maybe (maybeToList)
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
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
PendingBang
bang T.Text
url T.Text
displayName T.Text
notifyEmail (Maybe T.Text)
UniqueBang bang url displayName
deriving Show
|]
instance ToJSON PendingBang where
toJSON (PendingBang b u dp em) = object $
["bang" .= b, "url" .= u, "name" .= dp] ++ case em of
Nothing -> []
Just e -> ["email" .= e]
-- TODO toEncoding. Not sure how much value that holds though
instance FromJSON PendingBang where
parseJSON = withObject "PendingBang" $ \ob ->
PendingBang
<$> ob .: "bang"
<*> ob .: "url"
<*> ob .: "name"
<*> ob .:? "email"
data Search = Search {
bangState :: BangState,
sqlPool :: ConnectionPool
}
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
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@(PendingBang n u dp mayEm) <- requireCheckJsonBody
unless (T.all isAlphaNum n) $ invalidArgs []
let strings = [n, u, dp] <> maybeToList mayEm
unless (all ((<255) . T.length) strings) $ invalidArgs []
runDB $ insert400_ pb
getOpenSearchR :: Handler TypedContent
getOpenSearchR = do
neverExpires
resXml <- liftIO . makeOpenSearch =<< lookupGetParam "default"
return $ TypedContent "application/opensearchdescription+xml" $ toContent resXml
postVerdictR :: Bool -> Handler ()
postVerdictR b = do
ensureAuth
(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
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
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
|
