diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +1.2.0.0 +======= + +* Updted to ghc 8 and added changelog. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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: +``` + +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 +``` diff --git a/gore-and-ash-sync.cabal b/gore-and-ash-sync.cabal --- a/gore-and-ash-sync.cabal +++ b/gore-and-ash-sync.cabal @@ -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 diff --git a/src/Game/GoreAndAsh/Sync/Module.hs b/src/Game/GoreAndAsh/Sync/Module.hs --- a/src/Game/GoreAndAsh/Sync/Module.hs +++ b/src/Game/GoreAndAsh/Sync/Module.hs @@ -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: " <>) diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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]