module Game.GoreAndAsh.Sync.Message(
NetworkMessage(..)
, peerIndexedMessages
, peerProcessIndexed
, peerProcessIndexedM
, peerSendIndexedM
, peerSendIndexed
, peerSendIndexedDyn
, peerSendIndexedMany
, peerSendIndexedManyDyn
, 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
peerIndexedMessages :: forall m i a . (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))
=> Peer
-> ChannelID
-> i
-> GameWire m a (Event (S.Seq (NetworkMessageType i)))
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
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)
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
catMaybesSeq :: S.Seq (Maybe a) -> S.Seq a
catMaybesSeq = fmap fromJust . S.filter isJust
peerSendIndexedM :: forall m i . (SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))
=> Peer
-> ChannelID
-> i
-> MessageType
-> NetworkMessageType i
-> m ()
peerSendIndexedM p chid i mt msg = do
mnid <- getSyncIdM $ actorFingerprint (Proxy :: Proxy i)
case mnid of
Nothing -> syncScheduleMessageM p chid i mt msg
Just nid -> do
let w64 = fromIntegral (toCounter i) :: Word64
msg' = Message mt $! encode (nid, encode (w64, encode msg))
peerSendM p chid msg'
peerSendIndexed :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))
=> Peer
-> ChannelID
-> i
-> MessageType
-> GameWire m (Event (NetworkMessageType i)) (Event ())
peerSendIndexed p chid i mt = liftGameMonadEvent1 $ peerSendIndexedM p chid i mt
peerSendIndexedDyn :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))
=> ChannelID
-> MessageType
-> GameWire m (Event (Peer, i, NetworkMessageType i)) (Event ())
peerSendIndexedDyn chid mt = liftGameMonadEvent1 $ \(p, i, msg) -> peerSendIndexedM p chid i mt msg
peerSendIndexedMany :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i), F.Foldable t)
=> Peer
-> ChannelID
-> i
-> MessageType
-> GameWire m (Event (t (NetworkMessageType i))) (Event ())
peerSendIndexedMany p chid i mt = liftGameMonadEvent1 . F.mapM_ $ peerSendIndexedM p chid i mt
peerSendIndexedManyDyn :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i), F.Foldable t)
=> ChannelID
-> MessageType
-> GameWire m (Event (t (Peer, i, NetworkMessageType i))) (Event ())
peerSendIndexedManyDyn chid mt = liftGameMonadEvent1 . F.mapM_ $ \(p, i, msg) -> peerSendIndexedM p chid i mt msg
peerProcessIndexed :: (ActorMonad m,SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))
=> Peer
-> ChannelID
-> i
-> (a -> NetworkMessageType i -> a)
-> GameWire m a a
peerProcessIndexed p chid i f = proc a -> do
emsgs <- peerIndexedMessages p chid i -< ()
returnA -< event a (F.foldl' f a) emsgs
peerProcessIndexedM :: (ActorMonad m, SyncMonad m, NetworkMonad m, LoggingMonad m, NetworkMessage i, Serialize (NetworkMessageType i))
=> Peer
-> ChannelID
-> i
-> (a -> NetworkMessageType i -> GameMonadT m a)
-> GameWire m a a
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)
filterMsgs :: (Monad m)
=> (a -> Bool)
-> GameWire m (Event (S.Seq a)) (Event (S.Seq a))
filterMsgs p = filterE (not . S.null) . mapE (S.filter p)