This commit is contained in:
parent
c77e006ce4
commit
b8c7b4b954
|
@ -16,16 +16,12 @@ import Network.Wai
|
||||||
consumeRequestBodyStrict,
|
consumeRequestBodyStrict,
|
||||||
responseLBS,
|
responseLBS,
|
||||||
)
|
)
|
||||||
import State.ConnectedClientsState (MonadConnectedClientsRead)
|
|
||||||
import State.RoomDataState
|
import State.RoomDataState
|
||||||
( MonadRoomDataStateModify (setRoomDataState),
|
( MonadRoomDataStateModify (setRoomDataState),
|
||||||
MonadRoomDataStateRead,
|
MonadRoomDataStateRead,
|
||||||
)
|
)
|
||||||
import Types.AppTypes (HasConnectedClientState)
|
|
||||||
import Types.RoomsState
|
import Types.RoomsState
|
||||||
( HasRoomsState,
|
( roomStateDiffers,
|
||||||
roomStateDiffers,
|
|
||||||
updateRoomState,
|
|
||||||
)
|
)
|
||||||
import Types.WebEnv
|
import Types.WebEnv
|
||||||
( HasWebEnv (getRequest),
|
( HasWebEnv (getRequest),
|
||||||
|
|
|
@ -15,7 +15,7 @@ import Control.Monad.Except
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Network.Wai.Handler.Warp (run)
|
import Network.Wai.Handler.Warp (run)
|
||||||
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
|
import Network.Wai.Middleware.RequestLogger (logStdout)
|
||||||
import RoomDataHandler (roomDataHandler)
|
import RoomDataHandler (roomDataHandler)
|
||||||
import State.ConnectedClientsState
|
import State.ConnectedClientsState
|
||||||
( MonadConnectedClientsRead (..),
|
( MonadConnectedClientsRead (..),
|
||||||
|
@ -27,9 +27,7 @@ import State.RoomDataState
|
||||||
)
|
)
|
||||||
import Types.AppTypes (Env (..))
|
import Types.AppTypes (Env (..))
|
||||||
import Types.RoomsState
|
import Types.RoomsState
|
||||||
( HasRoomsState (getRoomsState),
|
( getRoomState,
|
||||||
getRoomState,
|
|
||||||
roomStateDiffers,
|
|
||||||
updateRoomState,
|
updateRoomState,
|
||||||
)
|
)
|
||||||
import Types.WebEnv
|
import Types.WebEnv
|
||||||
|
@ -122,24 +120,6 @@ notFound = do
|
||||||
"404 - Not Found"
|
"404 - Not Found"
|
||||||
throwError response
|
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 ::
|
runWebApp ::
|
||||||
( MonadIO m,
|
( MonadIO m,
|
||||||
MonadReader Env m
|
MonadReader Env m
|
||||||
|
@ -165,6 +145,6 @@ runWebServer ::
|
||||||
) =>
|
) =>
|
||||||
m ()
|
m ()
|
||||||
runWebServer = do
|
runWebServer = do
|
||||||
putStrLn "http://localhost:8081/"
|
putStrLn "Webserver up and running at http://localhost:8081/"
|
||||||
runWebApp >>= liftIO . (run 8081 . logStdoutDev)
|
runWebApp >>= liftIO . (run 8081 . logStdout)
|
||||||
return ()
|
return ()
|
||||||
|
|
|
@ -33,11 +33,11 @@ wsApp = do
|
||||||
broadcastUserData
|
broadcastUserData
|
||||||
withCleanUp $ forever $ do
|
withCleanUp $ forever $ do
|
||||||
handleWSAction
|
handleWSAction
|
||||||
broadcastUserData
|
|
||||||
|
|
||||||
handleWSAction ::
|
handleWSAction ::
|
||||||
( MonadWebSocketSession m,
|
( MonadWebSocketSession m,
|
||||||
MonadConnectedClientsModify m,
|
MonadConnectedClientsModify m,
|
||||||
|
MonadRoomDataStateRead m,
|
||||||
MonadBroadcast m,
|
MonadBroadcast m,
|
||||||
MonadAllChat m
|
MonadAllChat m
|
||||||
) =>
|
) =>
|
||||||
|
@ -47,8 +47,10 @@ handleWSAction = do
|
||||||
case msg of
|
case msg of
|
||||||
JoinRoomMessage _ -> do
|
JoinRoomMessage _ -> do
|
||||||
joinRoom
|
joinRoom
|
||||||
|
broadcastUserData
|
||||||
ClientInfoMessage clientInfo -> do
|
ClientInfoMessage clientInfo -> do
|
||||||
updateClientName clientInfo
|
updateClientName clientInfo
|
||||||
|
broadcastUserData
|
||||||
AllChatMessageIncomingMessage incomingMessage -> do
|
AllChatMessageIncomingMessage incomingMessage -> do
|
||||||
broadCastAllChatMessage incomingMessage
|
broadCastAllChatMessage incomingMessage
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue