{-# LANGUAGE
RankNTypes
, TypeFamilies
, DeriveGeneric
, NamedFieldPuns
, RecordWildCards
, FlexibleContexts
, FlexibleInstances
, OverloadedStrings
, StandaloneDeriving
, ScopedTypeVariables
, UndecidableInstances
, MultiParamTypeClasses
, ExistentialQuantification
#-}
module Test.Serialization.Symbiote
(
SymbioteOperation (..), Symbiote (..), SimpleSerialization (..), Topic, SymbioteT, register
,
First (..), Second (..), Generating (..), Operating (..)
,
Failure (..), defaultSuccess, defaultFailure, defaultProgress, nullProgress
,
simpleTest, simpleTest', firstPeer, secondPeer
) where
import Test.Serialization.Symbiote.Core
( Topic (..), newGeneration, SymbioteState (..), ExistsSymbiote (..), SymbioteT, runSymbioteT
, GenerateSymbiote (..), generateSymbiote, getProgress, Symbiote (..), SymbioteOperation (..))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Int (Int32)
import Data.Text (unpack)
import Data.Proxy (Proxy (..))
import Data.Aeson (ToJSON (..), FromJSON (..), (.=), object, (.:), Value (Object, String))
import Data.Aeson.Types (typeMismatch)
import Data.Serialize (Serialize (..))
import Data.Serialize.Put (putWord8, putInt32be, putByteString, putLazyByteString, PutM)
import Data.Serialize.Get (getWord8, getInt32be, getByteString, getLazyByteString, Get)
import Text.Printf (printf)
import Control.Concurrent.STM
(TVar, newTVarIO, readTVarIO, writeTVar, atomically, newTChan, readTChan, writeTChan)
import Control.Concurrent.Async (async, wait)
import Control.Applicative ((<|>))
import Control.Monad (void, replicateM)
import Control.Monad.Trans.Control.Aligned (MonadBaseControl, liftBaseWith)
import Control.Monad.State (modify')
import Control.Monad.IO.Class (MonadIO, liftIO)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Test.QuickCheck.Gen (Gen, oneof)
import GHC.Generics (Generic)
data SimpleSerialization a o
=
SimpleValue a
|
SimpleOutput o
|
SimpleOperation (Operation a)
deriving (Generic)
deriving instance (Show a, Show o, Show (Operation a)) => Show (SimpleSerialization a o)
deriving instance (Eq a, Eq o, Eq (Operation a)) => Eq (SimpleSerialization a o)
instance SymbioteOperation a o => Symbiote a o (SimpleSerialization a o) where
encode = SimpleValue
decode (SimpleValue x) = Just x
decode _ = Nothing
encodeOut _ = SimpleOutput
decodeOut _ (SimpleOutput x) = Just x
decodeOut _ _ = Nothing
encodeOp = SimpleOperation
decodeOp (SimpleOperation x) = Just x
decodeOp _ = Nothing
register :: forall a o s m
. Arbitrary a
=> Arbitrary (Operation a)
=> Symbiote a o s
=> Eq o
=> MonadIO m
=> Topic
-> Int32
-> Proxy a
-> SymbioteT s m ()
register t maxSize Proxy = do
generation <- liftIO (newTVarIO newGeneration)
let newState :: SymbioteState a o s
newState = SymbioteState
{ generate = arbitrary :: Gen a
, generateOp = arbitrary :: Gen (Operation a)
, equal = (==) :: o -> o -> Bool
, maxSize
, generation
, encode' = encode
, encodeOut' = encodeOut (Proxy :: Proxy a)
, encodeOp' = encodeOp
, decode' = decode
, decodeOut' = decodeOut (Proxy :: Proxy a)
, decodeOp' = decodeOp
, perform' = perform
}
modify' (Map.insert t (ExistsSymbiote newState))
data Generating s
=
Generated
{ genValue :: s
, genOperation :: s
}
|
BadResult s
|
YourTurn
|
ImFinished
|
GeneratingNoParseOperated s
deriving (Eq, Show, Generic)
instance Arbitrary s => Arbitrary (Generating s) where
arbitrary = oneof
[ Generated <$> arbitrary <*> arbitrary
, BadResult <$> arbitrary
, pure YourTurn
, pure ImFinished
, GeneratingNoParseOperated <$> arbitrary
]
instance ToJSON s => ToJSON (Generating s) where
toJSON x = case x of
Generated{..} -> object ["generated" .= object ["value" .= genValue, "operation" .= genOperation]]
BadResult r -> object ["badResult" .= r]
YourTurn -> String "yourTurn"
ImFinished -> String "imFinished"
GeneratingNoParseOperated r -> object ["noParseOperated" .= r]
instance FromJSON s => FromJSON (Generating s) where
parseJSON (Object o) = generated <|> badResult <|> noParseOperated
where
generated = do
o' <- o .: "generated"
Generated <$> o' .: "value" <*> o' .: "operation"
badResult = BadResult <$> o .: "badResult"
noParseOperated = GeneratingNoParseOperated <$> o .: "noParseOperated"
parseJSON x@(String s)
| s == "imFinished" = pure ImFinished
| s == "yourTurn" = pure YourTurn
| otherwise = typeMismatch "Generating s" x
parseJSON x = typeMismatch "Generating s" x
instance Serialize (Generating BS.ByteString) where
put x = case x of
Generated{..} -> putWord8 0 *> putByteString' genValue *> putByteString' genOperation
BadResult r -> putWord8 1 *> putByteString' r
YourTurn -> putWord8 2
ImFinished -> putWord8 3
GeneratingNoParseOperated r -> putWord8 4 *> putByteString' r
get = do
x <- getWord8
case x of
0 -> Generated <$> getByteString' <*> getByteString'
1 -> BadResult <$> getByteString'
2 -> pure YourTurn
3 -> pure ImFinished
4 -> GeneratingNoParseOperated <$> getByteString'
_ -> fail "Generating ByteString"
instance Serialize (Generating LBS.ByteString) where
put x = case x of
Generated{..} -> putWord8 0 *> putLazyByteString' genValue *> putLazyByteString' genOperation
BadResult r -> putWord8 1 *> putLazyByteString' r
YourTurn -> putWord8 2
ImFinished -> putWord8 3
GeneratingNoParseOperated r -> putWord8 4 *> putLazyByteString' r
get = do
x <- getWord8
case x of
0 -> Generated <$> getLazyByteString' <*> getLazyByteString'
1 -> BadResult <$> getLazyByteString'
2 -> pure YourTurn
3 -> pure ImFinished
4 -> GeneratingNoParseOperated <$> getLazyByteString'
_ -> fail "Generating LazyByteString"
data Operating s
=
Operated s
|
OperatingNoParseValue s
|
OperatingNoParseOperation s
deriving (Eq, Show, Generic)
instance Arbitrary s => Arbitrary (Operating s) where
arbitrary = oneof
[ Operated <$> arbitrary
, OperatingNoParseValue <$> arbitrary
, OperatingNoParseOperation <$> arbitrary
]
instance ToJSON s => ToJSON (Operating s) where
toJSON x = case x of
Operated r -> object ["operated" .= r]
OperatingNoParseValue r -> object ["noParseValue" .= r]
OperatingNoParseOperation r -> object ["noParseOperation" .= r]
instance FromJSON s => FromJSON (Operating s) where
parseJSON (Object o) = operated <|> noParseValue <|> noParseOperation
where
operated = Operated <$> o .: "operated"
noParseValue = OperatingNoParseValue <$> o .: "noParseValue"
noParseOperation = OperatingNoParseOperation <$> o .: "noParseOperation"
parseJSON x = typeMismatch "Operating s" x
instance Serialize (Operating BS.ByteString) where
put x = case x of
Operated y -> putWord8 0 *> putByteString' y
OperatingNoParseValue r -> putWord8 1 *> putByteString' r
OperatingNoParseOperation r -> putWord8 2 *> putByteString' r
get = do
x <- getWord8
case x of
0 -> Operated <$> getByteString'
1 -> OperatingNoParseValue <$> getByteString'
2 -> OperatingNoParseOperation <$> getByteString'
_ -> fail "Operating ByteString"
instance Serialize (Operating LBS.ByteString) where
put x = case x of
Operated y -> putWord8 0 *> putLazyByteString' y
OperatingNoParseValue r -> putWord8 1 *> putLazyByteString' r
OperatingNoParseOperation r -> putWord8 2 *> putLazyByteString' r
get = do
x <- getWord8
case x of
0 -> Operated <$> getLazyByteString'
1 -> OperatingNoParseValue <$> getLazyByteString'
2 -> OperatingNoParseOperation <$> getLazyByteString'
_ -> fail "Operating LazyByteString"
data First s
=
AvailableTopics (Map Topic Int32)
|
BadStartSubset
|
FirstGenerating
{ firstGeneratingTopic :: Topic
, firstGenerating :: Generating s
}
|
FirstOperating
{ firstOperatingTopic :: Topic
, firstOperating :: Operating s
}
deriving (Eq, Show, Generic)
instance Arbitrary s => Arbitrary (First s) where
arbitrary = oneof
[ AvailableTopics <$> arbitrary
, pure BadStartSubset
, FirstGenerating <$> arbitrary <*> arbitrary
, FirstOperating <$> arbitrary <*> arbitrary
]
instance ToJSON s => ToJSON (First s) where
toJSON x = case x of
AvailableTopics ts -> object ["availableTopics" .= ts]
BadStartSubset -> String "badStartSubset"
FirstGenerating t y -> object ["firstGenerating" .= object ["topic" .= t, "generating" .= y]]
FirstOperating t y -> object ["firstOperating" .= object ["topic" .= t, "operating" .= y]]
instance FromJSON s => FromJSON (First s) where
parseJSON json = case json of
Object o ->
let availableTopics = AvailableTopics <$> o .: "availableTopics"
firstGenerating' = do
o' <- o .: "firstGenerating"
FirstGenerating <$> o' .: "topic" <*> o' .: "generating"
firstOperating' = do
o' <- o .: "firstOperating"
FirstOperating <$> o' .: "topic" <*> o' .: "operating"
in availableTopics <|> firstGenerating' <|> firstOperating'
String s
| s == "badStartSubset" -> pure BadStartSubset
| otherwise -> fail'
_ -> fail'
where
fail' = typeMismatch "First s" json
instance Serialize (First BS.ByteString) where
put x = case x of
AvailableTopics ts -> do
putWord8 0
let ls = Map.toList ts
putInt32be (fromIntegral (length ls))
void (traverse put ls)
BadStartSubset -> putWord8 1
FirstGenerating t y -> putWord8 2 *> put t *> put y
FirstOperating t y -> putWord8 3 *> put t *> put y
get = do
x <- getWord8
case x of
0 -> do
l <- getInt32be
AvailableTopics . Map.fromList <$> replicateM (fromIntegral l) get
1 -> pure BadStartSubset
2 -> FirstGenerating <$> get <*> get
3 -> FirstOperating <$> get <*> get
_ -> fail "First BS.ByteString"
instance Serialize (First LBS.ByteString) where
put x = case x of
AvailableTopics ts -> do
putWord8 0
let ls = Map.toList ts
putInt32be (fromIntegral (length ls))
void (traverse put ls)
BadStartSubset -> putWord8 1
FirstGenerating t y -> putWord8 2 *> put t *> put y
FirstOperating t y -> putWord8 3 *> put t *> put y
get = do
x <- getWord8
case x of
0 -> do
l <- getInt32be
AvailableTopics . Map.fromList <$> replicateM (fromIntegral l) get
1 -> pure BadStartSubset
2 -> FirstGenerating <$> get <*> get
3 -> FirstOperating <$> get <*> get
_ -> fail "First LBS.ByteString"
getFirstGenerating :: First s -> Maybe (Topic, Generating s)
getFirstGenerating x = case x of
FirstGenerating topic g -> Just (topic, g)
_ -> Nothing
getFirstOperating :: First s -> Maybe (Topic, Operating s)
getFirstOperating x = case x of
FirstOperating topic g -> Just (topic, g)
_ -> Nothing
data Second s
=
BadTopics (Map Topic Int32)
|
Start (Set Topic)
|
SecondOperating
{ secondOperatingTopic :: Topic
, secondOperating :: Operating s
}
|
SecondGenerating
{ secondGeneratingTopic :: Topic
, secondGenerating :: Generating s
}
deriving (Eq, Show, Generic)
instance Arbitrary s => Arbitrary (Second s) where
arbitrary = oneof
[ BadTopics <$> arbitrary
, Start <$> arbitrary
, SecondOperating <$> arbitrary <*> arbitrary
, SecondGenerating <$> arbitrary <*> arbitrary
]
instance ToJSON s => ToJSON (Second s) where
toJSON x = case x of
BadTopics ts -> object ["badTopics" .= ts]
Start ts -> object ["start" .= ts]
SecondOperating t y -> object ["secondOperating" .= object ["topic" .= t, "operating" .= y]]
SecondGenerating t y -> object ["secondGenerating" .= object ["topic" .= t, "generating" .= y]]
instance FromJSON s => FromJSON (Second s) where
parseJSON (Object o) = badTopics <|> start <|> secondOperating' <|> secondGenerating'
where
badTopics = BadTopics <$> o .: "badTopics"
start = Start <$> o .: "start"
secondOperating' = do
o' <- o .: "secondOperating"
SecondOperating <$> o' .: "topic" <*> o' .: "operating"
secondGenerating' = do
o' <- o .: "secondGenerating"
SecondGenerating <$> o' .: "topic" <*> o' .: "generating"
parseJSON x = typeMismatch "Second s" x
instance Serialize (Second BS.ByteString) where
put x = case x of
BadTopics ts -> do
putWord8 0
let ls = Map.toList ts
putInt32be (fromIntegral (length ls))
void (traverse put ls)
Start ts -> do
putWord8 1
let ls = Set.toList ts
putInt32be (fromIntegral (length ls))
void (traverse put ls)
SecondOperating t y -> putWord8 2 *> put t *> put y
SecondGenerating t y -> putWord8 3 *> put t *> put y
get = do
x <- getWord8
case x of
0 -> do
l <- getInt32be
BadTopics . Map.fromList <$> replicateM (fromIntegral l) get
1 -> do
l <- getInt32be
Start . Set.fromList <$> replicateM (fromIntegral l) get
2 -> SecondOperating <$> get <*> get
3 -> SecondGenerating <$> get <*> get
_ -> fail "Second BS.ByteString"
instance Serialize (Second LBS.ByteString) where
put x = case x of
BadTopics ts -> do
putWord8 0
let ls = Map.toList ts
putInt32be (fromIntegral (length ls))
void (traverse put ls)
Start ts -> do
putWord8 1
let ls = Set.toList ts
putInt32be (fromIntegral (length ls))
void (traverse put ls)
SecondOperating t y -> putWord8 2 *> put t *> put y
SecondGenerating t y -> putWord8 3 *> put t *> put y
get = do
x <- getWord8
case x of
0 -> do
l <- getInt32be
BadTopics . Map.fromList <$> replicateM (fromIntegral l) get
1 -> do
l <- getInt32be
Start . Set.fromList <$> replicateM (fromIntegral l) get
2 -> SecondOperating <$> get <*> get
3 -> SecondGenerating <$> get <*> get
_ -> fail "Second LBS.ByteString"
getSecondGenerating :: Second s -> Maybe (Topic, Generating s)
getSecondGenerating x = case x of
SecondGenerating topic g -> Just (topic, g)
_ -> Nothing
getSecondOperating :: Second s -> Maybe (Topic, Operating s)
getSecondOperating x = case x of
SecondOperating topic g -> Just (topic, g)
_ -> Nothing
data Failure them s
=
BadTopicsFailure
{ badTopicsFirst :: Map Topic Int32
, badTopicsSecond :: Map Topic Int32
}
|
BadStartSubsetFailure (Set Topic)
|
OutOfSyncFirst (First s)
|
OutOfSyncSecond (Second s)
|
TopicNonexistent Topic
|
WrongTopic
{ wrongTopicExpected :: Topic
, wrongTopicGot :: Topic
}
| CantParseOperated Topic s
| CantParseGeneratedValue Topic s
| CantParseGeneratedOperation Topic s
| CantParseLocalValue Topic s
| CantParseLocalOperation Topic s
|
BadOperating Topic (Operating s)
|
BadGenerating Topic (Generating s)
|
BadThem Topic (them s)
|
SafeFailure
{ safeFailureTopic :: Topic
, safeFailureExpected :: s
, safeFailureGot :: s
}
deriving (Eq, Show)
defaultSuccess :: Topic -> IO ()
defaultSuccess (Topic t) = putStrLn $ "Topic " ++ unpack t ++ " succeeded"
defaultFailure :: Show (them s) => Show s => Failure them s -> IO ()
defaultFailure f = error $ "Failure: " ++ show f
defaultProgress :: Topic -> Float -> IO ()
defaultProgress (Topic t) p = putStrLn $ "Topic " ++ unpack t ++ ": " ++ printf "%.2f" (p * 100.0) ++ "%"
nullProgress :: Applicative m => Topic -> Float -> m ()
nullProgress _ _ = pure ()
firstPeer :: forall m s
. MonadIO m
=> Show s
=> (First s -> m ())
-> m (Second s)
-> (Topic -> m ())
-> (Failure Second s -> m ())
-> (Topic -> Float -> m ())
-> SymbioteT s m ()
-> m ()
firstPeer encodeAndSend receiveAndDecode onSuccess onFailure onProgress x = do
state <- runSymbioteT x True
let myTopics = go <$> state
where
go s = case s of
ExistsSymbiote s' -> maxSize s'
encodeAndSend (AvailableTopics myTopics)
shouldBeStart <- receiveAndDecode
case shouldBeStart of
BadTopics badTopics -> onFailure (BadTopicsFailure myTopics badTopics)
Start topicsSubset
| not (topicsSubset `Set.isSubsetOf` Map.keysSet myTopics) -> do
encodeAndSend BadStartSubset
onFailure (BadStartSubsetFailure topicsSubset)
| otherwise -> do
topicsToProcess <- liftIO (newTVarIO topicsSubset)
let processAllTopics = do
mTopicToProcess <- Set.maxView <$> liftIO (readTVarIO topicsToProcess)
case mTopicToProcess of
Nothing -> pure ()
Just (topic, newTopics) -> do
liftIO (atomically (writeTVar topicsToProcess newTopics))
case Map.lookup topic state of
Nothing -> onFailure (TopicNonexistent topic)
Just symbioteState -> do
hasSentFinishedVar <- liftIO (newTVarIO HasntSentFinished)
hasReceivedFinishedVar <- liftIO (newTVarIO HasntReceivedFinished)
generating
encodeAndSend receiveAndDecode
FirstGenerating FirstOperating
getSecondGenerating getSecondOperating
hasSentFinishedVar hasReceivedFinishedVar
processAllTopics
onSuccess
onFailure
onProgress
topic symbioteState
processAllTopics
_ -> onFailure (OutOfSyncSecond shouldBeStart)
secondPeer :: forall s m
. MonadIO m
=> Show s
=> (Second s -> m ())
-> m (First s)
-> (Topic -> m ())
-> (Failure First s -> m ())
-> (Topic -> Float -> m ())
-> SymbioteT s m ()
-> m ()
secondPeer encodeAndSend receiveAndDecode onSuccess onFailure onProgress x = do
state <- runSymbioteT x False
shouldBeAvailableTopics <- receiveAndDecode
case shouldBeAvailableTopics of
AvailableTopics topicsAvailable -> do
let myTopics = go <$> state
where
go s = case s of
ExistsSymbiote s' -> maxSize s'
if not (myTopics `Map.isSubmapOf` topicsAvailable)
then do
encodeAndSend (BadTopics myTopics)
onFailure (BadTopicsFailure topicsAvailable myTopics)
else do
encodeAndSend (Start (Map.keysSet myTopics))
topicsToProcess <- liftIO (newTVarIO (Map.keysSet myTopics))
let processAllTopics = do
mTopicToProcess <- Set.maxView <$> liftIO (readTVarIO topicsToProcess)
case mTopicToProcess of
Nothing -> pure ()
Just (topic, newTopics) -> do
liftIO (atomically (writeTVar topicsToProcess newTopics))
case Map.lookup topic state of
Nothing -> onFailure (TopicNonexistent topic)
Just symbioteState -> do
hasSentFinishedVar <- liftIO (newTVarIO HasntSentFinished)
hasReceivedFinishedVar <- liftIO (newTVarIO HasntReceivedFinished)
operating
encodeAndSend receiveAndDecode
SecondGenerating SecondOperating
getFirstGenerating getFirstOperating
hasSentFinishedVar hasReceivedFinishedVar
processAllTopics
onSuccess
onFailure
onProgress
topic symbioteState
processAllTopics
_ -> onFailure (OutOfSyncFirst shouldBeAvailableTopics)
data HasSentFinished
= HasSentFinished
| HasntSentFinished
data HasReceivedFinished
= HasReceivedFinished
| HasntReceivedFinished
generating :: forall s m them me
. MonadIO m
=> Show s
=> (me s -> m ())
-> m (them s)
-> (Topic -> Generating s -> me s)
-> (Topic -> Operating s -> me s)
-> (them s -> Maybe (Topic, Generating s))
-> (them s -> Maybe (Topic, Operating s))
-> TVar HasSentFinished
-> TVar HasReceivedFinished
-> m ()
-> (Topic -> m ())
-> (Failure them s -> m ())
-> (Topic -> Float -> m ())
-> Topic
-> ExistsSymbiote s
-> m ()
generating
encodeAndSend receiveAndDecode
makeGen makeOp
getGen getOp
hasSentFinishedVar hasReceivedFinishedVar
onFinished
onSuccess
onFailure
onProgress
topic existsSymbiote = do
mGenerated <- generateSymbiote existsSymbiote
case mGenerated of
DoneGenerating -> do
encodeAndSend $ makeGen topic ImFinished
liftIO $ atomically $ writeTVar hasSentFinishedVar HasSentFinished
operatingTryFinished
GeneratedSymbiote
{ generatedValue = generatedValueEncoded
, generatedOperation = generatedOperationEncoded
} -> do
encodeAndSend $ makeGen topic $ Generated
{ genValue = generatedValueEncoded
, genOperation = generatedOperationEncoded
}
shouldBeOperating <- receiveAndDecode
case getOp shouldBeOperating of
Just (secondOperatingTopic, shouldBeOperated)
| secondOperatingTopic /= topic ->
onFailure $ WrongTopic topic secondOperatingTopic
| otherwise -> case shouldBeOperated of
Operated operatedValueEncoded -> case existsSymbiote of
ExistsSymbiote symbioteState ->
let go :: forall a o
. Arbitrary a
=> Arbitrary (Operation a)
=> Symbiote a o s
=> Eq o
=> SymbioteState a o s -> m ()
go SymbioteState{decode',decodeOp',decodeOut',equal,encodeOut',perform'} = case decodeOut' operatedValueEncoded of
Nothing -> do
encodeAndSend $ makeGen topic $ GeneratingNoParseOperated operatedValueEncoded
onFailure $ CantParseOperated topic operatedValueEncoded
Just operatedValue -> case decode' generatedValueEncoded of
Nothing -> onFailure $ CantParseLocalValue topic generatedValueEncoded
Just generatedValue -> case decodeOp' generatedOperationEncoded of
Nothing -> onFailure $ CantParseLocalOperation topic generatedOperationEncoded
Just generatedOperation -> do
let expected :: o
expected = perform' generatedOperation generatedValue
if equal expected operatedValue
then do
encodeAndSend $ makeGen topic YourTurn
progress <- getProgress existsSymbiote
onProgress topic progress
operating
encodeAndSend receiveAndDecode
makeGen makeOp
getGen getOp
hasSentFinishedVar hasReceivedFinishedVar
onFinished
onSuccess
onFailure
onProgress
topic existsSymbiote
else do
encodeAndSend $ makeGen topic $ BadResult operatedValueEncoded
onFailure $ SafeFailure topic (encodeOut' expected) operatedValueEncoded
in go symbioteState
_ -> onFailure $ BadOperating topic shouldBeOperated
_ -> onFailure $ BadThem topic shouldBeOperating
where
operatingTryFinished :: m ()
operatingTryFinished = do
hasReceivedFinished <- liftIO $ readTVarIO hasReceivedFinishedVar
case hasReceivedFinished of
HasReceivedFinished -> do
onSuccess topic
onFinished
HasntReceivedFinished -> do
progress <- getProgress existsSymbiote
onProgress topic progress
operating
encodeAndSend receiveAndDecode
makeGen makeOp
getGen getOp
hasSentFinishedVar hasReceivedFinishedVar
onFinished
onSuccess
onFailure
onProgress
topic existsSymbiote
operating :: forall s m them me
. MonadIO m
=> Show s
=> (me s -> m ())
-> m (them s)
-> (Topic -> Generating s -> me s)
-> (Topic -> Operating s -> me s)
-> (them s -> Maybe (Topic, Generating s))
-> (them s -> Maybe (Topic, Operating s))
-> TVar HasSentFinished
-> TVar HasReceivedFinished
-> m ()
-> (Topic -> m ())
-> (Failure them s -> m ())
-> (Topic -> Float -> m ())
-> Topic
-> ExistsSymbiote s
-> m ()
operating
encodeAndSend receiveAndDecode
makeGen makeOp
getGen getOp
hasSentFinishedVar hasReceivedFinishedVar
onFinished
onSuccess
onFailure
onProgress
topic existsSymbiote = do
shouldBeGenerating <- receiveAndDecode
case getGen shouldBeGenerating of
Just (secondGeneratingTopic,shouldBeGenerated)
| secondGeneratingTopic /= topic ->
onFailure $ WrongTopic topic secondGeneratingTopic
| otherwise -> case existsSymbiote of
ExistsSymbiote symbioteState -> go symbioteState shouldBeGenerated
_ -> onFailure $ BadThem topic shouldBeGenerating
where
go :: forall a o
. Arbitrary a
=> Arbitrary (Operation a)
=> Symbiote a o s
=> Eq o
=> SymbioteState a o s -> Generating s -> m ()
go SymbioteState{decode',decodeOp',perform',encodeOut'} shouldBeGenerated = case shouldBeGenerated of
ImFinished -> do
liftIO $ atomically $ writeTVar hasReceivedFinishedVar HasReceivedFinished
generatingTryFinished
YourTurn -> do
progress <- getProgress existsSymbiote
onProgress topic progress
generating
encodeAndSend receiveAndDecode
makeGen makeOp
getGen getOp
hasSentFinishedVar hasReceivedFinishedVar
onFinished
onSuccess
onFailure
onProgress
topic existsSymbiote
Generated
{ genValue = generatedValueEncoded
, genOperation = generatedOperationEncoded
} -> case decode' generatedValueEncoded of
Nothing -> do
encodeAndSend $ makeOp topic $ OperatingNoParseValue generatedValueEncoded
onFailure $ CantParseGeneratedValue topic generatedValueEncoded
Just generatedValue -> case decodeOp' generatedOperationEncoded of
Nothing -> do
encodeAndSend $ makeOp topic $ OperatingNoParseValue generatedOperationEncoded
onFailure $ CantParseGeneratedOperation topic generatedOperationEncoded
Just generatedOperation -> do
encodeAndSend $ makeOp topic $ Operated $ encodeOut' $ perform' generatedOperation generatedValue
operating
encodeAndSend
receiveAndDecode
makeGen makeOp
getGen getOp
hasSentFinishedVar hasReceivedFinishedVar
onFinished
onSuccess
onFailure
onProgress
topic existsSymbiote
_ -> onFailure $ BadGenerating topic shouldBeGenerated
generatingTryFinished :: m ()
generatingTryFinished = do
hasSentFinished <- liftIO $ readTVarIO hasSentFinishedVar
case hasSentFinished of
HasSentFinished -> do
onSuccess topic
onFinished
HasntSentFinished -> do
progress <- getProgress existsSymbiote
onProgress topic progress
generating
encodeAndSend receiveAndDecode
makeGen makeOp
getGen getOp
hasSentFinishedVar hasReceivedFinishedVar
onFinished
onSuccess
onFailure
onProgress
topic existsSymbiote
simpleTest :: MonadBaseControl IO m stM
=> MonadIO m
=> Show s
=> SymbioteT s m () -> m ()
simpleTest =
simpleTest'
(const (pure ()))
(liftIO . defaultFailure)
(liftIO . defaultFailure)
nullProgress
simpleTest' :: MonadBaseControl IO m stM
=> MonadIO m
=> Show s
=> (Topic -> m ())
-> (Failure Second s -> m ())
-> (Failure First s -> m ())
-> (Topic -> Float -> m ())
-> SymbioteT s m () -> m ()
simpleTest' onSuccess onFailureSecond onFailureFirst onProgress suite = do
firstChan <- liftIO $ atomically newTChan
secondChan <- liftIO $ atomically newTChan
t <- liftBaseWith $ \runInBase -> async $
void $ runInBase $ firstPeer
(encodeAndSendChan firstChan)
(receiveAndDecodeChan secondChan)
onSuccess onFailureSecond onProgress
suite
secondPeer
(encodeAndSendChan secondChan)
(receiveAndDecodeChan firstChan)
onSuccess onFailureFirst onProgress
suite
liftIO (wait t)
where
encodeAndSendChan chan x = liftIO $ atomically (writeTChan chan x)
receiveAndDecodeChan chan = liftIO $ atomically (readTChan chan)
putByteString' :: BS.ByteString -> PutM ()
putByteString' b = do
putInt32be (fromIntegral (BS.length b))
putByteString b
getByteString' :: Get BS.ByteString
getByteString' = do
l <- getInt32be
getByteString (fromIntegral l)
putLazyByteString' :: LBS.ByteString -> PutM ()
putLazyByteString' b = do
putInt32be (fromIntegral (LBS.length b))
putLazyByteString b
getLazyByteString' :: Get LBS.ByteString
getLazyByteString' = do
l <- getInt32be
getLazyByteString (fromIntegral l)