gore-and-ash-sync 1.2.0.0 → 1.2.0.1
raw patch · 5 files changed
+156/−76 lines, 5 filesdep −resourcetdep −transformersdep −transformers-basedep ~gore-and-ash-actordep ~gore-and-ash-loggingdep ~gore-and-ash-network
Dependencies removed: resourcet, transformers, transformers-base
Dependency ranges changed: gore-and-ash-actor, gore-and-ash-logging, gore-and-ash-network
Files
- CHANGELOG.md +4/−0
- README.md +41/−0
- gore-and-ash-sync.cabal +11/−10
- src/Game/GoreAndAsh/Sync/Module.hs +60/−66
- stack.yaml +40/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+1.2.0.0+=======++* Updted to ghc 8 and added changelog.
+ README.md view
@@ -0,0 +1,41 @@+gore-and-ash-sync+====================++The module provides facilities of high level synchronizing 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)+- [gore-and-ash-actor](https://github.com/Teaspot-Studio/gore-and-ash-actor)+- [gore-and-ash-network](https://github.com/Teaspot-Studio/gore-and-ash-network)++Installing+==========++Add following to your `stack.yml` to `packages` section:+```yaml+- location:+ git: https://github.com/Teaspot-Studio/gore-and-ash-sync.git+ commit: <PLACE HERE FULL HASH OF LAST COMMIT> +```++When defining you application stack, add `SyncT`:+``` haskell+type AppStack = ModuleStack [LoggingT, ActorT, NetworkT, SyncT, ... other modules ... ] IO+```++Unfortunately deriving for `SyncMonad` isn't work (bug of GHC 7.10.3), so you need meddle with some boilerplate while defining `SyncMonad` instance for your application monad wrapper:+``` haskell+newtype AppMonad a = AppMonad (AppStack a)+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch LoggingMonad, NetworkMonad)++instance SyncMonad AppMonad where + getSyncIdM = AppMonad . getSyncIdM+ getSyncTypeRepM = AppMonad . getSyncTypeRepM+ registerSyncIdM = AppMonad . registerSyncIdM+ addSyncTypeRepM a b = AppMonad $ addSyncTypeRepM a b+ syncScheduleMessageM peer ch i mt msg = AppMonad $ syncScheduleMessageM peer ch i mt msg+ syncSetLoggingM = AppMonad . syncSetLoggingM+ syncSetRoleM = AppMonad . syncSetRoleM+ syncGetRoleM = AppMonad syncGetRoleM+ syncRequestIdM a b = AppMonad $ syncRequestIdM a b +```
gore-and-ash-sync.cabal view
@@ -1,5 +1,5 @@ name: gore-and-ash-sync-version: 1.2.0.0+version: 1.2.0.1 synopsis: Gore&Ash module for high level network synchronization description: Please see README.md homepage: https://github.com/Teaspot-Studio/gore-and-ash-sync@@ -11,10 +11,14 @@ category: Web build-type: Simple cabal-version: >=1.10+extra-source-files:+ README.md+ CHANGELOG.md+ stack.yaml library hs-source-dirs: src- exposed-modules: + exposed-modules: Game.GoreAndAsh.Sync Game.GoreAndAsh.Sync.API Game.GoreAndAsh.Sync.Message@@ -24,7 +28,7 @@ Game.GoreAndAsh.Sync.Remote.Collection Game.GoreAndAsh.Sync.Remote.Sync Game.GoreAndAsh.Sync.State- + default-language: Haskell2010 build-depends: base >= 4.7 && < 5 , bytestring >= 0.10.6.0@@ -33,18 +37,15 @@ , deepseq >= 1.4.1.1 , exceptions >= 0.8.0.2 , gore-and-ash >= 1.1.0.0- , gore-and-ash-actor >= 1.2.0.0- , gore-and-ash-logging >= 1.2.0.0- , gore-and-ash-network >= 1.2.0.0+ , gore-and-ash-actor >= 1.1.0.0+ , gore-and-ash-logging >= 2.0.0.0+ , gore-and-ash-network >= 1.4.0.0 , hashable >= 1.2.3.3 , mtl >= 2.2.1- , resourcet >= 1.1.7.1 , text >= 1.2.2.0- , transformers >= 0.4.2- , transformers-base >= 0.4.4 , unordered-containers >= 0.2.5.1 - default-extensions: + default-extensions: Arrows BangPatterns ConstraintKinds
src/Game/GoreAndAsh/Sync/Module.hs view
@@ -17,24 +17,21 @@ , syncLog ) where -import Control.Monad.Base import Control.Monad.Catch-import Control.Monad.Error.Class -import Control.Monad.Fix +import Control.Monad.Fix import Control.Monad.State.Strict-import Control.Monad.Trans.Resource import Data.Maybe-import Data.Monoid -import Data.Proxy +import Data.Monoid+import Data.Proxy import Data.Serialize import Data.Text (Text, pack) import Data.Word-import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as H -import qualified Data.Sequence as S +import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as H+import qualified Data.Sequence as S import Game.GoreAndAsh-import Game.GoreAndAsh.Actor +import Game.GoreAndAsh.Actor import Game.GoreAndAsh.Actor.TypeRep import Game.GoreAndAsh.Logging import Game.GoreAndAsh.Network@@ -49,12 +46,12 @@ -- [@a@] - Type of result value; -- -- How to embed module:--- +-- -- @ -- type AppStack = ModuleStack [LoggingT, NetworkT, ActorT, SyncT, ... other modules ... ] IO -- -- -- | Current GHC (7.10.3) isn't able to derive this--- instance SyncMonad AppMonad where +-- instance SyncMonad AppMonad where -- getSyncIdM = AppMonad . getSyncIdM -- getSyncTypeRepM = AppMonad . getSyncTypeRepM -- registerSyncIdM = AppMonad . registerSyncIdM@@ -63,7 +60,7 @@ -- syncSetLoggingM = AppMonad . syncSetLoggingM -- syncSetRoleM = AppMonad . syncSetRoleM -- syncGetRoleM = AppMonad syncGetRoleM--- syncRequestIdM a b = AppMonad $ syncRequestIdM a b +-- syncRequestIdM a b = AppMonad $ syncRequestIdM a b -- -- newtype AppMonad a = AppMonad (AppStack a) -- deriving (Functor, Applicative, Monad, MonadFix, MonadIO, LoggingMonad, MonadThrow, MonadCatch, NetworkMonad, ActorMonad)@@ -71,23 +68,17 @@ -- -- The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module. newtype SyncT s m a = SyncT { runSyncT :: StateT (SyncState s) m a }- deriving (Functor, Applicative, Monad, MonadState (SyncState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadError e)--instance MonadBase IO m => MonadBase IO (SyncT s m) where - liftBase = SyncT . liftBase + deriving (Functor, Applicative, Monad, MonadState (SyncState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask) -instance MonadResource m => MonadResource (SyncT s m) where - liftResourceT = SyncT . liftResourceT- -instance (NetworkMonad m, LoggingMonad m, ActorMonad m, GameModule m s) => GameModule (SyncT s m) (SyncState s) where +instance (NetworkMonad m, LoggingMonad m, ActorMonad m, GameModule m s) => GameModule (SyncT s m) (SyncState s) where type ModuleState (SyncT s m) = SyncState s runModule (SyncT m) s = do ((a, s'), nextState) <- runModule runCurrentModule (syncNextState s) return (a, s' {- syncNextState = nextState - }) + syncNextState = nextState+ }) where- runCurrentModule = do + runCurrentModule = do (a, s') <- runStateT m s s'' <- processServiceMessages s' return (a, s'')@@ -101,111 +92,114 @@ -- Note: service channel had id 1 by default, but if there is no such -- channel, it fallbacks to 0. Make shure that client and server has corresponding -- count of channels.-processServiceMessages :: (ActorMonad m, NetworkMonad m, LoggingMonad m) => SyncState s -> m (SyncState s)-processServiceMessages sstate = do +processServiceMessages :: forall m s . (ActorMonad m, NetworkMonad m, LoggingMonad m)+ => SyncState s -> m (SyncState s)+processServiceMessages sstate = do serviceChan <- getServiceChannel peers <- networkPeersM foldM (process serviceChan) sstate peers where -- | Process one peer- process serviceChan s peer = do + process :: ChannelID -> SyncState s -> Peer -> m (SyncState s)+ process serviceChan s peer = do bss <- peerMessagesM peer serviceChan let serviceMsgs = catMaybesSeq . fmap decodeService $ bss foldM (processService serviceChan peer) s serviceMsgs -- | Decode service message- decodeService bs = case decode bs of - Left _ -> Nothing - Right (w64 :: Word64, mbs :: BS.ByteString) -> if w64 == 0 - then case decode mbs of - Left _ -> Nothing - Right !msg -> Just msg - else Nothing + decodeService bs = case decode bs of+ Left _ -> Nothing+ Right (w64 :: Word64, mbs :: BS.ByteString) -> if w64 == 0+ then case decode mbs of+ Left _ -> Nothing+ Right !msg -> Just msg+ else Nothing -- | Service one service message for given peer+ processService :: ChannelID -> Peer -> SyncState s -> SyncServiceMsg -> m (SyncState s) processService serviceChan peer s serviceMsg = case serviceMsg of- SyncServiceRequestId aname -> do + SyncServiceRequestId aname -> do syncLog s $ "Received request for network id for actor " <> pack aname marep <- findActorTypeRepM aname- case marep of + case marep of Nothing -> do syncLog s "Such actor isn't known" sendService peer serviceChan $ SyncServiceResponseNotRegistered aname return s- Just arep -> case H.lookup arep . syncIdMap $ s of + Just arep -> case H.lookup arep . syncIdMap $ s of Nothing -> do syncLog s "Registering actor network id, sending"- let (w64, s') = registerSyncIdInternal arep s + let (w64, s') = registerSyncIdInternal arep s sendService peer serviceChan $ SyncServiceResponseId aname w64 return s'- Just w64 -> do + Just w64 -> do syncLog s "Known actor id, sending" sendService peer serviceChan $ SyncServiceResponseId aname w64- return s - SyncServiceResponseId aname w64 -> do + return s+ SyncServiceResponseId aname w64 -> do syncLog s $ "Received response for network id for actor " <> pack aname <> " and id " <> pack (show w64)- marep <- findActorTypeRepM aname - case marep of + marep <- findActorTypeRepM aname+ case marep of Nothing -> do syncLog s "Not known actor, ignoring"- return s - Just arep -> do + return s+ Just arep -> do syncLog s "Sending all scheduled messages"- let s' = addSyncTypeRepInternal arep w64 s + let s' = addSyncTypeRepInternal arep w64 s msgs = fromMaybe S.empty . H.lookup peer . syncScheduledMessages $! s' sheduled <- fmap catMaybesSeq . forM msgs $ \(aname', chan, msg) -> if aname == aname'- then do - peerSendM peer chan . msg $! w64 + then do+ peerSendM peer chan . msg $! w64 return Nothing else return $! Just (aname', chan, msg)- + let sended = S.length msgs - S.length sheduled syncLog s $ "Sended: " <> pack (show sended)- + return $! s' { syncScheduledMessages = H.insert peer sheduled . syncScheduledMessages $! s' }- SyncServiceResponseNotRegistered aname -> do - putMsgLnM $ "Sync module: Failed to resolve actor id with name " <> (pack aname) - return s + SyncServiceResponseNotRegistered aname -> do+ putMsgLnM LogError $ "Sync module: Failed to resolve actor id with name " <> (pack aname)+ return s -- | Helper for sending service messages sendService :: (NetworkMonad m, LoggingMonad m) => Peer -> ChannelID -> SyncServiceMsg -> m ()-sendService peer chanid msg = do +sendService peer chanid msg = do let msg' = encode (0 :: Word64, encode msg) peerSendM peer chanid . Message ReliableMessage $ msg' -- | catMaybes for sequences-catMaybesSeq :: S.Seq (Maybe a) -> S.Seq a +catMaybesSeq :: S.Seq (Maybe a) -> S.Seq a catMaybesSeq = fmap fromJust . S.filter isJust -- | Internal implementation of actor registrarion when monadic context isn't in scope registerSyncIdInternal :: HashableTypeRep -> SyncState s -> (Word64, SyncState s)-registerSyncIdInternal tr sstate = case H.lookup tr . syncIdMap $! sstate of +registerSyncIdInternal tr sstate = case H.lookup tr . syncIdMap $! sstate of Just !i -> (i, sstate)- Nothing -> (i, sstate { + Nothing -> (i, sstate { syncIdMap = H.insert tr i . syncIdMap $! sstate , syncIdMapRev = H.insert i tr . syncIdMapRev $! sstate- , syncNextId = i+1 + , syncNextId = i+1 }) where !i = findNextEmptyId sstate $ syncNextId sstate where- findNextEmptyId ss i = case H.lookup i .syncIdMapRev $! ss of - Nothing -> i + findNextEmptyId ss i = case H.lookup i .syncIdMapRev $! ss of+ Nothing -> i Just _ -> findNextEmptyId ss (i+1) -- | Internal implementation of actor registrarion when monadic context isn't in scope addSyncTypeRepInternal :: HashableTypeRep -> Word64 -> SyncState s -> SyncState s-addSyncTypeRepInternal !tr !i sstate = case H.lookup i . syncIdMapRev $! sstate of +addSyncTypeRepInternal !tr !i sstate = case H.lookup i . syncIdMapRev $! sstate of Just _ -> sstate- Nothing -> sstate { + Nothing -> sstate { syncIdMap = H.insert tr i . syncIdMap $! sstate , syncIdMapRev = H.insert i tr . syncIdMapRev $! sstate } -- | Internal implementation of sending service request for actor net id-syncRequestIdInternal :: forall proxy i m s . (ActorMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i) +syncRequestIdInternal :: forall proxy i m s . (ActorMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i) => Peer -> proxy i -> SyncState s -> m (SyncState s) syncRequestIdInternal peer p s = do chan <- getServiceChannel@@ -219,11 +213,11 @@ -- the module would use chanel id 1 as service channel, therefore count of channels -- on client and server should match (server won't response on channel 1 if it doesn't -- have it).-getServiceChannel :: NetworkMonad m => m ChannelID -getServiceChannel = do +getServiceChannel :: NetworkMonad m => m ChannelID+getServiceChannel = do maxi <- networkChannels return . ChannelID $! if maxi > 1 then 1 else 0 -- | Log only when flag is turned on syncLog :: LoggingMonad m => SyncState s -> Text -> m ()-syncLog SyncState{..} = when syncLogging . putMsgLnM . ("Sync module: " <>)+syncLog SyncState{..} = when syncLogging . putMsgLnM LogInfo . ("Sync module: " <>)
+ stack.yaml view
@@ -0,0 +1,40 @@+# 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: git@github.com:Teaspot-Studio/gore-and-ash-actor.git+ commit: d71d9d24f20c5d819e9397cbb0098cbc6ef01f88++# 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-1.2.2.0+- gore-and-ash-actor-1.2.2.0+- gore-and-ash-logging-2.0.1.0+- gore-and-ash-network-1.4.0.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]