diff --git a/configuration.yaml b/configuration.yaml index 385d470..99180ce 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -2,4 +2,4 @@ setSocketPath : "/tmp/wizard.sock" setMapRows : 20 setMapColumns : 20 setSpawnerProbability : 0.01 -setFPS : 5 +setFPS : 30 diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index a549ce3..4effbf6 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -54,6 +54,6 @@ receiveMessage sock queue = do msg <- B.pack <$> peekArray bufferLength ptr let mJsonMsg = A.decode' $ B8.fromStrict msg maybe - (pure ()) + (putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict msg)) (STM.atomically . STM.writeTQueue queue) mJsonMsg diff --git a/src-client/Main.hs b/src-client/Main.hs index 57283f6..23c56e9 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -5,6 +5,8 @@ import Control.Concurrent (threadDelay) import qualified Control.Concurrent.STM as STM +import Control.Monad.Loops (whileM_) + import Options.Applicative -- internal imports @@ -22,24 +24,33 @@ main = do sock <- connectSocket socketLocation queue <- STM.newTQueueIO putStrLn "connected" + + sendMessage (IdRequest) sock threadDelay $ 1 * 10 ^ 6 receiveMessage sock queue - threadDelay $ 1 * 10 ^ 6 + whileM_ + (STM.atomically $ STM.isEmptyTQueue queue) + (threadDelay $ 1 * 10 ^ 6) clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue) let clientId = acClientUUID clientIdMsg putStrLn $ "received client UUID: " <> show clientId - threadDelay $ 1 * 10 ^ 6 - putStrLn welcomeText - threadDelay $ 15 * 10 ^ 6 + + putStrLn welcomeText + -- threadDelay $ 15 * 10 ^ 6 + + sendMessage (ClientMessage clientId ClientRequestWizard) sock threadDelay $ 1 * 10 ^ 6 receiveMessage sock queue - threadDelay $ 1 * 10 ^ 6 + whileM_ + (STM.atomically $ STM.isEmptyTQueue queue) + (threadDelay $ 1 * 10 ^ 6) playerWizard <- head <$> STM.atomically (STM.flushTQueue queue) - putStrLn "received wizard" - print (initWizard playerWizard) + putStrLn $ "received wizard: " <> show (initWizard playerWizard) + + let initRead = ReaderContainer sock clientId initState = StateContainer (initWizard playerWizard) putStrLn "sending quit message" diff --git a/src-lib/Library/Types/Communication.hs b/src-lib/Library/Types/Communication.hs index 26c8a42..c1fbe26 100644 --- a/src-lib/Library/Types/Communication.hs +++ b/src-lib/Library/Types/Communication.hs @@ -10,6 +10,7 @@ import GHC.Generics -- internal imports import Library.Types.Player +import Library.Types.Map data ServerMessage = ServerQuit diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 5f35d42..46315aa 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -110,6 +110,7 @@ sendMessage sendMessage msg sock = do let msgJson = A.encode msg msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson + putStrLn $ "sending: " <> B8.unpack msgJson VS.unsafeWith msgVector (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) @@ -125,7 +126,10 @@ processMessages = do mapM_ (\(uuid, clientSocket) -> void $ liftIO $ forkIO $ do receiveMessage clientSocket queue - handleMessage serverState readerContainer + msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue + mapM_ + (handleMessage serverState readerContainer) + msgs ) clients @@ -151,6 +155,7 @@ receiveMessage sock queue = do (pure ()) (\msg -> do liftIO $ STM.atomically $ STM.writeTQueue queue msg + when (msg == IdRequest) (threadDelay $ 10 ^ 3) ) mmsg @@ -158,48 +163,42 @@ receiveMessage sock queue = do handleMessage :: StateContainer -> ReaderContainer + -> ClientMessage -> IO () -handleMessage stateContainer readerContainer = do - let queue = scMessageQueue stateContainer - clientList = scClientSockets stateContainer - msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue +handleMessage stateContainer readerContainer msg = do + let clientList = scClientSockets stateContainer clients <- liftIO $ STM.atomically $ STM.readTMVar clientList - mapM_ - (\msg -> liftIO $ do - putStrLn "Handling following:" - print msg - case msg of - IdRequest -> do - clientId <- nextRandom - let clientIdx = findIndex (\a -> fst a == Nothing) clients - let clientSock = snd $ clients !! fromJust clientIdx - sendMessage (AcceptClient clientId) clientSock - putStrLn $ "Accepted Client with UUID " <> show clientId - let newClients = map - (\old@(muuid, oldClientSock) -> - if oldClientSock == clientSock && muuid == Nothing - then - (Just clientId, clientSock) - else - old - ) - clients - void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients - ClientMessage clientId payload -> - case payload of - ClientQuit -> do - putStrLn $ "removing client " <> show clientId - let newClients = filter (\a -> fst a /= Just clientId) clients - void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients - ClientRequestWizard -> do - putStrLn "initializing new wizard" - let arena = rcMap readerContainer - initPos <- rollInitPosition arena - let clientSock = fromJust $ lookup (Just clientId) clients - sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock - _ -> pure () - ) - msgs + putStrLn $ "Handling following: " <> show msg + case msg of + IdRequest -> do + clientId <- nextRandom + let clientIdx = findIndex (\a -> fst a == Nothing) clients + let clientSock = snd $ clients !! fromJust clientIdx + let newClients = map + (\old@(muuid, oldClientSock) -> + if oldClientSock == clientSock && muuid == Nothing + then + (Just clientId, clientSock) + else + old + ) + clients + void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients + putStrLn $ "Accepted Client with UUID " <> show clientId + sendMessage (AcceptClient clientId) clientSock + ClientMessage clientId payload -> + case payload of + ClientQuit -> do + putStrLn $ "removing client " <> show clientId + let newClients = filter (\a -> fst a /= Just clientId) clients + void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients + ClientRequestWizard -> do + putStrLn "initializing new wizard" + let arena = rcMap readerContainer + initPos <- rollInitPosition arena + let clientSock = fromJust $ lookup (Just clientId) clients + sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock + _ -> pure () newWizard :: Position