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
|
{-# Language RecordWildCards #-}
{-# Language ApplicativeDo #-}
module Fig.Web.Utils
( FigWebException(..)
, loadConfig
, Config(..)
, websocket
, module Network.HTTP.Types.Status
) where
import Fig.Prelude
import Network.HTTP.Types.Status
import qualified Network.Wai.Handler.WebSockets as Wai.WS
import qualified Network.WebSockets as WS
import qualified Web.Scotty as Sc
import qualified Toml
newtype FigWebException = FigWebException Text
deriving (Show, Eq, Ord)
instance Exception FigWebException
data Config = Config
{ port :: !Int
, assetPath :: !FilePath
, clientId :: !Text
, authToken :: !Text
, dbHost :: !Text
, lldapCli :: !FilePath
, lldapHost :: !Text
, lldapUser :: !Text
, lldapPassword :: !Text
} deriving (Show, Eq, Ord)
configCodec :: Toml.TomlCodec Config
configCodec = do
port <- Toml.int "port" Toml..= (\a -> a.port)
assetPath <- Toml.string "asset_path" Toml..= (\a -> a.assetPath)
clientId <- Toml.text "client_id" Toml..= (\a -> a.clientId)
authToken <- Toml.text "auth_token" Toml..= (\a -> a.authToken)
dbHost <- Toml.text "db_host" Toml..= (\a -> a.dbHost)
lldapCli <- Toml.string "lldap_cli" Toml..= (\a -> a.lldapCli)
lldapHost <- Toml.text "lldap_host" Toml..= (\a -> a.lldapHost)
lldapUser <- Toml.text "lldap_user" Toml..= (\a -> a.lldapUser)
lldapPassword <- Toml.text "lldap_password" Toml..= (\a -> a.lldapPassword)
pure $ Config{..}
loadConfig :: FilePath -> IO Config
loadConfig path = Toml.decodeFileEither configCodec path >>= \case
Left err -> throwM . FigWebException $ tshow err
Right config -> pure config
websocket :: ByteString -> (WS.Connection -> IO ()) -> Sc.ScottyM ()
websocket pat h = Sc.middleware $ Wai.WS.websocketsOr WS.defaultConnectionOptions handler
where
handler pending = if WS.requestPath (WS.pendingRequest pending) == pat
then WS.acceptRequest pending >>= \c -> WS.withPingThread c 30 (pure ()) $ h c
else WS.rejectRequest pending ""
|
