Pure WS monad

backend/src/BroadcastUserData.hs

@@ -1,52 +1,51 @@
 module BroadcastUserData
   ( broadcastUserData,
+    broadCastToClientsGeneric,
+    MonadBroadcast (..),
   )
 where
 
-import ClassyPrelude
-import Data.Aeson (encode)
-import Network.WebSockets qualified as WS
-import Types.AppTypes (HasConnectedClientState (..))
-import Types.ConnectionState (Client (..), ConnectedClients)
-import Types.RoomsState (HasRoomsState (..))
-import Types.UsersData (UsersData (..))
+import           ClassyPrelude
+import           Data.Aeson                  (encode)
+import qualified Network.WebSockets          as WS
+import           State.ConnectedClientsState (MonadConnectedClientsRead (getConnctedClients))
+import           State.RoomDataState         (MonadRoomDataStateRead (getRoomDataState))
+import           Types.AppTypes              (HasConnectedClientState (..))
+import           Types.ConnectionState       (Client (..), ConnectedClients)
+import           Types.RoomsState            (HasRoomsState (..))
+import           Types.UsersData             (UsersData (..))
+
+class (Monad m, MonadConnectedClientsRead m) => MonadBroadcast m where
+  broadCastToClients :: Text -> m ()
 
 broadcastUserData ::
-  ( MonadIO m,
-    HasConnectedClientState env,
-    HasRoomsState env,
-    MonadReader env m
+  ( MonadRoomDataStateRead m,
+    MonadBroadcast m
   ) =>
   m ()
 broadcastUserData = do
-  putStrLn "broadcasting"
   userWithOutRoom <- getUsersWithoutRoom
-  roomsData <- ask >>= readMVar . getRoomsState
+  roomsData <- getRoomDataState
   let usersData = UsersData {usersWithOutRoom = userWithOutRoom, roomsData = roomsData}
   broadCastToClients $ (decodeUtf8 . toStrict . encode) usersData
 
 getUsersWithoutRoom ::
-  ( MonadIO m,
-    HasConnectedClientState env,
-    MonadReader env m
+  ( MonadConnectedClientsRead m
   ) =>
   m [Text]
-getUsersWithoutRoom = do
-  state <- ask >>= readMVar . getConnectedClientState
-  return $ map name $ filter (not . joinedRoom) state
+getUsersWithoutRoom = map name . filter (not . joinedRoom) <$> getConnctedClients
+
+broadCastToClientsGeneric ::
+  ( MonadIO m,
+    MonadConnectedClientsRead m
+  ) =>
+  Text ->
+  m ()
+broadCastToClientsGeneric message = do
+  state <- getConnctedClients
+  liftIO $ broadcast message state
 
 broadcast :: Text -> ConnectedClients -> IO ()
 broadcast message clients = do
   putStrLn message
   forM_ clients $ \client -> WS.sendTextData (conn client) message
-
-broadCastToClients ::
-  ( MonadIO m,
-    HasConnectedClientState env,
-    MonadReader env m
-  ) =>
-  Text ->
-  m ()
-broadCastToClients message = do
-  state <- getConnectedClientState <$> ask
-  liftIO $ withMVar state $ \currenState -> broadcast message currenState

backend/src/Lib.hs

@@ -10,7 +10,7 @@ import Types.AppTypes
 import Types.ConnectionState (initConnectionsState)
 import Types.RoomsState (initRoomsState)
 import WebServer (runWebServer)
-import WebSocket (runWebSocketServer)
+import WebSocket.Server (runWebSocketServer)
 
 runBothServers :: IO ()
 runBothServers = do

backend/src/RoomDataHandler.hs

@@ -5,7 +5,7 @@ module RoomDataHandler
   )
 where
 
-import BroadcastUserData (broadcastUserData)
+import BroadcastUserData (MonadBroadcast, broadcastUserData)
 import ClassyPrelude
 import Control.Monad.Except (MonadError, throwError)
 import Data.Aeson (eitherDecodeStrict)
@@ -16,27 +16,36 @@ import Network.Wai
     consumeRequestBodyStrict,
     responseLBS,
   )
+import State.ConnectedClientsState (MonadConnectedClientsRead)
+import State.RoomDataState
+  ( MonadRoomDataStateModify (setRoomDataState),
+    MonadRoomDataStateRead,
+  )
 import Types.AppTypes (HasConnectedClientState)
 import Types.RoomsState
   ( HasRoomsState,
     roomStateDiffers,
     updateRoomState,
   )
-import Types.WebEnv (HasWebEnv (getRequest), getRespond)
+import Types.WebEnv
+  ( HasWebEnv (getRequest),
+    getRespond,
+  )
 
 roomDataHandler ::
   ( MonadIO m,
     HasWebEnv env,
-    HasConnectedClientState env,
     MonadReader env m,
     MonadError ResponseReceived m,
-    HasRoomsState env
+    MonadRoomDataStateRead m,
+    MonadRoomDataStateModify m,
+    MonadBroadcast m
   ) =>
   m ResponseReceived
 roomDataHandler = do
   newRoomData <- parseBodyOrBadRequest
   whenM (roomStateDiffers newRoomData) $ do
-    updateRoomState newRoomData
+    setRoomDataState newRoomData
     broadcastUserData
   success
 

backend/src/State/ConnectedClientsState.hs

@@ -82,7 +82,7 @@ class Monad m => MonadConnectedClientsRead m where
 getConnctedClientsGeneric ::
   ( HasConnectedClientState env,
     MonadReader env m,
-    MonadUnliftIO m
+    MonadIO m
   ) =>
   m ConnectedClients
 getConnctedClientsGeneric = do

backend/src/State/RoomDataState.hs

@@ -0,0 +1,14 @@
+module State.RoomDataState
+  ( MonadRoomDataStateRead (..),
+    MonadRoomDataStateModify (..),
+  )
+where
+
+import ClassyPrelude
+import Types.RoomData
+
+class Monad m => MonadRoomDataStateModify m where
+  setRoomDataState :: RoomsData -> m ()
+
+class Monad m => MonadRoomDataStateRead m where
+  getRoomDataState :: m RoomsData

backend/src/Types/RoomsState.hs

@@ -4,10 +4,12 @@ module Types.RoomsState
     HasRoomsState (..),
     roomStateDiffers,
     updateRoomState,
+    getRoomState,
   )
 where
 
 import ClassyPrelude
+import State.RoomDataState (MonadRoomDataStateRead (getRoomDataState))
 import Types.RoomData (RoomsData)
 
 type RoomsState = MVar RoomsData
@@ -30,16 +32,23 @@ updateRoomState newData = do
   _ <- swapMVar state newData
   return ()
 
-roomStateDiffers ::
+getRoomState ::
   ( HasRoomsState env,
     MonadIO m,
     MonadReader env m
   ) =>
+  m RoomsData
+getRoomState = do
+  state <- getRoomsState <$> ask
+  readMVar state
+
+roomStateDiffers ::
+  ( MonadRoomDataStateRead m
+  ) =>
   RoomsData ->
   m Bool
 roomStateDiffers newData = do
-  currentData <- ask >>= readMVar . getRoomsState
-  return $ not $ eqIgnoreOrdering newData currentData
+  not . eqIgnoreOrdering newData <$> getRoomDataState
 
 eqIgnoreOrdering :: (Eq a) => [a] -> [a] -> Bool
 eqIgnoreOrdering a b = length a == length b && all (`elem` b) a

backend/src/WebServer.hs

@@ -1,22 +1,33 @@
 {-# 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 RoomDataHandler (roomDataHandler)
-import Types.AppTypes
-  ( Env (..),
-    HasConnectedClientState (..),
+import State.ConnectedClientsState
+  ( MonadConnectedClientsRead (..),
+    getConnctedClientsGeneric,
   )
+import State.RoomDataState
+  ( MonadRoomDataStateModify (..),
+    MonadRoomDataStateRead (getRoomDataState),
+  )
+import Types.AppTypes (Env (..))
 import Types.RoomsState
   ( HasRoomsState (getRoomsState),
+    getRoomState,
     roomStateDiffers,
     updateRoomState,
   )
@@ -43,6 +54,18 @@ newtype WebApp env a = WebApp {unWebApp :: env -> IO (Either ResponseReceived a)
     )
     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,
@@ -56,10 +79,11 @@ getRequestPath = do
 app ::
   ( MonadIO m,
     HasWebEnv env,
-    HasConnectedClientState env,
     MonadReader env m,
-    HasRoomsState env,
-    MonadError ResponseReceived m
+    MonadError ResponseReceived m,
+    MonadRoomDataStateModify m,
+    MonadRoomDataStateRead m,
+    MonadBroadcast m
   ) =>
   m ResponseReceived
 app = requestPathHandler
@@ -67,10 +91,11 @@ app = requestPathHandler
 requestPathHandler ::
   ( MonadIO m,
     HasWebEnv env,
-    HasConnectedClientState env,
     MonadReader env m,
-    HasRoomsState env,
-    MonadError ResponseReceived m
+    MonadError ResponseReceived m,
+    MonadRoomDataStateModify m,
+    MonadRoomDataStateRead m,
+    MonadBroadcast m
   ) =>
   m ResponseReceived
 requestPathHandler = do

backend/src/WebSocket.hs

@@ -3,178 +3,43 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module WebSocket (runWebSocketServer) where
+module WebSocket (WSEnv (..), wsApp, WSApp (..)) where
 
-import BroadcastUserData (broadcastUserData)
+import BroadcastUserData
+  ( MonadBroadcast (..),
+    broadcastUserData,
+  )
 import ClassyPrelude
-import Data.Aeson
-import Data.UUID (UUID)
-import Data.UUID.V4 (nextRandom)
-import Network.WebSockets qualified as WS
-import State.ConnectedClientsState
-  ( MonadConnectedClientsModify (..),
-    MonadConnectedClientsRead (getConnctedClients),
-    addWSClientGeneric,
-    getConnctedClientsGeneric,
-    removeWSClientGeneric,
-    updateWSClientGeneric,
-  )
-import Types.AppTypes
-  ( Env (..),
-    HasConnectedClientState (getConnectedClientState),
-  )
-import Types.ConnectionState
-  ( Client (..),
-    ConnectedClients,
-  )
-import Types.RoomsState (HasRoomsState (..))
+import Data.UUID.V4 ()
+import State.ConnectedClientsState (MonadConnectedClientsModify (..))
+import State.RoomDataState (MonadRoomDataStateRead (..))
+import Types.ConnectionState (Client (..))
 import Types.WebSocketMessages.WebSocketMessages
   ( SetClientInfo (displayName),
     WebSocketMessage (..),
   )
-
-data WSEnv = WSEnv
-  { appEnv :: Env,
-    connection :: WS.Connection,
-    clientId :: UUID
-  }
-
-instance HasConnectedClientState WSEnv where
-  getConnectedClientState = connectedClientsState . appEnv
-
-instance HasRoomsState WSEnv where
-  getRoomsState = roomsState . appEnv
-
-class HasWSEnv a where
-  getConn :: a -> WS.Connection
-  getClientId :: a -> UUID
-
-instance HasWSEnv WSEnv where
-  getConn = connection
-  getClientId = clientId
-
-joinRoom ::
-  ( MonadReader env m,
-    MonadConnectedClientsModify m,
-    HasWSEnv env
-  ) =>
-  m ()
-joinRoom = do
-  clientId <- getClientId <$> ask
-  updateWSClient clientId (\c -> c {joinedRoom = True})
-
-updateClientName ::
-  ( HasWSEnv env,
-    MonadReader env m,
-    MonadConnectedClientsModify m
-  ) =>
-  SetClientInfo ->
-  m ()
-updateClientName clientInfo = do
-  clientId <- getClientId <$> ask
-  updateWSClient clientId (\c -> c {name = displayName clientInfo})
-
-disconnectWsClient ::
-  ( HasWSEnv env,
-    MonadConnectedClientsModify m,
-    MonadReader env m
-  ) =>
-  m ()
-disconnectWsClient = do
-  clientId <- getClientId <$> ask
-  removeWSClient clientId
-
-runWebSocketServer ::
-  ( MonadIO m,
-    MonadReader Env m
-  ) =>
-  m ()
-runWebSocketServer = do
-  putStrLn "Websocket up at 127.0.0.1:9160"
-  wsApp' <- runWSApp
-  liftIO $ WS.runServer "127.0.0.1" 9160 wsApp'
-
-runWSApp ::
-  ( MonadIO m,
-    MonadReader Env m
-  ) =>
-  m WS.ServerApp
-runWSApp = do
-  env <- ask
-  return
-    ( \pending -> do
-        conn <- WS.acceptRequest pending
-        uuid <- nextRandom
-        let wsEnv = WSEnv {appEnv = env, connection = conn, clientId = uuid}
-        WS.withPingThread conn 30 (return ()) $ unWSApp wsApp wsEnv
-    )
-
-newClient ::
-  ( MonadIO m,
-    HasWSEnv env,
-    MonadReader env m
-  ) =>
-  SetClientInfo ->
-  m Client
-newClient clientInfo = do
-  env <- ask
-  return $ Client {uuid = getClientId env, name = displayName clientInfo, conn = getConn env, joinedRoom = False}
-
-newtype WSApp env a = WSApp {unWSApp :: env -> IO a}
-  deriving
-    ( Functor,
-      Applicative,
-      Monad,
-      MonadReader env,
-      MonadIO,
-      MonadUnliftIO
-    )
-    via ReaderT env IO
-
-class Monad m => MonadWebSocket m where
-  getTypedWSMessage :: FromJSON a => m a
-
-instance MonadWebSocket (WSApp WSEnv) where
-  getTypedWSMessage = do
-    msg <- getMessage
-    case eitherDecodeStrict $ encodeUtf8 msg of
-      Right a -> return a
-      Left err -> do
-        sendMessage $ "Bad message: " <> pack err
-        getTypedWSMessage
-
-instance MonadConnectedClientsModify (WSApp WSEnv) where
-  addWSClient = addWSClientGeneric
-  updateWSClient = updateWSClientGeneric
-  removeWSClient = removeWSClientGeneric
-
-instance MonadConnectedClientsRead (WSApp WSEnv) where
-  getConnctedClients = getConnctedClientsGeneric
+import WebSocket.MonadWebSocketSession
+import WebSocket.WSReaderTApp
 
 wsApp ::
-  ( HasWSEnv env,
-    HasConnectedClientState env,
-    HasRoomsState env,
-    MonadReader env m,
-    MonadUnliftIO m,
-    MonadWebSocket m,
-    MonadConnectedClientsModify m
+  ( MonadWebSocketSession m,
+    MonadWebSocketSessionInit m,
+    MonadConnectedClientsModify m,
+    MonadRoomDataStateRead m,
+    MonadBroadcast m
   ) =>
   m ()
 wsApp = do
   msg <- getTypedWSMessage
-  print msg
   client <- newClient msg
   addWSClient client
   broadcastUserData
-  flip finally disconnectWsClient $ forever $ do
+  withCleanUp $ forever $ do
     handleWSAction
     broadcastUserData
 
 handleWSAction ::
-  ( HasWSEnv env,
-    MonadReader env m,
-    MonadWebSocket m,
+  ( MonadWebSocketSession m,
     MonadConnectedClientsModify m
   ) =>
   m ()
@@ -183,27 +48,24 @@ handleWSAction = do
   case msg of
     JoinRoomMessage _ -> do
       joinRoom
-      return ()
     ClientInfoMessage clientInfo -> do
       updateClientName clientInfo
 
-getMessage ::
-  ( HasWSEnv env,
-    MonadIO m,
-    MonadReader env m
+joinRoom ::
+  ( MonadConnectedClientsModify m,
+    MonadWebSocketSession m
   ) =>
-  m Text
-getMessage = do
-  conn' <- getConn <$> ask
-  liftIO $ WS.receiveData conn'
-
-sendMessage ::
-  ( HasWSEnv env,
-    MonadIO m,
-    MonadReader env m
-  ) =>
-  Text ->
   m ()
-sendMessage msg = do
-  conn' <- getConn <$> ask
-  liftIO $ WS.sendTextData conn' msg
+joinRoom = do
+  clientId <- getSesssionId
+  updateWSClient clientId (\c -> c {joinedRoom = True})
+
+updateClientName ::
+  ( MonadWebSocketSession m,
+    MonadConnectedClientsModify m
+  ) =>
+  SetClientInfo ->
+  m ()
+updateClientName clientInfo = do
+  clientId <- getSesssionId
+  updateWSClient clientId (\c -> c {name = displayName clientInfo})

backend/src/WebSocket/Messages.hs

@@ -0,0 +1,30 @@
+module WebSocket.Messages
+  ( getMessage,
+    sendMessage,
+  )
+where
+
+import ClassyPrelude
+import Network.WebSockets qualified as WS
+import WebSocket.WSReaderTApp
+
+getMessage ::
+  ( HasWSEnv env,
+    MonadIO m,
+    MonadReader env m
+  ) =>
+  m Text
+getMessage = do
+  conn' <- getConn <$> ask
+  liftIO $ WS.receiveData conn'
+
+sendMessage ::
+  ( HasWSEnv env,
+    MonadIO m,
+    MonadReader env m
+  ) =>
+  Text ->
+  m ()
+sendMessage msg = do
+  conn' <- getConn <$> ask
+  liftIO $ WS.sendTextData conn' msg

backend/src/WebSocket/MonadWebSocketSession.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module WebSocket.MonadWebSocketSession
+  ( MonadWebSocketSession (..),
+    MonadWebSocketSessionInit (..),
+  )
+where
+
+import ClassyPrelude
+import Data.Aeson
+  ( FromJSON,
+    eitherDecodeStrict,
+  )
+import Data.UUID (UUID)
+import State.ConnectedClientsState
+  ( MonadConnectedClientsModify,
+    removeWSClient,
+  )
+import Types.ConnectionState (Client (..))
+import Types.WebSocketMessages.WebSocketMessages (SetClientInfo (..))
+import WebSocket.Messages
+import WebSocket.WSReaderTApp
+
+class Monad m => MonadWebSocketSession m where
+  getTypedWSMessage :: FromJSON a => m a
+  getSesssionId :: m UUID
+
+instance MonadWebSocketSession (WSApp WSEnv) where
+  getTypedWSMessage = do
+    msg <- getMessage
+    case eitherDecodeStrict $ encodeUtf8 msg of
+      Right a -> return a
+      Left err -> do
+        sendMessage $ "Bad message: " <> pack err
+        getTypedWSMessage
+  getSesssionId = getClientId <$> ask
+
+class (Monad m) => MonadWebSocketSessionInit m where
+  newClient :: SetClientInfo -> m Client
+  withCleanUp :: m () -> m ()
+
+instance MonadWebSocketSessionInit (WSApp WSEnv) where
+  newClient = newClientGeneric
+  withCleanUp = flip finally disconnectWsClient
+
+newClientGeneric ::
+  ( MonadIO m,
+    HasWSEnv env,
+    MonadReader env m
+  ) =>
+  SetClientInfo ->
+  m Client
+newClientGeneric clientInfo = do
+  env <- ask
+  return $ Client {uuid = getClientId env, name = displayName clientInfo, conn = getConn env, joinedRoom = False}
+
+disconnectWsClient ::
+  ( MonadConnectedClientsModify m,
+    MonadWebSocketSession m
+  ) =>
+  m ()
+disconnectWsClient = do
+  clientId <- getSesssionId
+  removeWSClient clientId

backend/src/WebSocket/Server.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module WebSocket.Server
+  ( runWebSocketServer,
+    runWSApp,
+  )
+where
+
+import ClassyPrelude
+import Data.UUID.V4 (nextRandom)
+import Network.WebSockets qualified as WS
+import Types.AppTypes
+import WebSocket
+import WebSocket (WSApp (..))
+
+runWebSocketServer ::
+  ( MonadIO m,
+    MonadReader Env m
+  ) =>
+  m ()
+runWebSocketServer = do
+  putStrLn "Websocket up at 127.0.0.1:9160"
+  wsApp' <- runWSApp
+  liftIO $ WS.runServer "127.0.0.1" 9160 wsApp'
+
+runWSApp ::
+  ( MonadIO m,
+    MonadReader Env m
+  ) =>
+  m WS.ServerApp
+runWSApp = do
+  env <- ask
+  return
+    ( \pending -> do
+        conn <- WS.acceptRequest pending
+        uuid <- nextRandom
+        let wsEnv = WSEnv {appEnv = env, connection = conn, clientId = uuid}
+        WS.withPingThread conn 30 (return ()) $ unWSApp wsApp wsEnv
+    )

backend/src/WebSocket/WSReaderTApp.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module WebSocket.WSReaderTApp
+  ( WSApp (..),
+    WSEnv (..),
+    HasWSEnv (..),
+  )
+where
+
+import BroadcastUserData
+  ( MonadBroadcast (..),
+    broadCastToClientsGeneric,
+  )
+import ClassyPrelude
+import Data.UUID
+import Network.WebSockets qualified as WS
+import State.ConnectedClientsState
+  ( MonadConnectedClientsModify (..),
+    MonadConnectedClientsRead (..),
+    addWSClientGeneric,
+    getConnctedClientsGeneric,
+    removeWSClientGeneric,
+    updateWSClientGeneric,
+  )
+import State.RoomDataState
+import Types.AppTypes
+import Types.RoomsState (HasRoomsState (..), getRoomState)
+
+data WSEnv = WSEnv
+  { appEnv :: Env,
+    connection :: WS.Connection,
+    clientId :: UUID
+  }
+
+class HasWSEnv a where
+  getConn :: a -> WS.Connection
+  getClientId :: a -> UUID
+
+instance HasWSEnv WSEnv where
+  getConn = connection
+  getClientId = clientId
+
+newtype WSApp env a = WSApp {unWSApp :: env -> IO a}
+  deriving
+    ( Functor,
+      Applicative,
+      Monad,
+      MonadReader env,
+      MonadIO,
+      MonadUnliftIO
+    )
+    via ReaderT env IO
+
+instance HasConnectedClientState WSEnv where
+  getConnectedClientState = connectedClientsState . appEnv
+
+instance HasRoomsState WSEnv where
+  getRoomsState = roomsState . appEnv
+
+instance MonadConnectedClientsModify (WSApp WSEnv) where
+  addWSClient = addWSClientGeneric
+  updateWSClient = updateWSClientGeneric
+  removeWSClient = removeWSClientGeneric
+
+instance MonadConnectedClientsRead (WSApp WSEnv) where
+  getConnctedClients = getConnctedClientsGeneric
+
+instance MonadRoomDataStateRead (WSApp WSEnv) where
+  getRoomDataState = getRoomState
+
+instance MonadBroadcast (WSApp WSEnv) where
+  broadCastToClients = broadCastToClientsGeneric