packages feed

gore-and-ash-sync (empty) → 1.1.0.0

raw patch · 12 files changed

+1728/−0 lines, 12 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, deepseq, exceptions, gore-and-ash, gore-and-ash-actor, gore-and-ash-logging, gore-and-ash-network, hashable, mtl, text, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Gushcha Anton (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of  nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gore-and-ash-sync.cabal view
@@ -0,0 +1,61 @@+name:                gore-and-ash-sync+version:             1.1.0.0+synopsis:            Gore&Ash module for high level network synchronization+description:         Please see README.md+homepage:            https://github.com/Teaspot-Studio/gore-and-ash-sync+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2016 Anton Gushcha+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     +                       Game.GoreAndAsh.Sync+                       Game.GoreAndAsh.Sync.API+                       Game.GoreAndAsh.Sync.Message+                       Game.GoreAndAsh.Sync.Module+                       Game.GoreAndAsh.Sync.Remote+                       Game.GoreAndAsh.Sync.Remote.Actor+                       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+                     , cereal >= 0.4.1.1+                     , containers >= 0.5.6.2+                     , deepseq >= 1.4.1.1+                     , exceptions >= 0.8.0.2+                     , gore-and-ash >= 1.1.0.0+                     , gore-and-ash-actor >= 1.1.0.0+                     , gore-and-ash-logging >= 1.1.0.0+                     , gore-and-ash-network >= 1.1.0.0+                     , hashable >= 1.2.3.3+                     , mtl >= 2.2.1+                     , text >= 1.2.2.0+                     , unordered-containers >= 0.2.5.1+                     +  default-extensions:  +                       Arrows+                       BangPatterns+                       ConstraintKinds+                       DeriveGeneric+                       FlexibleContexts+                       FlexibleInstances+                       FunctionalDependencies+                       GADTs+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses+                       OverloadedStrings+                       RecordWildCards+                       ScopedTypeVariables+                       StandaloneDeriving+                       TupleSections+                       TypeFamilies+                       UndecidableInstances
+ src/Game/GoreAndAsh/Sync.hs view
@@ -0,0 +1,334 @@+{-|+Module      : Game.GoreAndAsh.Sync+Description : Gore&Ash high-level networking core module+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The core module contains high-level networking API for Gore&Ash. It allows to define separate+types of messages for each actor and perform automatic synchronzation controlled by synchronization+EDSL.++The module depends on following core modules:++* actor - "Game.GoreAndAsh.Actor"+* logging - "Game.GoreAndAsh.Logging"+* network - "Game.GoreAndAsh.Network"++So 'SyncT' should be placed after 'LoggingT', 'ActorT' and 'NetworkT' in monad stack.++The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module.++Example of embedding:++@+-- | Application monad is monad stack build from given list of modules over base monad (IO)+type AppStack = ModuleStack [LoggingT, NetworkT, ActorT, SyncT ... other modules ... ] IO+newtype AppState = AppState (ModuleState AppStack)+  deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, LoggingMonad, NetworkMonad, ActorMonad, SyncMonad ... other modules monads ... )++-- | Current GHC (7.10.3) isn't able to derive this+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 ++instance GameModule AppMonad AppState where +  type ModuleState AppMonad = AppState+  runModule (AppMonad m) (AppState s) = do +    (a, s') <- runModule m s +    return (a, AppState s')+  newModuleState = AppState <$> newModuleState+  withModule _ = withModule (Proxy :: Proxy AppStack)+  cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b+-- | Action that makes indexed app wire+type AppActor i a b = GameActor AppMonad i a b+@++Important note, the system tries to use channel id 1 for service messages, but fallbacks+to default channel if there is only one channel allocated in network module. Check initalization+of network module, client and server allocated channels count must match.+-}+module Game.GoreAndAsh.Sync(+  -- * Low-level API+    SyncState+  , SyncT+  , SyncRole(..)+  , SyncMonad(..)+  -- * Typed message API+  -- $messageExample+  , NetworkMessage(..)+  -- ** Getting messages+  , peerIndexedMessages+  , peerProcessIndexed+  , peerProcessIndexedM+  -- ** Sending messages+  , peerSendIndexedM+  , peerSendIndexed+  , peerSendIndexedDyn+  , peerSendIndexedMany+  , peerSendIndexedManyDyn+  -- ** Helpers+  , filterMsgs+  -- * Automatic synchronization+  -- $syncExample+  -- ** Remote actor API+  , RemoteActor(..)+  , clientSync+  , serverSync+  -- *** Synchronization primitives+  , Sync+  , FullSync+  , noSync+  , clientSide+  , serverSide+  , condSync+  , syncReject+  -- *** Helpers for conditional synchronization+  , fieldChanges+  , fieldChangesWithin+  -- ** Remote collection+  , RemActorCollId(..)+  , remoteActorCollectionServer+  , remoteActorCollectionClient+  ) where++import Game.GoreAndAsh.Sync.API as X+import Game.GoreAndAsh.Sync.Message as X+import Game.GoreAndAsh.Sync.Module as X+import Game.GoreAndAsh.Sync.Remote as X+import Game.GoreAndAsh.Sync.State as X++{- $messageExample+Example of usage of typed message API:++@+data Player = Player {+  playerId :: !PlayerId+, playerPos :: !(V2 Double)+, playerSize :: !Double+} deriving (Generic)++instance NFData Player ++newtype PlayerId = PlayerId { unPlayerId :: Int } deriving (Eq, Show, Generic) +instance NFData PlayerId +instance Hashable PlayerId +instance Serialize PlayerId++-- | Local message type+data PlayerMessage =+    -- | The player was shot by specified player+    PlayerShotMessage !PlayerId +  deriving (Typeable, Generic)++instance NFData PlayerMessage ++instance ActorMessage PlayerId where+  type ActorMessageType PlayerId = PlayerMessage+  toCounter = unPlayerId+  fromCounter = PlayerId++-- | Remote message type+data PlayerNetMessage = +    NetMsgPlayerFire !(V2 Double)+  deriving (Generic, Show)++instance NFData PlayerNetMessage+instance Serialize PlayerNetMessage++instance NetworkMessage PlayerId where +  type NetworkMessageType PlayerId = PlayerNetMessage++playerActorServer :: :: (PlayerId -> Player) -> AppActor PlayerId Game Player +playerActorServer initialPlayer = makeActor $ \i -> stateWire (initialPlayer i) $ mainController i+  where+  mainController i = proc (g, p) -> do+    p2 <- peerProcessIndexedM peer (ChannelID 0) i netProcess -< p+    forceNF . playerShot -< p2+    where+    -- | Shortcut for peer+    peer = playerPeer $ initialPlayer i++    -- | Handle when player is shot+    playerShot :: AppWire Player Player+    playerShot = proc p -> do +      emsg <- actorMessages i isPlayerShotMessage -< ()+      let newPlayer = p {+          playerPos = 0+        }+      returnA -< event p (const newPlayer) emsg++    -- | Process player specific net messages+    netProcess :: Player -> PlayerNetMessage -> GameMonadT AppMonad Player +    netProcess p msg = case msg of +      NetMsgPlayerFire v -> do +        let d = normalize v +            v2 a = V2 a a+            pos = playerPos p + d * v2 (playerSize p * 1.5)+            vel = d * v2 bulletSpeed+        putMsgLnM $ "Fire bullet at " <> pack (show pos) <> " with velocity " <> pack (show vel)+        actors <- calculatePlayersOnLine pos vel+        forM_ actors . actorSendM actor . PlayerShotMessage . playerId $ p+        return p ++playerActorClient :: Peer -> PlayerId -> AppActor PlayerId Camera Player +playerActorClient peer i = makeFixedActor i $ stateWire initialPlayer $ proc (c, p) -> do +  processFire -< (c, p)+  liftGameMonad4 renderSquare -< (playerSize p, playerPos p, playerColor p, c)+  forceNF -< p+  where+    initialPlayer = Player {+        playerId = i +      , playerPos = 0+      , playerColor = V3 1 0 0+      , playerRot = 0+      , playerSpeed = 0.5+      , playerSize = 1+      }++    processFire :: AppWire (Camera, Player) ()+    processFire = proc (c, p) -> do +      e <- mouseClick ButtonLeft -< ()+      let wpos = cameraToWorld c <$> e+      let edir = (\v -> normalize $ v - playerPos p) <$> wpos +      let emsg = NetMsgPlayerFire <$> edir+      peerSendIndexed peer (ChannelID 0) i ReliableMessage -< emsg+      returnA -< ()+@+-}++{- $syncExample++The synchronization API is built around 'Sync' applicative functor. It allows to combine+complex synchronization strategies from reasonable small amount of basic blocks (see 'noSync', 'clientSide', 'serverSide', 'condSync', 'syncReject'). ++Synchornization description is considered as complete, when you get 'Sync m i a a' type ('FullSync' type synonym).+After that you can use 'clientSync' and 'serverSync' at your actors to sync them.++Example of usage of sync API:++@+data Player = Player {+  playerId :: !PlayerId+, playerPos :: !(V2 Double)+, playerSize :: !Double+} deriving (Generic)++instance NFData Player ++newtype PlayerId = PlayerId { unPlayerId :: Int } deriving (Eq, Show, Generic) +instance NFData PlayerId +instance Hashable PlayerId +instance Serialize PlayerId++-- | Local message type+data PlayerMessage =+    -- | The player was shot by specified player+    PlayerShotMessage !PlayerId +  deriving (Typeable, Generic)++instance NFData PlayerMessage ++instance ActorMessage PlayerId where+  type ActorMessageType PlayerId = PlayerMessage+  toCounter = unPlayerId+  fromCounter = PlayerId++-- | Remote message type+data PlayerNetMessage = +    NetMsgPlayerFire !(V2 Double)+  deriving (Generic, Show)++instance NFData PlayerNetMessage+instance Serialize PlayerNetMessage++instance NetworkMessage PlayerId where +  type NetworkMessageType PlayerId = PlayerNetMessage++playerActorServer :: :: (PlayerId -> Player) -> AppActor PlayerId Game Player +playerActorServer initialPlayer = makeActor $ \i -> stateWire (initialPlayer i) $ mainController i+  where+  mainController i = proc (g, p) -> do+    p2 <- peerProcessIndexedM peer (ChannelID 0) i netProcess -< p+    forceNF . serverSync playerSync i . playerShot -< p2+    where+    -- | Shortcut for peer+    peer = playerPeer $ initialPlayer i++    -- | Handle when player is shot+    playerShot :: AppWire Player Player+    playerShot = proc p -> do +      emsg <- actorMessages i isPlayerShotMessage -< ()+      let newPlayer = p {+          playerPos = 0+        }+      returnA -< event p (const newPlayer) emsg++    -- | Process player specific net messages+    netProcess :: Player -> PlayerNetMessage -> GameMonadT AppMonad Player +    netProcess p msg = case msg of +      NetMsgPlayerFire v -> do +        let d = normalize v +            v2 a = V2 a a+            pos = playerPos p + d * v2 (playerSize p * 1.5)+            vel = d * v2 bulletSpeed+        putMsgLnM $ "Fire bullet at " <> pack (show pos) <> " with velocity " <> pack (show vel)+        actors <- calculatePlayersOnLine pos vel+        forM_ actors . actorSendM actor . PlayerShotMessage . playerId $ p+        return p ++    playerSync :: FullSync AppMonad PlayerId Player +    playerSync = Player +      \<$\> pure i +      \<*\> clientSide peer 0 playerPos+      \<*\> clientSide peer 1 playerSize++playerActorClient :: Peer -> PlayerId -> AppActor PlayerId Camera Player +playerActorClient peer i = makeFixedActor i $ stateWire initialPlayer $ proc (c, p) -> do +  processFire -< (c, p)+  liftGameMonad4 renderSquare -< (playerSize p, playerPos p, playerColor p, c)+  forceNF . clientSync playerSync peer i -< p+  where+    initialPlayer = Player {+        playerId = i +      , playerPos = 0+      , playerColor = V3 1 0 0+      , playerRot = 0+      , playerSpeed = 0.5+      , playerSize = 1+      }++    processFire :: AppWire (Camera, Player) ()+    processFire = proc (c, p) -> do +      e <- mouseClick ButtonLeft -< ()+      let wpos = cameraToWorld c <$> e+      let edir = (\v -> normalize $ v - playerPos p) <$> wpos +      let emsg = NetMsgPlayerFire <$> edir+      peerSendIndexed peer (ChannelID 0) i ReliableMessage -< emsg+      returnA -< ()++    playerSync :: FullSync AppMonad PlayerId Player +    playerSync = Player +      \<$\> pure i +      \<*\> clientSide peer 0 playerPos+      \<*\> clientSide peer 1 playerSize+@+-}
+ src/Game/GoreAndAsh/Sync/API.hs view
@@ -0,0 +1,138 @@+{-|+Module      : Game.GoreAndAsh.Sync.API+Description : Monadic API of core module+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.API(+    SyncMonad(..)+  ) where++import Control.Monad.State.Strict+import Control.Wire+import Data.Proxy +import Data.Serialize (encode, Serialize)+import Data.Text+import Data.Word +import Prelude hiding (id, (.))+import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Actor.TypeRep+import Game.GoreAndAsh.Logging +import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync.Module+import Game.GoreAndAsh.Sync.State++-- | Low level API for module+-- Need at least one network channel to operate. If you open more than one channel,+-- 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).+class MonadIO m => SyncMonad m where +  -- | Find actor id by it stable type representation+  getSyncIdM :: HashableTypeRep -> m (Maybe Word64)+  -- | Find actor type representation by it id+  getSyncTypeRepM :: Word64 -> m (Maybe HashableTypeRep)+  -- | Generate and register new id for given actor type representation+  registerSyncIdM :: LoggingMonad m => HashableTypeRep -> m Word64+  -- | Register new type rep with given id, doesn't overide existing records+  addSyncTypeRepM :: LoggingMonad m => HashableTypeRep -> Word64 -> m ()++  -- | Send message as soon as network id of actor is resolved+  syncScheduleMessageM :: (NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))+    => Peer -- ^ Which peer we sending to+    -> ChannelID -- ^ Which channel we are sending within+    -> i -- ^ ID of actor+    -> MessageType -- ^ Strategy of the message (reliable, unordered etc.)+    -> NetworkMessageType i -- ^ Message to send+    -> m ()++  -- | Switch on/off detailed logging of the module+  syncSetLoggingM :: Bool -> m ()++  -- | Setups behavior model in synchronizing of actor ids+  -- Note: clients should be slaves and server master+  syncSetRoleM :: SyncRole -> m ()++  -- | Returns current behavior model in synchronizing of actor ids+  -- Note: clients should be slaves and server master+  syncGetRoleM :: m SyncRole++  -- | Send request for given peer for id of given actor+  syncRequestIdM :: forall proxy i . (ActorMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i) +    => Peer -> proxy i -> m ()++instance {-# OVERLAPPING #-} MonadIO m => SyncMonad (SyncT s m) where+  getSyncIdM !tr = do +    sstate <- SyncT get +    return . H.lookup tr . syncIdMap $! sstate++  getSyncTypeRepM !w = do +    sstate <- SyncT get +    return . H.lookup w . syncIdMapRev $! sstate++  registerSyncIdM !tr = do +    sstate <- SyncT get+    let (w64, s') = registerSyncIdInternal tr sstate+    syncLog s' $ "Registering new actor type " <> pack (show tr) <> " with id " <> pack (show w64)+    SyncT . put $! s'+    return w64++  addSyncTypeRepM !tr !i = do +    sstate <- SyncT get +    syncLog sstate $ "Registering new actor type " <> pack (show tr) <> " with id " <> pack (show i)+    SyncT . put $! addSyncTypeRepInternal tr i sstate++  syncScheduleMessageM peer ch i mt msg = do +    sstate <- SyncT get +    let name = getActorName i +        serviceMsg = Message ReliableMessage $! encode (0 :: Word64, encode $! SyncServiceRequestId name )+        actorId = fromIntegral (toCounter i) :: Word64+        v = (name, ch, \netid -> Message mt $! encode (netid, encode (actorId, encode msg)))+    serviceChan <- getServiceChannel +    peerSendM peer serviceChan serviceMsg+    SyncT . put $! sstate {+        syncScheduledMessages = case H.lookup peer . syncScheduledMessages $! sstate of +          Nothing -> H.insert peer (S.singleton v) . syncScheduledMessages $! sstate+          Just msgs -> H.insert peer (msgs S.|> v) . syncScheduledMessages $! sstate+      }++  syncSetLoggingM f = do +    sstate <- SyncT get +    SyncT . put $! sstate {+        syncLogging = f+      }++  syncSetRoleM r = do +    sstate <- SyncT get+    SyncT . put $! sstate {+        syncRole = r +      }++  syncGetRoleM = syncRole <$> SyncT get ++  syncRequestIdM peer p = do+    s <- SyncT get+    syncLog s $ "request id of actor " <> pack (show $ actorFingerprint p)+    s' <- syncRequestIdInternal peer p s+    SyncT . put $! s'++instance {-# OVERLAPPABLE #-} (MonadIO (mt m), SyncMonad m, ActorMonad m, NetworkMonad m, LoggingMonad m,  MonadTrans mt) => SyncMonad (mt m) where +  getSyncIdM = lift . getSyncIdM+  getSyncTypeRepM = lift . getSyncTypeRepM+  registerSyncIdM = lift . registerSyncIdM+  addSyncTypeRepM a b = lift $ addSyncTypeRepM a b+  syncScheduleMessageM peer ch i mt msg  = lift $ syncScheduleMessageM peer ch i mt msg+  syncSetLoggingM = lift . syncSetLoggingM+  syncSetRoleM = lift . syncSetRoleM+  syncGetRoleM = lift syncGetRoleM+  syncRequestIdM a b = lift $ syncRequestIdM a b ++-- | Return typename of actor using it type representation+getActorName :: forall i . ActorMessage i => i -> String +getActorName _ = show $ actorFingerprint (Proxy :: Proxy i)
+ src/Game/GoreAndAsh/Sync/Message.hs view
@@ -0,0 +1,189 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.Sync.Message+Description : Arrow utilities for messaging+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.Message(+    NetworkMessage(..)+  -- * Getting messages+  , peerIndexedMessages+  , peerProcessIndexed+  , peerProcessIndexedM+  -- * Sending messages+  , peerSendIndexedM+  , peerSendIndexed+  , peerSendIndexedDyn+  , peerSendIndexedMany+  , peerSendIndexedManyDyn+  -- * Helpers+  , filterMsgs+  ) where++import Control.Wire+import Control.Wire.Unsafe.Event+import Data.Maybe +import Data.Serialize+import Data.Typeable +import Data.Word+import Prelude hiding ((.), id)+import qualified Control.Monad as M +import qualified Data.ByteString as BS +import qualified Data.Foldable as F +import qualified Data.Sequence as S ++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync.API +import Game.GoreAndAsh.Sync.State++-- | Fires when network messages for specific actor has arrived+-- Note: mid-level API is not safe to use with low-level at same time as+-- first bytes of formed message are used for actor id. So, you need to +-- have a special forbidden id for you custom messages.+peerIndexedMessages :: forall m i a . (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))+  => Peer -- ^ Which peer we are listening+  -> ChannelID -- ^ Which channel we are listening+  -> i -- ^ ID of actor +  -> GameWire m a (Event (S.Seq (NetworkMessageType i))) -- ^ Messages that are addressed to the actor+peerIndexedMessages p chid i = inhibit2NoEvent $ proc _ -> do +  netid <- mkNetId -< ()+  emsgs <- peerMessages p chid -< ()+  filterE (not . S.null) . mapE (\(netid, msgs) -> catMaybesSeq $ (parse netid) <$> msgs)+    -< (netid, ) <$> emsgs+  where+    inhibit2NoEvent w = w <|> never ++    -- | If actor is new, register actor and cache the id+    mkNetId :: GameWire m () Word64+    mkNetId = go False+      where+      go sended = mkGen $ \_ _ -> do +        let !tr = actorFingerprint (Proxy :: Proxy i)+        mnid <- getSyncIdM tr+        case mnid of +          Nothing -> do +            r <- syncGetRoleM+            case r of +              SyncMaster -> do +                !nid <- registerSyncIdM tr+                return (Right nid, pure nid)+              SyncSlave -> do +                M.unless sended $ syncRequestIdM p (Proxy :: Proxy i)+                return (Left (), go True)+          Just !nid -> return (Right nid, pure nid)++    -- | Parses packet, decodes only user messages+    parse :: Word64 -> BS.ByteString -> Maybe (NetworkMessageType i)+    parse !netid !bs = case decode bs of +      Left _ -> Nothing+      Right (fp :: Word64, bs2 :: BS.ByteString) -> if fp == 0 +        then Nothing+        else case decode bs2 of +          Left _ -> Nothing+          Right (w64 :: Word64, mbs :: BS.ByteString) -> if not (fp == netid && fromIntegral w64 == toCounter i)+            then Nothing+            else case decode mbs of +              Left _ -> Nothing +              Right !m -> Just $! m++-- | catMaybes for sequences+catMaybesSeq :: S.Seq (Maybe a) -> S.Seq a +catMaybesSeq = fmap fromJust . S.filter isJust++-- | Encodes a message for specific actor type and send it to remote host+-- Note: mid-level API is not safe to use with low-level at same time as+-- first bytes of formed message are used for actor id. So, you need to +-- have a special forbidden id for you custom messages.+peerSendIndexedM :: forall m i . (SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))+  => Peer -- ^ Which peer we sending to+  -> ChannelID -- ^ Which channel we are sending within+  -> i -- ^ ID of actor+  -> MessageType -- ^ Strategy of the message (reliable, unordered etc.)+  -> NetworkMessageType i -- ^ Message to send+  -> m ()+peerSendIndexedM p chid i mt msg = do +  mnid <- getSyncIdM $ actorFingerprint (Proxy :: Proxy i)+  case mnid of +    Nothing -> syncScheduleMessageM p chid i mt msg  -- schedule message send when we resolve sync id +    Just nid -> do +      let w64 = fromIntegral (toCounter i) :: Word64+          msg' = Message mt $! encode (nid, encode (w64, encode msg))+      peerSendM p chid msg'++-- | Encodes a message for specific actor type and send it to remote host, arrow version+-- Note: mid-level API is not safe to use with low-level at same time as+-- first bytes of formed message are used for actor id. So, you need to +-- have a special forbidden id for you custom messages.+peerSendIndexed :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))+  => Peer -- ^ Which peer we sending to+  -> ChannelID -- ^ Which channel we are sending within+  -> i -- ^ ID of actor+  -> MessageType -- ^ Strategy of the message (reliable, unordered etc.)+  -> GameWire m (Event (NetworkMessageType i)) (Event ())+peerSendIndexed p chid i mt = liftGameMonadEvent1 $ peerSendIndexedM p chid i mt++-- | Encodes a message for specific actor type and send it to remote host, arrow version.+-- Takes peer, id and message as arrow input.+peerSendIndexedDyn :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))+  => ChannelID -- ^ Which channel we are sending within+  -> MessageType -- ^ Strategy of the message (reliable, unordered etc.)+  -> GameWire m (Event (Peer, i, NetworkMessageType i)) (Event ())+peerSendIndexedDyn chid mt = liftGameMonadEvent1 $ \(p, i, msg) -> peerSendIndexedM p chid i mt msg++-- | Encodes a message for specific actor type and send it to remote host, arrow version+-- Note: mid-level API is not safe to use with low-level at same time as+-- first bytes of formed message are used for actor id. So, you need to +-- have a special forbidden id for you custom messages.+peerSendIndexedMany :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i), F.Foldable t)+  => Peer -- ^ Which peer we sending to+  -> ChannelID -- ^ Which channel we are sending within+  -> i -- ^ ID of actor+  -> MessageType -- ^ Strategy of the message (reliable, unordered etc.)+  -> GameWire m (Event (t (NetworkMessageType i))) (Event ())+peerSendIndexedMany p chid i mt = liftGameMonadEvent1 . F.mapM_ $ peerSendIndexedM p chid i mt++-- | Encodes a message for specific actor type and send it to remote host, arrow version.+-- Takes peer, id and message as arrow input.+peerSendIndexedManyDyn :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i), F.Foldable t)+  => ChannelID -- ^ Which channel we are sending within+  -> MessageType -- ^ Strategy of the message (reliable, unordered etc.)+  -> GameWire m (Event (t (Peer, i, NetworkMessageType i))) (Event ())+peerSendIndexedManyDyn chid mt = liftGameMonadEvent1 . F.mapM_ $ \(p, i, msg) -> peerSendIndexedM p chid i mt msg+++-- | Same as @peerIndexedMessages@, but transforms input state with given handler+peerProcessIndexed :: (ActorMonad m,SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))+  => Peer -- ^ Which peer we are listening+  -> ChannelID -- ^ Which channel we are listening+  -> i -- ^ ID of actor+  -> (a -> NetworkMessageType i -> a) -- ^ Handler of message+  -> GameWire m a a -- ^ Updates @a@ with given handler for messages+peerProcessIndexed p chid i f = proc a -> do +  emsgs <- peerIndexedMessages p chid i -< ()+  returnA -< event a (F.foldl' f a) emsgs++-- | Same as @peerIndexedMessages@, but transforms input state with given handler, monadic version+peerProcessIndexedM :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))+  => Peer -- ^ Which peer we are listening+  -> ChannelID -- ^ Which channel we are listening+  -> i -- ^ ID of actor+  -> (a -> NetworkMessageType i -> GameMonadT m a) -- ^ Handler of message+  -> GameWire m a a -- ^ Updates @a@ with given handler for messages+peerProcessIndexedM p chid i f = proc a -> do +  emsgs <- peerIndexedMessages p chid i -< ()+  liftGameMonad2 (\emsgs a -> case emsgs of+    NoEvent -> return a +    Event msgs -> F.foldlM f a msgs) -< (emsgs, a) ++-- | Helper to filter output of @peerIndexedMessages@+filterMsgs :: (Monad m)+  => (a -> Bool) -- ^ Predicate to test message+  -> GameWire m (Event (S.Seq a)) (Event (S.Seq a))+filterMsgs p = filterE (not . S.null) . mapE (S.filter p)
+ src/Game/GoreAndAsh/Sync/Module.hs view
@@ -0,0 +1,219 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.Sync.Module+Description : Monad transformer and game module instance+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.Module(+    SyncT(..)+  , registerSyncIdInternal+  , addSyncTypeRepInternal+  , syncRequestIdInternal+  , getServiceChannel+  , syncLog+  ) where++import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.State.Strict+import Data.Maybe+import Data.Monoid +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 Game.GoreAndAsh+import Game.GoreAndAsh.Actor +import Game.GoreAndAsh.Actor.TypeRep+import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync.State++-- | Monad transformer of sync core module.+--+-- [@s@] - State of next core module in modules chain;+--+-- [@m@] - Next monad in modules monad stack;+--+-- [@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 +--   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 +--+-- newtype AppMonad a = AppMonad (AppStack a)+--   deriving (Functor, Applicative, Monad, MonadFix, MonadIO, LoggingMonad, MonadThrow, MonadCatch, NetworkMonad, ActorMonad)+-- @+--+-- 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)++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 +      })  +    where+    runCurrentModule = do +      (a, s') <- runStateT m s+      s'' <- processServiceMessages s'+      return (a, s'')++  newModuleState = emptySyncState <$> newModuleState+  withModule _ = id+  cleanupModule _ = return ()++-- | Detect service messages arrived to the machine and process them+--+-- 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 +  serviceChan <- getServiceChannel+  peers <- networkPeersM+  foldM (process serviceChan) sstate peers+  where+  -- | Process one peer+  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 ++  -- | Service one service message for given peer+  processService serviceChan peer s serviceMsg = case serviceMsg of+    SyncServiceRequestId aname -> do +      syncLog s $ "Received request for network id for actor " <> pack aname+      marep <- findActorTypeRepM aname+      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 +          Nothing -> do+            syncLog s "Registering actor network id, sending"+            let (w64, s') = registerSyncIdInternal arep s +            sendService peer serviceChan $ SyncServiceResponseId aname w64+            return s'+          Just w64 -> do +            syncLog s "Known actor id, sending"+            sendService peer serviceChan $ SyncServiceResponseId aname w64+            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 +        Nothing -> do+          syncLog s "Not known actor, ignoring"+          return s +        Just arep -> do +          syncLog s "Sending all scheduled messages"+          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 +              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 ++-- | Helper for sending service messages+sendService :: (NetworkMonad m, LoggingMonad m) => Peer -> ChannelID -> SyncServiceMsg -> m ()+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 = 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 +  Just !i -> (i, sstate)+  Nothing -> (i, sstate { +        syncIdMap = H.insert tr i . syncIdMap $! sstate+      , syncIdMapRev = H.insert i tr . syncIdMapRev $! sstate+      , syncNextId = i+1          +      })+    where+      !i = findNextEmptyId sstate $ syncNextId sstate+  where+    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 +  Just _ -> 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) +    => Peer -> proxy i -> SyncState s -> m (SyncState s)+syncRequestIdInternal peer p s = do+  chan <- getServiceChannel+  registerActorTypeRepM p+  sendService peer chan $ SyncServiceRequestId $ show $ actorFingerprint p+  return s++-- | Return channel id 1 if network module has more than 1 channel, either fallback to 0+--+-- Note: If you open more than one channel,+-- 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 +  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: " <>)
+ src/Game/GoreAndAsh/Sync/Remote.hs view
@@ -0,0 +1,16 @@+{-|+Module      : Game.GoreAndAsh.Sync.Remote+Description : Remote actors handling+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.Remote(+    module X+  ) where++import Game.GoreAndAsh.Sync.Remote.Actor as X +import Game.GoreAndAsh.Sync.Remote.Collection as X+import Game.GoreAndAsh.Sync.Remote.Sync as X
+ src/Game/GoreAndAsh/Sync/Remote/Actor.hs view
@@ -0,0 +1,297 @@+{-|+Module      : Game.GoreAndAsh.Sync.Remote.Actor+Description : Automatic synchronization of actor+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.Remote.Actor(+    RemoteActor(..)+  , RemActorId(..)+  , RemActorNetMessage(..)+  , clientSync+  , serverSync+  , registerRemoteActor+  ) where++import Control.Monad.Fix +import Control.Wire+import Control.Wire.Unsafe.Event (event, Event(..))+import Data.Proxy +import Data.Serialize +import Data.Word+import GHC.Generics+import Prelude hiding ((.), id)+import qualified Data.ByteString as BS +import qualified Data.Sequence as S++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Logging+import Game.GoreAndAsh.Sync.Message +import Game.GoreAndAsh.Sync.Remote.Sync +import Game.GoreAndAsh.Sync.API ++-- | Id of synchronization actor build over another actor+newtype RemActorId i = RemActorId { unRemActorId :: i }+  deriving (Show, Eq, Ord, Generic)++-- | Need to be called once for each remote actor (remote collections actually do this)+registerRemoteActor :: forall proxy i a m . (ActorMonad m, ActorMessage i, RemoteActor i a) +  => proxy i -- ^ Proxy of type of base actor id+  -> GameMonadT m () -- ^ Register basic id+registerRemoteActor _ = registerActorTypeRepM (Proxy :: Proxy (RemActorId i))++-- | Stub for local remote actor API+data RemActorMessage i ++instance RemoteActor i a => ActorMessage (RemActorId i) where+  type ActorMessageType (RemActorId i) = RemActorMessage i+  toCounter = toCounter . unRemActorId+  fromCounter = RemActorId . fromCounter++-- | Network protocol of synchronization actor+data RemActorNetMessage i = +    RemActorSyncRequest -- ^ Request full synchronization+  | RemActorSyncValue !Word64 !BS.ByteString -- ^ Carries value of indexed value+  deriving (Generic, Show)++instance Serialize (RemActorNetMessage i)++-- | Filter helper to pass through only RemActorSyncRequest+isRemActorSyncRequest :: RemActorNetMessage i -> Bool +isRemActorSyncRequest m = case m of +  RemActorSyncRequest -> True +  _ -> False ++-- | Filter helper to pass through only RemActorSyncValue+isRemActorSyncValue :: Word64 -> RemActorNetMessage i -> Bool +isRemActorSyncValue ia m = case m of +  RemActorSyncValue ib _ -> ia == ib +  _ -> False ++-- | Helper to construct sync message+mkSyncMessage :: Dict (Serialize a) -> Word64 -> a -> RemActorNetMessage i+mkSyncMessage d w a = RemActorSyncValue w (encodish d a)++-- | Helper to parse sync message+fromSyncMessage :: Dict (Serialize a) -> RemActorNetMessage i -> Maybe a +fromSyncMessage d m = case m of +  RemActorSyncRequest -> Nothing+  RemActorSyncValue _ bs -> case decodish d bs of +    Left _ -> Nothing+    Right a -> Just a++-- | Helper to deserialize only last message+fromSyncMessageLast :: Dict (Serialize a) -> S.Seq (RemActorNetMessage i) -> Maybe a +fromSyncMessageLast d s = case S.viewr s of +  S.EmptyR -> Nothing +  _ S.:> m -> fromSyncMessage d m ++instance RemoteActor i a => NetworkMessage (RemActorId i) where+  type NetworkMessageType (RemActorId i) = RemActorNetMessage i++-- | Helper to run @peerSendIndexedM@ with given dictionary+peerSendRemoteActorMsg :: (ActorMonad m, NetworkMonad m, LoggingMonad m, SyncMonad m)+  => Dict (RemoteActor i a) -- ^ Dictionary from Sync AST+  -> Peer -> ChannelID -> RemActorId i -> MessageType -> RemActorNetMessage i +  -> GameMonadT m ()+peerSendRemoteActorMsg Dict = peerSendIndexedM++-- | Helper to run @peerIndexedMessages@ with given dictionary+peerListenRemoteActor :: (ActorMonad m, NetworkMonad m, LoggingMonad m, SyncMonad m)+  => Dict (RemoteActor i a) -- ^ Dictionary from Sync AST+  -> Peer -> ChannelID -> RemActorId i+  -> GameWire m () (Event (S.Seq (RemActorNetMessage i)))+peerListenRemoteActor Dict = peerIndexedMessages++-- | Sends all data to remote client+serverFullSync :: (SyncMonad m, ActorMonad m, NetworkMonad m, LoggingMonad m) +  => Sync m i s a -- ^ Strategy of syncing+  -> Peer -- ^ Which client to send+  -> i -- ^ Id of actor+  -> GameWire m s a+serverFullSync ms peer i = case ms of +  SyncPure a -> pure a -- Client already knows the constant value+  SyncNone sa -> arr sa+  SyncClient Dict _ w sa -> liftGameMonad1 $ \s -> do+    let val = sa s+    peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage . mkSyncMessage Dict w $! val+    return val+  SyncServer Dict w sa -> liftGameMonad1 $ \s -> do+    let val = sa s+    peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage . mkSyncMessage Dict w $! val+    return val+  SyncCond _ _ ma -> serverFullSync ma peer i+  SyncReject _ _ _ ma -> serverFullSync ma peer i+  SyncApp mf ma -> proc s -> do +    f <- serverFullSync mf peer i -< s+    a <- serverFullSync ma peer i -< s+    returnA -< f a++-- | Sends all data to remote server+clientFullSync :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m) +  => Sync m i s a -- ^ Sync strategy+  -> Peer -- ^ Server connection+  -> i -- ^ Actor id+  -> GameWire m s a -- ^ Synchronizing of client state+clientFullSync ms peer i = case ms of +  SyncPure a -> pure a -- Client already knows the constant value+  SyncNone sa -> arr sa+  SyncClient Dict _ w sa -> liftGameMonad1 $ \s -> do+    let val = sa s+    peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage . mkSyncMessage Dict w $! val+    return val+  SyncServer _ _ sa -> arr sa -- The value is server side+  SyncCond _ _ ma -> clientFullSync ma peer i+  SyncReject _ _ _ ma -> clientFullSync ma peer i+  SyncApp mf ma -> proc s -> do +    f <- clientFullSync mf peer i -< s+    a <- clientFullSync ma peer i -< s+    returnA -< f a++-- | Perform partial client side synchronization+clientPartialSync :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m) +  => Sync m i s a -- ^ Sync strategy+  -> Peer -- ^ Server connection+  -> i -- ^ Actor id+  -> GameWire m s a -- ^ Synchronizing of client state+clientPartialSync ms peer i = case ms of +  SyncPure a -> pure a+  SyncNone sa -> arr sa+  SyncClient Dict _ w sa -> proc s -> do+    emsgs <- filterMsgs (isRemActorSyncValue w) . peerListenRemoteActor Dict peer (ChannelID 0) (RemActorId i) -< ()+    emsg <- filterJustE . mapE (fromSyncMessageLast Dict) -< emsgs+    case emsg of +      NoEvent -> do +        let val = event (sa s) id emsg+        liftGameMonad1 (+          peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage +          . mkSyncMessage Dict w) -< val+        returnA -< val+      Event val -> returnA -< val+  SyncServer Dict w sa -> proc s -> do +    emsgs <- filterMsgs (isRemActorSyncValue w) . peerListenRemoteActor Dict peer (ChannelID 0) (RemActorId i) -< ()+    emsg <- filterJustE . mapE (fromSyncMessageLast Dict) -< emsgs+    returnA -< event (sa s) id emsg+  SyncCond w sa ma -> proc s -> do +    e <- w -< s +    case e of +      NoEvent -> returnA -< sa s+      Event _ -> clientPartialSync ma peer i -< s +  SyncReject Dict w wid ma -> proc s -> do +    a <- clientPartialSync ma peer i -< s +    e <- w -< (s, a)+    case e of +      NoEvent -> returnA -< a +      Event a' -> do+        syncPeer -< a'+        returnA -< a'+    where+    syncPeer = liftGameMonad1 $ do+      peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage +      . mkSyncMessage Dict wid+  SyncApp mf ma -> proc s -> do +    f <- clientPartialSync mf peer i -< s+    a <- clientPartialSync ma peer i -< s+    returnA -< f a++-- | Perform partial server side synchronization+serverPartialSync :: (MonadFix m, ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m) +  => Sync m i s a -- ^ Sync strategy+  -> i -- ^ Actor id+  -> GameWire m s a -- ^ Transformer of state+serverPartialSync ms i = case ms of +  SyncPure a -> pure a+  SyncNone sa -> arr sa+  SyncClient Dict сpeer w sa -> onPeers $ \peers -> proc s -> do +    ea <- listenPeer -< s+    let a = sa s +        a' = event (sa s) id ea+    sequenceA (liftGameMonad1 . syncPeer <$> S.filter (/= сpeer) peers) -< a'+    serverChanged -< (a, a')+    returnA -< a'+    where+    -- Listen field owner about updates+    listenPeer = proc _ -> do +      emsgs <- filterMsgs (isRemActorSyncValue w) . peerListenRemoteActor Dict сpeer (ChannelID 0) (RemActorId i) -< ()+      filterJustE . mapE (fromSyncMessageLast Dict) -< emsgs+    -- Sync given peer field state+    syncPeer peer = do+      peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage +      . mkSyncMessage Dict w+    -- Detect when server changes the value and resync owner+    serverChanged = mkSFN $ \(_, a') -> ((), go a')+      where +      go v = mkGen $ \_ (a, a') -> if v == a +        then return (Right (), go a')+        else do +          syncPeer сpeer a+          return (Right (), go a')++  SyncServer Dict w sa -> onPeers $ \peers -> proc s -> do +    let val = sa s+    sequenceA (syncPeer <$> peers) -< val +    returnA -< val+    where+    syncPeer peer = liftGameMonad1 $ do+      peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage +      . mkSyncMessage Dict w+  SyncCond w sa ma -> proc s -> do +    e <- w -< s +    case e of +      NoEvent -> returnA -< sa s+      Event _ -> serverPartialSync ma i -< s +  SyncReject Dict w wid ma -> proc s -> do +    a <- serverPartialSync ma i -< s +    e <- w -< (s, a)+    case e of +      NoEvent -> returnA -< a +      Event a' -> do+        onPeers (sequenceA . fmap syncPeer) -< a'+        returnA -< a'+    where+    syncPeer peer = liftGameMonad1 $ do+      peerSendRemoteActorMsg Dict peer (ChannelID 0) (RemActorId i) ReliableMessage +      . mkSyncMessage Dict wid+  SyncApp mf ma -> proc s -> do +    f <- serverPartialSync mf i -< s+    a <- serverPartialSync ma i -< s+    returnA -< f a++-- | Perform client side synchronization+clientSync :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, RemoteActor i a) +  => Sync m i s a -- ^ Sync strategy+  -> Peer -- ^ Server connection+  -> i -- ^ Actor id+  -> GameWire m s a -- ^ Synchronizing of client state+clientSync ms peer i = proc s -> do +  peerSendIndexed peer (ChannelID 0) (RemActorId i) ReliableMessage . now -< RemActorSyncRequest+  syncOnRequest -< s +  clientPartialSync ms peer i -< s+  where +    syncOnRequest = proc s -> do +      emsgs <- filterMsgs isRemActorSyncRequest . peerIndexedMessages peer (ChannelID 0) (RemActorId i) -< ()+      case emsgs of +        NoEvent -> returnA -< ()+        Event _ -> pure () . clientFullSync  ms peer i -< s++-- | Perform server side synchronization+serverSync :: (MonadFix m, ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, RemoteActor i a) +  => Sync m i s a -- ^ Sync strategy+  -> i -- ^ Actor id+  -> GameWire m s a -- ^ Synchronizing of server state+serverSync ms i = proc s -> do +  syncOnRequest -< s +  serverPartialSync ms i -< s+  where +    syncOnRequest = onPeers $ \peers -> sequenceA $ syncOnRequestPeer <$> peers++    syncOnRequestPeer peer = proc s -> do +      emsgs <- filterMsgs isRemActorSyncRequest . peerIndexedMessages peer (ChannelID 0) (RemActorId i) -< ()+      case emsgs of +        NoEvent -> returnA -< ()+        Event _ -> pure () . serverFullSync  ms peer i -< s
+ src/Game/GoreAndAsh/Sync/Remote/Collection.hs view
@@ -0,0 +1,196 @@+{-|+Module      : Game.GoreAndAsh.Sync.Remote.Collection+Description : Automatic synchronization of collection of actors+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.Remote.Collection(+    RemActorCollId(..)+  , remoteActorCollectionServer+  , remoteActorCollectionClient+  ) where++import Control.DeepSeq+import Control.Monad (liftM)+import Control.Monad.Fix +import Control.Wire+import Control.Wire.Unsafe.Event+import Data.Filterable+import Data.Hashable +import Data.Proxy +import Data.Serialize+import GHC.Generics+import Prelude hiding ((.), id)+import qualified Data.Foldable as F +import qualified Data.Sequence as S ++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Actor.Collection+import Game.GoreAndAsh.Actor.Indexed+import Game.GoreAndAsh.Logging +import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync.API+import Game.GoreAndAsh.Sync.Message ++import Game.GoreAndAsh.Sync.Remote.Actor++-- | Unique id space for remote collections actors+newtype RemActorCollId = RemActorCollId { unRemActorCollId :: Int } +  deriving (Show, Eq, Ord, Generic)++instance NFData RemActorCollId +instance Hashable RemActorCollId++-- | Stub for local collection API+data RemActorCollMessage++instance ActorMessage RemActorCollId where+  type ActorMessageType RemActorCollId = RemActorCollMessage+  toCounter = unRemActorCollId+  fromCounter = RemActorCollId++-- | Comminucation protocol between client and server side collections+data RemActorCollNetMessage =+  -- | Sent to client when server collection adds new actor+    RemActorCollNetSpawn !Int +  -- | Sent to client when server collection removes specific actor+  | RemActorCollNetDespawn !Int +  -- | Sent when remote collection is set up to get actors that were +  -- created before the collection creation+  | RemActorCollRequestOthers +  deriving (Generic)++instance NFData RemActorCollNetMessage+instance Serialize RemActorCollNetMessage++instance NetworkMessage RemActorCollId where+  type NetworkMessageType RemActorCollId = RemActorCollNetMessage++-- | Helper to filter out specific message type+isRemActorCollNetSpawn :: RemActorCollNetMessage -> Bool +isRemActorCollNetSpawn m = case m of +  RemActorCollNetSpawn _ -> True +  _ -> False ++-- | Helper to filter out specific message type+isRemActorCollNetDespawn :: RemActorCollNetMessage -> Bool +isRemActorCollNetDespawn m = case m of +  RemActorCollNetDespawn _ -> True +  _ -> False++-- | Helper to filter out specific message type+isRemActorCollRequestOthers :: RemActorCollNetMessage -> Bool +isRemActorCollRequestOthers m = case m of +  RemActorCollRequestOthers -> True +  _ -> False++-- | Helper that performs monadic action over value of event or returns default value+-- Note: the function is isomorphic to @Data.Maybe.maybe@+onEvent :: Monad m => b -> Event a -> (a -> m b) -> m b+onEvent def e f = case e of +  NoEvent -> return def +  Event a -> f a ++-- | Server side collection of network actors that are automatically+-- synchronized to remote clients (creation and removing of actors).+-- +-- * Second wire input is event with new actors to add to the collection+--+-- * Third wire input is event with id of actor to delete from the collection+--+-- Note: the collection doesn't do synchronization of actor internal state, you should+-- call 'clientSync' by yourself.+remoteActorCollectionServer :: forall m a b c c2 i . (MonadFix m, SyncMonad m, LoggingMonad m, ActorMonad m, NetworkMonad m, Eq i, RemoteActor i b, DynCollection c, FilterConstraint c (GameWireIndexed m i a b), FilterConstraint c (Either () (b, i)), F.Foldable c2, Functor c2) +  => c (GameActor m i a b) -- ^ Initial set of actors+  -> GameActor m RemActorCollId (a, Event (c (GameActor m i a b)), Event (c2 i)) (c b)+remoteActorCollectionServer initialActors = do+  registerRemoteActor (Proxy :: Proxy i)+  makeActor $ \cid -> proc (a, addEvent, remEvent) -> do +    liftGameMonadOnce (registerActorTypeRepM (Proxy :: Proxy i)) -< ()+    (bs, is) <- dynCollection' cid -< (a, addEvent, remEvent)+    respondRequestOthers cid -< is+    returnA -< bs +  where +  -- | If any client asks for other actors, send ids+  respondRequestOthers :: RemActorCollId -> GameWire m (c i) ()+  respondRequestOthers cid = onPeers listenPeers+    where+      listenPeers :: S.Seq Peer -> GameWire m (c i) ()+      listenPeers peers = proc is -> do +        sequenceA (listenPeer <$> peers) -< is +        returnA -< ()++      listenPeer :: Peer -> GameWire m (c i) ()+      listenPeer peer = proc is -> do +        e <- filterMsgs isRemActorCollRequestOthers . peerIndexedMessages peer (ChannelID 0) cid -< ()+        let msgs = RemActorCollNetSpawn . toCounter <$> is+        peerSendIndexedMany peer (ChannelID 0) cid ReliableMessage -< const msgs <$> e+        returnA -< ()++  -- | Modified dynamic collection implementation+  dynCollection' cid = mkGen $ \ds input -> do +    arrs <- sequence initialActors+    go arrs ds input+    where+    -- | Send ids to clients+    sendSpawnMsgs is = do +      peers <- networkPeersM +      F.forM_ peers $ \peer -> F.forM_ is $ \i -> +        peerSendIndexedM peer (ChannelID 0) cid ReliableMessage $ RemActorCollNetSpawn i++    -- | Send ids to clients+    sendDespawnMsgs is = do +      peers <- networkPeersM +      F.forM_ peers $ \peer -> F.forM_ is $ \i -> +        peerSendIndexedM peer (ChannelID 0) cid ReliableMessage $ RemActorCollNetDespawn i++    -- | Each iteration do+    go :: c (GameWireIndexed m i a b)+      -> GameTime+      -> (a, Event (c (GameActor m i a b)), Event (c2 i))+      -> GameMonadT m (Either () (c b, c i), GameWire m (a, Event (c (GameActor m i a b)), Event (c2 i)) (c b, c i))+    go currentWires ds (a, addEvent, removeEvent) = do+      -- Adding new wires+      newAddedWires <- onEvent currentWires addEvent $ \newActors -> do +        addWires <- sequence newActors +        sendSpawnMsgs $ toCounter . indexedId <$> addWires+        return $ currentWires `concatDynColl` addWires++      -- Removing wires+      newRemovedWires <- onEvent newAddedWires removeEvent $ \ids ->  do +        sendDespawnMsgs $ toCounter <$> ids+        return $ F.foldl' (\acc i -> fFilter ((/= i) . indexedId) acc) newAddedWires ids++      -- Calculating outputs+      (bs, newWiresCntrls) <- liftM unzipDynColl $ mapM (\w -> stepWire w ds (Right a)) $ indexedWire <$> newRemovedWires+      let newWires = uncurry updateIndexedWire <$> (fmap const newWiresCntrls `zipDynColl` newRemovedWires)++      -- Attach ids+      let is = indexedId <$> newRemovedWires :: c i+      let bs' = (\(eb, i) -> (, i) <$> eb) <$> bs `zipDynColl` is :: c (Either () (b, i))+      let bs'' = unzipDynColl $ rightsDynColl bs' :: (c b, c i)+      return $ length newWires `seq` length is `seq` (Right bs'', mkGen $ go newWires)+++-- | Client side collection of network actors that are automatically+-- synchronized to remote clients (creation and removing of actors).+--+-- Note: the collection doesn't do synchronization of actor internal state, you should+-- call 'serverSync' by yourself.+remoteActorCollectionClient :: forall m i a b . (SyncMonad m, LoggingMonad m, ActorMonad m, NetworkMonad m, Eq i, RemoteActor i b) +  => RemActorCollId -- ^ Corresponding server collection id+  -> Peer -- ^ Server peer+  -> (i -> GameActor m i a b) -- ^ How to construct client side actors+  -> GameActor m RemActorCollId a (S.Seq b)+remoteActorCollectionClient cid peer mkActor = do +  registerRemoteActor (Proxy :: Proxy i)+  makeFixedActor cid $ proc a -> do+    peerSendIndexed peer (ChannelID 0) cid ReliableMessage . now -< RemActorCollRequestOthers+    emsgs <- peerIndexedMessages peer (ChannelID 0) cid -< ()+    addEvent <- mapE (fmap $ \(RemActorCollNetSpawn i) -> fromCounter i) . filterMsgs isRemActorCollNetSpawn -< emsgs+    remEvent <- mapE (fmap $ \(RemActorCollNetDespawn i) -> fromCounter i) . filterMsgs isRemActorCollNetDespawn -< emsgs+    dynCollection emptyDynColl -< (a, fmap mkActor <$> addEvent, remEvent)
+ src/Game/GoreAndAsh/Sync/Remote/Sync.hs view
@@ -0,0 +1,159 @@+{-|+Module      : Game.GoreAndAsh.Sync.Remote.Sync+Description : EDSL for automatic synchronization+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.Remote.Sync(+  -- * Remote actor API+    Sync(..)+  , FullSync+  , RemoteActor(..)+  , noSync+  , clientSide+  , serverSide+  , condSync+  , syncReject+  -- * Helpers for conditional synchronization+  , fieldChanges+  , fieldChangesWithin+  -- * Dictionary utils+  , Dict(..)+  , encodish+  , decodish+  ) where++import Control.Wire+import Control.Wire.Unsafe.Event+import Data.Serialize+import Data.Word +import qualified Data.ByteString as BS +import Prelude hiding (id, (.))++import Game.GoreAndAsh+import Game.GoreAndAsh.Network+import Game.GoreAndAsh.Sync.Message ++-- | Reify typeclass to dictionary+data Dict ctxt where+  Dict :: ctxt => Dict ctxt++-- | Use serialize dictionary to call @encode@+encodish :: Dict (Serialize a) -> a -> BS.ByteString +encodish Dict = encode ++-- | Use serialize dictionary to call @decode@+decodish :: Dict (Serialize a) -> BS.ByteString -> Either String a+decodish Dict = decode ++-- | Special monad that keeps info about synchronization logic +-- between client and server for type @a@. Remote collection +-- uses the description to generate special code to automatic+-- synchronization of shared actor state.+--+-- [@m@] means underlying game monad, that will be used during synchronization+-- +-- [@i@] means actor unique id type+--+-- [@s@] means actor state that is beeing syncing. As soon as you crafted+--   'Sync i s s' it means you defined full description how to sync actor state.+--+-- [@a@] is actual value type that the 'Sync' value is describing synchronization for.+--   As soon as you crafted 'Sync i s s' it means you defined full description how to sync actor state.+data Sync m i s a where+  SyncPure :: a -> Sync m i s a -- Statically known value+  SyncNone :: (s -> a) -> Sync m i s a -- No synchronization, take local value+  SyncClient :: Dict (Eq a, Serialize a, RemoteActor i s) -> Peer -> !Word64 -> (s -> a) -> Sync m i s a -- The value is controlled by client and synched to server.+  SyncServer :: Dict (Serialize a, RemoteActor i s) -> !Word64 -> (s -> a) -> Sync m i s a -- The value is controlled by server and synched to clients.+  SyncCond :: GameWire m s (Event ()) -> (s -> a) -> Sync m i s a -> Sync m i s a -- Conditional synchronization+  SyncReject :: Dict (Serialize a, RemoteActor i s) -> GameWire m (s, a) (Event a) -> !Word64 -> Sync m i s a -> Sync m i s a -- Validate synchronized value, rollback if failed+  SyncApp :: Sync m i s (a -> b) -> Sync m i s a -> Sync m i s b -- Applicative application of actions++instance Functor (Sync m i s) where+  fmap f s = case s of +    SyncPure a -> SyncPure (f a)+    _ -> SyncApp (SyncPure f) s++instance Applicative (Sync m i s) where+  pure = SyncPure+  sf <*> s = SyncApp sf s++-- | Type synonim for those Sync DSL programs that defines full synchronization of actor state+type FullSync m i s = Sync m i s s++-- | API to support automatic synchronization of actors between client and server+class NetworkMessage i => RemoteActor i a | i -> a, a -> i where+  -- | State of remote actor (should be equal a)+  type RemoteActorState i :: *+  -- | Id of remote actor (should be equal i)+  type RemoteActorId a :: *++-- | Perphoms no synchronization, the sync primitive returns local value of field+noSync :: (s -> a) -- ^ Getter of the field+  -> Sync m i s a+noSync = SyncNone ++-- | Declares that state field is client side, i.e. it is produced in client actor+-- and then sent to server. For peers that are not equal to specified (owner of the field)+-- the sync behavior acts as @serverSide@.+--+-- If server side changes the value manually, client is forced to new server side value.+clientSide :: (Eq a, Serialize a, RemoteActor i s)+  => Peer -- ^ Which peer controls the field, sync messages from other peers are not processed+  -> Word64 -- ^ Field id, other side actor should define @clientSide@ with matching id+  -> (s -> a) -- ^ Field getter+  -> Sync m i s a+clientSide peer !w getter = SyncClient Dict peer w getter++-- | Declares that state field is server side, i.e. it is produced in server actor+-- and then sent to all clients.+--+-- Clients cannot change the value manually.+serverSide :: (Serialize a, RemoteActor i s)+  => Word64 -- ^ Field id, other side actor should define @serverSide@ with matching id+  -> (s -> a) -- ^ Field getter+  -> Sync m i s a+serverSide !w getter = SyncServer Dict w getter++-- | Makes synchronization appear only when given wire produces an event.+--+-- Note: intended to use with 'serverSide'+condSync :: Monad m => GameWire m s (Event b) -- ^ Wire that produces events when sync should be done+  -> (s -> a) -- ^ Field getter+  -> Sync m i s a -- ^ Sub action that should be done when sync event is produced+  -> Sync m i s a+condSync w getter ms = SyncCond (mapE (const ()) . w) getter ms++-- | Produces event when given field is changed+fieldChanges :: Eq a => (s -> a) -- ^ Field getter+  -> GameWire m s (Event a)+fieldChanges getter = mkSFN $ \s -> let a = getter s in a `seq` (Event a, go a)+  where+    go a = mkSFN $ \s -> if a == getter s +      then (NoEvent, go a)+      else let a2 = getter s in a2 `seq` (Event a2, go a2)++-- | Produces event when given field is changed+fieldChangesWithin :: (Num a, Ord a) => (s -> a) -- ^ Field getter+  -> a -- ^ Delta, variation greater than the value is treated as change+  -> GameWire m s (Event a)+fieldChangesWithin getter delta = mkSFN $ \s -> let a = getter s in a `seq` (Event a, go a)+  where+    go a = mkSFN $ \s -> let a2 = getter s in if abs (a - a2) < delta+      then (NoEvent, go a)+      else a2 `seq` (Event a2, go a2)++-- | There are sometimes net errors or malicios data change in remote actor,+-- the action provides you ability to reject incorrect values and resync remote+-- actor to fallback value.+--+-- Note: intended to use with 'serverSide'+syncReject :: (Serialize a, RemoteActor i s)+  => GameWire m (s, a) (Event a) -- ^ Fires event when the synced value is invalid, event carries new value that should be placed and sended to remote peer+  -> Word64 -- ^ Id of field to resync at remote host when failed+  -> Sync m i s a -- ^ Sub action that produces synced values for first argument+  -> Sync m i s a+syncReject w wid ms = SyncReject Dict w wid ms
+ src/Game/GoreAndAsh/Sync/State.hs view
@@ -0,0 +1,87 @@+{-|+Module      : Game.GoreAndAsh.Sync.State+Description : Internal state of core module and message typeclass+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Sync.State(+    SyncState(..)+  , SyncRole(..)+  , NetworkMessage(..)+  , SyncServiceMsg(..)+  , emptySyncState+  ) where++import Control.DeepSeq+import Data.Serialize +import Data.Word +import GHC.Generics+import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++import Game.GoreAndAsh.Actor+import Game.GoreAndAsh.Actor.TypeRep+import Game.GoreAndAsh.Network ++-- | Defines behavior in synchronization for actor ids+data SyncRole = +    SyncMaster -- ^ Registers types of actors+  | SyncSlave -- ^ Always ask for ids from other nodes+  deriving (Generic, Eq, Show, Enum)++instance NFData SyncRole ++-- | Extension for actor message, messages that are sent to remote host+class ActorMessage i => NetworkMessage i where+  -- | Corresponding message payload for @i@ identifier, usually ADT+  type NetworkMessageType i :: *++-- | Internal service message for synchronizing ids of actors+data SyncServiceMsg = +  -- | Request id of actor with specified name+    SyncServiceRequestId !String+  -- | Response with actor id and name+  | SyncServiceResponseId !String !Word64+  -- | Response that given actor is not found+  | SyncServiceResponseNotRegistered !String+  deriving (Generic)++instance Serialize SyncServiceMsg++-- | Inner state of sync module+--+-- [@s@] - State of next module, the states are chained via nesting.+data SyncState s = SyncState {+  -- | Next module in chain+  syncNextState :: !s+  -- | Mapping from type representation to id+, syncIdMap :: !(H.HashMap HashableTypeRep Word64)+  -- | Reverse mapping from id to type representation+, syncIdMapRev :: !(H.HashMap Word64 HashableTypeRep)+  -- | Next empty id for registering, value zero is service value+, syncNextId :: !Word64+  -- | Messages that are waiting resolving of network id of actor+  -- Actor name and actor local id is stored with the message to sent+, syncScheduledMessages :: !(H.HashMap Peer (S.Seq (String, ChannelID, Word64 -> Message)))+  -- | Flag that enables detailed logging+, syncLogging :: !Bool+  -- | Current model of synchronization+, syncRole :: !SyncRole+} deriving (Generic)++instance NFData s => NFData (SyncState s)++-- | Make empty sync state+emptySyncState :: s -> SyncState s +emptySyncState s = SyncState {+    syncNextState = s+  , syncIdMap = H.empty +  , syncIdMapRev = H.empty+  , syncNextId = 1+  , syncScheduledMessages = H.empty+  , syncLogging = False+  , syncRole = SyncMaster+  }