symbiote 0.0.1.1 → 0.0.2
raw patch · 12 files changed
+1002/−260 lines, 12 filesdep +exceptionsdep +extractable-singletondep +http-typesdep −cereal-textdep −monad-control
Dependencies added: exceptions, extractable-singleton, http-types, monad-control-aligned, wai, wai-extra, wai-transformers, wai-websockets, warp, websockets, websockets-simple, websockets-simple-extra, zeromq4-haskell, zeromq4-simple
Dependencies removed: cereal-text, monad-control
Files
- README.md +2/−1
- src/Test/Serialization/Symbiote.hs +133/−30
- src/Test/Serialization/Symbiote/Core.hs +14/−4
- src/Test/Serialization/Symbiote/Debug.hs +4/−0
- src/Test/Serialization/Symbiote/WebSocket.hs +268/−0
- src/Test/Serialization/Symbiote/ZeroMQ.hs +106/−0
- symbiote.cabal +31/−6
- test/Spec.hs +8/−219
- test/Spec/Local.hs +73/−0
- test/Spec/Protocol.hs +180/−0
- test/Spec/Sanity.hs +73/−0
- test/Spec/Types.hs +110/−0
README.md view
@@ -52,4 +52,5 @@ ------------- -For an example, check out the tests - they are performed locally in an asynchronous channel, but achieve the right goal.+For an example, check out the tests - they are performed both locally in an asynchronous channel, and remotely+with its sister package - [purescript-symbiote](https://pursuit.purescript.org/package/purescript-symbiote).
src/Test/Serialization/Symbiote.hs view
@@ -95,21 +95,23 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import Data.Int (Int32) import Data.Text (unpack) import Data.Proxy (Proxy (..)) import Data.Aeson (ToJSON (..), FromJSON (..), (.=), object, (.:), Value (Object, String)) import Data.Aeson.Types (typeMismatch) import Data.Serialize (Serialize (..))-import Data.Serialize.Put (putWord8)-import Data.Serialize.Get (getWord8)+import Data.Serialize.Put (putWord8, putInt32be, putByteString, putLazyByteString)+import Data.Serialize.Get (getWord8, getInt32be, getByteString, getLazyByteString) import Text.Printf (printf) import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, writeTVar, atomically, newTChan, readTChan, writeTChan) import Control.Concurrent.Async (async, wait) import Control.Applicative ((<|>))-import Control.Monad (void)-import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith)+import Control.Monad (void, replicateM)+import Control.Monad.Trans.Control.Aligned (MonadBaseControl, liftBaseWith) import Control.Monad.State (modify') import Control.Monad.IO.Class (MonadIO, liftIO) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)@@ -207,22 +209,40 @@ | s == "yourTurn" = pure YourTurn | otherwise = typeMismatch "Generating s" x parseJSON x = typeMismatch "Generating s" x-instance Serialize s => Serialize (Generating s) where+-- | For supporting 32bit limitation on length prefix+instance Serialize (Generating BS.ByteString) where put x = case x of- Generated{..} -> putWord8 0 *> put genValue *> put genOperation- BadResult r -> putWord8 1 *> put r+ Generated{..} -> putWord8 0 *> putByteString' genValue *> putByteString' genOperation+ BadResult r -> putWord8 1 *> putByteString' r YourTurn -> putWord8 2 ImFinished -> putWord8 3- GeneratingNoParseOperated r -> putWord8 4 *> put r+ GeneratingNoParseOperated r -> putWord8 4 *> putByteString' r get = do x <- getWord8 case x of- 0 -> Generated <$> get <*> get- 1 -> BadResult <$> get+ 0 -> Generated <$> getByteString' <*> getByteString'+ 1 -> BadResult <$> getByteString' 2 -> pure YourTurn 3 -> pure ImFinished- 4 -> GeneratingNoParseOperated <$> get- _ -> fail "Generating s"+ 4 -> GeneratingNoParseOperated <$> getByteString'+ _ -> fail "Generating ByteString"+-- | For supporting 32bit limitation on length prefix+instance Serialize (Generating LBS.ByteString) where+ put x = case x of+ Generated{..} -> putWord8 0 *> putLazyByteString' genValue *> putLazyByteString' genOperation+ BadResult r -> putWord8 1 *> putLazyByteString' r+ YourTurn -> putWord8 2+ ImFinished -> putWord8 3+ GeneratingNoParseOperated r -> putWord8 4 *> putLazyByteString' r+ get = do+ x <- getWord8+ case x of+ 0 -> Generated <$> getLazyByteString' <*> getLazyByteString'+ 1 -> BadResult <$> getLazyByteString'+ 2 -> pure YourTurn+ 3 -> pure ImFinished+ 4 -> GeneratingNoParseOperated <$> getLazyByteString'+ _ -> fail "Generating LazyByteString" -- | Messages sent by a peer during their operating phase data Operating s@@ -248,18 +268,32 @@ noParseValue = OperatingNoParseValue <$> o .: "noParseValue" noParseOperation = OperatingNoParseOperation <$> o .: "noParseOperation" parseJSON x = typeMismatch "Operating s" x-instance Serialize s => Serialize (Operating s) where+-- | For supporting 32bit limitation on length prefix+instance Serialize (Operating BS.ByteString) where put x = case x of- Operated y -> putWord8 0 *> put y- OperatingNoParseValue r -> putWord8 1 *> put r- OperatingNoParseOperation r -> putWord8 2 *> put r+ Operated y -> putWord8 0 *> putByteString' y+ OperatingNoParseValue r -> putWord8 1 *> putByteString' r+ OperatingNoParseOperation r -> putWord8 2 *> putByteString' r get = do x <- getWord8 case x of- 0 -> Operated <$> get- 1 -> OperatingNoParseValue <$> get- 2 -> OperatingNoParseOperation <$> get- _ -> fail "Operating s"+ 0 -> Operated <$> getByteString'+ 1 -> OperatingNoParseValue <$> getByteString'+ 2 -> OperatingNoParseOperation <$> getByteString'+ _ -> fail "Operating ByteString"+-- | For supporting 32bit limitation on length prefix+instance Serialize (Operating LBS.ByteString) where+ put x = case x of+ Operated y -> putWord8 0 *> putLazyByteString' y+ OperatingNoParseValue r -> putWord8 1 *> putLazyByteString' r+ OperatingNoParseOperation r -> putWord8 2 *> putLazyByteString' r+ get = do+ x <- getWord8+ case x of+ 0 -> Operated <$> getLazyByteString'+ 1 -> OperatingNoParseValue <$> getLazyByteString'+ 2 -> OperatingNoParseOperation <$> getLazyByteString'+ _ -> fail "Operating LazyByteString" -- | Messages sent by the first peer data First s@@ -295,18 +329,42 @@ o' <- o .: "firstOperating" FirstOperating <$> o' .: "topic" <*> o' .: "operating" parseJSON x = typeMismatch "First s" x-instance Serialize s => Serialize (First s) where+instance Serialize (First BS.ByteString) where put x = case x of- AvailableTopics ts -> putWord8 0 *> put ts+ AvailableTopics ts -> do+ putWord8 0+ let ls = Map.toList ts+ putInt32be (fromIntegral (length ls))+ void (traverse put ls) FirstGenerating t y -> putWord8 1 *> put t *> put y FirstOperating t y -> putWord8 2 *> put t *> put y get = do x <- getWord8 case x of- 0 -> AvailableTopics <$> get+ 0 -> do+ l <- getInt32be+ AvailableTopics . Map.fromList <$> replicateM (fromIntegral l) get 1 -> FirstGenerating <$> get <*> get 2 -> FirstOperating <$> get <*> get _ -> fail "First s"+instance Serialize (First LBS.ByteString) where+ put x = case x of+ AvailableTopics ts -> do+ putWord8 0+ let ls = Map.toList ts+ putInt32be (fromIntegral (length ls))+ void (traverse put ls)+ FirstGenerating t y -> putWord8 1 *> put t *> put y+ FirstOperating t y -> putWord8 2 *> put t *> put y+ get = do+ x <- getWord8+ case x of+ 0 -> do+ l <- getInt32be+ AvailableTopics . Map.fromList <$> replicateM (fromIntegral l) get+ 1 -> FirstGenerating <$> get <*> get+ 2 -> FirstOperating <$> get <*> get+ _ -> fail "First s" getFirstGenerating :: First s -> Maybe (Topic, Generating s) getFirstGenerating x = case x of@@ -359,20 +417,46 @@ | s == "start" = pure Start | otherwise = typeMismatch "Second s" x parseJSON x = typeMismatch "Second s" x-instance Serialize s => Serialize (Second s) where+instance Serialize (Second BS.ByteString) where put x = case x of- BadTopics ts -> putWord8 0 *> put ts+ BadTopics ts -> do+ putWord8 0+ let ls = Map.toList ts+ putInt32be (fromIntegral (length ls))+ void (traverse put ls) Start -> putWord8 1 SecondOperating t y -> putWord8 2 *> put t *> put y SecondGenerating t y -> putWord8 3 *> put t *> put y get = do x <- getWord8 case x of- 0 -> BadTopics <$> get+ 0 -> do+ l <- getInt32be+ BadTopics . Map.fromList <$> replicateM (fromIntegral l) get 1 -> pure Start 2 -> SecondOperating <$> get <*> get 3 -> SecondGenerating <$> get <*> get _ -> fail "Second s"+instance Serialize (Second LBS.ByteString) where+ put x = case x of+ BadTopics ts -> do+ putWord8 0+ let ls = Map.toList ts+ putInt32be (fromIntegral (length ls))+ void (traverse put ls)+ Start -> putWord8 1+ SecondOperating t y -> putWord8 2 *> put t *> put y+ SecondGenerating t y -> putWord8 3 *> put t *> put y+ get = do+ x <- getWord8+ case x of+ 0 -> do+ l <- getInt32be+ BadTopics . Map.fromList <$> replicateM (fromIntegral l) get+ 1 -> pure Start+ 2 -> SecondOperating <$> get <*> get+ 3 -> SecondGenerating <$> get <*> get+ _ -> fail "Second s" getSecondGenerating :: Second s -> Maybe (Topic, Generating s) getSecondGenerating x = case x of@@ -430,7 +514,8 @@ nullProgress _ _ = pure () --- | Run the test suite as the first peer+-- | Run the test suite as the first peer - see 'Test.Serialization.Symbiote.WebSocket' for end-user+-- implementations. firstPeer :: forall m s . MonadIO m => Show s@@ -478,7 +563,8 @@ _ -> onFailure $ OutOfSyncSecond shouldBeStart --- | Run the test suite as the second peer+-- | Run the test suite as the second peer - see 'Test.Serialization.Symbiote.WebSocket' for end-user+-- implementations. secondPeer :: forall s m . MonadIO m => Show s@@ -763,7 +849,7 @@ -- | Prints to stdout and uses a local channel for a sanity-check - doesn't serialize.-simpleTest :: MonadBaseControl IO m+simpleTest :: MonadBaseControl IO m stM => MonadIO m => Show s => SymbioteT s m () -> m ()@@ -774,7 +860,7 @@ (liftIO . defaultFailure) nullProgress -simpleTest' :: MonadBaseControl IO m+simpleTest' :: MonadBaseControl IO m stM => MonadIO m => Show s => (Topic -> m ()) -- ^ report topic success@@ -801,3 +887,20 @@ where encodeAndSendChan chan x = liftIO $ atomically (writeTChan chan x) receiveAndDecodeChan chan = liftIO $ atomically (readTChan chan)+++putByteString' b = do+ putInt32be (fromIntegral (BS.length b))+ putByteString b++getByteString' = do+ l <- getInt32be+ getByteString (fromIntegral l)++putLazyByteString' b = do+ putInt32be (fromIntegral (LBS.length b))+ putLazyByteString b++getLazyByteString' = do+ l <- getInt32be+ getLazyByteString (fromIntegral l)
src/Test/Serialization/Symbiote/Core.hs view
@@ -22,15 +22,18 @@ module Test.Serialization.Symbiote.Core where -import Data.Text (Text)+import Data.Text (Text, unpack, pack, length) import Data.String (IsString) import Data.Map (Map) import qualified Data.Map as Map import Data.Int (Int32) import Data.Proxy (Proxy (..))+import Data.Traversable (traverse) import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)-import Data.Serialize (Serialize)-import Data.Serialize.Text ()+import Data.Serialize (Serialize (..))+import Data.Serialize.Put (putInt32be)+import Data.Serialize.Get (getInt32be)+import Control.Monad (void, replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Concurrent.STM (TVar, readTVar, readTVarIO, modifyTVar', atomically)@@ -59,7 +62,14 @@ -- | Unique name of a type, for a suite of tests newtype Topic = Topic Text- deriving (Eq, Ord, Show, IsString, Arbitrary, ToJSON, FromJSON, ToJSONKey, FromJSONKey, Serialize)+ deriving (Eq, Ord, Show, IsString, Arbitrary, ToJSON, FromJSON, ToJSONKey, FromJSONKey)+instance Serialize Topic where+ put (Topic t) = do+ putInt32be (fromIntegral (Data.Text.length t))+ void (traverse put (unpack t))+ get = do+ l <- getInt32be+ Topic . pack <$> replicateM (fromIntegral l) get -- | Protocol state for a particular topic data SymbioteProtocol a s
+ src/Test/Serialization/Symbiote/Debug.hs view
@@ -0,0 +1,4 @@+module Test.Serialization.Symbiote.Debug where+++data Debug = FullDebug | Percent | NoDebug
+ src/Test/Serialization/Symbiote/WebSocket.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE+ RankNTypes+ , NamedFieldPuns+ , FlexibleContexts+ , ScopedTypeVariables+ #-}++{-|++Module: Test.Serialization.Symbiote.WebSocket+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC++Use these functions to communicate over a WebSocket as your peer-to-peer communication mechanism.++-}+++module Test.Serialization.Symbiote.WebSocket where++import Test.Serialization.Symbiote+ (firstPeer, secondPeer, SymbioteT, defaultFailure, defaultProgress, nullProgress, Topic, Failure)+import Test.Serialization.Symbiote.Debug (Debug (..))++import Data.Aeson (ToJSON, FromJSON, Value)+import Data.Serialize (Serialize)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Serialize as Cereal+import Data.Singleton.Class (Extractable)+import Control.Monad (forever, void)+import Control.Monad.Trans.Control.Aligned (MonadBaseControl, liftBaseWith)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Catch (MonadCatch)+import Control.Concurrent.STM+ ( TChan, TMVar, newTChanIO, readTChan, writeTChan, atomically+ , newEmptyTMVarIO, putTMVar, takeTMVar)+import Control.Concurrent.Async (async, cancel, wait, Async)+import Network.WebSockets.Simple+ (WebSocketsApp (..), WebSocketsAppParams (..), toClientAppTString, toClientAppTBinary, dimap', dimapJson, dimapStringify)+import Network.WebSockets.Simple.Logger (logStdout)+import Network.WebSockets.Trans (ClientAppT)+++secondPeerWebSocketLazyByteString :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> SymbioteT LBS.ByteString m () -- ^ Tests registered+ -> m ()+secondPeerWebSocketLazyByteString host debug = peerWebSocketLazyByteString host debug secondPeer++firstPeerWebSocketLazyByteString :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> SymbioteT LBS.ByteString m () -- ^ Tests registered+ -> m ()+firstPeerWebSocketLazyByteString host debug = peerWebSocketLazyByteString host debug firstPeer++secondPeerWebSocketByteString :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> SymbioteT BS.ByteString m () -- ^ Tests registered+ -> m ()+secondPeerWebSocketByteString host debug = peerWebSocketByteString host debug secondPeer++firstPeerWebSocketByteString :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> SymbioteT BS.ByteString m () -- ^ Tests registered+ -> m ()+firstPeerWebSocketByteString host debug = peerWebSocketByteString host debug firstPeer++secondPeerWebSocketJson :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> SymbioteT Value m () -- ^ Tests registered+ -> m ()+secondPeerWebSocketJson host debug = peerWebSocketJson host debug secondPeer++firstPeerWebSocketJson :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> SymbioteT Value m () -- ^ Tests registered+ -> m ()+firstPeerWebSocketJson host debug = peerWebSocketJson host debug firstPeer++peerWebSocketLazyByteString :: forall m stM them me+ . MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => Show (them LBS.ByteString)+ => Serialize (me LBS.ByteString)+ => Serialize (them LBS.ByteString)+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> ( (me LBS.ByteString -> m ())+ -> m (them LBS.ByteString)+ -> (Topic -> m ())+ -> (Failure them LBS.ByteString -> m ())+ -> (Topic -> Float -> m ())+ -> SymbioteT LBS.ByteString m ()+ -> m ()+ )+ -> SymbioteT LBS.ByteString m () -- ^ Tests registered+ -> m ()+peerWebSocketLazyByteString runClientAppT debug = peerWebSocket go debug+ where+ go :: WebSocketsApp IO (them LBS.ByteString) (me LBS.ByteString) -> IO ()+ go app =+ runClientAppT $ toClientAppTBinary $+ ( case debug of+ FullDebug -> logStdout+ _ -> id+ ) $ dimap' receive Cereal.encodeLazy app+ where+ receive :: LBS.ByteString -> IO (them LBS.ByteString)+ receive buf = do+ let eX = Cereal.decodeLazy buf+ case eX of+ Left e -> do+ putStrLn $ "Can't parse buffer: " ++ show buf+ error e+ Right x -> pure x++peerWebSocketByteString :: forall m stM them me+ . MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => Show (them BS.ByteString)+ => Serialize (me BS.ByteString)+ => Serialize (them BS.ByteString)+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> ( (me BS.ByteString -> m ())+ -> m (them BS.ByteString)+ -> (Topic -> m ())+ -> (Failure them BS.ByteString -> m ())+ -> (Topic -> Float -> m ())+ -> SymbioteT BS.ByteString m ()+ -> m ()+ )+ -> SymbioteT BS.ByteString m () -- ^ Tests registered+ -> m ()+peerWebSocketByteString runClientAppT debug = peerWebSocket go debug+ where+ go :: WebSocketsApp IO (them BS.ByteString) (me BS.ByteString) -> IO ()+ go app =+ runClientAppT $ toClientAppTBinary $ toLazy $+ ( case debug of+ FullDebug -> logStdout+ _ -> id+ ) $ dimap' receive Cereal.encode app+ where+ receive :: BS.ByteString -> IO (them BS.ByteString)+ receive buf = do+ let eX = Cereal.decode buf+ case eX of+ Left e -> do+ putStrLn $ "Can't parse buffer: " ++ show buf+ error e+ Right x -> pure x++ toLazy :: WebSocketsApp IO BS.ByteString BS.ByteString -> WebSocketsApp IO LBS.ByteString LBS.ByteString+ toLazy = dimap' r s+ where+ r = pure . LBS.toStrict+ s = LBS.fromStrict+++peerWebSocketJson :: MonadIO m+ => MonadBaseControl IO m stM+ => Extractable stM+ => MonadCatch m+ => Show (them Value)+ => ToJSON (me Value)+ => FromJSON (them Value)+ => (ClientAppT IO () -> IO ()) -- ^ Run the generated WebSocket client+ -> Debug+ -> ( (me Value -> m ())+ -> m (them Value)+ -> (Topic -> m ())+ -> (Failure them Value -> m ())+ -> (Topic -> Float -> m ())+ -> SymbioteT Value m ()+ -> m ()+ )+ -> SymbioteT Value m () -- ^ Tests registered+ -> m ()+peerWebSocketJson runClientAppT debug = peerWebSocket+ ( runClientAppT+ . toClientAppTString+ . ( case debug of+ FullDebug -> logStdout+ _ -> id+ )+ . dimapStringify+ . dimapJson+ )+ debug++peerWebSocket :: forall m stM s them me+ . MonadIO m+ => MonadBaseControl IO m stM+ => Show (them s)+ => Show s+ => ( WebSocketsApp IO (them s) (me s)+ -> IO ()+ ) -- ^ Run the generated WebSocketsApp+ -> Debug+ -> ( (me s -> m ())+ -> m (them s)+ -> (Topic -> m ())+ -> (Failure them s -> m ())+ -> (Topic -> Float -> m ())+ -> SymbioteT s m ()+ -> m ()+ )+ -> SymbioteT s m () -- ^ Tests registered+ -> m ()+peerWebSocket webSocket debug peer tests = do+ (outgoing :: TChan (me s)) <- liftIO newTChanIO+ (incoming :: TChan (them s)) <- liftIO newTChanIO+ (outgoingThreadVar :: TMVar (Async ())) <- liftIO newEmptyTMVarIO+ let encodeAndSend x = liftIO $ atomically $ writeTChan outgoing x+ receiveAndDecode = liftIO $ atomically $ readTChan incoming+ onSuccess t = liftIO $ putStrLn $ "Topic finished: " ++ show t+ onFailure = liftIO . defaultFailure+ onProgress t n = case debug of+ NoDebug -> nullProgress t n+ _ -> liftIO (defaultProgress t n)++ onOpen :: WebSocketsAppParams IO (me s) -> IO ()+ onOpen WebSocketsAppParams{close,send} = do+ outgoingThread <- async $ forever $ atomically (readTChan outgoing) >>= send+ atomically (putTMVar outgoingThreadVar outgoingThread)+ app :: WebSocketsApp IO (them s) (me s)+ app = WebSocketsApp+ { onClose = \_ _ -> do+ outgoingThread <- atomically (takeTMVar outgoingThreadVar)+ cancel outgoingThread+ , onReceive = \_ -> atomically . writeTChan incoming+ , onOpen+ }+ wsThread <- liftIO (async (webSocket app))+ peer encodeAndSend receiveAndDecode onSuccess onFailure onProgress tests+ liftIO (cancel wsThread)
+ src/Test/Serialization/Symbiote/ZeroMQ.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE+ RankNTypes+ , FlexibleContexts+ , ScopedTypeVariables+ #-}++{-|++Module: Test.Serialization.Symbiote.ZeroMQ+Copyright: (c) 2019 Athan Clark+License: BSD-3-Style+Maintainer: athan.clark@gmail.com+Portability: GHC++Use these functions to communicate over a Peer-to-Peer ZeroMQ socket.++-}++module Test.Serialization.Symbiote.ZeroMQ where+++import Test.Serialization.Symbiote+ (firstPeer, secondPeer, SymbioteT, defaultFailure, defaultProgress, nullProgress, Topic, Failure)+import Test.Serialization.Symbiote.Debug (Debug (..))++import qualified Data.ByteString as BS+import qualified Data.Serialize as Cereal+import Data.List.NonEmpty (NonEmpty (..))+import Data.Singleton.Class (Extractable)+import Control.Monad (forever)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Control.Aligned (MonadBaseControl)+import Control.Concurrent.Async (Async, cancel)+import Control.Concurrent.STM (TChan, TMVar, newTChanIO, writeTChan, readTChan, newEmptyTMVarIO, putTMVar, takeTMVar, atomically)+import System.ZMQ4 (Pair (..))+import System.ZMQ4.Monadic (runZMQ, async)+import System.ZMQ4.Simple (socket, bind, send, receive)++++secondPeerZeroMQ :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => String+ -> Debug+ -> SymbioteT BS.ByteString m () -- ^ Tests registered+ -> m ()+secondPeerZeroMQ host debug = peerZeroMQ host debug secondPeer++firstPeerZeroMQ :: MonadIO m+ => MonadBaseControl IO m stM+ => MonadCatch m+ => Extractable stM+ => String+ -> Debug+ -> SymbioteT BS.ByteString m () -- ^ Tests registered+ -> m ()+firstPeerZeroMQ host debug = peerZeroMQ host debug firstPeer++peerZeroMQ :: forall m stM them me+ . MonadIO m+ => MonadBaseControl IO m stM+ => Show (them BS.ByteString)+ => Cereal.Serialize (me BS.ByteString)+ => Cereal.Serialize (them BS.ByteString)+ => String -- ^ Host+ -> Debug+ -> ( (me BS.ByteString -> m ())+ -> m (them BS.ByteString)+ -> (Topic -> m ())+ -> (Failure them BS.ByteString -> m ())+ -> (Topic -> Float -> m ())+ -> SymbioteT BS.ByteString m ()+ -> m ()+ )+ -> SymbioteT BS.ByteString m () -- ^ Tests registered+ -> m ()+peerZeroMQ host debug peer tests = do+ (outgoing :: TChan (me BS.ByteString)) <- liftIO newTChanIO+ (incoming :: TChan (them BS.ByteString)) <- liftIO newTChanIO+ (outgoingThreadVar :: TMVar (Async ())) <- liftIO newEmptyTMVarIO+ let encodeAndSend x = liftIO $ atomically $ writeTChan outgoing x+ receiveAndDecode = liftIO $ atomically $ readTChan incoming+ onSuccess t = liftIO $ putStrLn $ "Topic finished: " ++ show t+ onFailure = liftIO . defaultFailure+ onProgress t n = case debug of+ NoDebug -> nullProgress t n+ _ -> liftIO (defaultProgress t n)+ zThread <- runZMQ $ async $ do+ s <- socket Pair Pair+ bind s host+ outgoingThread <- async $ forever $ do+ x <- liftIO (atomically (readTChan outgoing))+ send () s ((Cereal.encode x) :| [])+ liftIO (atomically (putTMVar outgoingThreadVar outgoingThread))+ forever $ do+ mX <- receive s+ case mX of+ Nothing -> liftIO $ putStrLn "got nothin"+ Just ((),x :| _) -> case Cereal.decode x of+ Left e -> error $ "couldn't decode: " ++ e+ Right x' -> liftIO (atomically (writeTChan incoming x'))+ peer encodeAndSend receiveAndDecode onSuccess onFailure onProgress tests+ liftIO (cancel zThread)
symbiote.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 25783954120aa1f2248704db9140a112893ef6810db416a5c6725e34df0edc76+-- hash: b6ff1fa8d8f7f7eb06962e6726c32348cec4ff8a0d70f61b0628093fbdc88029 name: symbiote-version: 0.0.1.1+version: 0.0.2 synopsis: Data serialization, communication, and operation verification implementation description: Please see the README on GitHub at <https://github.com/athanclark/symbiote#readme> category: Data, Testing@@ -35,6 +35,9 @@ Test.Serialization.Symbiote.Cereal Test.Serialization.Symbiote.Cereal.Lazy Test.Serialization.Symbiote.Core+ Test.Serialization.Symbiote.Debug+ Test.Serialization.Symbiote.WebSocket+ Test.Serialization.Symbiote.ZeroMQ other-modules: Paths_symbiote hs-source-dirs:@@ -47,19 +50,29 @@ , base >=4.7 && <5 , bytestring , cereal- , cereal-text , containers- , monad-control+ , exceptions+ , extractable-singleton+ , monad-control-aligned , mtl , quickcheck-instances , stm , text+ , wai-transformers >=0.1.0+ , websockets-simple >=0.2.0+ , websockets-simple-extra+ , zeromq4-haskell+ , zeromq4-simple >=0.0.0.2 default-language: Haskell2010 test-suite symbiote-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:+ Spec.Local+ Spec.Protocol+ Spec.Sanity+ Spec.Types Paths_symbiote hs-source-dirs: test@@ -72,9 +85,11 @@ , base >=4.7 && <5 , bytestring , cereal- , cereal-text , containers- , monad-control+ , exceptions+ , extractable-singleton+ , http-types+ , monad-control-aligned , mtl , quickcheck-instances , stm@@ -83,4 +98,14 @@ , tasty-hunit , tasty-quickcheck , text+ , wai+ , wai-extra+ , wai-transformers+ , wai-websockets+ , warp+ , websockets+ , websockets-simple+ , websockets-simple-extra+ , zeromq4-haskell+ , zeromq4-simple >=0.0.0.2 default-language: Haskell2010
test/Spec.hs view
@@ -1,34 +1,18 @@ {-# LANGUAGE TypeFamilies- , DeriveGeneric , FlexibleContexts , OverloadedStrings , FlexibleInstances- , StandaloneDeriving , UndecidableInstances , MultiParamTypeClasses #-} +import Spec.Sanity (sanityTests)+import Spec.Local (localIsos)+import Spec.Protocol (protocolTests)+ import Test.Tasty (defaultMain, testGroup, TestTree)-import Test.Tasty.HUnit (testCase)-import Test.Tasty.QuickCheck (testProperty)-import Test.Serialization.Symbiote- ( SymbioteT, register, firstPeer, secondPeer, SymbioteOperation (..), Symbiote (..), SimpleSerialization- , First, Second, Generating, Operating, Topic, simpleTest, defaultSuccess, defaultFailure, defaultProgress)-import Test.Serialization.Symbiote.Cereal ()-import Test.Serialization.Symbiote.Aeson ()-import Test.Serialization.Symbiote.Abides-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 ()@@ -36,202 +20,7 @@ tests :: TestTree-tests = testGroup "All Tests"- [ testGroup "Symbiote Sanity Checks"- [ simpleTests- , bytestringTests- , jsonTests- ]- , testGroup "Local Isomorphisms"- [ testGroup "Json" $- let go (n,p) = testProperty n (jsonIso p)- in [ testGroup "Abides"- [ go ("AbidesSemigroup [Int]", Proxy :: Proxy (AbidesSemigroup [Int]))- , go ("AbidesMonoid [Int]", Proxy :: Proxy (AbidesMonoid [Int]))- , go ("AbidesEq Int", Proxy :: Proxy (AbidesEq Int))- , go ("AbidesOrd Int", Proxy :: Proxy (AbidesOrd Int))- , go ("AbidesEnum Int", Proxy :: Proxy (AbidesEnum Int))- , go ("AbidesSemiring Int", Proxy :: Proxy (AbidesSemiring Int))- , go ("AbidesRing Int", Proxy :: Proxy (AbidesRing Int))- , go ("AbidesCommutativeRing Int", Proxy :: Proxy (AbidesCommutativeRing Int))- , go ("AbidesDivisionRing Int", Proxy :: Proxy (AbidesDivisionRing Int))- , go ("AbidesEuclideanRing Int", Proxy :: Proxy (AbidesEuclideanRing Int))- , go ("AbidesField Int", Proxy :: Proxy (AbidesField Int))- ]- , testGroup "Symbiote"- [ go ("Generating Int", Proxy :: Proxy (Generating Int))- , go ("Operating Int", Proxy :: Proxy (Operating Int))- , go ("First Int", Proxy :: Proxy (First Int))- , go ("Second Int", Proxy :: Proxy (Second Int))- , go ("Topic", Proxy :: Proxy Topic)- ]- ]- , testGroup "Cereal" $- let go (n,p) = testProperty n (cerealIso p)- in [ testGroup "Abides"- [ go ("AbidesSemigroup [Int]", Proxy :: Proxy (AbidesSemigroup [Int]))- , go ("AbidesMonoid [Int]", Proxy :: Proxy (AbidesMonoid [Int]))- , go ("AbidesEq Int", Proxy :: Proxy (AbidesEq Int))- , go ("AbidesOrd Int", Proxy :: Proxy (AbidesOrd Int))- , go ("AbidesEnum Int", Proxy :: Proxy (AbidesEnum Int))- , go ("AbidesSemiring Int", Proxy :: Proxy (AbidesSemiring Int))- , go ("AbidesRing Int", Proxy :: Proxy (AbidesRing Int))- , go ("AbidesCommutativeRing Int", Proxy :: Proxy (AbidesCommutativeRing Int))- , go ("AbidesDivisionRing Int", Proxy :: Proxy (AbidesDivisionRing Int))- , go ("AbidesEuclideanRing Int", Proxy :: Proxy (AbidesEuclideanRing Int))- , go ("AbidesField Int", Proxy :: Proxy (AbidesField Int))- ]- , testGroup "Symbiote"- [ go ("Generating Int", Proxy :: Proxy (Generating Int))- , go ("Operating Int", Proxy :: Proxy (Operating Int))- , go ("First Int", Proxy :: Proxy (First Int))- , go ("Second Int", Proxy :: Proxy (Second Int))- , go ("Topic", Proxy :: Proxy Topic)- ]- ]- ]- ]- 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 (SimpleSerialization () ()) IO ()- unitSuite = register "Unit" 100 (Proxy :: Proxy ())- intSuite :: SymbioteT (SimpleSerialization Int Bool) IO ()- intSuite = register "Int" 100 (Proxy :: Proxy Int)- doubleSuite :: SymbioteT (SimpleSerialization Double Bool) IO ()- doubleSuite = register "Double" 100 (Proxy :: Proxy Double)- listSuite :: SymbioteT (SimpleSerialization [Int] (Either Bool [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 Bool where- data Operation Int- = IntCommutativeRing (Operation (AbidesCommutativeRing Int))- perform op x = case op of- IntCommutativeRing op' -> perform op' (AbidesCommutativeRing x)-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 = IntCommutativeRing <$> arbitrary---instance SymbioteOperation Double Bool where- data Operation Double- = DoubleField (Operation (AbidesField Double))- perform op x = case op of- DoubleField op' -> perform op' (AbidesField 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 = DoubleField <$> arbitrary--instance Eq a => SymbioteOperation [a] (Either Bool [a]) where- data Operation [a]- = ListMonoid (Operation (AbidesMonoid [a]))- | ReverseList- | InitList- | TailList- perform op x = case op of- ListMonoid op' -> Left (perform op' (AbidesMonoid x))- ReverseList -> Right (reverse x)- InitList -> Right $ if null x then [] else init x- TailList -> Right $ if null x then [] else tail x-deriving instance Show a => Show (Operation [a])-deriving instance Generic (Operation [a])-instance Cereal.Serialize a => Cereal.Serialize (Operation [a])-instance Json.ToJSON a => Json.ToJSON (Operation [a])-instance Json.FromJSON a => Json.FromJSON (Operation [a])-instance Arbitrary a => Arbitrary (Operation [a]) where- arbitrary = oneof- [ pure ReverseList- , pure InitList- , pure TailList- , ListMonoid <$> arbitrary- ]--instance SymbioteOperation Json.Value 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 Json.Value LBS.ByteString where- encode = Json.encode- decode = Json.decode- encodeOut _ = Json.encode- decodeOut _ = 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- ]----jsonIso :: Json.ToJSON a => Json.FromJSON a => Eq a => Proxy a -> a -> Bool-jsonIso Proxy x = Json.decode (Json.encode x) == Just x---cerealIso :: Cereal.Serialize a => Eq a => Proxy a -> a -> Bool-cerealIso Proxy x = Cereal.decode (Cereal.encode x) == Right x+tests = testGroup "All Tests" $+ [ sanityTests+ , localIsos+ ] ++ protocolTests
+ test/Spec/Local.hs view
@@ -0,0 +1,73 @@+module Spec.Local where++import Spec.Types ()++import qualified Data.Aeson as Json+import qualified Data.Serialize as Cereal+import Data.ByteString (ByteString)+import Data.Proxy (Proxy (..))+import Test.Tasty (testGroup, TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck.Instances ()+import Test.Serialization.Symbiote (First, Second, Generating, Operating, Topic)+import Test.Serialization.Symbiote.Abides+++localIsos :: TestTree+localIsos =+ testGroup "Local Isomorphisms"+ [ testGroup "Json" $+ let go (n,p) = testProperty n (jsonIso p)+ in [ testGroup "Abides"+ [ go ("AbidesSemigroup [Int]", Proxy :: Proxy (AbidesSemigroup [Int]))+ , go ("AbidesMonoid [Int]", Proxy :: Proxy (AbidesMonoid [Int]))+ , go ("AbidesEq Int", Proxy :: Proxy (AbidesEq Int))+ , go ("AbidesOrd Int", Proxy :: Proxy (AbidesOrd Int))+ , go ("AbidesEnum Int", Proxy :: Proxy (AbidesEnum Int))+ , go ("AbidesSemiring Int", Proxy :: Proxy (AbidesSemiring Int))+ , go ("AbidesRing Int", Proxy :: Proxy (AbidesRing Int))+ , go ("AbidesCommutativeRing Int", Proxy :: Proxy (AbidesCommutativeRing Int))+ , go ("AbidesDivisionRing Int", Proxy :: Proxy (AbidesDivisionRing Int))+ , go ("AbidesEuclideanRing Int", Proxy :: Proxy (AbidesEuclideanRing Int))+ , go ("AbidesField Int", Proxy :: Proxy (AbidesField Int))+ ]+ , testGroup "Symbiote"+ [ go ("Generating Int", Proxy :: Proxy (Generating Int))+ , go ("Operating Int", Proxy :: Proxy (Operating Int))+ , go ("First Int", Proxy :: Proxy (First Int))+ , go ("Second Int", Proxy :: Proxy (Second Int))+ , go ("Topic", Proxy :: Proxy Topic)+ ]+ ]+ , testGroup "Cereal" $+ let go (n,p) = testProperty n (cerealIso p)+ in [ testGroup "Abides"+ [ go ("AbidesSemigroup [Int]", Proxy :: Proxy (AbidesSemigroup [Int]))+ , go ("AbidesMonoid [Int]", Proxy :: Proxy (AbidesMonoid [Int]))+ , go ("AbidesEq Int", Proxy :: Proxy (AbidesEq Int))+ , go ("AbidesOrd Int", Proxy :: Proxy (AbidesOrd Int))+ , go ("AbidesEnum Int", Proxy :: Proxy (AbidesEnum Int))+ , go ("AbidesSemiring Int", Proxy :: Proxy (AbidesSemiring Int))+ , go ("AbidesRing Int", Proxy :: Proxy (AbidesRing Int))+ , go ("AbidesCommutativeRing Int", Proxy :: Proxy (AbidesCommutativeRing Int))+ , go ("AbidesDivisionRing Int", Proxy :: Proxy (AbidesDivisionRing Int))+ , go ("AbidesEuclideanRing Int", Proxy :: Proxy (AbidesEuclideanRing Int))+ , go ("AbidesField Int", Proxy :: Proxy (AbidesField Int))+ ]+ , testGroup "Symbiote"+ [ go ("Generating ByteString", Proxy :: Proxy (Generating ByteString))+ , go ("Operating ByteString", Proxy :: Proxy (Operating ByteString))+ , go ("First ByteString", Proxy :: Proxy (First ByteString))+ , go ("Second ByteString", Proxy :: Proxy (Second ByteString))+ , go ("Topic", Proxy :: Proxy Topic)+ ]+ ]+ ]+++jsonIso :: Json.ToJSON a => Json.FromJSON a => Eq a => Proxy a -> a -> Bool+jsonIso Proxy x = Json.decode (Json.encode x) == Just x+++cerealIso :: Cereal.Serialize a => Eq a => Proxy a -> a -> Bool+cerealIso Proxy x = Cereal.decode (Cereal.encode x) == Right x
+ test/Spec/Protocol.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE+ MultiParamTypeClasses+ , TypeFamilies+ , FlexibleInstances+ , FlexibleContexts+ , OverloadedStrings+ #-}++module Spec.Protocol where++import qualified Data.Aeson as Json+import qualified Data.Aeson.Types as Json+import qualified Data.Serialize as Cereal+import qualified Data.Serialize.Get as Cereal+import qualified Data.Serialize.Put as Cereal+import qualified Data.ByteString as BS+import Data.Proxy+import Control.Monad.IO.Class (liftIO)+import Test.Serialization.Symbiote+ (SymbioteOperation (..), Generating, Operating, First, Second, Topic, SymbioteT, register)+import Test.Serialization.Symbiote.Debug (Debug (..))+import Test.Serialization.Symbiote.WebSocket (firstPeerWebSocketJson, firstPeerWebSocketByteString)+import Test.Serialization.Symbiote.ZeroMQ (firstPeerZeroMQ)+import Test.Serialization.Symbiote.Aeson ()+import Test.Serialization.Symbiote.Cereal ()+import Test.QuickCheck (Arbitrary (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Network.WebSockets.Connection (defaultConnectionOptions)+import Network.WebSockets.Simple (accept)+import Network.WebSockets.Trans (runServerAppT)+import Network.Wai (responseLBS)+import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.RequestLogger (logStdoutDev)+import Network.HTTP.Types (status400)+++protocolTests :: [TestTree]+protocolTests =+ [ testGroup "WebSocket Server"+ [ testCase "Json" $+ let tests :: SymbioteT Json.Value IO ()+ tests = do+ register "Generating Topic" 100 (Proxy :: Proxy (Generating Topic))+ register "Operating Topic" 100 (Proxy :: Proxy (Operating Topic))+ register "First Topic" 100 (Proxy :: Proxy (First Topic))+ register "Second Topic" 100 (Proxy :: Proxy (Second Topic))+ register "Topic" 100 (Proxy :: Proxy Topic)+ runClient client = do+ -- runServer "localhost" 3000 server'+ let server = accept client+ server' <- runServerAppT server+ liftIO $ run 3000 $ logStdoutDev $ websocketsOr defaultConnectionOptions server' $ \_ respond ->+ respond $ responseLBS status400 [] "Not a websocket"+ in firstPeerWebSocketJson runClient NoDebug tests+ , testCase "ByteString" $+ let tests :: SymbioteT BS.ByteString IO ()+ tests = do+ register "Generating ByteString" 50 (Proxy :: Proxy (Generating BS.ByteString))+ register "Operating ByteString" 50 (Proxy :: Proxy (Operating BS.ByteString))+ register "First ByteString" 50 (Proxy :: Proxy (First BS.ByteString))+ register "Second ByteString" 50 (Proxy :: Proxy (Second BS.ByteString))+ register "Topic" 50 (Proxy :: Proxy Topic)+ runClient client = do+ -- runServer "localhost" 3000 server'+ let server = accept client+ server' <- runServerAppT server+ liftIO $ run 3001 $ logStdoutDev $ websocketsOr defaultConnectionOptions server' $ \_ respond ->+ respond $ responseLBS status400 [] "Not a websocket"+ in firstPeerWebSocketByteString runClient NoDebug tests+ ]+ , testGroup "ZeroMQ Server"+ [ testCase "ByteString" $+ let tests :: SymbioteT BS.ByteString IO ()+ tests = do+ register "Generating ByteString" 50 (Proxy :: Proxy (Generating BS.ByteString))+ register "Operating ByteString" 50 (Proxy :: Proxy (Operating BS.ByteString))+ register "First ByteString" 50 (Proxy :: Proxy (First BS.ByteString))+ register "Second ByteString" 50 (Proxy :: Proxy (Second BS.ByteString))+ register "Topic" 50 (Proxy :: Proxy Topic)+ in firstPeerZeroMQ "tcp://*:3002" NoDebug tests+ ]+ ]++-- Internal instances+instance SymbioteOperation (Generating s) (Generating s) where+ data Operation (Generating s) = GeneratingId+ perform GeneratingId x = x+instance Arbitrary (Operation (Generating s)) where+ arbitrary = pure GeneratingId+instance Json.ToJSON (Operation (Generating s)) where+ toJSON GeneratingId = Json.String "id"+instance Json.FromJSON (Operation (Generating s)) where+ parseJSON (Json.String s)+ | s == "id" = pure GeneratingId+ parseJSON json = Json.typeMismatch "Operation (Generating s)" json+instance Cereal.Serialize (Operation (Generating s)) where+ put GeneratingId = Cereal.putWord8 0+ get = do+ x <- Cereal.getWord8+ case x of+ 0 -> pure GeneratingId+ _ -> fail "Operation (Generating s)"++instance SymbioteOperation (Operating s) (Operating s) where+ data Operation (Operating s) = OperatingId+ perform OperatingId x = x+instance Arbitrary (Operation (Operating s)) where+ arbitrary = pure OperatingId+instance Json.ToJSON (Operation (Operating s)) where+ toJSON OperatingId = Json.String "id"+instance Json.FromJSON (Operation (Operating s)) where+ parseJSON (Json.String s)+ | s == "id" = pure OperatingId+ parseJSON json = Json.typeMismatch "Operation (Operating S)" json+instance Cereal.Serialize (Operation (Operating s)) where+ put OperatingId = Cereal.putWord8 0+ get = do+ x <- Cereal.getWord8+ case x of+ 0 -> pure OperatingId+ _ -> fail "Operation (Operating s)"++instance SymbioteOperation (First s) (First s) where+ data Operation (First s) = FirstId+ perform FirstId x = x+instance Arbitrary (Operation (First s)) where+ arbitrary = pure FirstId+instance Json.ToJSON (Operation (First s)) where+ toJSON FirstId = Json.String "id"+instance Json.FromJSON (Operation (First s)) where+ parseJSON (Json.String s)+ | s == "id" = pure FirstId+ parseJSON json = Json.typeMismatch "Operation (First S)" json+instance Cereal.Serialize (Operation (First s)) where+ put FirstId = Cereal.putWord8 0+ get = do+ x <- Cereal.getWord8+ case x of+ 0 -> pure FirstId+ _ -> fail "Operation (First s)"++instance SymbioteOperation (Second s) (Second s) where+ data Operation (Second s) = SecondId+ perform SecondId x = x+instance Arbitrary (Operation (Second s)) where+ arbitrary = pure SecondId+instance Json.ToJSON (Operation (Second s)) where+ toJSON SecondId = Json.String "id"+instance Json.FromJSON (Operation (Second s)) where+ parseJSON (Json.String s)+ | s == "id" = pure SecondId+ parseJSON json = Json.typeMismatch "Operation (Second S)" json+instance Cereal.Serialize (Operation (Second s)) where+ put SecondId = Cereal.putWord8 0+ get = do+ x <- Cereal.getWord8+ case x of+ 0 -> pure SecondId+ _ -> fail "Operation (Second s)"++instance SymbioteOperation Topic Topic where+ data Operation Topic = TopicId+ perform TopicId x = x+instance Arbitrary (Operation Topic) where+ arbitrary = pure TopicId+instance Json.ToJSON (Operation Topic) where+ toJSON TopicId = Json.String "id"+instance Json.FromJSON (Operation Topic) where+ parseJSON (Json.String s)+ | s == "id" = pure TopicId+ parseJSON json = Json.typeMismatch "Operation Topic" json+instance Cereal.Serialize (Operation Topic) where+ put TopicId = Cereal.putWord8 0+ get = do+ x <- Cereal.getWord8+ case x of+ 0 -> pure TopicId+ _ -> fail "Operation Topic"
+ test/Spec/Sanity.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE+ OverloadedStrings+ #-}++module Spec.Sanity where++import Spec.Types ()++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Aeson as Json+import Data.Proxy (Proxy (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.Serialization.Symbiote (SymbioteT, SimpleSerialization, simpleTest, register)+import Test.Serialization.Symbiote.Cereal ()+import Test.Serialization.Symbiote.Aeson ()++++sanityTests :: TestTree+sanityTests =+ testGroup "Symbiote Sanity Checks"+ [ 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 (SimpleSerialization () ()) IO ()+ unitSuite = register "Unit" 100 (Proxy :: Proxy ())+ intSuite :: SymbioteT (SimpleSerialization Int Bool) IO ()+ intSuite = register "Int" 100 (Proxy :: Proxy Int)+ doubleSuite :: SymbioteT (SimpleSerialization Double Bool) IO ()+ doubleSuite = register "Double" 100 (Proxy :: Proxy Double)+ listSuite :: SymbioteT (SimpleSerialization [Int] (Either Bool [Int])) IO ()+ listSuite = register "List" 100 (Proxy :: Proxy [Int])+ bytestringTests :: TestTree+ bytestringTests = testGroup "ByteString Tests"+ [ testCase "Json over id" (simpleTest jsonSuiteByteString)+ , testCase "Int over various" (simpleTest intSuiteByteString)+ , testCase "Double over various" (simpleTest doubleSuiteByteString)+ , testCase "List over various" (simpleTest listSuiteByteString)+ ]+ where+ jsonSuiteByteString :: SymbioteT LBS.ByteString IO ()+ jsonSuiteByteString = register "Json" 100 (Proxy :: Proxy Json.Value)+ intSuiteByteString :: SymbioteT BS.ByteString IO ()+ intSuiteByteString = register "Int" 100 (Proxy :: Proxy Int)+ doubleSuiteByteString :: SymbioteT BS.ByteString IO ()+ doubleSuiteByteString = register "Double" 100 (Proxy :: Proxy Double)+ listSuiteByteString :: SymbioteT BS.ByteString IO ()+ listSuiteByteString = register "List" 100 (Proxy :: Proxy [Int])+ jsonTests :: TestTree+ jsonTests = testGroup "Json Tests"+ [ testCase "Int over various" (simpleTest intSuiteJson)+ , testCase "Double over various" (simpleTest doubleSuiteJson)+ , testCase "List over various" (simpleTest listSuiteJson)+ ]+ where+ intSuiteJson :: SymbioteT Json.Value IO ()+ intSuiteJson = register "Int" 100 (Proxy :: Proxy Int)+ doubleSuiteJson :: SymbioteT Json.Value IO ()+ doubleSuiteJson = register "Double" 100 (Proxy :: Proxy Double)+ listSuiteJson :: SymbioteT Json.Value IO ()+ listSuiteJson = register "List" 100 (Proxy :: Proxy [Int])
+ test/Spec/Types.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE+ StandaloneDeriving+ , MultiParamTypeClasses+ , TypeFamilies+ , FlexibleInstances+ , DeriveGeneric+ , OverloadedStrings+ #-}++module Spec.Types where++import qualified Data.Serialize as Cereal+import qualified Data.Aeson as Json+import qualified Data.ByteString.Lazy as LBS+import Test.Serialization.Symbiote (SymbioteOperation (..), Symbiote (..))+import Test.Serialization.Symbiote.Abides+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Gen (oneof, scale, getSize)+import GHC.Generics (Generic)+++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 Bool where+ data Operation Int+ = IntCommutativeRing (Operation (AbidesCommutativeRing Int))+ perform op x = case op of+ IntCommutativeRing op' -> perform op' (AbidesCommutativeRing x)+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 = IntCommutativeRing <$> arbitrary+++instance SymbioteOperation Double Bool where+ data Operation Double+ = DoubleField (Operation (AbidesField Double))+ perform op x = case op of+ DoubleField op' -> perform op' (AbidesField 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 = DoubleField <$> arbitrary++instance Eq a => SymbioteOperation [a] (Either Bool [a]) where+ data Operation [a]+ = ListMonoid (Operation (AbidesMonoid [a]))+ | ReverseList+ | InitList+ | TailList+ perform op x = case op of+ ListMonoid op' -> Left (perform op' (AbidesMonoid x))+ ReverseList -> Right (reverse x)+ InitList -> Right $ if null x then [] else init x+ TailList -> Right $ if null x then [] else tail x+deriving instance Show a => Show (Operation [a])+deriving instance Generic (Operation [a])+instance Cereal.Serialize a => Cereal.Serialize (Operation [a])+instance Json.ToJSON a => Json.ToJSON (Operation [a])+instance Json.FromJSON a => Json.FromJSON (Operation [a])+instance Arbitrary a => Arbitrary (Operation [a]) where+ arbitrary = oneof+ [ pure ReverseList+ , pure InitList+ , pure TailList+ , ListMonoid <$> arbitrary+ ]++instance SymbioteOperation Json.Value 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 Json.Value LBS.ByteString where+ encode = Json.encode+ decode = Json.decode+ encodeOut _ = Json.encode+ decodeOut _ = 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+ ]+