packages feed

symbiote (empty) → 0.0.0

raw patch · 10 files changed

+1034/−0 lines, 10 filesdep +QuickCheckdep +aesondep +asyncsetup-changed

Dependencies added: QuickCheck, aeson, async, base, bytestring, cereal, containers, monad-control, mtl, quickcheck-instances, stm, symbiote, tasty, tasty-hunit, text

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for symbiote++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2019++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 Author name here 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.
+ README.md view
@@ -0,0 +1,8 @@+# symbiote++This project aims to be a network agnostic and data format agnostic serialization verifier - it's main+purpose is to verify that _data_, _operations_ on that data, and _serialization_ of that data is+all consistent for multiple platforms. This project defines a trivial protocol that can be re-implemented+in any platform, over any network medium.++For an example, check out the tests.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Test/Serialization/Symbiote.hs view
@@ -0,0 +1,642 @@+{-# LANGUAGE+    MultiParamTypeClasses+  , TypeFamilies+  , ExistentialQuantification+  , RankNTypes+  , ScopedTypeVariables+  , NamedFieldPuns+  , FlexibleContexts+  , GeneralizedNewtypeDeriving+  , StandaloneDeriving+  , UndecidableInstances+  , FlexibleInstances+  #-}++{-|++The project operates as follows:++Given two peers A and B and some communications transport T (utilizing a serialization format S),+and a data type Q with some set of operations on that data type Op_Q,+the following functions / procedures are assumed:++tAB: the function communicates some data in S from peer A to peer B+tBA: the function communicates some data in S from peer B to peer A+encode :: Q -> S+decode :: S -> Q -- disregarding error handling++And the following property should exist, from peer A's perspective:++forall f in Op_Q, q in Q.+  f q == decode (tBA (f (tAB (encode q)))++where the left invocation of f occurs in peer A, and the right invocation occurs in peer B.++-}++module Test.Serialization.Symbiote+  ( SymbioteOperation (..), Symbiote (..), EitherOp (..), Topic, SymbioteT, register+  , firstPeer, secondPeer, First (..), Second (..), Generating (..), Operating (..), Failure (..)+  , defaultSuccess, defaultFailure, defaultProgress, nullProgress, simpleTest+  ) where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text, unpack)+import Data.String (IsString)+import Data.Proxy (Proxy (..))+import Text.Printf (printf)+import Control.Concurrent.STM+  (TVar, newTVarIO, readTVar, readTVarIO, modifyTVar', writeTVar, atomically, newTChan, readTChan, writeTChan)+import Control.Concurrent.Async (async, wait)+import Control.Monad (forever, void)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.State (StateT, modify', execStateT)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import Test.QuickCheck.Gen (Gen, resize)+import qualified Test.QuickCheck.Gen as QC+++class SymbioteOperation a where+  data Operation a :: *+  perform :: Operation a -> a -> a++-- | A type and operation set over a serialization format+class SymbioteOperation a => Symbiote a s where+  encode   :: a -> s+  decode   :: s -> Maybe a+  encodeOp :: Operation a -> s+  decodeOp :: s -> Maybe (Operation a)+++-- | The most trivial serialization medium for any @a@.+newtype EitherOp a = EitherOp (Either a (Operation a))+deriving instance (Eq a, Eq (Operation a)) => Eq (EitherOp a)+deriving instance (Show a, Show (Operation a)) => Show (EitherOp a)++instance SymbioteOperation a => Symbiote a (EitherOp a) where+  encode = EitherOp . Left+  decode (EitherOp (Left x)) = Just x+  decode (EitherOp (Right _)) = Nothing+  encodeOp = EitherOp . Right+  decodeOp (EitherOp (Left _)) = Nothing+  decodeOp (EitherOp (Right x)) = Just x++-- | Unique name of a type, for a suite of tests+newtype Topic = Topic Text+  deriving (Eq, Ord, Show, IsString)++-- | Protocol state for a particular topic+data SymbioteProtocol a s+  = MeGenerated+    { meGenValue :: a+    , meGenOperation :: Operation a+    , meGenReceived :: Maybe s+    }+  | ThemGenerating+    { themGen :: Maybe (s, s)+    }+  | NotStarted+  | Finished++-- | Protocol generation state+data SymbioteGeneration a s = SymbioteGeneration+  { size     :: Int+  , protocol :: SymbioteProtocol a s+  }++newGeneration :: SymbioteGeneration a s+newGeneration = SymbioteGeneration+  { size = 1+  , protocol = NotStarted+  }+++-- | Internal existential state of a registered topic with type's facilities+data SymbioteState s =+  forall a+  . ( Arbitrary a+    , Arbitrary (Operation a)+    , Symbiote a s+    , Eq a+    ) =>+  SymbioteState+  { generate   :: Gen a+  , generateOp :: Gen (Operation a)+  , equal      :: a -> a -> Bool+  , maxSize    :: Int+  , generation :: TVar (SymbioteGeneration a s)+  , encode'    :: a -> s+  , encodeOp'  :: Operation a -> s+  , decode'    :: s -> Maybe a+  , decodeOp'  :: s -> Maybe (Operation a)+  , perform'   :: Operation a -> a -> a+  }+++type SymbioteT s m = ReaderT Bool (StateT (Map Topic (SymbioteState s)) m)++runSymbioteT :: Monad m+             => SymbioteT s m ()+             -> Bool -- ^ Is this the first peer to initiate the protocol?+             -> m (Map Topic (SymbioteState s))+runSymbioteT x isFirst = execStateT (runReaderT x isFirst) Map.empty+++data GenerateSymbiote s+  = DoneGenerating+  | GeneratedSymbiote+    { generatedValue :: s+    , generatedOperation :: s+    }+++generateSymbiote :: forall s m. MonadIO m => SymbioteState s -> m (GenerateSymbiote s)+generateSymbiote SymbioteState{generate,generateOp,maxSize,generation} = do+  let go g@SymbioteGeneration{size} = g {size = size + 1}+  SymbioteGeneration{size} <- liftIO $ atomically $ modifyTVar' generation go *> readTVar generation+  if size >= maxSize+    then pure DoneGenerating+    else do+      let genResize :: forall q. Gen q -> m q+          genResize = liftIO . QC.generate . resize size+      generatedValue <- encode <$> genResize generate+      generatedOperation <- encodeOp <$> genResize generateOp+      pure GeneratedSymbiote{generatedValue,generatedOperation}+++getProgress :: MonadIO m => SymbioteState s -> m Float+getProgress SymbioteState{maxSize,generation} = do+  SymbioteGeneration{size} <- liftIO $ readTVarIO generation+  pure $ fromIntegral size / fromIntegral maxSize+++-- | Register a topic in the test suite+register :: forall a s m+          . Arbitrary a+         => Arbitrary (Operation a)+         => Symbiote a s+         => Eq a+         => MonadIO m+         => Topic+         -> Int -- ^ Max size+         -> Proxy a+         -> SymbioteT s m ()+register t maxSize Proxy = do+  generation <- liftIO (newTVarIO newGeneration)+  let newState :: SymbioteState s+      newState = SymbioteState+        { generate = arbitrary :: Gen a+        , generateOp = arbitrary :: Gen (Operation a)+        , equal = (==) :: a -> a -> Bool+        , maxSize+        , generation+        , encode' = encode+        , encodeOp' = encodeOp+        , decode' = decode+        , decodeOp' = decodeOp+        , perform' = perform+        }+  modify' (Map.insert t newState)++-- | Messages sent by a peer during their generating phase+data Generating s+  = Generated+    { genValue :: s+    , genOperation :: s+    }+  | BadResult s -- ^ Expected value+  | YourTurn+  | ImFinished+  | GeneratingNoParseOperated s+  deriving (Eq, Show)++-- | Messages sent by a peer during their operating phase+data Operating s+  = Operated s -- ^ Serialized value after operation+  | OperatingNoParseValue s+  | OperatingNoParseOperation s+  deriving (Eq, Show)++-- | Messages sent by the first peer+data First s+  = AvailableTopics (Map Topic Int) -- ^ Mapping of topics to their gen size+  | FirstGenerating+    { firstGeneratingTopic :: Topic+    , firstGenerating :: Generating s+    }+  | FirstOperating+    { firstOperatingTopic :: Topic+    , firstOperating :: Operating s+    }+  deriving (Eq, Show)++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+++-- | Messages sent by the second peer+data Second s+  = BadTopics (Map Topic Int) -- ^ Second's available topics with identical gen sizes+  | Start+  | SecondOperating+    { secondOperatingTopic :: Topic+    , secondOperating :: Operating s+    }+  | SecondGenerating+    { secondGeneratingTopic :: Topic+    , secondGenerating :: Generating s+    }+  deriving (Eq, Show)++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 Int+    , badTopicsSecond :: Map Topic Int+    }+  | 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)+++-- | Via putStrLn+defaultSuccess :: Topic -> IO ()+defaultSuccess (Topic t) = putStrLn $ "Topic " ++ unpack t ++ " succeeded"++-- | Via putStrLn+defaultFailure :: Show (them s) => Show s => Failure them s -> IO ()+defaultFailure f = error $ "Failure: " ++ show f++-- | Via putStrLn+defaultProgress :: Topic -> Float -> IO ()+defaultProgress (Topic t) p = putStrLn $ "Topic " ++ unpack t ++ ": " ++ (printf "%.2f" (p * 100.0)) ++ "%"++-- | Do nothing+nullProgress :: Topic -> Float -> IO ()+nullProgress _ _ = pure ()+++firstPeer :: forall m s+           . MonadIO m+          => Show s+          => (First s -> m ()) -- ^ Encode and send first messages+          -> (m (Second s)) -- ^ Receive and decode second messages+          -> (Topic -> m ()) -- ^ Report when Successful+          -> (Failure Second s -> m ()) -- ^ Report when Failed+          -> (Topic -> Float -> m ()) -- ^ Report on Progress+          -> SymbioteT s m ()+          -> m ()+firstPeer encodeAndSend receiveAndDecode onSuccess onFailure onProgress x = do+  state <- runSymbioteT x True+  let topics = maxSize <$> state+  encodeAndSend (AvailableTopics topics)+  shouldBeStart <- receiveAndDecode+  case shouldBeStart of+    BadTopics badTopics -> onFailure $ BadTopicsFailure topics badTopics+    Start -> do+      topicsToProcess <- liftIO (newTVarIO (Map.keysSet topics))+      let processAllTopics = do+            mTopicToProcess <- Set.maxView <$> liftIO (readTVarIO topicsToProcess)+            case mTopicToProcess of+              Nothing -> pure () -- done+              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 ()) -- ^ Encode and send second messages+           -> (m (First s)) -- ^ Receive and decode first messages+           -> (Topic -> m ()) -- ^ Report when Successful+           -> (Failure First s -> m ()) -- ^ Report when Failed+           -> (Topic -> Float -> m ()) -- ^ Report on Progress+           -> SymbioteT s m ()+           -> m ()+secondPeer encodeAndSend receiveAndDecode onSuccess onFailure onProgress x = do+  state <- runSymbioteT x False+  shouldBeAvailableTopics <- receiveAndDecode+  case shouldBeAvailableTopics of+    AvailableTopics topics -> do+      let myTopics = maxSize <$> state+      if myTopics /= topics+        then do+          encodeAndSend (BadTopics myTopics)+          onFailure $ BadTopicsFailure topics myTopics+        else do+          encodeAndSend Start+          topicsToProcess <- liftIO (newTVarIO (Map.keysSet topics))+          let processAllTopics = do+                mTopicToProcess <- Set.maxView <$> liftIO (readTVarIO topicsToProcess)+                case mTopicToProcess of+                  Nothing -> pure () -- done+                  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 :: MonadIO m+           => Show s+           => (me s -> m ()) -- ^ Encode and send first messages+           -> (m (them s)) -- ^ Receive and decode second messages+           -> (Topic -> Generating s -> me s) -- ^ Build a generating datum, whether first or second+           -> (Topic -> Operating s -> me s) -- ^ Build a generating datum, whether first or second+           -> (them s -> Maybe (Topic, Generating s)) -- ^ Deconstruct an operating datum, whether first or second+           -> (them s -> Maybe (Topic, Operating s)) -- ^ Deconstruct an operating datum, whether first or second+           -> TVar HasSentFinished+           -> TVar HasReceivedFinished+           -> m () -- ^ on finished - loop+           -> (Topic -> m ()) -- ^ report topic success+           -> (Failure them s -> m ()) -- ^ report topic failure+           -> (Topic -> Float -> m ()) -- ^ report topic progress+           -> Topic+           -> SymbioteState s+           -> m ()+generating+  encodeAndSend receiveAndDecode+  makeGen makeOp+  getGen getOp+  hasSentFinishedVar hasReceivedFinishedVar+  onFinished+  onSuccess+  onFailure+  onProgress+  topic symbioteState@SymbioteState{equal,encode'} = do+  mGenerated <- generateSymbiote symbioteState+  case mGenerated of+    DoneGenerating -> do+      encodeAndSend $ makeGen topic ImFinished+      liftIO $ atomically $ writeTVar hasSentFinishedVar HasSentFinished+      operatingTryFinished+    GeneratedSymbiote+      { generatedValue = generatedValueEncoded+      , generatedOperation = generatedOperationEncoded+      } -> do+      -- send+      encodeAndSend $ makeGen topic $ Generated+        { genValue = generatedValueEncoded+        , genOperation = generatedOperationEncoded+        }+      -- receive+      shouldBeOperating <- receiveAndDecode+      case getOp shouldBeOperating of+        Just (secondOperatingTopic, shouldBeOperated)+          | secondOperatingTopic /= topic ->+            onFailure $ WrongTopic topic secondOperatingTopic+          | otherwise -> case shouldBeOperated of+              Operated operatedValueEncoded -> case decode 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+                      -- decoded operated value, generated value & operation+                      let expected = perform generatedOperation generatedValue+                      if equal expected operatedValue+                        then do+                          encodeAndSend $ makeGen topic YourTurn+                          progress <- getProgress symbioteState+                          (onProgress topic progress)+                          operating+                            encodeAndSend receiveAndDecode+                            makeGen makeOp+                            getGen getOp+                            hasSentFinishedVar hasReceivedFinishedVar+                            onFinished+                            onSuccess+                            onFailure+                            onProgress+                            topic symbioteState+                        else do+                          encodeAndSend $ makeGen topic $ BadResult operatedValueEncoded+                          onFailure $ SafeFailure topic (encode' expected) operatedValueEncoded+              _ -> onFailure $ BadOperating topic shouldBeOperated+        _ -> onFailure $ BadThem topic shouldBeOperating+  where+    operatingTryFinished = do+      hasReceivedFinished <- liftIO $ readTVarIO hasReceivedFinishedVar+      case hasReceivedFinished of+        HasReceivedFinished -> do+          (onSuccess topic)+          onFinished -- stop cycling - last generation in sequence is from second+        HasntReceivedFinished -> do+          progress <- getProgress symbioteState+          (onProgress topic progress)+          operating+            encodeAndSend receiveAndDecode+            makeGen makeOp+            getGen getOp+            hasSentFinishedVar hasReceivedFinishedVar+            onFinished+            onSuccess+            onFailure+            onProgress+            topic symbioteState++operating :: MonadIO m+          => Show s+          => (me s -> m ()) -- ^ Encode and send first messages+          -> (m (them s)) -- ^ Receive and decode second messages+          -> (Topic -> Generating s -> me s) -- ^ Build a generating datum, whether first or second+          -> (Topic -> Operating s -> me s) -- ^ Build a generating datum, whether first or second+          -> (them s -> Maybe (Topic, Generating s)) -- ^ Deconstruct an operating datum, whether first or second+          -> (them s -> Maybe (Topic, Operating s)) -- ^ Deconstruct an operating datum, whether first or second+          -> TVar HasSentFinished+          -> TVar HasReceivedFinished+          -> m () -- ^ on finished+          -> (Topic -> m ()) -- ^ report topic success+          -> (Failure them s -> m ()) -- ^ report topic failure+          -> (Topic -> Float -> m ()) -- ^ report topic progress+          -> Topic+          -> SymbioteState s+          -> m ()+operating+  encodeAndSend receiveAndDecode+  makeGen makeOp+  getGen getOp+  hasSentFinishedVar hasReceivedFinishedVar+  onFinished+  onSuccess+  onFailure+  onProgress+  topic symbioteState@SymbioteState{decode',decodeOp',perform',encode'} = do+  shouldBeGenerating <- receiveAndDecode+  case getGen shouldBeGenerating of+    Just (secondGeneratingTopic,shouldBeGenerated)+      | secondGeneratingTopic /= topic ->+        onFailure $ WrongTopic topic secondGeneratingTopic+      | otherwise -> case shouldBeGenerated of+          ImFinished -> do+            liftIO $ atomically $ writeTVar hasReceivedFinishedVar HasReceivedFinished+            generatingTryFinished+          YourTurn -> do+            progress <- getProgress symbioteState+            (onProgress topic progress)+            generating+              encodeAndSend receiveAndDecode+              makeGen makeOp+              getGen getOp+              hasSentFinishedVar hasReceivedFinishedVar+              onFinished+              onSuccess+              onFailure+              onProgress+              topic symbioteState+          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 $ encode' $ perform' generatedOperation generatedValue+                -- wait for response+                operating+                  encodeAndSend+                  receiveAndDecode+                  makeGen makeOp+                  getGen getOp+                  hasSentFinishedVar hasReceivedFinishedVar+                  onFinished+                  onSuccess+                  onFailure+                  onProgress+                  topic symbioteState+          _ -> onFailure $ BadGenerating topic shouldBeGenerated+    _ -> onFailure $ BadThem topic shouldBeGenerating+  where+    generatingTryFinished = do+      hasSentFinished <- liftIO $ readTVarIO hasSentFinishedVar+      case hasSentFinished of+        HasSentFinished -> do+          (onSuccess topic)+          onFinished -- stop cycling - last operation in sequence is from first+        HasntSentFinished -> do+          progress <- getProgress symbioteState+          (onProgress topic progress)+          generating+            encodeAndSend receiveAndDecode+            makeGen makeOp+            getGen getOp+            hasSentFinishedVar hasReceivedFinishedVar+            onFinished+            onSuccess+            onFailure+            onProgress+            topic symbioteState+++-- | Prints to stdout and uses a local channel for a sanity-check - doesn't serialize.+simpleTest :: MonadBaseControl IO m+           => MonadIO m+           => Show s+           => SymbioteT s m () -> m ()+simpleTest suite = do+  firstChan <- liftIO $ atomically newTChan+  secondChan <- liftIO $ atomically newTChan++  t <- liftBaseWith $ \runInBase -> async $+    void $ runInBase $ firstPeer+      (encodeAndSendChan firstChan)+      (receiveAndDecodeChan secondChan)+      (const (pure ())) (liftIO . defaultFailure) (\a b -> liftIO $ nullProgress a b)+      suite+  secondPeer+    (encodeAndSendChan secondChan)+    (receiveAndDecodeChan firstChan)+    (const (pure ())) (liftIO . defaultFailure) (\a b -> liftIO $ nullProgress a b)+    suite+  liftIO (wait t)+  where+    encodeAndSendChan chan x = liftIO $ atomically (writeTChan chan x)+    receiveAndDecodeChan chan = liftIO $ atomically (readTChan chan)
+ src/Test/Serialization/Symbiote/Aeson.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE+    MultiParamTypeClasses+  , FlexibleInstances+  , FlexibleContexts+  , UndecidableInstances+  #-}++module Test.Serialization.Symbiote.Aeson where++import Test.Serialization.Symbiote (SymbioteOperation, Symbiote (..), Operation)+import qualified Data.Aeson as Json+import qualified Data.Aeson.Types as Json++instance+  ( Json.ToJSON a+  , Json.FromJSON a+  , Json.ToJSON (Operation a)+  , Json.FromJSON (Operation a)+  , SymbioteOperation a+  ) => Symbiote a Json.Value where+  encode = Json.toJSON+  decode = Json.parseMaybe Json.parseJSON+  encodeOp = Json.toJSON+  decodeOp = Json.parseMaybe Json.parseJSON
+ src/Test/Serialization/Symbiote/Cereal.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE+    MultiParamTypeClasses+  , FlexibleInstances+  , FlexibleContexts+  , UndecidableInstances+  #-}++module Test.Serialization.Symbiote.Cereal where++import Test.Serialization.Symbiote (SymbioteOperation, Symbiote (..), Operation)+import qualified Data.Serialize as Cereal+import qualified Data.ByteString as BS++instance+  ( Cereal.Serialize a+  , Cereal.Serialize (Operation a)+  , SymbioteOperation a+  ) => Symbiote a BS.ByteString where+  encode = Cereal.encode+  decode x = case Cereal.decode x of+    Left _ -> Nothing+    Right y -> Just y+  encodeOp = Cereal.encode+  decodeOp x = case Cereal.decode x of+    Left _ -> Nothing+    Right y -> Just y
+ src/Test/Serialization/Symbiote/Cereal/Lazy.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE+    MultiParamTypeClasses+  , FlexibleInstances+  , FlexibleContexts+  , UndecidableInstances+  #-}++module Test.Serialization.Symbiote.Cereal.Lazy where++import Test.Serialization.Symbiote (SymbioteOperation, Symbiote (..), Operation)+import qualified Data.Serialize as Cereal+import qualified Data.ByteString.Lazy as LBS++instance+  ( Cereal.Serialize a+  , Cereal.Serialize (Operation a)+  , SymbioteOperation a+  ) => Symbiote a LBS.ByteString where+  encode = Cereal.encodeLazy+  decode x = case Cereal.decodeLazy x of+    Left _ -> Nothing+    Right y -> Just y+  encodeOp = Cereal.encodeLazy+  decodeOp x = case Cereal.decodeLazy x of+    Left _ -> Nothing+    Right y -> Just y
+ symbiote.cabal view
@@ -0,0 +1,78 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d552556fe53910bd17c181cb95675e95a8276726b5345eb5f3f9743acae318ff++name:           symbiote+version:        0.0.0+synopsis:       Data serialization, communication, and operation verification implementation+description:    Please see the README on GitHub at <https://github.com/athanclark/symbiote#readme>+category:       Data+homepage:       https://github.com/athanclark/symbiote#readme+bug-reports:    https://github.com/athanclark/symbiote/issues+author:         Athan Clark+maintainer:     athan.clark@gmail.com+copyright:      2019 Athan Clark+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/athanclark/symbiote++library+  exposed-modules:+      Test.Serialization.Symbiote+      Test.Serialization.Symbiote.Aeson+      Test.Serialization.Symbiote.Cereal+      Test.Serialization.Symbiote.Cereal.Lazy+  other-modules:+      Paths_symbiote+  hs-source-dirs:+      src+  build-depends:+      QuickCheck+    , aeson+    , async+    , base >=4.7 && <5+    , bytestring+    , cereal+    , containers+    , monad-control+    , mtl+    , stm+    , text+  default-language: Haskell2010++test-suite symbiote-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_symbiote+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , aeson+    , async+    , base >=4.7 && <5+    , bytestring+    , cereal+    , containers+    , monad-control+    , mtl+    , quickcheck-instances+    , stm+    , symbiote+    , tasty+    , tasty-hunit+    , text+  default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE+    OverloadedStrings+  , MultiParamTypeClasses+  , TypeFamilies+  , FlexibleInstances+  , StandaloneDeriving+  , FlexibleContexts+  , UndecidableInstances+  , DeriveGeneric+  #-}++import Test.Tasty (defaultMain, testGroup, TestTree)+import Test.Tasty.HUnit (testCase)+import Test.Serialization.Symbiote+  ( SymbioteT, register, firstPeer, secondPeer, SymbioteOperation (..), Symbiote (..), EitherOp+  , First, Second, simpleTest)+import Test.Serialization.Symbiote.Cereal ()+import Test.Serialization.Symbiote.Aeson ()+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Gen (elements, oneof, scale, getSize)+import Test.QuickCheck.Instances ()++import Data.Proxy (Proxy (..))+import qualified Data.Aeson as Json+import qualified Data.Aeson.Types as Json+import qualified Data.Serialize as Cereal+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import GHC.Generics (Generic)+++main :: IO ()+main = defaultMain tests+++tests :: TestTree+tests = testGroup "All Tests"+  [ simpleTests+  , bytestringTests+  , jsonTests+  ]+  where+    simpleTests :: TestTree+    simpleTests = testGroup "Simple Tests"+      [ testCase "Unit over id" (simpleTest unitSuite)+      , testCase "Int over various" (simpleTest intSuite)+      , testCase "Double over various" (simpleTest doubleSuite)+      , testCase "List over various" (simpleTest listSuite)+      ]+      where+        unitSuite :: SymbioteT (EitherOp ()) IO ()+        unitSuite = register "Unit" 100 (Proxy :: Proxy ())+        intSuite :: SymbioteT (EitherOp Int) IO ()+        intSuite = register "Int" 100 (Proxy :: Proxy Int)+        doubleSuite :: SymbioteT (EitherOp Double) IO ()+        doubleSuite = register "Double" 100 (Proxy :: Proxy Double)+        listSuite :: SymbioteT (EitherOp [Int]) IO ()+        listSuite = register "List" 100 (Proxy :: Proxy [Int])+    bytestringTests :: TestTree+    bytestringTests = testGroup "ByteString Tests"+      [ testCase "Json over id" (simpleTest jsonSuite)+      , testCase "Int over various" (simpleTest intSuite)+      , testCase "Double over various" (simpleTest doubleSuite)+      , testCase "List over various" (simpleTest listSuite)+      ]+      where+        jsonSuite :: SymbioteT LBS.ByteString IO ()+        jsonSuite = register "Json" 100 (Proxy :: Proxy Json.Value)+        intSuite :: SymbioteT BS.ByteString IO ()+        intSuite = register "Int" 100 (Proxy :: Proxy Int)+        doubleSuite :: SymbioteT BS.ByteString IO ()+        doubleSuite = register "Double" 100 (Proxy :: Proxy Double)+        listSuite :: SymbioteT BS.ByteString IO ()+        listSuite = register "List" 100 (Proxy :: Proxy [Int])+    jsonTests :: TestTree+    jsonTests = testGroup "Json Tests"+      [ testCase "Int over various" (simpleTest intSuite)+      , testCase "Double over various" (simpleTest doubleSuite)+      , testCase "List over various" (simpleTest listSuite)+      ]+      where+        intSuite :: SymbioteT Json.Value IO ()+        intSuite = register "Int" 100 (Proxy :: Proxy Int)+        doubleSuite :: SymbioteT Json.Value IO ()+        doubleSuite = register "Double" 100 (Proxy :: Proxy Double)+        listSuite :: SymbioteT Json.Value IO ()+        listSuite = register "List" 100 (Proxy :: Proxy [Int])++instance SymbioteOperation () where+  data Operation () = UnitId+  perform UnitId () = ()+deriving instance Show (Operation ())+deriving instance Generic (Operation ())+instance Arbitrary (Operation ()) where+  arbitrary = pure UnitId++instance SymbioteOperation Int where+  data Operation Int+    = AddInt Int+    | SubInt Int+    | DivInt Int+    | MulInt Int+    | ModInt Int+  perform op x = case op of+    AddInt y -> x + y+    SubInt y -> x - y+    DivInt y -> if y == 0 then 0 else x `div` y+    MulInt y -> x * y+    ModInt y -> if y == 0 then 0 else x `mod` y+deriving instance Show (Operation Int)+deriving instance Generic (Operation Int)+instance Cereal.Serialize (Operation Int)+instance Json.ToJSON (Operation Int)+instance Json.FromJSON (Operation Int)+instance Arbitrary (Operation Int) where+  arbitrary = oneof+    [ AddInt <$> arbitrary+    , SubInt <$> arbitrary+    , DivInt <$> arbitrary+    , MulInt <$> arbitrary+    , ModInt <$> arbitrary+    ]+++instance SymbioteOperation Double where+  data Operation Double+    = AddDouble Double+    | SubDouble Double+    | DivDouble Double+    | MulDouble Double+    | RecipDouble+  perform op x = case op of+    AddDouble y -> x + y+    SubDouble y -> x - y+    DivDouble y -> if y == 0.0 then 0.0 else x / y+    MulDouble y -> x * y+    RecipDouble -> if x == 0.0 then 0.0 else recip x+deriving instance Show (Operation Double)+deriving instance Generic (Operation Double)+instance Cereal.Serialize (Operation Double)+instance Json.ToJSON (Operation Double)+instance Json.FromJSON (Operation Double)+instance Arbitrary (Operation Double) where+  arbitrary = oneof+    [ AddDouble <$> arbitrary+    , SubDouble <$> arbitrary+    , DivDouble <$> arbitrary+    , MulDouble <$> arbitrary+    , pure RecipDouble+    ]++instance SymbioteOperation [a] where+  data Operation [a]+    = ReverseList+    | InitList+    | TailList+  perform op x = case op of+    ReverseList -> reverse x+    InitList -> if length x == 0 then [] else init x+    TailList -> if length x == 0 then [] else tail x+deriving instance Show (Operation [a])+deriving instance Generic (Operation [a])+instance Cereal.Serialize (Operation [a])+instance Json.ToJSON (Operation [a])+instance Json.FromJSON (Operation [a])+instance Arbitrary (Operation [a]) where+  arbitrary = elements [ReverseList, InitList, TailList]++instance SymbioteOperation Json.Value where+  data Operation Json.Value = JsonId+  perform _ x = x+deriving instance Show (Operation Json.Value)+deriving instance Generic (Operation Json.Value)+instance Arbitrary (Operation Json.Value) where+  arbitrary = pure JsonId+instance Symbiote Json.Value LBS.ByteString where+  encode = Json.encode+  decode = Json.decode+  encodeOp _ = "id"+  decodeOp x | x == "id" = Just JsonId+             | otherwise = Nothing+instance Arbitrary Json.Value where+  arbitrary = do+    s <- getSize+    if s <= 1+      then oneof+            [ pure Json.Null+            , Json.Bool <$> arbitrary+            , Json.Number <$> arbitrary+            ]+      else oneof+            [ Json.String <$> scale (`div` 2) arbitrary+            , Json.Array <$> scale (`div` 2) arbitrary+            , Json.Object <$> scale (`div` 2) arbitrary+            ]