diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). 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 @@ -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) diff --git a/src/Test/Serialization/Symbiote/Core.hs b/src/Test/Serialization/Symbiote/Core.hs --- a/src/Test/Serialization/Symbiote/Core.hs +++ b/src/Test/Serialization/Symbiote/Core.hs @@ -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 diff --git a/src/Test/Serialization/Symbiote/Debug.hs b/src/Test/Serialization/Symbiote/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote/Debug.hs @@ -0,0 +1,4 @@ +module Test.Serialization.Symbiote.Debug where + + +data Debug = FullDebug | Percent | NoDebug diff --git a/src/Test/Serialization/Symbiote/WebSocket.hs b/src/Test/Serialization/Symbiote/WebSocket.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote/WebSocket.hs @@ -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) diff --git a/src/Test/Serialization/Symbiote/ZeroMQ.hs b/src/Test/Serialization/Symbiote/ZeroMQ.hs new file mode 100644 --- /dev/null +++ b/src/Test/Serialization/Symbiote/ZeroMQ.hs @@ -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) diff --git a/symbiote.cabal b/symbiote.cabal --- a/symbiote.cabal +++ b/symbiote.cabal @@ -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 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Spec/Local.hs b/test/Spec/Local.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Local.hs @@ -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 diff --git a/test/Spec/Protocol.hs b/test/Spec/Protocol.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Protocol.hs @@ -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" diff --git a/test/Spec/Sanity.hs b/test/Spec/Sanity.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Sanity.hs @@ -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]) diff --git a/test/Spec/Types.hs b/test/Spec/Types.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Types.hs @@ -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 + ] +