symbiote 0.0.0 → 0.0.0.1

raw patch · 5 files changed

+260/−140 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• README.md +49/−2
• src/Test/Serialization/Symbiote.hs +79/−134
• src/Test/Serialization/Symbiote/Core.hs +127/−0
• symbiote.cabal +4/−3

@@ -1,4 +1,4 @@-Copyright Author name here (c) 2019+Copyright Athen Clark (c) 2019  All rights reserved. 

@@ -1,8 +1,55 @@-# symbiote+# 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.+## How the Protocol Works++It's a pretty simple idea:++![](https://github.com/athanclark/symbiote/raw/master/images/drawing-rendered.png)++### Setting++Basically, the test suite envolves two peers - we'll call them Peer A and Peer B, and they're connected+by some network. Likewise, they are both using (possibly different) systems, which we've denoted as Lang A+(like Haskell) and Lang B (like PureScript / JavaScript).++The goal of this suite is to ensure that the _same idea_ defined on these different platforms have the+_same representation_ - both operationally (i.e., QuickCheck laws) and through some encoding (like printing+the data to JSON or a ByteString).++In the diagram above, each system has some idea of what "Type T" looks and feels like, but could be completely+different implementations on each system. Again, though, we care about their _outcome_ being identical; so we+disambiguate the idea from the data.++### Protocol++The first step in the protocol is for the generating party (Peer A) to generate an instance of Type T, and an operation+on that type - this operation, too, needs a serialization implementation (but for most intents and purposes,+the implementation will be only for the scope of use with this test suite).++Peer A then does two things: it serializes both the operation and instance to the network-acceptable format, _and_+it "performs" the operation on that instance to get an _expected result_. Basically, Peer A is using Peer B as a+remote procedure call for that operation, and verifying that the result obtained remotely is identical to the+result obtained locally.++### Remote Procedure Call++As just stated, Peer A then sends the serialized instance and operation to Peer B over that network, where Peer B+decodes the data, and performs the operation. Peer B then encodes the result, and sends it back to Peer A.++### Verification++Peer A now receives the performed data from Peer B, and can now decode it, and test to see if it is equal to the+expected result. If it is, it will tell Peer B that it's "their turn" to generate data.+++All of this relies on QuickCheck to generate the data - with the size of the generated data increasing at each step,+until a maximum is reached (which is clarified in the documentation).++-------------++For an example, check out the tests - they are performed locally in an asynchronous channel, but achieve the right goal.

@@ -6,7 +6,6 @@   , ScopedTypeVariables   , NamedFieldPuns   , FlexibleContexts-  , GeneralizedNewtypeDeriving   , StandaloneDeriving   , UndecidableInstances   , FlexibleInstances@@ -14,24 +13,68 @@  {-| -The project operates as follows:+Module: Test.Serialization.Symbiote+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC -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:+As an example, say you have some data type @TypeA@, and some encoding / decoding instance with Aeson+for that data type. Now, you've also got a few functions that work with that data type - @f :: TypeA -> TypeA@+and @g :: TypeA -> TypeA -> TypeA@, and you've also taken the time to write a proper 'Arbitrary' instance for @TypeA@. -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+Your first order of business in making @TypeA@ a symbiote, is to first demonstrate what operations are supported by it: -And the following property should exist, from peer A's perspective:+> {-# LANGUAGE MultiparamTypeClasses, TypeFamilies #-}+>+> instance SymbioteOperation TypeA where+>   data Operation TypeA+>     = F+>     | G TypeA+>   perform op x = case op of+>     F -> f x+>     G y -> g y x -forall f in Op_Q, q in Q.-  f q == decode (tBA (f (tAB (encode q)))+You're also going to need to make sure your new data-family has appropriate serialization instances, as well: -where the left invocation of f occurs in peer A, and the right invocation occurs in peer B.+> instance ToJSON (Operation TypeA) where+>   toJSON op = case op of+>     F -> toJSON "f"+>     G x -> "g" .: x+>+> instance FromJSON (Operation TypeA) where+>   parseJSON json = getF <|> getG+>     where+>       getF = do+>         s <- parseJSON json+>         if s == "f"+>           then pure F+>           else fail "Not F"+>       getG = do+>         x <- json .: "g"+>         pure (G x) +Next, let's make @TypeA@ an instance of 'Symbiote':++> instance Symbiote TypeA Value where+>   encode = Aeson.toJSON+>   decode = Aeson.parseMaybe Aeson.parseJSON+>   encodeOp = Aeson.toJSON+>   decodeOp = Aeson.parseMaybe Aeson.parseJSON++this instance above actually works for any type that implements @ToJSON@ and @FromJSON@ - there's an orphan+definition in "Test.Serialization.Symbiote.Aeson".++Next, you're going to need to actually use this, by registering the type in a test suite:++> myFancyTestSuite :: SymbioteT Value IO ()+> myFancyTestSuite = register "TypeA" 100 (Proxy :: Proxy TypeA)++Lastly, you're going to need to actually run the test suite by attaching it to a network. The best way to+do that, is decide whether this peer will be the first or second peer to start the protocol, then use the+respective 'firstPeer' and 'secondPeer' functions - they take as arguments functions that define "how to send"+and "how to receive" messages, and likewise how to report status.+ -}  module Test.Serialization.Symbiote@@ -40,37 +83,25 @@   , defaultSuccess, defaultFailure, defaultProgress, nullProgress, simpleTest   ) where +import Test.Serialization.Symbiote.Core+  ( Topic (..), newGeneration, SymbioteState (..), 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 Data.Text (Text, unpack)-import Data.String (IsString)+import Data.Text (unpack) import Data.Proxy (Proxy (..)) import Text.Printf (printf) import Control.Concurrent.STM-  (TVar, newTVarIO, readTVar, readTVarIO, modifyTVar', writeTVar, atomically, newTChan, readTChan, writeTChan)+  (TVar, newTVarIO, readTVarIO, writeTVar, atomically, newTChan, readTChan, writeTChan) import Control.Concurrent.Async (async, wait)-import Control.Monad (forever, void)+import Control.Monad (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.State (modify') 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)+import Test.QuickCheck.Gen (Gen)   -- | The most trivial serialization medium for any @a@.@@ -86,95 +117,7 @@   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@@ -248,7 +191,7 @@  -- | Messages sent by the second peer data Second s-  = BadTopics (Map Topic Int) -- ^ Second's available topics with identical gen sizes+  = BadTopics (Map Topic Int)   | Start   | SecondOperating     { secondOperatingTopic :: Topic@@ -309,18 +252,19 @@  -- | Via putStrLn defaultProgress :: Topic -> Float -> IO ()-defaultProgress (Topic t) p = putStrLn $ "Topic " ++ unpack t ++ ": " ++ (printf "%.2f" (p * 100.0)) ++ "%"+defaultProgress (Topic t) p = putStrLn $ "Topic " ++ unpack t ++ ": " ++ printf "%.2f" (p * 100.0) ++ "%"  -- | Do nothing nullProgress :: Topic -> Float -> IO () nullProgress _ _ = pure ()  +-- | Run the test suite as the first peer firstPeer :: forall m s            . MonadIO m           => Show s           => (First s -> m ()) -- ^ Encode and send first messages-          -> (m (Second s)) -- ^ Receive and decode second 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@@ -360,11 +304,12 @@     _ -> onFailure $ OutOfSyncSecond shouldBeStart  +-- | Run the test suite as the second peer secondPeer :: forall s m             . MonadIO m            => Show s            => (Second s -> m ()) -- ^ Encode and send second messages-           -> (m (First s)) -- ^ Receive and decode first 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@@ -420,7 +365,7 @@ generating :: MonadIO m            => Show s            => (me s -> m ()) -- ^ Encode and send first messages-           -> (m (them s)) -- ^ Receive and decode second 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@@ -481,7 +426,7 @@                         then do                           encodeAndSend $ makeGen topic YourTurn                           progress <- getProgress symbioteState-                          (onProgress topic progress)+                          onProgress topic progress                           operating                             encodeAndSend receiveAndDecode                             makeGen makeOp@@ -502,11 +447,11 @@       hasReceivedFinished <- liftIO $ readTVarIO hasReceivedFinishedVar       case hasReceivedFinished of         HasReceivedFinished -> do-          (onSuccess topic)+          onSuccess topic           onFinished -- stop cycling - last generation in sequence is from second         HasntReceivedFinished -> do           progress <- getProgress symbioteState-          (onProgress topic progress)+          onProgress topic progress           operating             encodeAndSend receiveAndDecode             makeGen makeOp@@ -521,7 +466,7 @@ operating :: MonadIO m           => Show s           => (me s -> m ()) -- ^ Encode and send first messages-          -> (m (them s)) -- ^ Receive and decode second 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@@ -556,7 +501,7 @@             generatingTryFinished           YourTurn -> do             progress <- getProgress symbioteState-            (onProgress topic progress)+            onProgress topic progress             generating               encodeAndSend receiveAndDecode               makeGen makeOp@@ -599,11 +544,11 @@       hasSentFinished <- liftIO $ readTVarIO hasSentFinishedVar       case hasSentFinished of         HasSentFinished -> do-          (onSuccess topic)+          onSuccess topic           onFinished -- stop cycling - last operation in sequence is from first         HasntSentFinished -> do           progress <- getProgress symbioteState-          (onProgress topic progress)+          onProgress topic progress           generating             encodeAndSend receiveAndDecode             makeGen makeOp

@@ -0,0 +1,127 @@+{-# LANGUAGE+    ExistentialQuantification+  , NamedFieldPuns+  , RankNTypes+  , ScopedTypeVariables+  , TypeFamilies+  , MultiParamTypeClasses+  , FlexibleContexts+  , GeneralizedNewtypeDeriving+  #-}++module Test.Serialization.Symbiote.Core where++import Data.Text (Text)+import Data.String (IsString)+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Concurrent.STM+  (TVar, readTVar, readTVarIO, modifyTVar', atomically)+import Control.Monad.Reader (ReaderT, runReaderT)+import Control.Monad.State (StateT, execStateT)+import Test.QuickCheck.Arbitrary (Arbitrary)+import Test.QuickCheck.Gen (Gen, resize)+import qualified Test.QuickCheck.Gen as QC+++-- | A type-level relation between a type and appropriate, testable operations on that type.+class SymbioteOperation a where+  data Operation a :: *+  perform :: Operation a -> a -> a++-- | A serialization format for a particular type, and serialized data type.+class SymbioteOperation a => Symbiote a s where+  encode   :: a -> s+  decode   :: s -> Maybe a+  encodeOp :: Operation a -> s+  decodeOp :: s -> Maybe (Operation a)+++-- | 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

@@ -4,13 +4,13 @@ -- -- see: https://github.com/sol/hpack ----- hash: d552556fe53910bd17c181cb95675e95a8276726b5345eb5f3f9743acae318ff+-- hash: 118f84a8b5a0694dfff43f8d16ecdca761bc22eff9d85afce8dda972d41be76a  name:           symbiote-version:        0.0.0+version:        0.0.0.1 synopsis:       Data serialization, communication, and operation verification implementation description:    Please see the README on GitHub at <https://github.com/athanclark/symbiote#readme>-category:       Data+category:       Data, Testing homepage:       https://github.com/athanclark/symbiote#readme bug-reports:    https://github.com/athanclark/symbiote/issues author:         Athan Clark@@ -33,6 +33,7 @@       Test.Serialization.Symbiote.Aeson       Test.Serialization.Symbiote.Cereal       Test.Serialization.Symbiote.Cereal.Lazy+      Test.Serialization.Symbiote.Core   other-modules:       Paths_symbiote   hs-source-dirs: