110 lines
2.4 KiB
Haskell
110 lines
2.4 KiB
Haskell
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
|
|
{-# HLINT ignore "Redundant bracket" #-}
|
|
|
|
module WebServer (runWebServer) where
|
|
|
|
import ClassyPrelude hiding (decodeUtf8)
|
|
import Data.Text.Encoding
|
|
import Network.HTTP.Types
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp (run)
|
|
import Types.AppTypes
|
|
( Env (..),
|
|
HasConnectedClientState (..),
|
|
)
|
|
import Types.RoomsState
|
|
( HasRoomsState (getRoomsState),
|
|
roomStateDiffers,
|
|
updateRoomState,
|
|
)
|
|
import WebSocket (broadCastToClients)
|
|
|
|
newtype WebApp env a = WebApp {unWebApp :: env -> IO a}
|
|
deriving
|
|
( Functor,
|
|
Applicative,
|
|
Monad,
|
|
MonadReader env,
|
|
MonadIO
|
|
)
|
|
via ReaderT env IO
|
|
|
|
data WebEnv = WebEnv
|
|
{ appEnv :: Env,
|
|
request :: Request,
|
|
respond :: Response -> IO ResponseReceived
|
|
}
|
|
|
|
instance HasConnectedClientState WebEnv where
|
|
getConnectedClientState = connectedClientsState . appEnv
|
|
|
|
instance HasRoomsState WebEnv where
|
|
getRoomsState = roomsState . appEnv
|
|
|
|
class HasWebEnv a where
|
|
getRequest :: a -> Request
|
|
getRespond :: a -> (Response -> IO ResponseReceived)
|
|
|
|
instance HasWebEnv WebEnv where
|
|
getRequest = request
|
|
getRespond = respond
|
|
|
|
getRequestBody ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
MonadReader env m
|
|
) =>
|
|
m Text
|
|
getRequestBody = do
|
|
request <- getRequest <$> ask
|
|
liftIO $ (decodeUtf8 . toStrict) <$> consumeRequestBodyStrict request
|
|
|
|
app ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
HasConnectedClientState env,
|
|
MonadReader env m,
|
|
HasRoomsState env
|
|
) =>
|
|
m ResponseReceived
|
|
app =
|
|
do
|
|
liftIO $ putStrLn "I've done some IO here"
|
|
getRequestBody >>= broadCastToClients
|
|
respond' <- getRespond <$> ask
|
|
shouldAct <- roomStateDiffers []
|
|
case shouldAct of
|
|
True -> do
|
|
updateRoomState []
|
|
ans respond'
|
|
False -> ans respond'
|
|
where
|
|
ans respond' = liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] ""
|
|
|
|
runWebApp ::
|
|
( MonadIO m,
|
|
MonadReader Env m
|
|
) =>
|
|
m Application
|
|
runWebApp = do
|
|
env <- ask
|
|
return
|
|
( \req res -> do
|
|
let webEnv = WebEnv {appEnv = env, request = req, respond = res}
|
|
unWebApp app webEnv
|
|
)
|
|
|
|
runWebServer ::
|
|
( MonadIO m,
|
|
MonadReader Env m
|
|
) =>
|
|
m ()
|
|
runWebServer = do
|
|
putStrLn "http://localhost:8081/"
|
|
runWebApp >>= liftIO . run 8081
|
|
return ()
|