module NetworkedGame.Server
(NetworkServer(..), Handles, ConnectionId,
serverMain, announce, announceOne
)
where
import Control.Concurrent (forkIO, threadDelay, ThreadId,
Chan, newChan, readChan, writeChan)
import Control.Exception (SomeException, handle, bracket_)
import Control.Monad (forM_, forever, when)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Binary (Binary, encode, decode)
import Data.Foldable (for_)
import Data.Int (Int64)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Network (PortID, accept, listenOn, Socket)
import Network.Socket (getSocketName)
import System.IO (Handle)
import qualified Data.ByteString.Lazy as B
import NetworkedGame.Handles
import NetworkedGame.Packet
data NetworkServer c w = NetworkServer
{ serverPort :: PortID
, eventsPerSecond :: Int
, onTick :: Handles -> Float -> w -> IO w
, onConnect :: Handles -> ConnectionId -> w -> IO w
, onDisconnect :: Handles -> ConnectionId -> w -> IO w
, onCommand :: Handles -> ConnectionId -> c -> w -> IO w
}
serverMain ::
Binary c =>
NetworkServer c w ->
w ->
IO ()
serverMain env w =
do events <- newChan
_acceptThreadId <- startNetwork env events
lastTick <- getCurrentTime
_tickThreadId <- forkIO $ tickThread env events
eventLoop env events emptyHandles w lastTick
startNetwork ::
Binary c =>
NetworkServer c w ->
Chan (ServerEvent c) ->
IO ThreadId
startNetwork env events =
do sock <- listenOn $ serverPort env
sockName <- getSocketName sock
putStrLn $ "Server listening on " ++ show sockName
forkIO $ mapM_ (acceptClient events sock . ConnectionId) [0..]
acceptClient ::
Binary c =>
Chan (ServerEvent c) ->
Socket ->
ConnectionId ->
IO ThreadId
acceptClient events sock i =
do (h,host,port) <- accept sock
putStrLn $ concat ["Got connection from ", host, ":", show port]
forkIO $ bracket_ (writeChan events $ JoinEvent i h)
(writeChan events $ DisconnectEvent i)
(clientSocketLoop i h events)
clientSocketLoop ::
Binary c =>
ConnectionId -> Handle -> Chan (ServerEvent c) -> IO ()
clientSocketLoop i h events =
handle ignoreExceptions $
forever $ do msg <- hGetPacketed h
writeChan events $ ClientEvent i msg
announce :: (MonadIO m, Binary c) =>
Handles ->
c ->
m ()
announce hs msg = liftIO $
do let p = mkPacket msg
forHandles_ hs $ \h ->
handle ignoreExceptions $
hPutPacket h p
announceOne ::
(MonadIO m, Binary c) =>
Handles ->
ConnectionId ->
c ->
m ()
announceOne hs i msg = liftIO $
let p = mkPacket msg in
for_ (lookupHandle i hs) $ \h ->
handle ignoreExceptions $
hPutPacket h p
ignoreExceptions :: SomeException -> IO ()
ignoreExceptions _ = return ()
tickThread ::
NetworkServer c w ->
Chan (ServerEvent c) ->
IO ()
tickThread env events =
when (eventsPerSecond env > 0) $
forever $ do writeChan events TickEvent
threadDelay $ 1000000 `div` eventsPerSecond env
data ServerEvent c
= TickEvent
| JoinEvent ConnectionId Handle
| DisconnectEvent ConnectionId
| ClientEvent ConnectionId c
eventLoop ::
NetworkServer c w ->
Chan (ServerEvent c) ->
Handles ->
w ->
UTCTime ->
IO ()
eventLoop env events = loop
where
loop hs w lastTick = do
event <- readChan events
case event of
JoinEvent i h ->
do let hs' = addHandle i h hs
w' <- onConnect env hs' i w
loop hs' w' lastTick
TickEvent ->
do now <- getCurrentTime
let elapsed = realToFrac (diffUTCTime now lastTick)
w' <- onTick env hs elapsed w
loop hs w' now
ClientEvent i c ->
do w' <- onCommand env hs i c w
loop hs w' lastTick
DisconnectEvent i ->
do let hs' = removeHandle i hs
w' <- onDisconnect env hs i w
loop hs' w' lastTick