restructure

This commit is contained in:
nek0 2024-05-01 23:52:49 +02:00
parent 9a2786fa2d
commit 34ae1d4de4
7 changed files with 400 additions and 310 deletions

View file

@ -1,5 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Server.Communication where
module Server.Communication
( module Server.Communication
, module S
) where
import Control.Concurrent
@ -13,24 +16,6 @@ import Control.Monad.IO.Class
import Control.Monad.RWS.Strict
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.List
import Data.Maybe
import Data.UUID hiding (null)
import Data.UUID.V4
import Data.Time
import qualified Data.Vector.Storable as VS
import Foreign hiding (void)
import Network.Socket as Net
import System.Posix.Signals
@ -39,8 +24,10 @@ import System.Posix.Signals
import Library.Types
import Server.Communication.Handler as S
import Server.Communication.Receive as S
import Server.Communication.Send as S
import Server.Types
import Server.Util
-- | Function which determines whether the given filePath is a supported socket path and
-- subsequently creates a socket in said location.
@ -97,26 +84,6 @@ disconnectClients clientList clients = do
)
clients
-- | Drops the client from internal management and closes its socket, if still present.
dropClient
:: STM.TMVar [ClientComms]
-> Socket
-> IO ()
dropClient clientList sock = do
mclient <- STM.atomically $ do
clients <- STM.readTMVar clientList
let mclient = find (\client -> ccSocket client == sock) clients
let reducedClients = filter (\client -> ccSocket client /= sock) clients
void $ STM.swapTMVar clientList reducedClients
pure mclient
maybe
(putStrLn $ "closing unknown socket: " <> show sock)
(\client -> do
putStrLn $ "dropping client: " <> show (fromJust $ ccUUID client)
killThread (ccListener client)
)
mclient
close sock
-- | Process incoming connection requests
processRequests :: Game ()
@ -143,211 +110,3 @@ processRequests = do
abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
unless abortCondition $
acceptConnection mainSocket socketList queue st
-- | Sends a specified message through given socket to the client
sendMessage
:: ServerMessage
-> UUID
-> STM.TMVar [ClientComms]
-> IO ()
sendMessage msg uuid clientList = do
clients <- STM.atomically $ STM.readTMVar clientList
let mSock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
-- putStrLn $ "Sending: " <> B8.unpack msgJson
maybe
(putStrLn $ "unknown client UUID: " <> show uuid)
(\sock ->
VS.unsafeWith
msgVector
(\ptr -> do
eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
case eResult of
Left (_ :: IOException) ->
putStrLn $ "cant reach client " <> show uuid
Right _ ->
pure ()
)
)
mSock
-- | handle received messages
handleMessages :: Game ()
handleMessages = do
queue <- gets scMessageQueue
serverState <- get
readerContainer <- ask
liftIO $ do
msgs <- STM.atomically $ do
emptyState <- STM.isEmptyTQueue queue
if emptyState
then
pure []
else
STM.flushTQueue queue
void $ do
mapM_
(handleMessage serverState readerContainer)
msgs
-- | receive a 'ClientMessage'
receiveMessage
:: Socket
-> STM.TQueue ClientMessage
-> STM.TMVar [ClientComms]
-> IO ()
receiveMessage sock queue clientList = do
let maxBufferLength = 4096
mMsg <- do
ptr <- mallocArray maxBufferLength
eBufferLength <-
try $ recvBuf sock ptr maxBufferLength
bufferLength <- case eBufferLength of
Left (_ :: IOException) -> do
putStrLn "Socket vanished, cleaning up…"
dropClient clientList sock
pure 0
Right len -> pure len
msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
free ptr
if bufferLength > 0
then
pure mJsonMsg
else
pure Nothing
maybe
(pure ())
(\msg -> do
liftIO $ STM.atomically $ STM.writeTQueue queue msg
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
)
mMsg
-- | function for translating 'ClientMessage's into server actions
handleMessage
:: StateContainer
-> ReaderContainer
-> ClientMessage
-> IO ()
handleMessage stateContainer readerContainer msg = do
let clientList = scClientSockets stateContainer
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
-- putStrLn $ "Handling: " <> show msg
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (isNothing . ccUUID) clients
clientSock = ccSocket $ clients !! fromJust clientIdx
newClients = map
(\old@(ClientComms mUUID oldClientSock _) ->
if oldClientSock == clientSock && isNothing mUUID
then
old
{ ccUUID = Just clientId
}
else
old
)
clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
putStrLn $ "Accepted Client with UUID " <> show clientId
sendMessage (AcceptClient clientId) clientId clientList
ClientMessage clientId payload ->
case payload of
ClientQuit -> do
putStrLn $ "client " <> show clientId <> " has quit the game"
let client = find (\a -> ccUUID a == Just clientId) clients
dropClient clientList (ccSocket $ fromJust client)
ClientRequestWizard -> do
putStrLn "initializing new wizard"
let arena = rcMap readerContainer
initPos <- rollInitPosition arena
now <- liftIO getCurrentTime
uuid <- nextRandom
let freshWizard = newWizard initPos
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
void $ STM.swapTMVar (scPlayers stateContainer) $
Player clientId freshWizard False (now, uuid) : currentPlayers
sendMessage (ProvideInitialWizard freshWizard) clientId clientList
ClientReady -> do
putStrLn $ "client " <> show clientId <> " is ready!"
now <- getCurrentTime
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
let (thisPlayers, otherPlayers) =
partition (\p -> playerId p == clientId) currentPlayers
unless (null thisPlayers) $
void $ STM.swapTMVar (scPlayers stateContainer) $
(head thisPlayers)
{ playerReady = True
, playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
}
: otherPlayers
Pong uuid -> do
let mclient = find (\c -> ccUUID c == Just clientId) clients
maybe
(putStrLn $ "Who is " <> show uuid <> "?")
(\_ -> do
mPlayer <- STM.atomically $ do
players <- STM.readTMVar (scPlayers stateContainer)
pure $ find (\p -> playerId p == clientId) players
maybe
(pure ())
(\player ->
if snd (playerLastPong player) /= uuid
then
putStrLn $ "Pong ID mismatch from " <> show clientId
else do
now <- getCurrentTime
STM.atomically$ do
players <- STM.readTMVar (scPlayers stateContainer)
let otherPlayers = filter (\a -> playerId a /= playerId player) players
modPlayer = player
{ playerLastPong = (now, uuid)
}
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
)
mPlayer
)
mclient
sendPings :: Game ()
sendPings = do
now <- liftIO getCurrentTime
maxTimeout <- asks rcClientMaxTimeout
framesPerPing <- asks rcFramesPerPing
fps <- asks rcFPS
stateContainer <- get
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
mapM_
(\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
when (isJust clientSock) $
if timeDiff > realToFrac maxTimeout
then do
liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock)
put stateContainer
else do
random <- liftIO nextRandom
let newPong = (now, random)
liftIO $ sendMessage
( Ping random
)
plId
(scClientSockets stateContainer)
let newPlayer = player
{ playerLastPong = newPong
}
otherPlayers = filter (\a -> playerId a /= plId) players
liftIO $ void $ STM.atomically $
STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
)
players
put stateContainer

View file

@ -0,0 +1,130 @@
module Server.Communication.Handler where
import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Time
import Data.UUID.V4
import Library.Types
import Server.Communication.Send
import Server.Types
import Server.Util
-- | function for translating 'ClientMessage's into server actions
handleMessage
:: StateContainer
-> ReaderContainer
-> ClientMessage
-> IO ()
handleMessage stateContainer readerContainer msg = do
let clientList = scClientSockets stateContainer
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
-- putStrLn $ "Handling: " <> show msg
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (isNothing . ccUUID) clients
clientSock = ccSocket $ clients !! fromJust clientIdx
newClients = map
(\old@(ClientComms mUUID oldClientSock _) ->
if oldClientSock == clientSock && isNothing mUUID
then
old
{ ccUUID = Just clientId
}
else
old
)
clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
putStrLn $ "Accepted Client with UUID " <> show clientId
sendMessage (AcceptClient clientId) clientId clientList
ClientMessage clientId payload ->
case payload of
ClientQuit -> do
putStrLn $ "client " <> show clientId <> " has quit the game"
let client = find (\a -> ccUUID a == Just clientId) clients
dropClient clientList (ccSocket $ fromJust client)
ClientRequestWizard -> do
putStrLn "initializing new wizard"
let arena = rcMap readerContainer
initPos <- rollInitPosition arena
now <- liftIO getCurrentTime
uuid <- nextRandom
let freshWizard = newWizard initPos
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
void $ STM.swapTMVar (scPlayers stateContainer) $
Player clientId freshWizard False (now, uuid) : currentPlayers
sendMessage (ProvideInitialWizard freshWizard) clientId clientList
ClientReady -> do
putStrLn $ "client " <> show clientId <> " is ready!"
now <- getCurrentTime
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
let (thisPlayers, otherPlayers) =
partition (\p -> playerId p == clientId) currentPlayers
unless (null thisPlayers) $
void $ STM.swapTMVar (scPlayers stateContainer) $
(head thisPlayers)
{ playerReady = True
, playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
}
: otherPlayers
Pong uuid -> do
let mclient = find (\c -> ccUUID c == Just clientId) clients
maybe
(putStrLn $ "Who is " <> show uuid <> "?")
(\_ -> do
mPlayer <- STM.atomically $ do
players <- STM.readTMVar (scPlayers stateContainer)
pure $ find (\p -> playerId p == clientId) players
maybe
(pure ())
(\player ->
if snd (playerLastPong player) /= uuid
then
putStrLn $ "Pong ID mismatch from " <> show clientId
else do
now <- getCurrentTime
STM.atomically$ do
players <- STM.readTMVar (scPlayers stateContainer)
let otherPlayers = filter (\a -> playerId a /= playerId player) players
modPlayer = player
{ playerLastPong = (now, uuid)
}
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
)
mPlayer
)
mclient
-- | handle received messages
handleMessages :: Game ()
handleMessages = do
queue <- gets scMessageQueue
serverState <- get
readerContainer <- ask
liftIO $ do
msgs <- STM.atomically $ do
emptyState <- STM.isEmptyTQueue queue
if emptyState
then
pure []
else
STM.flushTQueue queue
void $ do
mapM_
(handleMessage serverState readerContainer)
msgs

View file

@ -0,0 +1,55 @@
module Server.Communication.Receive where
import qualified Control.Concurrent.STM as STM
import Control.Exception
import Control.Monad.IO.Class
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Foreign.Marshal
import Network.Socket
import Library.Types
import Server.Communication.Send
import Server.Types
-- | receive a 'ClientMessage'
receiveMessage
:: Socket
-> STM.TQueue ClientMessage
-> STM.TMVar [ClientComms]
-> IO ()
receiveMessage sock queue clientList = do
let maxBufferLength = 4096
mMsg <- do
ptr <- mallocArray maxBufferLength
eBufferLength <-
try $ recvBuf sock ptr maxBufferLength
bufferLength <- case eBufferLength of
Left (_ :: IOException) -> do
putStrLn "Socket vanished, cleaning up…"
dropClient clientList sock
pure 0
Right len -> pure len
msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
free ptr
if bufferLength > 0
then
pure mJsonMsg
else
pure Nothing
maybe
(pure ())
(\msg -> do
liftIO $ STM.atomically $ STM.writeTQueue queue msg
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
)
mMsg

View file

@ -0,0 +1,127 @@
module Server.Communication.Send where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Aeson as A
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Time
import qualified Data.Vector.Storable as VS
import Data.List
import Data.UUID
import Data.UUID.V4
import Network.Socket
-- internal imports
import Library.Types
import Server.Types
-- | Sends a specified message through given socket to the client
sendMessage
:: ServerMessage
-> UUID
-> STM.TMVar [ClientComms]
-> IO ()
sendMessage msg uuid clientList = do
clients <- STM.atomically $ STM.readTMVar clientList
let mSock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
-- putStrLn $ "Sending: " <> B8.unpack msgJson
maybe
(putStrLn $ "unknown client UUID: " <> show uuid)
(\sock ->
VS.unsafeWith
msgVector
(\ptr -> do
eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
case eResult of
Left (_ :: IOException) ->
putStrLn $ "cant reach client " <> show uuid
Right _ ->
pure ()
)
)
mSock
sendPings :: Game ()
sendPings = do
now <- liftIO getCurrentTime
maxTimeout <- asks rcClientMaxTimeout
framesPerPing <- asks rcFramesPerPing
fps <- asks rcFPS
stateContainer <- get
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
mapM_
(\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
when (isJust clientSock) $
if timeDiff > realToFrac maxTimeout
then do
liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock)
put stateContainer
else do
random <- liftIO nextRandom
let newPong = (now, random)
liftIO $ sendMessage
( Ping random
)
plId
(scClientSockets stateContainer)
let newPlayer = player
{ playerLastPong = newPong
}
otherPlayers = filter (\a -> playerId a /= plId) players
liftIO $ void $ STM.atomically $
STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
)
players
put stateContainer
-- | Drops the client from internal management and closes its socket, if still present.
dropClient
:: STM.TMVar [ClientComms]
-> Socket
-> IO ()
dropClient clientList sock = do
mClient <- STM.atomically $ do
clients <- STM.readTMVar clientList
let mclient = find (\client -> ccSocket client == sock) clients
let reducedClients = filter (\client -> ccSocket client /= sock) clients
void $ STM.swapTMVar clientList reducedClients
pure mclient
maybe
(putStrLn $ "closing unknown socket: " <> show sock)
(\client -> do
putStrLn $ "dropping client: " <> show (fromJust $ ccUUID client)
killThread (ccListener client)
)
mClient
close sock
sendUpdates
:: Game ()
sendUpdates = pure ()

View file

@ -21,8 +21,7 @@ import System.IO (stdout)
-- internal imports
import Library.Types
import Server.Game.Update
import Server.Communication
import Server.Types
@ -39,6 +38,7 @@ runGame = do
handleMessages
updateSpawners delta
updateWizards delta
sendUpdates
modify'
(\s -> s
{ scServerLastTick = now
@ -52,63 +52,3 @@ runGame = do
)
liftIO $ threadDelay (10 ^ 6)
-- liftIO $ killThread recvThread
updateSpawners :: Float -> Game ()
updateSpawners dt =
modify' (\sc@(StateContainer spawners _ _ _ _ _) ->
let newSpawners = map
(\spawner -> do
let newTTL = spawnerReloadTTL spawner - dt
if newTTL < 0 && spawnerState spawner == SpawnerEmpty
then spawner
{ spawnerReloadTTL = fromIntegral $ spawnerReloadTime spawner
, spawnerState = SpawnerFull
}
else spawner
{ spawnerReloadTTL = spawnerReloadTTL spawner - dt
}
)
spawners
in sc
{ scSpawners = newSpawners
}
)
updateWizards :: Float -> Game ()
updateWizards dt = do
playersVar <- gets scPlayers
players <- liftIO $ STM.atomically $ STM.readTMVar playersVar
let newPlayers = map
(\player@(Player pId wizard@(Wizard _ _ health _ _ effects) readiness lastPong) ->
let newEffects = foldl
(\acc effect@(Effect _ ttl) ->
if ttl - dt < 0
then acc
else effect
{ effectTTL = ttl - dt
} : acc
)
[]
effects
effectDamage = foldl
(\acc (Effect kind _) ->
if kind `elem` harmingAfflictions
then acc + 1
else acc
)
0
effects
in
if readiness
then
player
{ playerWizard = wizard
{ wizardEffects = newEffects
, wizardHealth = health - effectDamage
}
}
else
player
)
players
void $ liftIO $ STM.atomically $ STM.swapTMVar playersVar newPlayers

View file

@ -0,0 +1,75 @@
module Server.Game.Update where
import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
-- internal imports
import Library.Types
import Server.Types
updateSpawners :: Float -> Game ()
updateSpawners dt =
modify' (\sc@(StateContainer spawners _ _ _ _ _) ->
let newSpawners = map
(\spawner -> do
let newTTL = spawnerReloadTTL spawner - dt
if newTTL < 0 && spawnerState spawner == SpawnerEmpty
then spawner
{ spawnerReloadTTL = fromIntegral $ spawnerReloadTime spawner
, spawnerState = SpawnerFull
}
else spawner
{ spawnerReloadTTL = spawnerReloadTTL spawner - dt
}
)
spawners
in sc
{ scSpawners = newSpawners
}
)
updateWizards :: Float -> Game ()
updateWizards dt = do
playersVar <- gets scPlayers
players <- liftIO $ STM.atomically $ STM.readTMVar playersVar
let newPlayers = map
(\player@(Player pId wizard@(Wizard _ _ health _ _ effects) readiness lastPong) ->
let newEffects = foldl
(\acc effect@(Effect _ ttl) ->
if ttl - dt < 0
then acc
else effect
{ effectTTL = ttl - dt
} : acc
)
[]
effects
effectDamage = foldl
(\acc (Effect kind _) ->
if kind `elem` harmingAfflictions
then acc + 1
else acc
)
0
effects
in
if readiness
then
player
{ playerWizard = wizard
{ wizardEffects = newEffects
, wizardHealth = health - effectDamage
}
}
else
player
)
players
void $ liftIO $ STM.atomically $ STM.swapTMVar playersVar newPlayers

View file

@ -63,7 +63,11 @@ executable wizard-wipeout-server
import: warnings
main-is: Main.hs
other-modules: Server.Communication
Server.Communication.Handler
Server.Communication.Receive
Server.Communication.Send
Server.Game
Server.Game.Update
Server.Map
Server.Types
Server.Util