diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for symbiote + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Test/Serialization/Symbiote.hs b/src/Test/Serialization/Symbiote.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote.hs @@ -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) diff --git a/src/Test/Serialization/Symbiote/Aeson.hs b/src/Test/Serialization/Symbiote/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote/Aeson.hs @@ -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 diff --git a/src/Test/Serialization/Symbiote/Cereal.hs b/src/Test/Serialization/Symbiote/Cereal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote/Cereal.hs @@ -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 diff --git a/src/Test/Serialization/Symbiote/Cereal/Lazy.hs b/src/Test/Serialization/Symbiote/Cereal/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote/Cereal/Lazy.hs @@ -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 diff --git a/symbiote.cabal b/symbiote.cabal new file mode 100644 --- /dev/null +++ b/symbiote.cabal @@ -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 +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ]