mirror of https://github.com/voidlizard/hbs2
wtf?
This commit is contained in:
Dmitry Zuikov
parent
1bdf9e58ae
commit
af1009e194
|
|
@ -1,2 +1,6 @@
|
||||||
packages: **/*.cabal
|
packages:
|
||||||
|
hbs2/hbs2.cabal
|
||||||
|
hbs2-core/hbs2-core.cabal
|
||||||
|
hbs2-storage-simple/hbs2-storage-simple.cabal
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,252 @@
|
||||||
|
{-# Language TemplateHaskell #-}
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
module HBS2.Actors.Peer where
|
||||||
|
|
||||||
|
import HBS2.Prelude
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
import HBS2.Net.Proto
|
||||||
|
import HBS2.Net.Messaging
|
||||||
|
import HBS2.Clock
|
||||||
|
import HBS2.Actors
|
||||||
|
import HBS2.Defaults
|
||||||
|
|
||||||
|
|
||||||
|
import Control.Concurrent.Async
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Data.ByteString.Lazy ( ByteString )
|
||||||
|
import Data.Digest.Murmur32
|
||||||
|
import Data.Foldable hiding (find)
|
||||||
|
import Data.Hashable
|
||||||
|
import Data.Kind
|
||||||
|
import Data.Map qualified as Map
|
||||||
|
import GHC.TypeLits
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
import System.Random qualified as Random
|
||||||
|
import Data.Cache (Cache)
|
||||||
|
import Data.Cache qualified as Cache
|
||||||
|
import Data.Dynamic
|
||||||
|
import Data.Maybe
|
||||||
|
|
||||||
|
import Codec.Serialise hiding (encode,decode)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
data AnyMessage e = AnyMessage Integer (Encoded e)
|
||||||
|
deriving stock (Generic)
|
||||||
|
|
||||||
|
instance Serialise (Encoded e) => Serialise (AnyMessage e)
|
||||||
|
|
||||||
|
|
||||||
|
data EngineEnv e = forall bus . ( Messaging bus e ByteString
|
||||||
|
, Serialise (Encoded e)
|
||||||
|
) =>
|
||||||
|
EngineEnv
|
||||||
|
{ _peer :: Maybe (Peer e)
|
||||||
|
, _self :: Peer e
|
||||||
|
, _sessions :: Cache SKey Dynamic
|
||||||
|
, bus :: bus
|
||||||
|
, defer :: Pipeline IO ()
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
newtype EngineM e m a = EngineM { fromEngine :: ReaderT (EngineEnv e) m a }
|
||||||
|
deriving newtype ( Functor
|
||||||
|
, Applicative
|
||||||
|
, Monad
|
||||||
|
, MonadIO
|
||||||
|
, MonadReader (EngineEnv e)
|
||||||
|
, MonadTrans
|
||||||
|
)
|
||||||
|
|
||||||
|
data ResponseEnv e =
|
||||||
|
ResponseEnv
|
||||||
|
{ _engine :: EngineEnv e
|
||||||
|
, _respPeer :: Peer e
|
||||||
|
}
|
||||||
|
|
||||||
|
newtype ResponseM e m a = ResponseM { fromResponse :: ReaderT (ResponseEnv e) m a }
|
||||||
|
deriving newtype ( Functor
|
||||||
|
, Applicative
|
||||||
|
, Monad
|
||||||
|
, MonadIO
|
||||||
|
, MonadReader (ResponseEnv e)
|
||||||
|
, MonadTrans
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
makeLenses 'EngineEnv
|
||||||
|
|
||||||
|
makeLenses 'ResponseEnv
|
||||||
|
|
||||||
|
data AnyProtocol e m = forall p . ( HasProtocol e p
|
||||||
|
, Response e p m
|
||||||
|
) =>
|
||||||
|
AnyProtocol
|
||||||
|
{ myProtoId :: Integer
|
||||||
|
, protoDecode :: Encoded e -> Maybe p
|
||||||
|
, protoEncode :: p -> Encoded e
|
||||||
|
, handle :: p -> m ()
|
||||||
|
}
|
||||||
|
|
||||||
|
makeResponse :: forall e p m . ( MonadIO m
|
||||||
|
, Response e p m
|
||||||
|
, HasProtocol e p
|
||||||
|
)
|
||||||
|
=> (p -> m ()) -> AnyProtocol e m
|
||||||
|
|
||||||
|
makeResponse h = AnyProtocol { myProtoId = natVal (Proxy @(ProtocolId p))
|
||||||
|
, protoDecode = decode
|
||||||
|
, protoEncode = encode
|
||||||
|
, handle = h
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
runEngineM :: EngineEnv e -> EngineM e m a -> m a
|
||||||
|
runEngineM e f = runReaderT (fromEngine f) e
|
||||||
|
|
||||||
|
runResponseM :: Monad m => EngineEnv e -> Peer e -> ResponseM e m a -> EngineM e m a
|
||||||
|
runResponseM eng p f = lift $ runReaderT (fromResponse f) (ResponseEnv eng p)
|
||||||
|
|
||||||
|
instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where
|
||||||
|
request p msg = do
|
||||||
|
let proto = protoId @e @p (Proxy @p)
|
||||||
|
ask >>= \case
|
||||||
|
EngineEnv { _self = s, bus = b} -> do
|
||||||
|
let bs = serialise (AnyMessage @e proto (encode msg))
|
||||||
|
liftIO $ sendTo b (To p) (From s) bs
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
instance ( MonadIO m
|
||||||
|
, HasProtocol e p
|
||||||
|
, Eq (SessionKey e p)
|
||||||
|
, Typeable (SessionKey e p)
|
||||||
|
, Typeable (SessionData e p)
|
||||||
|
, Hashable (SessionKey e p)
|
||||||
|
) => Sessions e p (ResponseM e m) where
|
||||||
|
|
||||||
|
find k f = flip runEngineM (find k f) =<< asks (view engine)
|
||||||
|
|
||||||
|
fetch i d k f = flip runEngineM (fetch i d k f) =<< asks (view engine)
|
||||||
|
|
||||||
|
update d k f = flip runEngineM (update d k f) =<< asks (view engine)
|
||||||
|
|
||||||
|
expire k = flip runEngineM (expire k) =<< asks (view engine)
|
||||||
|
|
||||||
|
|
||||||
|
instance ( MonadIO m
|
||||||
|
, HasProtocol e p
|
||||||
|
, Eq (SessionKey e p)
|
||||||
|
, Typeable (SessionKey e p)
|
||||||
|
, Typeable (SessionData e p)
|
||||||
|
, Hashable (SessionKey e p)
|
||||||
|
) => Sessions e p (EngineM e m) where
|
||||||
|
|
||||||
|
|
||||||
|
find k f = do
|
||||||
|
se <- asks (view sessions)
|
||||||
|
let sk = newSKey @(SessionKey e p) k
|
||||||
|
r <- liftIO $ Cache.lookup se sk
|
||||||
|
case fromDynamic @(SessionData e p) <$> r of
|
||||||
|
Just v -> pure $ f <$> v
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
|
||||||
|
fetch upd def k fn = do
|
||||||
|
se <- asks (view sessions)
|
||||||
|
let sk = newSKey @(SessionKey e p) k
|
||||||
|
let ddef = toDyn def
|
||||||
|
|
||||||
|
r <- liftIO $ Cache.lookup se sk
|
||||||
|
|
||||||
|
case r of
|
||||||
|
Just v -> pure $ fn $ fromMaybe def (fromDynamic @(SessionData e p) v )
|
||||||
|
Nothing -> do
|
||||||
|
when upd $ liftIO $ Cache.insert se sk ddef
|
||||||
|
pure (fn def)
|
||||||
|
|
||||||
|
update def k f = do
|
||||||
|
se <- asks (view sessions)
|
||||||
|
val <- fetch @e @p True def k id
|
||||||
|
liftIO $ Cache.insert se (newSKey @(SessionKey e p) k) (toDyn (f val))
|
||||||
|
|
||||||
|
expire k = do
|
||||||
|
se <- asks (view sessions)
|
||||||
|
liftIO $ Cache.delete se (newSKey @(SessionKey e p) k)
|
||||||
|
|
||||||
|
instance (HasProtocol e p, Serialise (Encoded e)) => Response e p (ResponseM e IO) where
|
||||||
|
|
||||||
|
thatPeer _ = asks (view respPeer)
|
||||||
|
|
||||||
|
deferred _ m = do
|
||||||
|
e@(EngineEnv { defer = d }) <- asks (view engine)
|
||||||
|
p <- asks (view respPeer)
|
||||||
|
addJob d (runEngineM e (runResponseM e p m))
|
||||||
|
|
||||||
|
response resp = do
|
||||||
|
env <- ask
|
||||||
|
let p = env ^. respPeer
|
||||||
|
let s = env ^. (engine . self)
|
||||||
|
let proto = protoId @e @p (Proxy @p)
|
||||||
|
let bs = serialise (AnyMessage @e proto (encode resp))
|
||||||
|
|
||||||
|
-- TODO: wrap somehow
|
||||||
|
case env ^. engine of
|
||||||
|
EngineEnv { bus = b } -> liftIO $ sendTo b (To p) (From s) bs
|
||||||
|
|
||||||
|
newEnv :: forall e bus m . ( Monad m
|
||||||
|
, MonadIO m
|
||||||
|
, Messaging bus e ByteString
|
||||||
|
, Serialise (Encoded e)
|
||||||
|
)
|
||||||
|
=> Peer e
|
||||||
|
-> bus
|
||||||
|
-> m (EngineEnv e)
|
||||||
|
|
||||||
|
newEnv p pipe = do
|
||||||
|
de <- liftIO $ newPipeline defProtoPipelineSize
|
||||||
|
se <- liftIO $ Cache.newCache (Just defCookieTimeout) -- FIXME: some more clever for timeout, i.e. typeclass
|
||||||
|
pure $ EngineEnv Nothing p se pipe de
|
||||||
|
|
||||||
|
runPeer :: forall e m a . ( MonadIO m
|
||||||
|
)
|
||||||
|
=> EngineEnv e
|
||||||
|
-> [AnyProtocol e (ResponseM e m)]
|
||||||
|
-> m a
|
||||||
|
|
||||||
|
runPeer env@(EngineEnv {bus = pipe, defer = d}) hh = do
|
||||||
|
|
||||||
|
let me = env ^. self
|
||||||
|
|
||||||
|
let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ]
|
||||||
|
|
||||||
|
let disp = Map.fromList resp
|
||||||
|
|
||||||
|
void $ liftIO $ async $ runPipeline d
|
||||||
|
|
||||||
|
runEngineM env $ do
|
||||||
|
|
||||||
|
forever $ do
|
||||||
|
messages <- receive pipe (To me)
|
||||||
|
|
||||||
|
for_ messages $ \(From pip, bs) -> do
|
||||||
|
|
||||||
|
case deserialiseOrFail @(AnyMessage e) bs of
|
||||||
|
|
||||||
|
Left _-> pure () -- liftIO $ print "failed to deserialise"
|
||||||
|
|
||||||
|
Right (AnyMessage n msg) -> do
|
||||||
|
|
||||||
|
local (set peer (Just pip)) do
|
||||||
|
|
||||||
|
ee <- ask
|
||||||
|
|
||||||
|
case Map.lookup n disp of
|
||||||
|
Nothing -> pure ()
|
||||||
|
|
||||||
|
Just (AnyProtocol { protoDecode = decoder
|
||||||
|
, handle = h
|
||||||
|
}) -> maybe (pure ()) (runResponseM ee pip . h) (decoder msg)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,252 +1,3 @@
|
||||||
{-# Language TemplateHaskell #-}
|
|
||||||
{-# Language UndecidableInstances #-}
|
|
||||||
module HBS2.Actors.Peer where
|
module HBS2.Actors.Peer where
|
||||||
|
|
||||||
import HBS2.Prelude
|
|
||||||
import HBS2.Prelude.Plated
|
|
||||||
import HBS2.Net.Proto
|
|
||||||
import HBS2.Net.Messaging
|
|
||||||
import HBS2.Clock
|
|
||||||
import HBS2.Actors
|
|
||||||
import HBS2.Defaults
|
|
||||||
|
|
||||||
|
|
||||||
import Control.Concurrent.Async
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import Control.Monad.Trans.Maybe
|
|
||||||
import Data.ByteString.Lazy ( ByteString )
|
|
||||||
import Data.Digest.Murmur32
|
|
||||||
import Data.Foldable hiding (find)
|
|
||||||
import Data.Hashable
|
|
||||||
import Data.Kind
|
|
||||||
import Data.Map qualified as Map
|
|
||||||
import GHC.TypeLits
|
|
||||||
import Lens.Micro.Platform
|
|
||||||
import System.Random qualified as Random
|
|
||||||
import Data.Cache (Cache)
|
|
||||||
import Data.Cache qualified as Cache
|
|
||||||
import Data.Dynamic
|
|
||||||
import Data.Maybe
|
|
||||||
|
|
||||||
import Codec.Serialise hiding (encode,decode)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
data AnyMessage e = AnyMessage Integer (Encoded e)
|
|
||||||
deriving stock (Generic)
|
|
||||||
|
|
||||||
instance Serialise (Encoded e) => Serialise (AnyMessage e)
|
|
||||||
|
|
||||||
|
|
||||||
data EngineEnv e = forall bus . ( Messaging bus e ByteString
|
|
||||||
, Serialise (Encoded e)
|
|
||||||
) =>
|
|
||||||
EngineEnv
|
|
||||||
{ _peer :: Maybe (Peer e)
|
|
||||||
, _self :: Peer e
|
|
||||||
, _sessions :: Cache SKey Dynamic
|
|
||||||
, bus :: bus
|
|
||||||
, defer :: Pipeline IO ()
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
newtype EngineM e m a = EngineM { fromEngine :: ReaderT (EngineEnv e) m a }
|
|
||||||
deriving newtype ( Functor
|
|
||||||
, Applicative
|
|
||||||
, Monad
|
|
||||||
, MonadIO
|
|
||||||
, MonadReader (EngineEnv e)
|
|
||||||
, MonadTrans
|
|
||||||
)
|
|
||||||
|
|
||||||
data ResponseEnv e =
|
|
||||||
ResponseEnv
|
|
||||||
{ _engine :: EngineEnv e
|
|
||||||
, _respPeer :: Peer e
|
|
||||||
}
|
|
||||||
|
|
||||||
newtype ResponseM e m a = ResponseM { fromResponse :: ReaderT (ResponseEnv e) m a }
|
|
||||||
deriving newtype ( Functor
|
|
||||||
, Applicative
|
|
||||||
, Monad
|
|
||||||
, MonadIO
|
|
||||||
, MonadReader (ResponseEnv e)
|
|
||||||
, MonadTrans
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
makeLenses 'EngineEnv
|
|
||||||
|
|
||||||
makeLenses 'ResponseEnv
|
|
||||||
|
|
||||||
data AnyProtocol e m = forall p . ( HasProtocol e p
|
|
||||||
, Response e p m
|
|
||||||
) =>
|
|
||||||
AnyProtocol
|
|
||||||
{ myProtoId :: Integer
|
|
||||||
, protoDecode :: Encoded e -> Maybe p
|
|
||||||
, protoEncode :: p -> Encoded e
|
|
||||||
, handle :: p -> m ()
|
|
||||||
}
|
|
||||||
|
|
||||||
makeResponse :: forall e p m . ( MonadIO m
|
|
||||||
, Response e p m
|
|
||||||
, HasProtocol e p
|
|
||||||
)
|
|
||||||
=> (p -> m ()) -> AnyProtocol e m
|
|
||||||
|
|
||||||
makeResponse h = AnyProtocol { myProtoId = natVal (Proxy @(ProtocolId p))
|
|
||||||
, protoDecode = decode
|
|
||||||
, protoEncode = encode
|
|
||||||
, handle = h
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
runEngineM :: EngineEnv e -> EngineM e m a -> m a
|
|
||||||
runEngineM e f = runReaderT (fromEngine f) e
|
|
||||||
|
|
||||||
runResponseM :: Monad m => EngineEnv e -> Peer e -> ResponseM e m a -> EngineM e m a
|
|
||||||
runResponseM eng p f = lift $ runReaderT (fromResponse f) (ResponseEnv eng p)
|
|
||||||
|
|
||||||
instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where
|
|
||||||
request p msg = do
|
|
||||||
let proto = protoId @e @p (Proxy @p)
|
|
||||||
ask >>= \case
|
|
||||||
EngineEnv { _self = s, bus = b} -> do
|
|
||||||
let bs = serialise (AnyMessage @e proto (encode msg))
|
|
||||||
liftIO $ sendTo b (To p) (From s) bs
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
instance ( MonadIO m
|
|
||||||
, HasProtocol e p
|
|
||||||
, Eq (SessionKey e p)
|
|
||||||
, Typeable (SessionKey e p)
|
|
||||||
, Typeable (SessionData e p)
|
|
||||||
, Hashable (SessionKey e p)
|
|
||||||
) => Sessions e p (ResponseM e m) where
|
|
||||||
|
|
||||||
find k f = flip runEngineM (find k f) =<< asks (view engine)
|
|
||||||
|
|
||||||
fetch i d k f = flip runEngineM (fetch i d k f) =<< asks (view engine)
|
|
||||||
|
|
||||||
update d k f = flip runEngineM (update d k f) =<< asks (view engine)
|
|
||||||
|
|
||||||
expire k = flip runEngineM (expire k) =<< asks (view engine)
|
|
||||||
|
|
||||||
|
|
||||||
instance ( MonadIO m
|
|
||||||
, HasProtocol e p
|
|
||||||
, Eq (SessionKey e p)
|
|
||||||
, Typeable (SessionKey e p)
|
|
||||||
, Typeable (SessionData e p)
|
|
||||||
, Hashable (SessionKey e p)
|
|
||||||
) => Sessions e p (EngineM e m) where
|
|
||||||
|
|
||||||
|
|
||||||
find k f = do
|
|
||||||
se <- asks (view sessions)
|
|
||||||
let sk = newSKey @(SessionKey e p) k
|
|
||||||
r <- liftIO $ Cache.lookup se sk
|
|
||||||
case fromDynamic @(SessionData e p) <$> r of
|
|
||||||
Just v -> pure $ f <$> v
|
|
||||||
Nothing -> pure Nothing
|
|
||||||
|
|
||||||
fetch upd def k fn = do
|
|
||||||
se <- asks (view sessions)
|
|
||||||
let sk = newSKey @(SessionKey e p) k
|
|
||||||
let ddef = toDyn def
|
|
||||||
|
|
||||||
r <- liftIO $ Cache.lookup se sk
|
|
||||||
|
|
||||||
case r of
|
|
||||||
Just v -> pure $ fn $ fromMaybe def (fromDynamic @(SessionData e p) v )
|
|
||||||
Nothing -> do
|
|
||||||
when upd $ liftIO $ Cache.insert se sk ddef
|
|
||||||
pure (fn def)
|
|
||||||
|
|
||||||
update def k f = do
|
|
||||||
se <- asks (view sessions)
|
|
||||||
val <- fetch @e @p True def k id
|
|
||||||
liftIO $ Cache.insert se (newSKey @(SessionKey e p) k) (toDyn (f val))
|
|
||||||
|
|
||||||
expire k = do
|
|
||||||
se <- asks (view sessions)
|
|
||||||
liftIO $ Cache.delete se (newSKey @(SessionKey e p) k)
|
|
||||||
|
|
||||||
instance (HasProtocol e p, Serialise (Encoded e)) => Response e p (ResponseM e IO) where
|
|
||||||
|
|
||||||
thatPeer _ = asks (view respPeer)
|
|
||||||
|
|
||||||
deferred _ m = do
|
|
||||||
e@(EngineEnv { defer = d }) <- asks (view engine)
|
|
||||||
p <- asks (view respPeer)
|
|
||||||
addJob d (runEngineM e (runResponseM e p m))
|
|
||||||
|
|
||||||
response resp = do
|
|
||||||
env <- ask
|
|
||||||
let p = env ^. respPeer
|
|
||||||
let s = env ^. (engine . self)
|
|
||||||
let proto = protoId @e @p (Proxy @p)
|
|
||||||
let bs = serialise (AnyMessage @e proto (encode resp))
|
|
||||||
|
|
||||||
-- TODO: wrap somehow
|
|
||||||
case env ^. engine of
|
|
||||||
EngineEnv { bus = b } -> liftIO $ sendTo b (To p) (From s) bs
|
|
||||||
|
|
||||||
newEnv :: forall e bus m . ( Monad m
|
|
||||||
, MonadIO m
|
|
||||||
, Messaging bus e ByteString
|
|
||||||
, Serialise (Encoded e)
|
|
||||||
)
|
|
||||||
=> Peer e
|
|
||||||
-> bus
|
|
||||||
-> m (EngineEnv e)
|
|
||||||
|
|
||||||
newEnv p pipe = do
|
|
||||||
de <- liftIO $ newPipeline defProtoPipelineSize
|
|
||||||
se <- liftIO $ Cache.newCache (Just defCookieTimeout) -- FIXME: some more clever for timeout, i.e. typeclass
|
|
||||||
pure $ EngineEnv Nothing p se pipe de
|
|
||||||
|
|
||||||
runPeer :: forall e m a . ( MonadIO m
|
|
||||||
)
|
|
||||||
=> EngineEnv e
|
|
||||||
-> [AnyProtocol e (ResponseM e m)]
|
|
||||||
-> m a
|
|
||||||
|
|
||||||
runPeer env@(EngineEnv {bus = pipe, defer = d}) hh = do
|
|
||||||
|
|
||||||
let me = env ^. self
|
|
||||||
|
|
||||||
let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ]
|
|
||||||
|
|
||||||
let disp = Map.fromList resp
|
|
||||||
|
|
||||||
void $ liftIO $ async $ runPipeline d
|
|
||||||
|
|
||||||
runEngineM env $ do
|
|
||||||
|
|
||||||
forever $ do
|
|
||||||
messages <- receive pipe (To me)
|
|
||||||
|
|
||||||
for_ messages $ \(From pip, bs) -> do
|
|
||||||
|
|
||||||
case deserialiseOrFail @(AnyMessage e) bs of
|
|
||||||
|
|
||||||
Left _-> pure () -- liftIO $ print "failed to deserialise"
|
|
||||||
|
|
||||||
Right (AnyMessage n msg) -> do
|
|
||||||
|
|
||||||
local (set peer (Just pip)) do
|
|
||||||
|
|
||||||
ee <- ask
|
|
||||||
|
|
||||||
case Map.lookup n disp of
|
|
||||||
Nothing -> pure ()
|
|
||||||
|
|
||||||
Just (AnyProtocol { protoDecode = decoder
|
|
||||||
, handle = h
|
|
||||||
}) -> maybe (pure ()) (runResponseM ee pip . h) (decoder msg)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue