gore-and-ash-network 1.3.2.0 → 1.4.0.0
raw patch · 6 files changed
+137/−70 lines, 6 filesdep ~gore-and-ash-logging
Dependency ranges changed: gore-and-ash-logging
Files
- CHANGELOG.md +4/−0
- README.md +27/−0
- gore-and-ash-network.cabal +7/−3
- src/Game/GoreAndAsh/Network/API.hs +52/−52
- src/Game/GoreAndAsh/Network/State.hs +9/−15
- stack.yaml +38/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+1.4.0.0+=======++* Adapt to new `gore-and-ash-logger` and ghc 8.0
+ README.md view
@@ -0,0 +1,27 @@+gore-and-ash-network+====================++The module provides facilities for basic networking for [Gore&Ash](https://github.com/Teaspot-Studio/gore-and-ash) engine.++The module depends on [gore-and-ash-logging](https://github.com/Teaspot-Studio/gore-and-ash-logging) module.++Installing+==========++Add following to your `stack.yml` to `packages` section:+```yaml+- location:+ git: https://github.com/Teaspot-Studio/gore-and-ash-network.git+ commit: <PLACE HERE FULL HASH OF LAST COMMIT> +```++When defining you application stack, add `NetworkT`:+``` haskell+type AppStack = ModuleStack [LoggingT, NetworkT, ... other modules ... ] IO+```++And derive `NetworkMonad` for your resulting `AppMonad`:+``` haskell+newtype AppMonad a = AppMonad (AppStack a)+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch LoggingMonad, NetworkMonad)+```
gore-and-ash-network.cabal view
@@ -1,5 +1,5 @@ name: gore-and-ash-network-version: 1.3.2.0+version: 1.4.0.0 synopsis: Core module for Gore&Ash engine with low level network API description: Please see README.md homepage: https://github.com/Teaspot-Studio/gore-and-ash-network@@ -17,7 +17,11 @@ build-type: Simple cabal-version: >=1.10 -extra-source-files: enet/include/enet/*.h+extra-source-files: + enet/include/enet/*.h+ README.md+ CHANGELOG.md+ stack.yaml Bug-reports: https://github.com/Teaspot-Studio/gore-and-ash-network/issues Source-repository head@@ -65,7 +69,7 @@ , extra >= 1.4.2 , ghc-prim , gore-and-ash >= 1.1.0.0- , gore-and-ash-logging >= 1.1.0.0+ , gore-and-ash-logging >= 2.0.0.0 , hashable >= 1.2.3.3 , integer-gmp >= 1.0.0.0 , mtl >= 2.2.1
src/Game/GoreAndAsh/Network/API.hs view
@@ -42,9 +42,9 @@ import Network.ENet.Peer import Network.Socket (SockAddr) import Prelude hiding ((.), id)-import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as H +import qualified Data.HashMap.Strict as H import qualified Data.Sequence as S -- | Low-level monadic API of the core module@@ -82,18 +82,18 @@ networkSetDetailedLoggingM :: Bool -> m () -- | Return count of allocated network channels- networkChannels :: m Word + networkChannels :: m Word instance {-# OVERLAPPING #-} (MonadIO m, MonadCatch m) => NetworkMonad (NetworkT s m) where networkBind addr conCount chanCount inBandth outBandth = do- nstate <- NetworkT get + nstate <- NetworkT get phost <- liftIO $ create addr (fromIntegral conCount) (fromIntegral chanCount) inBandth outBandth if phost == nullPtr- then case addr of - Nothing -> putMsgLnM "Network: failed to initalize client side"- Just a -> putMsgLnM $ "Network: failed to connect to " <> pack (show a)+ then case addr of+ Nothing -> putMsgLnM LogError "Network: failed to initalize client side"+ Just a -> putMsgLnM LogError $ "Network: failed to connect to " <> pack (show a) else do- when (networkDetailedLogging nstate) $ putMsgLnM $ case addr of + when (networkDetailedLogging nstate) $ putMsgLnM LogInfo $ case addr of Nothing -> "Network: client network system initalized" Just a -> "Network: binded to " <> pack (show a) NetworkT $ put $ nstate {@@ -101,25 +101,25 @@ , networkMaximumChannels = chanCount } - peersConnectedM = do - NetworkState{..} <- NetworkT get + peersConnectedM = do+ NetworkState{..} <- NetworkT get return networkConnectedPeers - peersDisconnectedM = do - NetworkState{..} <- NetworkT get + peersDisconnectedM = do+ NetworkState{..} <- NetworkT get return networkDisconnectedPeers - networkConnect addr chanCount datum = do - nstate <- NetworkT get - case networkHost nstate of - Nothing -> do - putMsgLnM $ "Network: cannot connect to " <> pack (show addr) <> ", system isn't initalized"+ networkConnect addr chanCount datum = do+ nstate <- NetworkT get+ case networkHost nstate of+ Nothing -> do+ putMsgLnM LogError $ "Network: cannot connect to " <> pack (show addr) <> ", system isn't initalized" return $ Just () Just host -> do- peer <- liftIO $ connect host addr (fromIntegral chanCount) datum + peer <- liftIO $ connect host addr (fromIntegral chanCount) datum if peer == nullPtr then do- putMsgLnM $ "Network: failed to connect to " <> pack (show addr)+ putMsgLnM LogError $ "Network: failed to connect to " <> pack (show addr) return Nothing else do NetworkT . put $! nstate {@@ -132,59 +132,59 @@ return . fromMaybe S.empty $! H.lookup (peer, ch) msgs peerSendM peer ch msg = do- nstate <- NetworkT get - when (networkDetailedLogging nstate) $ putMsgLnM $ "Network: sending packet via channel "+ nstate <- NetworkT get+ when (networkDetailedLogging nstate) $ putMsgLnM LogInfo $ "Network: sending packet via channel " <> pack (show ch) <> ", payload: " <> pack (show msg) -- IOError let sendAction = liftIO $ send peer ch =<< P.poke (messageToPacket msg)- catch sendAction $ \(e :: IOException) -> do - putMsgLnM $ "Network: failed to send packet '" <> pack (show e) <> "'"- + catch sendAction $ \(e :: IOException) -> do+ putMsgLnM LogError $ "Network: failed to send packet '" <> pack (show e) <> "'" - networkPeersM = do - NetworkState{..} <- NetworkT get ++ networkPeersM = do+ NetworkState{..} <- NetworkT get return $! networkPeers S.>< networkConnectedPeers - networkSetDetailedLoggingM f = do - s <- NetworkT get + networkSetDetailedLoggingM f = do+ s <- NetworkT get put $ s { networkDetailedLogging = f } - networkChannels = do - s <- NetworkT get - return $ networkMaximumChannels s + networkChannels = do+ s <- NetworkT get+ return $ networkMaximumChannels s -instance {-# OVERLAPPABLE #-} (MonadIO (mt m), MonadCatch (mt m), LoggingMonad m, NetworkMonad m, MonadTrans mt) => NetworkMonad (mt m) where +instance {-# OVERLAPPABLE #-} (MonadIO (mt m), MonadCatch (mt m), LoggingMonad m, NetworkMonad m, MonadTrans mt) => NetworkMonad (mt m) where networkBind a mc mch ib ob = lift $ networkBind a mc mch ib ob peersConnectedM = lift peersConnectedM peersDisconnectedM = lift peersDisconnectedM- networkConnect a b c = lift $ networkConnect a b c - peerMessagesM a b = lift $ peerMessagesM a b + networkConnect a b c = lift $ networkConnect a b c+ peerMessagesM a b = lift $ peerMessagesM a b peerSendM a b c = lift $ peerSendM a b c networkPeersM = lift networkPeersM networkSetDetailedLoggingM = lift . networkSetDetailedLoggingM- networkChannels = lift networkChannels - + networkChannels = lift networkChannels+ -- | Fires when one or several clients were connected peersConnected :: (LoggingMonad m, NetworkMonad m) => GameWire m a (Event (S.Seq Peer))-peersConnected = mkGen_ $ \_ -> do +peersConnected = mkGen_ $ \_ -> do ps <- peersConnectedM- return $! if S.null ps + return $! if S.null ps then Right NoEvent else ps `deepseq` Right (Event ps) -- | Fires when one of connected peers is disconnected for some reason peersDisconnected :: (LoggingMonad m, NetworkMonad m) => GameWire m a (Event (S.Seq Peer))-peersDisconnected = mkGen_ $ \_ -> do - ps <- peersDisconnectedM - return $! if S.null ps +peersDisconnected = mkGen_ $ \_ -> do+ ps <- peersDisconnectedM+ return $! if S.null ps then Right NoEvent else ps `deepseq` Right (Event ps) -- | Fires when statically known peer is disconnected peerDisconnected :: (LoggingMonad m, NetworkMonad m) => Peer -> GameWire m a (Event ())-peerDisconnected p = mkGen_ $ \_ -> do - ps <- peersDisconnectedM - return $! case F.find (p ==) ps of +peerDisconnected p = mkGen_ $ \_ -> do+ ps <- peersDisconnectedM+ return $! case F.find (p ==) ps of Nothing -> Right NoEvent Just _ -> Right $! Event () @@ -193,20 +193,20 @@ currentPeers = liftGameMonad networkPeersM -- | Returns sequence of packets that were recieved during last frame from given peer and channel id-peerMessages :: (LoggingMonad m, NetworkMonad m) => Peer -> ChannelID -> GameWire m a (Event (S.Seq BS.ByteString)) -peerMessages p ch = mkGen_ $ \_ -> do +peerMessages :: (LoggingMonad m, NetworkMonad m) => Peer -> ChannelID -> GameWire m a (Event (S.Seq BS.ByteString))+peerMessages p ch = mkGen_ $ \_ -> do msgs <- peerMessagesM p ch- return $! if S.null msgs + return $! if S.null msgs then Right NoEvent else msgs `deepseq` Right (Event msgs) -- | Send message to given peer with given channel id peerSend :: (LoggingMonad m, NetworkMonad m) => Peer -> ChannelID -> GameWire m (Event Message) (Event ())-peerSend peer chid = liftGameMonadEvent1 $ peerSendM peer chid +peerSend peer chid = liftGameMonadEvent1 $ peerSendM peer chid -- | Send several messages to given peer with given channel id peerSendMany :: (LoggingMonad m, NetworkMonad m, F.Foldable t) => Peer -> ChannelID -> GameWire m (Event (t Message)) (Event ())-peerSendMany peer chid = liftGameMonadEvent1 $ mapM_ (peerSendM peer chid) +peerSendMany peer chid = liftGameMonadEvent1 $ mapM_ (peerSendM peer chid) -- | Sometimes you want to listen all peers and use statefull computations at the same time. --@@ -219,7 +219,7 @@ epeers <- now . currentPeers -< () returnA -< (error "onPeers: impossible", go <$> epeers) where- go initalPeers = proc a -> do + go initalPeers = proc a -> do conEvent <- peersConnected -< () disEvent <- peersDisconnected -< () @@ -233,6 +233,6 @@ returnA -< b where listenPeers :: S.Seq Peer -> GameWire m a (S.Seq Peer, b)- listenPeers peers = proc a -> do - b <- w peers -< a + listenPeers peers = proc a -> do+ b <- w peers -< a returnA -< (peers, b)
src/Game/GoreAndAsh/Network/State.hs view
@@ -16,28 +16,28 @@ , emptyNetworkState ) where -import Control.DeepSeq +import Control.DeepSeq import Data.Hashable import Foreign import GHC.Generics (Generic)-import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as H +import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as H import qualified Data.Sequence as S import qualified Network.ENet.Bindings as B -- | Local endpoint-type Host = Ptr B.Host +type Host = Ptr B.Host -- | Remote endpoint type Peer = Ptr B.Peer instance Hashable Peer where- hashWithSalt s ptr = hashWithSalt s i - where + hashWithSalt s ptr = hashWithSalt s i+ where i :: Int i = fromIntegral $ ptrToIntPtr ptr instance Hashable B.ChannelID where- hashWithSalt s (B.ChannelID i) = hashWithSalt s i + hashWithSalt s (B.ChannelID i) = hashWithSalt s i -- | Inner state of network layer --@@ -53,22 +53,16 @@ , networkNextState :: !s } deriving (Generic) -instance NFData Host where - rnf p = p `seq` ()--instance NFData Peer where - rnf p = p `seq` ()- instance NFData s => NFData (NetworkState s) -instance NFData B.ChannelID where +instance NFData B.ChannelID where rnf (B.ChannelID i) = i `seq` () -- | Creates initial state emptyNetworkState :: s -> NetworkState s emptyNetworkState s = NetworkState { networkNextState = s- , networkHost = Nothing + , networkHost = Nothing , networkPeers = S.empty , networkMessages = H.empty , networkDetailedLogging = False
+ stack.yaml view
@@ -0,0 +1,38 @@+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-7.9++# Local packages, usually specified by relative directory name+packages:+- '.'+- location:+ git: https://github.com/Teaspot-Studio/gore-and-ash-logging+ commit: d535d99c83c2c8999afe6aadc015a572ebb023db++# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps:+- typesafe-endian-0.1.0.1+- gore-and-ash-logging-2.0.1.0+- gore-and-ash-1.2.2.0++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 1.0.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]