module Netcode.IO.Server (
ServerConnectDisconnectCallback
, ServerConfig
, defaultServerConfig
, setProtocolID
, setPrivateKey
, setServerConnectDisconnectCallback, clearServerConnectDisconnectCallback
, setServerSendReceiveOverrides, clearServerSendReceiveOverrides
, Server
, createServer
, destroyServer
, startServer
, maxNumClients
, stopServer
, updateServer
, clientConnectedAtIndex
, clientIdAtIndex
, withClientAddressAtIndex
, withClientUserDataAtIndex
, clientUserDataAtIndex
, maxClientsForServer
, numConnectedClients
, isServerRunning
, isServerFull
, getServerPort
, sendPacketFromServer
, broadcastPacketFromServer
, disconnectClientFromServer
, disconnectAllClientsFromServer
, receivePacketFromClient
, nextServerPacketSequence
) where
import Control.Applicative (liftA2)
import Control.Monad (when, forM_)
import Data.Word (Word8, Word16, Word64)
import Foreign.C.String (withCString)
import Foreign.C.Types (CDouble(..))
import Foreign.Concurrent (newForeignPtr)
import Foreign.ForeignPtr (newForeignPtr_)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (peekArray)
import Foreign.Ptr ( Ptr, nullPtr, castPtr
, FunPtr, nullFunPtr, freeHaskellFunPtr
)
import Foreign.Storable (peek, poke)
import Bindings.Netcode.IO
import Netcode.IO.Address
import Netcode.IO.Callbacks
import Netcode.IO.Packet
freeNullFunPtr :: FunPtr a -> IO ()
freeNullFunPtr :: FunPtr a -> IO ()
freeNullFunPtr FunPtr a
x
| FunPtr a
x FunPtr a -> FunPtr a -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr a
forall a. FunPtr a
nullFunPtr = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = FunPtr a -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr a
x
data Server = Server
{ Server -> Ptr C'netcode_server_t
serverPtr :: Ptr C'netcode_server_t
, Server -> ServerCallbacks
serverCallbacks :: ServerCallbacks
} deriving (Int -> Server -> ShowS
[Server] -> ShowS
Server -> String
(Int -> Server -> ShowS)
-> (Server -> String) -> ([Server] -> ShowS) -> Show Server
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Server] -> ShowS
$cshowList :: [Server] -> ShowS
show :: Server -> String
$cshow :: Server -> String
showsPrec :: Int -> Server -> ShowS
$cshowsPrec :: Int -> Server -> ShowS
Show)
data ServerCallbacks = ServerCallbacks
{ ServerCallbacks -> C'connect_disconnect_callback_t
serverConnectDisconnect :: C'connect_disconnect_callback_t
, ServerCallbacks -> C'send_packet_override_t
serverSendPacketOverride :: C'send_packet_override_t
, ServerCallbacks -> C'receive_packet_override_t
serverReceivePacketOverride :: C'receive_packet_override_t
} deriving (Int -> ServerCallbacks -> ShowS
[ServerCallbacks] -> ShowS
ServerCallbacks -> String
(Int -> ServerCallbacks -> ShowS)
-> (ServerCallbacks -> String)
-> ([ServerCallbacks] -> ShowS)
-> Show ServerCallbacks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerCallbacks] -> ShowS
$cshowList :: [ServerCallbacks] -> ShowS
show :: ServerCallbacks -> String
$cshow :: ServerCallbacks -> String
showsPrec :: Int -> ServerCallbacks -> ShowS
$cshowsPrec :: Int -> ServerCallbacks -> ShowS
Show)
defaultServerCallbacks :: ServerCallbacks
defaultServerCallbacks :: ServerCallbacks
defaultServerCallbacks = C'connect_disconnect_callback_t
-> C'send_packet_override_t
-> C'receive_packet_override_t
-> ServerCallbacks
ServerCallbacks C'connect_disconnect_callback_t
forall a. FunPtr a
nullFunPtr C'send_packet_override_t
forall a. FunPtr a
nullFunPtr C'receive_packet_override_t
forall a. FunPtr a
nullFunPtr
newtype ServerConfig = ServerConfig
( Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
)
defaultServerConfig :: ServerConfig
defaultServerConfig :: ServerConfig
defaultServerConfig = (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
ServerConfig ((Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig)
-> (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
serverConfig ServerCallbacks
cbs -> do
Ptr C'netcode_server_config_t -> IO ()
c'netcode_default_server_config Ptr C'netcode_server_config_t
serverConfig
(Ptr C'netcode_server_config_t, ServerCallbacks)
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_config_t
serverConfig, ServerCallbacks
cbs)
setProtocolID :: Word64 -> ServerConfig -> ServerConfig
setProtocolID :: Word64 -> ServerConfig -> ServerConfig
setProtocolID Word64
protocolID (ServerConfig Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkServerPtr) =
(Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
ServerConfig ((Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig)
-> (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
serverConfig ServerCallbacks
cbs' -> do
(Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
cbs) <- Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkServerPtr Ptr C'netcode_server_config_t
serverConfig ServerCallbacks
cbs'
C'netcode_server_config_t
config <- Ptr C'netcode_server_config_t -> IO C'netcode_server_config_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'netcode_server_config_t
configPtr
Ptr C'netcode_server_config_t -> C'netcode_server_config_t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr C'netcode_server_config_t
configPtr (C'netcode_server_config_t -> IO ())
-> C'netcode_server_config_t -> IO ()
forall a b. (a -> b) -> a -> b
$
C'netcode_server_config_t
config { c'netcode_server_config_t'protocol_id :: Word64
c'netcode_server_config_t'protocol_id = Word64
protocolID }
(Ptr C'netcode_server_config_t, ServerCallbacks)
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
cbs)
setPrivateKey :: [Word8] -> ServerConfig -> ServerConfig
setPrivateKey :: [Word8] -> ServerConfig -> ServerConfig
setPrivateKey [Word8]
key (ServerConfig Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkServerPtr) =
(Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
ServerConfig ((Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig)
-> (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
serverConfig ServerCallbacks
cbs' -> do
(Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
cbs) <- Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkServerPtr Ptr C'netcode_server_config_t
serverConfig ServerCallbacks
cbs'
C'netcode_server_config_t
config <- Ptr C'netcode_server_config_t -> IO C'netcode_server_config_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'netcode_server_config_t
configPtr
Ptr C'netcode_server_config_t -> C'netcode_server_config_t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr C'netcode_server_config_t
configPtr (C'netcode_server_config_t -> IO ())
-> C'netcode_server_config_t -> IO ()
forall a b. (a -> b) -> a -> b
$
C'netcode_server_config_t
config {
c'netcode_server_config_t'private_key :: [Word8]
c'netcode_server_config_t'private_key =
Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take Int
forall a. Num a => a
c'NETCODE_KEY_BYTES ([Word8]
key [Word8] -> [Word8] -> [Word8]
forall a. Semigroup a => a -> a -> a
<> Word8 -> [Word8]
forall a. a -> [a]
repeat Word8
0)
}
(Ptr C'netcode_server_config_t, ServerCallbacks)
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
cbs)
type ServerConnectDisconnectCallback
= Int
-> Bool
-> IO ()
mkServerConnectDisconnectCallback :: ServerConnectDisconnectCallback
-> IO C'connect_disconnect_callback_t
mkServerConnectDisconnectCallback :: ServerConnectDisconnectCallback
-> IO C'connect_disconnect_callback_t
mkServerConnectDisconnectCallback ServerConnectDisconnectCallback
cb = (Ptr () -> CInt -> CInt -> IO ())
-> IO C'connect_disconnect_callback_t
mk'connect_disconnect_callback_t ((Ptr () -> CInt -> CInt -> IO ())
-> IO C'connect_disconnect_callback_t)
-> (Ptr () -> CInt -> CInt -> IO ())
-> IO C'connect_disconnect_callback_t
forall a b. (a -> b) -> a -> b
$
\Ptr ()
_ CInt
clientIdx CInt
connected -> ServerConnectDisconnectCallback
cb (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
clientIdx) (CInt
connected CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0)
setServerConnectDisconnectCallback :: ServerConnectDisconnectCallback
-> ServerConfig -> ServerConfig
setServerConnectDisconnectCallback :: ServerConnectDisconnectCallback -> ServerConfig -> ServerConfig
setServerConnectDisconnectCallback ServerConnectDisconnectCallback
cb (ServerConfig Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig) =
(Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
ServerConfig ((Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig)
-> (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks' -> do
(Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
callbacks) <- Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks'
C'connect_disconnect_callback_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'connect_disconnect_callback_t -> IO ())
-> C'connect_disconnect_callback_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'connect_disconnect_callback_t
serverConnectDisconnect ServerCallbacks
callbacks
C'connect_disconnect_callback_t
fPtr <- ServerConnectDisconnectCallback
-> IO C'connect_disconnect_callback_t
mkServerConnectDisconnectCallback ServerConnectDisconnectCallback
cb
C'netcode_server_config_t
config <- Ptr C'netcode_server_config_t -> IO C'netcode_server_config_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'netcode_server_config_t
configPtr
Ptr C'netcode_server_config_t -> C'netcode_server_config_t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr C'netcode_server_config_t
configPtr (C'netcode_server_config_t -> IO ())
-> C'netcode_server_config_t -> IO ()
forall a b. (a -> b) -> a -> b
$ C'netcode_server_config_t
config
{ c'netcode_server_config_t'connect_disconnect_callback :: C'connect_disconnect_callback_t
c'netcode_server_config_t'connect_disconnect_callback = C'connect_disconnect_callback_t
fPtr
}
(Ptr C'netcode_server_config_t, ServerCallbacks)
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
callbacks { serverConnectDisconnect :: C'connect_disconnect_callback_t
serverConnectDisconnect = C'connect_disconnect_callback_t
fPtr })
clearServerConnectDisconnectCallback :: ServerConfig -> ServerConfig
clearServerConnectDisconnectCallback :: ServerConfig -> ServerConfig
clearServerConnectDisconnectCallback (ServerConfig Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig) =
(Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
ServerConfig ((Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig)
-> (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks' -> do
(Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
callbacks) <- Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks'
C'connect_disconnect_callback_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'connect_disconnect_callback_t -> IO ())
-> C'connect_disconnect_callback_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'connect_disconnect_callback_t
serverConnectDisconnect ServerCallbacks
callbacks
C'netcode_server_config_t
config <- Ptr C'netcode_server_config_t -> IO C'netcode_server_config_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'netcode_server_config_t
configPtr
Ptr C'netcode_server_config_t -> C'netcode_server_config_t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr C'netcode_server_config_t
configPtr (C'netcode_server_config_t -> IO ())
-> C'netcode_server_config_t -> IO ()
forall a b. (a -> b) -> a -> b
$ C'netcode_server_config_t
config
{ c'netcode_server_config_t'connect_disconnect_callback :: C'connect_disconnect_callback_t
c'netcode_server_config_t'connect_disconnect_callback = C'connect_disconnect_callback_t
forall a. FunPtr a
nullFunPtr
}
(Ptr C'netcode_server_config_t, ServerCallbacks)
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
callbacks { serverConnectDisconnect :: C'connect_disconnect_callback_t
serverConnectDisconnect = C'connect_disconnect_callback_t
forall a. FunPtr a
nullFunPtr })
setServerSendReceiveOverrides :: SendPacketOverride
-> ReceivePacketOverride
-> ServerConfig -> ServerConfig
setServerSendReceiveOverrides :: SendPacketOverride
-> ReceivePacketOverride -> ServerConfig -> ServerConfig
setServerSendReceiveOverrides SendPacketOverride
sendFn ReceivePacketOverride
recvFn (ServerConfig Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig) =
(Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
ServerConfig ((Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig)
-> (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks' -> do
(Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
callbacks) <- Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks'
C'send_packet_override_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'send_packet_override_t -> IO ())
-> C'send_packet_override_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'send_packet_override_t
serverSendPacketOverride ServerCallbacks
callbacks
C'receive_packet_override_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'receive_packet_override_t -> IO ())
-> C'receive_packet_override_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'receive_packet_override_t
serverReceivePacketOverride ServerCallbacks
callbacks
C'netcode_server_config_t
config <- Ptr C'netcode_server_config_t -> IO C'netcode_server_config_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'netcode_server_config_t
configPtr
C'send_packet_override_t
sendOverride <- SendPacketOverride -> IO C'send_packet_override_t
mkSendPacketOverride SendPacketOverride
sendFn
C'receive_packet_override_t
recvOverride <- ReceivePacketOverride -> IO C'receive_packet_override_t
mkReceivePacketOverride ReceivePacketOverride
recvFn
Ptr C'netcode_server_config_t -> C'netcode_server_config_t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr C'netcode_server_config_t
configPtr (C'netcode_server_config_t -> IO ())
-> C'netcode_server_config_t -> IO ()
forall a b. (a -> b) -> a -> b
$ C'netcode_server_config_t
config
{ c'netcode_server_config_t'send_packet_override :: C'send_packet_override_t
c'netcode_server_config_t'send_packet_override = C'send_packet_override_t
sendOverride
, c'netcode_server_config_t'receive_packet_override :: C'receive_packet_override_t
c'netcode_server_config_t'receive_packet_override = C'receive_packet_override_t
recvOverride
, c'netcode_server_config_t'override_send_and_receive :: CInt
c'netcode_server_config_t'override_send_and_receive = CInt
1
}
let newcbs :: ServerCallbacks
newcbs = ServerCallbacks
callbacks
{ serverSendPacketOverride :: C'send_packet_override_t
serverSendPacketOverride = C'send_packet_override_t
sendOverride
, serverReceivePacketOverride :: C'receive_packet_override_t
serverReceivePacketOverride = C'receive_packet_override_t
recvOverride
}
(Ptr C'netcode_server_config_t, ServerCallbacks)
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
newcbs)
clearServerSendReceiveOverrides :: ServerConfig -> ServerConfig
clearServerSendReceiveOverrides :: ServerConfig -> ServerConfig
clearServerSendReceiveOverrides (ServerConfig Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig) =
(Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
ServerConfig ((Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig)
-> (Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks))
-> ServerConfig
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks' -> do
(Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
callbacks) <- Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig Ptr C'netcode_server_config_t
configPtr' ServerCallbacks
callbacks'
C'send_packet_override_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'send_packet_override_t -> IO ())
-> C'send_packet_override_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'send_packet_override_t
serverSendPacketOverride ServerCallbacks
callbacks
C'receive_packet_override_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'receive_packet_override_t -> IO ())
-> C'receive_packet_override_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'receive_packet_override_t
serverReceivePacketOverride ServerCallbacks
callbacks
C'netcode_server_config_t
config <- Ptr C'netcode_server_config_t -> IO C'netcode_server_config_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'netcode_server_config_t
configPtr
Ptr C'netcode_server_config_t -> C'netcode_server_config_t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr C'netcode_server_config_t
configPtr (C'netcode_server_config_t -> IO ())
-> C'netcode_server_config_t -> IO ()
forall a b. (a -> b) -> a -> b
$ C'netcode_server_config_t
config
{ c'netcode_server_config_t'send_packet_override :: C'send_packet_override_t
c'netcode_server_config_t'send_packet_override = C'send_packet_override_t
forall a. FunPtr a
nullFunPtr
, c'netcode_server_config_t'receive_packet_override :: C'receive_packet_override_t
c'netcode_server_config_t'receive_packet_override = C'receive_packet_override_t
forall a. FunPtr a
nullFunPtr
, c'netcode_server_config_t'override_send_and_receive :: CInt
c'netcode_server_config_t'override_send_and_receive = CInt
0
}
let newcbs :: ServerCallbacks
newcbs = ServerCallbacks
callbacks
{ serverSendPacketOverride :: C'send_packet_override_t
serverSendPacketOverride = C'send_packet_override_t
forall a. FunPtr a
nullFunPtr
, serverReceivePacketOverride :: C'receive_packet_override_t
serverReceivePacketOverride = C'receive_packet_override_t
forall a. FunPtr a
nullFunPtr
}
(Ptr C'netcode_server_config_t, ServerCallbacks)
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_config_t
configPtr, ServerCallbacks
newcbs)
createServer :: String -> ServerConfig -> Double -> IO Server
createServer :: String -> ServerConfig -> Double -> IO Server
createServer String
s (ServerConfig Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig) Double
time = (Ptr C'netcode_server_config_t -> IO Server) -> IO Server
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr C'netcode_server_config_t -> IO Server) -> IO Server)
-> (Ptr C'netcode_server_config_t -> IO Server) -> IO Server
forall a b. (a -> b) -> a -> b
$ \Ptr C'netcode_server_config_t
serverConfig -> do
(Ptr C'netcode_server_config_t
config, ServerCallbacks
cbs) <- Ptr C'netcode_server_config_t
-> ServerCallbacks
-> IO (Ptr C'netcode_server_config_t, ServerCallbacks)
mkConfig Ptr C'netcode_server_config_t
serverConfig ServerCallbacks
defaultServerCallbacks
Ptr C'netcode_server_t
ptr <- String
-> (CString -> IO (Ptr C'netcode_server_t))
-> IO (Ptr C'netcode_server_t)
forall a. String -> (CString -> IO a) -> IO a
withCString String
s (\CString
cs -> CString
-> Ptr C'netcode_server_config_t
-> CDouble
-> IO (Ptr C'netcode_server_t)
c'netcode_server_create CString
cs Ptr C'netcode_server_config_t
config (Double -> CDouble
CDouble Double
time))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr C'netcode_server_t
ptr Ptr C'netcode_server_t -> Ptr C'netcode_server_t -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr C'netcode_server_t
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to create server!"
Server -> IO Server
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'netcode_server_t -> ServerCallbacks -> Server
Server Ptr C'netcode_server_t
ptr ServerCallbacks
cbs)
startServer :: Server -> Int -> IO ()
startServer :: Server -> Int -> IO ()
startServer (Server Ptr C'netcode_server_t
s ServerCallbacks
_) Int
n = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forall a. Num a => a
maxNumClients) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
String
"Warning: Can only start server with at most "
, Int -> String
forall a. Show a => a -> String
show (Int
forall a. Num a => a
maxNumClients :: Int), String
" clients. Requested: ", Int -> String
forall a. Show a => a -> String
show Int
n
]
Ptr C'netcode_server_t -> CInt -> IO ()
c'netcode_server_start Ptr C'netcode_server_t
s (CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
min CInt
forall a. Num a => a
maxNumClients (CInt -> CInt) -> CInt -> CInt
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
maxNumClients :: Num a => a
maxNumClients :: a
maxNumClients = a
forall a. Num a => a
c'NETCODE_MAX_CLIENTS
stopServer :: Server -> IO ()
stopServer :: Server -> IO ()
stopServer (Server Ptr C'netcode_server_t
s ServerCallbacks
_) = Ptr C'netcode_server_t -> IO ()
c'netcode_server_stop Ptr C'netcode_server_t
s
destroyServer :: Server -> IO ()
destroyServer :: Server -> IO ()
destroyServer (Server Ptr C'netcode_server_t
s ServerCallbacks
cbs) = do
Ptr C'netcode_server_t -> IO ()
c'netcode_server_destroy Ptr C'netcode_server_t
s
C'connect_disconnect_callback_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'connect_disconnect_callback_t -> IO ())
-> C'connect_disconnect_callback_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'connect_disconnect_callback_t
serverConnectDisconnect ServerCallbacks
cbs
C'send_packet_override_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'send_packet_override_t -> IO ())
-> C'send_packet_override_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'send_packet_override_t
serverSendPacketOverride ServerCallbacks
cbs
C'receive_packet_override_t -> IO ()
forall a. FunPtr a -> IO ()
freeNullFunPtr (C'receive_packet_override_t -> IO ())
-> C'receive_packet_override_t -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerCallbacks -> C'receive_packet_override_t
serverReceivePacketOverride ServerCallbacks
cbs
updateServer :: Server -> Double -> IO ()
updateServer :: Server -> Double -> IO ()
updateServer (Server Ptr C'netcode_server_t
s ServerCallbacks
_) = Ptr C'netcode_server_t -> CDouble -> IO ()
c'netcode_server_update Ptr C'netcode_server_t
s (CDouble -> IO ()) -> (Double -> CDouble) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> CDouble
CDouble
clientConnectedAtIndex :: Server -> Int -> IO Bool
clientConnectedAtIndex :: Server -> Int -> IO Bool
clientConnectedAtIndex (Server Ptr C'netcode_server_t
s ServerCallbacks
_) =
(CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO CInt -> IO Bool) -> (Int -> IO CInt) -> Int -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr C'netcode_server_t -> CInt -> IO CInt
c'netcode_server_client_connected Ptr C'netcode_server_t
s (CInt -> IO CInt) -> (Int -> CInt) -> Int -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral
clientIdAtIndex :: Server -> Int -> IO Word64
clientIdAtIndex :: Server -> Int -> IO Word64
clientIdAtIndex (Server Ptr C'netcode_server_t
s ServerCallbacks
_) = Ptr C'netcode_server_t -> CInt -> IO Word64
c'netcode_server_client_id Ptr C'netcode_server_t
s (CInt -> IO Word64) -> (Int -> CInt) -> Int -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral
withClientAddressAtIndex :: Server -> Int -> (Address -> IO a) -> IO a
withClientAddressAtIndex :: Server -> Int -> (Address -> IO a) -> IO a
withClientAddressAtIndex (Server Ptr C'netcode_server_t
s ServerCallbacks
_) Int
cidx Address -> IO a
fn = do
Ptr C'netcode_address_t
aptr <- Ptr C'netcode_server_t -> CInt -> IO (Ptr C'netcode_address_t)
c'netcode_server_client_address Ptr C'netcode_server_t
s (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cidx)
if Ptr C'netcode_address_t
aptr Ptr C'netcode_address_t -> Ptr C'netcode_address_t -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr C'netcode_address_t
forall a. Ptr a
nullPtr
then String -> IO Address
parseAddress String
"0.0.0.0" IO Address -> (Address -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Address -> IO a
fn
else ForeignPtr C'netcode_address_t -> Address
Address (ForeignPtr C'netcode_address_t -> Address)
-> IO (ForeignPtr C'netcode_address_t) -> IO Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr C'netcode_address_t -> IO (ForeignPtr C'netcode_address_t)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr C'netcode_address_t
aptr IO Address -> (Address -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Address -> IO a
fn
withClientUserDataAtIndex :: Server -> Int -> (Ptr () -> IO a) -> IO a
withClientUserDataAtIndex :: Server -> Int -> (Ptr () -> IO a) -> IO a
withClientUserDataAtIndex (Server Ptr C'netcode_server_t
s ServerCallbacks
_) Int
cidx Ptr () -> IO a
fn =
Ptr C'netcode_server_t -> CInt -> IO (Ptr ())
c'netcode_server_client_user_data Ptr C'netcode_server_t
s (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cidx) IO (Ptr ()) -> (Ptr () -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr () -> IO a
fn
clientUserDataAtIndex :: Server -> Int -> IO [Word8]
clientUserDataAtIndex :: Server -> Int -> IO [Word8]
clientUserDataAtIndex Server
s Int
i = Server -> Int -> (Ptr () -> IO [Word8]) -> IO [Word8]
forall a. Server -> Int -> (Ptr () -> IO a) -> IO a
withClientUserDataAtIndex Server
s Int
i ((Ptr () -> IO [Word8]) -> IO [Word8])
-> (Ptr () -> IO [Word8]) -> IO [Word8]
forall a b. (a -> b) -> a -> b
$ \Ptr ()
ptr ->
if Ptr ()
ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
then [Word8] -> IO [Word8]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else Int -> Ptr Word8 -> IO [Word8]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
forall a. Num a => a
c'NETCODE_USER_DATA_BYTES (Ptr () -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
ptr)
maxClientsForServer :: Server -> IO Int
maxClientsForServer :: Server -> IO Int
maxClientsForServer (Server Ptr C'netcode_server_t
s ServerCallbacks
_) =
CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr C'netcode_server_t -> IO CInt
c'netcode_server_max_clients Ptr C'netcode_server_t
s
numConnectedClients :: Server -> IO Int
numConnectedClients :: Server -> IO Int
numConnectedClients (Server Ptr C'netcode_server_t
s ServerCallbacks
_) =
CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr C'netcode_server_t -> IO CInt
c'netcode_server_num_connected_clients Ptr C'netcode_server_t
s
isServerRunning :: Server -> IO Bool
isServerRunning :: Server -> IO Bool
isServerRunning (Server Ptr C'netcode_server_t
s ServerCallbacks
_) = (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr C'netcode_server_t -> IO CInt
c'netcode_server_running Ptr C'netcode_server_t
s
isServerFull :: Server -> IO Bool
isServerFull :: Server -> IO Bool
isServerFull (Server Ptr C'netcode_server_t
s ServerCallbacks
_) =
(CInt -> CInt -> Bool) -> IO CInt -> IO CInt -> IO Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Ptr C'netcode_server_t -> IO CInt
c'netcode_server_num_connected_clients Ptr C'netcode_server_t
s)
(Ptr C'netcode_server_t -> IO CInt
c'netcode_server_max_clients Ptr C'netcode_server_t
s)
getServerPort :: Server -> IO Word16
getServerPort :: Server -> IO Word16
getServerPort (Server Ptr C'netcode_server_t
s ServerCallbacks
_) = Ptr C'netcode_server_t -> IO Word16
c'netcode_server_get_port Ptr C'netcode_server_t
s
disconnectClientFromServer :: Server -> Int -> IO ()
disconnectClientFromServer :: Server -> Int -> IO ()
disconnectClientFromServer (Server Ptr C'netcode_server_t
s ServerCallbacks
_) =
Ptr C'netcode_server_t -> CInt -> IO ()
c'netcode_server_disconnect_client Ptr C'netcode_server_t
s (CInt -> IO ()) -> (Int -> CInt) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral
disconnectAllClientsFromServer :: Server -> IO ()
disconnectAllClientsFromServer :: Server -> IO ()
disconnectAllClientsFromServer (Server Ptr C'netcode_server_t
s ServerCallbacks
_) =
Ptr C'netcode_server_t -> IO ()
c'netcode_server_disconnect_all_clients Ptr C'netcode_server_t
s
nextServerPacketSequence :: Server -> Int -> IO Word64
nextServerPacketSequence :: Server -> Int -> IO Word64
nextServerPacketSequence (Server Ptr C'netcode_server_t
s ServerCallbacks
_) =
Ptr C'netcode_server_t -> CInt -> IO Word64
c'netcode_server_next_packet_sequence Ptr C'netcode_server_t
s (CInt -> IO Word64) -> (Int -> CInt) -> Int -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral
sendPacketFromServer :: Server
-> Int
-> Int
-> Ptr Word8
-> IO ()
sendPacketFromServer :: Server -> Int -> Int -> Ptr Word8 -> IO ()
sendPacketFromServer (Server Ptr C'netcode_server_t
s ServerCallbacks
_) Int
clientIdx Int
pktSz Ptr Word8
pktMem = do
let pktSize :: CInt
pktSize = CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
min CInt
forall a. Num a => a
c'NETCODE_MAX_PACKET_SIZE (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pktSz)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pktSz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forall a. Num a => a
c'NETCODE_MAX_PACKET_SIZE) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"WARNING: Sending packet that's too large: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
pktSz
Ptr C'netcode_server_t -> CInt -> Ptr Word8 -> CInt -> IO ()
c'netcode_server_send_packet Ptr C'netcode_server_t
s (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
clientIdx) Ptr Word8
pktMem CInt
pktSize
broadcastPacketFromServer :: Server -> Int -> Ptr Word8 -> IO ()
broadcastPacketFromServer :: Server -> Int -> Ptr Word8 -> IO ()
broadcastPacketFromServer Server
s Int
pktSz Ptr Word8
pktMem = do
Int
numClients <- Server -> IO Int
numConnectedClients Server
s
[Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..(Int
numClients Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Server -> Int -> Int -> Ptr Word8 -> IO ()
sendPacketFromServer Server
s Int
i Int
pktSz Ptr Word8
pktMem
receivePacketFromClient :: Server -> Int -> IO (Maybe Packet)
receivePacketFromClient :: Server -> Int -> IO (Maybe Packet)
receivePacketFromClient (Server Ptr C'netcode_server_t
s ServerCallbacks
_) Int
clientIdx =
(Ptr Word64 -> IO (Maybe Packet)) -> IO (Maybe Packet)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word64 -> IO (Maybe Packet)) -> IO (Maybe Packet))
-> (Ptr Word64 -> IO (Maybe Packet)) -> IO (Maybe Packet)
forall a b. (a -> b) -> a -> b
$ \Ptr Word64
sequenceNumPtr ->
(Ptr CInt -> IO (Maybe Packet)) -> IO (Maybe Packet)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Maybe Packet)) -> IO (Maybe Packet))
-> (Ptr CInt -> IO (Maybe Packet)) -> IO (Maybe Packet)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
pktSzPtr -> do
Ptr Word8
packetMem <- Ptr C'netcode_server_t
-> CInt -> Ptr CInt -> Ptr Word64 -> IO (Ptr Word8)
c'netcode_server_receive_packet Ptr C'netcode_server_t
s (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
clientIdx) Ptr CInt
pktSzPtr Ptr Word64
sequenceNumPtr
if Ptr Word8
packetMem Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall a. Ptr a
nullPtr
then Maybe Packet -> IO (Maybe Packet)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Packet
forall a. Maybe a
Nothing
else (Packet -> Maybe Packet) -> IO Packet -> IO (Maybe Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Packet -> Maybe Packet
forall a. a -> Maybe a
Just (IO Packet -> IO (Maybe Packet)) -> IO Packet -> IO (Maybe Packet)
forall a b. (a -> b) -> a -> b
$
Word64 -> Int -> ForeignPtr Word8 -> Packet
Packet (Word64 -> Int -> ForeignPtr Word8 -> Packet)
-> IO Word64 -> IO (Int -> ForeignPtr Word8 -> Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
sequenceNumPtr
IO (Int -> ForeignPtr Word8 -> Packet)
-> IO Int -> IO (ForeignPtr Word8 -> Packet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
pktSzPtr)
IO (ForeignPtr Word8 -> Packet)
-> IO (ForeignPtr Word8) -> IO Packet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Word8 -> IO () -> IO (ForeignPtr Word8)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr Ptr Word8
packetMem (Ptr C'netcode_server_t -> Ptr () -> IO ()
c'netcode_server_free_packet Ptr C'netcode_server_t
s (Ptr Word8 -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
packetMem))