module Netcode.IO.Server ( -- * Servers -- ** Server-specific callbacks ServerConnectDisconnectCallback -- ** Server configs , ServerConfig , defaultServerConfig , setProtocolID , setPrivateKey , setServerConnectDisconnectCallback, clearServerConnectDisconnectCallback , setServerSendReceiveOverrides, clearServerSendReceiveOverrides -- ** Server objects , 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 x | x == nullFunPtr = return () | otherwise = freeHaskellFunPtr x -------------------------------------------------------------------------------- -- | A server object. This is an opaque type meant to be used in conjunction -- with this library. -- -- A server is generally meant to represent and endpoint for one or more -- t'Network.IO.Client's to connect to. The server application is similar to -- that of the client in that it is expected to have a running timer with a -- resolution of at least seconds. The main loop of the server application is -- meant to call 'updateServer' to allow the library to process incoming -- packets and send outgoing packets to the clients. data Server = Server { serverPtr :: Ptr C'netcode_server_t , serverCallbacks :: ServerCallbacks } deriving (Show) data ServerCallbacks = ServerCallbacks { serverConnectDisconnect :: C'connect_disconnect_callback_t , serverSendPacketOverride :: C'send_packet_override_t , serverReceivePacketOverride :: C'receive_packet_override_t } deriving (Show) defaultServerCallbacks :: ServerCallbacks defaultServerCallbacks = ServerCallbacks nullFunPtr nullFunPtr nullFunPtr -- | A 'ServerConfig' is a type that specifies the behavior of a 'Server' and -- contains associated metadata. -- -- At a minimum, the connection protocol ID and the private key for the -- application should be set for each server (via 'setProtocolID' and -- 'setPrivateKey', respectively). newtype ServerConfig = ServerConfig ( Ptr C'netcode_server_config_t -> ServerCallbacks -> IO (Ptr C'netcode_server_config_t, ServerCallbacks) ) -- | The default 'ServerConfig' contains no callbacks or overrides, and -- contains empty values for the required fields needed to properly have -- a server respond to a connecting t'Netcode.IO.Client'. defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig $ \serverConfig cbs -> do c'netcode_default_server_config serverConfig return (serverConfig, cbs) -- | Sets the connection protocol ID used by this 'Server'. This is a unique -- ID that must match the protocol ID used in -- 'Netcode.IO.generateConnectToken' setProtocolID :: Word64 -> ServerConfig -> ServerConfig setProtocolID protocolID (ServerConfig mkServerPtr) = ServerConfig $ \serverConfig cbs' -> do (configPtr, cbs) <- mkServerPtr serverConfig cbs' config <- peek configPtr poke configPtr $ config { c'netcode_server_config_t'protocol_id = protocolID } return (configPtr, cbs) -- | Sets the private key used by this 'Server'. This key must match the -- private key used in 'Netcode.IO.generateConnectToken' setPrivateKey :: [Word8] -> ServerConfig -> ServerConfig setPrivateKey key (ServerConfig mkServerPtr) = ServerConfig $ \serverConfig cbs' -> do (configPtr, cbs) <- mkServerPtr serverConfig cbs' config <- peek configPtr poke configPtr $ config { c'netcode_server_config_t'private_key = take c'NETCODE_KEY_BYTES (key <> repeat 0) } return (configPtr, cbs) -- | A server-specific callback that gets invoked each time a client either -- connects to, or disconnects from, the server. type ServerConnectDisconnectCallback = Int -- ^ Client index connected -> Bool -- ^ True if the client connected -> IO () mkServerConnectDisconnectCallback :: ServerConnectDisconnectCallback -> IO C'connect_disconnect_callback_t mkServerConnectDisconnectCallback cb = mk'connect_disconnect_callback_t $ \_ clientIdx connected -> cb (fromIntegral clientIdx) (connected /= 0) -- | Replaces the existing 'ServerConnectDisconnectCallback' with the given one -- and frees any associated memory that may be allocated for the the existing -- callback. setServerConnectDisconnectCallback :: ServerConnectDisconnectCallback -> ServerConfig -> ServerConfig setServerConnectDisconnectCallback cb (ServerConfig mkConfig) = ServerConfig $ \configPtr' callbacks' -> do (configPtr, callbacks) <- mkConfig configPtr' callbacks' freeNullFunPtr $ serverConnectDisconnect callbacks fPtr <- mkServerConnectDisconnectCallback cb config <- peek configPtr poke configPtr $ config { c'netcode_server_config_t'connect_disconnect_callback = fPtr } return (configPtr, callbacks { serverConnectDisconnect = fPtr }) -- | Removes the existing 'ServerConnectDisconnectCallback' and frees any -- associated memory that may be allocated for the the existing callback. clearServerConnectDisconnectCallback :: ServerConfig -> ServerConfig clearServerConnectDisconnectCallback (ServerConfig mkConfig) = ServerConfig $ \configPtr' callbacks' -> do (configPtr, callbacks) <- mkConfig configPtr' callbacks' freeNullFunPtr $ serverConnectDisconnect callbacks config <- peek configPtr poke configPtr $ config { c'netcode_server_config_t'connect_disconnect_callback = nullFunPtr } return (configPtr, callbacks { serverConnectDisconnect = nullFunPtr }) -- | Removes the existing send and receive overrides for the given config, if -- set, and instead uses the ones given. setServerSendReceiveOverrides :: SendPacketOverride -> ReceivePacketOverride -> ServerConfig -> ServerConfig setServerSendReceiveOverrides sendFn recvFn (ServerConfig mkConfig) = ServerConfig $ \configPtr' callbacks' -> do (configPtr, callbacks) <- mkConfig configPtr' callbacks' freeNullFunPtr $ serverSendPacketOverride callbacks freeNullFunPtr $ serverReceivePacketOverride callbacks config <- peek configPtr sendOverride <- mkSendPacketOverride sendFn recvOverride <- mkReceivePacketOverride recvFn poke configPtr $ config { c'netcode_server_config_t'send_packet_override = sendOverride , c'netcode_server_config_t'receive_packet_override = recvOverride , c'netcode_server_config_t'override_send_and_receive = 1 } let newcbs = callbacks { serverSendPacketOverride = sendOverride , serverReceivePacketOverride = recvOverride } return (configPtr, newcbs) -- | Changes the config to use the default send and receive packet functions. clearServerSendReceiveOverrides :: ServerConfig -> ServerConfig clearServerSendReceiveOverrides (ServerConfig mkConfig) = ServerConfig $ \configPtr' callbacks' -> do (configPtr, callbacks) <- mkConfig configPtr' callbacks' freeNullFunPtr $ serverSendPacketOverride callbacks freeNullFunPtr $ serverReceivePacketOverride callbacks config <- peek configPtr poke configPtr $ config { c'netcode_server_config_t'send_packet_override = nullFunPtr , c'netcode_server_config_t'receive_packet_override = nullFunPtr , c'netcode_server_config_t'override_send_and_receive = 0 } let newcbs = callbacks { serverSendPacketOverride = nullFunPtr , serverReceivePacketOverride = nullFunPtr } return (configPtr, newcbs) -- | Creates a server at the given address using the provided config. Throws an -- IOException on failure. -- -- Note, the address used here can be either formatted as an IPv4 address or an -- IPv6 address, similar to the arguments passed to 'parseAddress'. In the -- common case, you will likely want to use INADDR_ANY to bind to the -- underlying socket, which is represented by the address "0.0.0.0" -- -- The time passed to this create function should be a measurement in seconds, -- such that when connecting in the future using 'updateServer', the same -- resolution timer is being passed. That allows the library to properly -- timeout in cases where connections are taking too long to establish. createServer :: String -> ServerConfig -> Double -> IO Server createServer s (ServerConfig mkConfig) time = alloca $ \serverConfig -> do (config, cbs) <- mkConfig serverConfig defaultServerCallbacks ptr <- withCString s (\cs -> c'netcode_server_create cs config (CDouble time)) when (ptr == nullPtr) $ fail "Failed to create server!" return (Server ptr cbs) -- | Starts the server and specifies the maximum number of clients that can -- connect. Emits a warning when the maximum number of clients is more than -- 'maxNumClients'. startServer :: Server -> Int -> IO () startServer (Server s _) n = do when (n > maxNumClients) $ putStrLn $ concat [ "Warning: Can only start server with at most " , show (maxNumClients :: Int), " clients. Requested: ", show n ] c'netcode_server_start s (min maxNumClients $ fromIntegral n) -- | Returns the maximum number of clients that a server can support. maxNumClients :: Num a => a maxNumClients = c'NETCODE_MAX_CLIENTS -- | Stops the server. stopServer :: Server -> IO () stopServer (Server s _) = c'netcode_server_stop s -- | Destroys the server object and frees the associated Haskell-side callbacks -- and overrides destroyServer :: Server -> IO () destroyServer (Server s cbs) = do c'netcode_server_destroy s freeNullFunPtr $ serverConnectDisconnect cbs freeNullFunPtr $ serverSendPacketOverride cbs freeNullFunPtr $ serverReceivePacketOverride cbs -- | Main processing call for a 'Server' with the current time in seconds (in -- the same domain as the time passed to 'createServer'). This flushes packet -- queues at the appropriate rate and updates connection statuses among other -- things. It is expected to be called in the main loop of the application. updateServer :: Server -> Double -> IO () updateServer (Server s _) = c'netcode_server_update s . CDouble -- | Returns @True@ if the client at the given client index is connected to -- the server. Returns @False@ if not connected, if the server is not running, -- or if the client index is out of bounds. clientConnectedAtIndex :: Server -> Int -> IO Bool clientConnectedAtIndex (Server s _) = fmap (/= 0) . c'netcode_server_client_connected s . fromIntegral -- | Returns the client ID of the client at the given client index. Returns @0@ -- if not connected, the server is not running, or if the client index is out -- of bounds. clientIdAtIndex :: Server -> Int -> IO Word64 clientIdAtIndex (Server s _) = c'netcode_server_client_id s . fromIntegral -- | Performs an action with the address of the client to which the given -- 'Server' is connected to. This is meant to minimize the chances that the -- 'Address' value will be used in a manner that outlives the given 'Server' or -- the connection lifetime of the client. Callers should avoid storing the -- 'Address' value or returning it as a result of this function. -- -- In the event that the client index is out of bounds, or the client is not -- connected at that slot, the address passed to the action will be @0.0.0.0@. withClientAddressAtIndex :: Server -> Int -> (Address -> IO a) -> IO a withClientAddressAtIndex (Server s _) cidx fn = do aptr <- c'netcode_server_client_address s (fromIntegral cidx) if aptr == nullPtr then parseAddress "0.0.0.0" >>= fn else Address <$> newForeignPtr_ aptr >>= fn -- | Performs an action with the user data of the client to which the given -- 'Server' is connected to. This is meant to minimize the chances that the -- memory buffer will be used in a manner that outlives the given 'Server' or -- the connection lifetime of the client. Callers should avoid storing the -- @Ptr@ value or returning it as a result of this function. -- -- In the event that the client index is out of bounds, or the client is not -- connected at that slot, the given action will receive @nullPtr@. withClientUserDataAtIndex :: Server -> Int -> (Ptr () -> IO a) -> IO a withClientUserDataAtIndex (Server s _) cidx fn = c'netcode_server_client_user_data s (fromIntegral cidx) >>= fn -- | Returns the user data for the client connected at the given client index. -- -- In the event that the client index is out of bounds, or the client is not -- connected at that slot, the result will be the empty list. clientUserDataAtIndex :: Server -> Int -> IO [Word8] clientUserDataAtIndex s i = withClientUserDataAtIndex s i $ \ptr -> if ptr == nullPtr then return [] else peekArray c'NETCODE_USER_DATA_BYTES (castPtr ptr) -- | Returns the maximum number of clients that can connect to this server, or -- zero if the server has not been started yet (via a call to 'startServer'). maxClientsForServer :: Server -> IO Int maxClientsForServer (Server s _) = fromIntegral <$> c'netcode_server_max_clients s -- | Returns the number of currently connected clients. numConnectedClients :: Server -> IO Int numConnectedClients (Server s _) = fromIntegral <$> c'netcode_server_num_connected_clients s -- | Returns True if the server has been started, and is ready to accept -- incoming connections from clients. isServerRunning :: Server -> IO Bool isServerRunning (Server s _) = (/= 0) <$> c'netcode_server_running s -- | Returns true if the number of connected clients matches the maximum number -- of possibly connected clients. isServerFull :: Server -> IO Bool isServerFull (Server s _) = liftA2 (==) (c'netcode_server_num_connected_clients s) (c'netcode_server_max_clients s) -- | Returns the port assigned to the server's IP address. getServerPort :: Server -> IO Word16 getServerPort (Server s _) = c'netcode_server_get_port s -- | Disconnects the client at the given index from the server. disconnectClientFromServer :: Server -> Int -> IO () disconnectClientFromServer (Server s _) = c'netcode_server_disconnect_client s . fromIntegral -- | Disconnects all clients from the server. disconnectAllClientsFromServer :: Server -> IO () disconnectAllClientsFromServer (Server s _) = c'netcode_server_disconnect_all_clients s -- | Returns the next sequence number of a packet destined for the client at -- the given client index. nextServerPacketSequence :: Server -> Int -> IO Word64 nextServerPacketSequence (Server s _) = c'netcode_server_next_packet_sequence s . fromIntegral -- | Enqueues a packet to be sent to the client at the given index during the -- next call to 'updateServer'. sendPacketFromServer :: Server -> Int -- ^ Client index -> Int -- ^ Size in bytes of packet data -> Ptr Word8 -- ^ Packet data buffer -> IO () sendPacketFromServer (Server s _) clientIdx pktSz pktMem = do let pktSize = min c'NETCODE_MAX_PACKET_SIZE (fromIntegral pktSz) when (pktSz > c'NETCODE_MAX_PACKET_SIZE) $ putStrLn $ "WARNING: Sending packet that's too large: " <> show pktSz c'netcode_server_send_packet s (fromIntegral clientIdx) pktMem pktSize -- | Enqueues a packet with the given size and data to all connected clients. broadcastPacketFromServer :: Server -> Int -> Ptr Word8 -> IO () broadcastPacketFromServer s pktSz pktMem = do numClients <- numConnectedClients s forM_ [0..(numClients - 1)] $ \i -> sendPacketFromServer s i pktSz pktMem -- | Dequeues a received packet from the t'Netcode.IO.Client' at the given -- client index. This function returns a @Just@ until the queue is empty, upon -- which it will return a @Nothing@. receivePacketFromClient :: Server -> Int -> IO (Maybe Packet) receivePacketFromClient (Server s _) clientIdx = alloca $ \sequenceNumPtr -> alloca $ \pktSzPtr -> do packetMem <- c'netcode_server_receive_packet s (fromIntegral clientIdx) pktSzPtr sequenceNumPtr if packetMem == nullPtr then return Nothing else fmap Just $ Packet <$> peek sequenceNumPtr <*> (fromIntegral <$> peek pktSzPtr) <*> newForeignPtr packetMem (c'netcode_server_free_packet s (castPtr packetMem))