171 lines
3.8 KiB
Haskell
171 lines
3.8 KiB
Haskell
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module WebServer (runWebServer) where
|
|
|
|
import BroadcastUserData
|
|
( MonadBroadcast (..),
|
|
broadCastToClientsGeneric,
|
|
)
|
|
import ClassyPrelude hiding (decodeUtf8)
|
|
import Control.Monad.Except
|
|
import Network.HTTP.Types
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp (run)
|
|
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
|
|
import RoomDataHandler (roomDataHandler)
|
|
import State.ConnectedClientsState
|
|
( MonadConnectedClientsRead (..),
|
|
getConnctedClientsGeneric,
|
|
)
|
|
import State.RoomDataState
|
|
( MonadRoomDataStateModify (..),
|
|
MonadRoomDataStateRead (getRoomDataState),
|
|
)
|
|
import Types.AppTypes (Env (..))
|
|
import Types.RoomsState
|
|
( HasRoomsState (getRoomsState),
|
|
getRoomState,
|
|
roomStateDiffers,
|
|
updateRoomState,
|
|
)
|
|
import Types.WebEnv
|
|
|
|
newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)}
|
|
deriving
|
|
( Functor,
|
|
Applicative,
|
|
Monad,
|
|
MonadIO,
|
|
MonadError e
|
|
)
|
|
via ExceptT e IO
|
|
|
|
newtype WebApp env a = WebApp {unWebApp :: env -> IO (Either ResponseReceived a)}
|
|
deriving
|
|
( Functor,
|
|
Applicative,
|
|
Monad,
|
|
MonadReader env,
|
|
MonadIO,
|
|
MonadError ResponseReceived
|
|
)
|
|
via ReaderT env (ExceptTApp ResponseReceived)
|
|
|
|
instance MonadConnectedClientsRead (WebApp WebEnv) where
|
|
getConnctedClients = getConnctedClientsGeneric
|
|
|
|
instance MonadRoomDataStateModify (WebApp WebEnv) where
|
|
setRoomDataState = updateRoomState
|
|
|
|
instance MonadRoomDataStateRead (WebApp WebEnv) where
|
|
getRoomDataState = getRoomState
|
|
|
|
instance MonadBroadcast (WebApp WebEnv) where
|
|
broadCastToClients = broadCastToClientsGeneric
|
|
|
|
getRequestPath ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
MonadReader env m
|
|
) =>
|
|
m [Text]
|
|
getRequestPath = do
|
|
request <- getRequest <$> ask
|
|
return $ pathInfo request
|
|
|
|
app ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
MonadReader env m,
|
|
MonadError ResponseReceived m,
|
|
MonadRoomDataStateModify m,
|
|
MonadRoomDataStateRead m,
|
|
MonadBroadcast m
|
|
) =>
|
|
m ResponseReceived
|
|
app = requestPathHandler
|
|
|
|
requestPathHandler ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
MonadReader env m,
|
|
MonadError ResponseReceived m,
|
|
MonadRoomDataStateModify m,
|
|
MonadRoomDataStateRead m,
|
|
MonadBroadcast m
|
|
) =>
|
|
m ResponseReceived
|
|
requestPathHandler = do
|
|
getRequestPath >>= \case
|
|
["roomdata"] -> roomDataHandler
|
|
_ -> notFound
|
|
|
|
notFound ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
MonadReader env m,
|
|
MonadError ResponseReceived m
|
|
) =>
|
|
m ResponseReceived
|
|
notFound = do
|
|
respond' <- getRespond <$> ask
|
|
response <-
|
|
liftIO $
|
|
respond' $
|
|
responseLBS
|
|
status404
|
|
[("Content-Type", "text/plain")]
|
|
"404 - Not Found"
|
|
throwError response
|
|
|
|
-- notFound ::
|
|
-- ( MonadIO m,
|
|
-- HasWebEnv env,
|
|
-- MonadReader env m,
|
|
-- MonadError ResponseReceived m
|
|
-- ) =>
|
|
-- m ResponseReceived
|
|
-- notFound = do
|
|
-- respond' <- getRespond <$> ask
|
|
-- response <-
|
|
-- liftIO $
|
|
-- respond' $
|
|
-- responseLBS
|
|
-- status200
|
|
-- [("Content-Type", "text/plain")]
|
|
-- "200 - Success"
|
|
-- response
|
|
|
|
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}
|
|
eitherResult <- unWebApp app webEnv
|
|
case eitherResult of
|
|
Left result -> do
|
|
liftIO $ putStrLn "Some error occured"
|
|
return result
|
|
Right result -> do
|
|
return result
|
|
)
|
|
|
|
runWebServer ::
|
|
( MonadIO m,
|
|
MonadReader Env m
|
|
) =>
|
|
m ()
|
|
runWebServer = do
|
|
putStrLn "http://localhost:8081/"
|
|
runWebApp >>= liftIO . (run 8081 . logStdoutDev)
|
|
return ()
|