Monadic WS

backend/src/Types/WebSocketMessages/WebSocketMessages.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Types.WebSocketMessages.WebSocketMessages
+  ( WebSocketMessage (..),
+    SetClientInfo (..),
+    JoinRoom (..),
+  )
+where
+
+import ClassyPrelude
+import Data.Aeson
+  ( FromJSON (parseJSON),
+    Options (sumEncoding),
+    SumEncoding (..),
+    decode,
+    defaultOptions,
+    genericParseJSON,
+    withObject,
+    (.:),
+  )
+
+data WebSocketMessage = ClientInfoMessage SetClientInfo | JoinRoomMessage JoinRoom
+  deriving (Generic)
+
+instance FromJSON WebSocketMessage where
+  parseJSON = genericParseJSON defaultOptions {sumEncoding = UntaggedValue}
+
+data SetClientInfo = SetClientInfo
+  { displayName :: Text
+  }
+  deriving (Generic, Show)
+
+instance FromJSON SetClientInfo
+
+data JoinRoom = JoinRoom
+  { roomName :: Text
+  }
+  deriving (Generic, Show)
+
+instance FromJSON JoinRoom

backend/src/WebServer.hs

@@ -7,7 +7,6 @@ module WebServer (runWebServer) where
 
 import ClassyPrelude hiding (decodeUtf8)
 import Control.Monad.Except
-import Data.Text.Encoding
 import Network.HTTP.Types
 import Network.Wai
 import Network.Wai.Handler.Warp (run)
@@ -44,8 +43,6 @@ newtype WebApp env a = WebApp {unWebApp :: env -> IO (Either ResponseReceived a)
     )
     via ReaderT env (ExceptTApp ResponseReceived)
 
--- via  ExceptT ResponseReceived (ReaderT env IO)
-
 getRequestPath ::
   ( MonadIO m,
     HasWebEnv env,

backend/src/WebSocket.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module WebSocket (runWebSocketServer) where
 
 import BroadcastUserData (broadcastUserData)
 import ClassyPrelude
+import Data.Aeson
 import Data.UUID (UUID)
 import Data.UUID.V4 (nextRandom)
 import Network.WebSockets qualified as WS
@@ -13,8 +15,15 @@ import Types.AppTypes
   ( Env (..),
     HasConnectedClientState (getConnectedClientState),
   )
-import Types.ConnectionState (Client (..), ConnectedClients)
+import Types.ConnectionState
+  ( Client (..),
+    ConnectedClients,
+  )
 import Types.RoomsState (HasRoomsState (..))
+import Types.WebSocketMessages.WebSocketMessages
+  ( SetClientInfo (displayName),
+    WebSocketMessage (..),
+  )
 
 data WSEnv = WSEnv
   { appEnv :: Env,
@@ -81,6 +90,21 @@ joinRoom = do
     let s' = updateClient clientId (\c -> c {joinedRoom = True}) s
      in return s'
 
+updateClientName ::
+  ( HasWSEnv env,
+    HasConnectedClientState env,
+    MonadReader env m,
+    MonadUnliftIO m
+  ) =>
+  SetClientInfo ->
+  m ()
+updateClientName clientInfo = do
+  clientId <- getClientId <$> ask
+  state <- getConnectedClientState <$> ask
+  modifyMVar_ state $ \s ->
+    let s' = updateClient clientId (\c -> c {name = displayName clientInfo}) s
+     in return s'
+
 removeClient :: UUID -> ConnectedClients -> ConnectedClients
 removeClient toRemove = filter ((/= toRemove) . uuid)
 
@@ -121,11 +145,11 @@ newClient ::
     HasWSEnv env,
     MonadReader env m
   ) =>
-  Text ->
+  SetClientInfo ->
   m Client
-newClient name = do
+newClient clientInfo = do
   env <- ask
-  return $ Client {uuid = getClientId env, name = name, conn = getConn env, joinedRoom = False}
+  return $ Client {uuid = getClientId env, name = displayName clientInfo, conn = getConn env, joinedRoom = False}
 
 newtype WSApp env a = WSApp {unWSApp :: env -> IO a}
   deriving
@@ -138,25 +162,54 @@ newtype WSApp env a = WSApp {unWSApp :: env -> IO a}
     )
     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
+
 wsApp ::
   ( HasWSEnv env,
     HasConnectedClientState env,
     HasRoomsState env,
     MonadReader env m,
-    MonadUnliftIO m
+    MonadUnliftIO m,
+    MonadWebSocket m
   ) =>
   m ()
 wsApp = do
-  msg <- getMessage
-  putStrLn msg
+  msg <- getTypedWSMessage
+  print msg
   client <- newClient msg
   addWSClient client
   broadcastUserData
   flip finally disconnectWsClient $ forever $ do
-    currentMsg <- getMessage
-    joinRoom
+    handleWSAction
     broadcastUserData
-    putStrLn currentMsg
+
+handleWSAction ::
+  ( HasWSEnv env,
+    HasConnectedClientState env,
+    HasRoomsState env,
+    MonadReader env m,
+    MonadUnliftIO m,
+    MonadWebSocket m
+  ) =>
+  m ()
+handleWSAction = do
+  msg <- getTypedWSMessage
+  case msg of
+    JoinRoomMessage _ -> do
+      joinRoom
+      return ()
+    ClientInfoMessage clientInfo -> do
+      updateClientName clientInfo
 
 getMessage ::
   ( HasWSEnv env,
@@ -167,3 +220,14 @@ getMessage ::
 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