diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Author name here (c) 2019 +Copyright Athen Clark (c) 2019 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/src/Test/Serialization/Symbiote.hs b/src/Test/Serialization/Symbiote.hs --- a/src/Test/Serialization/Symbiote.hs +++ b/src/Test/Serialization/Symbiote.hs @@ -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 diff --git a/src/Test/Serialization/Symbiote/Core.hs b/src/Test/Serialization/Symbiote/Core.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote/Core.hs @@ -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 diff --git a/symbiote.cabal b/symbiote.cabal --- a/symbiote.cabal +++ b/symbiote.cabal @@ -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 -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: