purescript-iso 0.0.1.2 → 0.0.1.3
raw patch · 6 files changed
+318/−273 lines, 6 files
Files
- purescript-iso.cabal +5/−3
- src/Data/Aeson/JSONDateTime.hs +1/−3
- src/Data/Aeson/JSONString.hs +31/−0
- src/Test/Serialization.hs +100/−84
- src/Test/Serialization/Types.hs +174/−179
- test/Spec.hs +7/−4
purescript-iso.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3027dbec58707b55ea24b591ca5fb8d9bad467ac4211f9a7777444dbded91d3a+-- hash: 385def0412c2a5d163265905ddac9752da049097f6c7d5233b8afbe5e98b912c name: purescript-iso-version: 0.0.1.2+version: 0.0.1.3 synopsis: Isomorphic trivial data type definitions over JSON description: Please see the README on GitHub at <https://github.com/githubuser/purescript-iso#readme> category: Web@@ -29,6 +29,7 @@ exposed-modules: Data.Aeson.JSONDateTime Data.Aeson.JSONEither+ Data.Aeson.JSONString Data.Aeson.JSONTuple Data.Aeson.JSONUnit Test.Serialization@@ -37,6 +38,7 @@ Paths_purescript_iso hs-source-dirs: src+ ghc-options: -Wall build-depends: QuickCheck , aeson@@ -65,7 +67,7 @@ Paths_purescript_iso hs-source-dirs: test- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck , aeson
src/Data/Aeson/JSONDateTime.hs view
@@ -32,7 +32,5 @@ instance Arbitrary JSONDateTime where arbitrary =- let go = unsafePerformIO $ do- now <- getCurrentTime- pure (jsonDateTime now)+ let go = unsafePerformIO (jsonDateTime <$> getCurrentTime) in go `seq` pure go
+ src/Data/Aeson/JSONString.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE+ OverloadedStrings+ , GeneralizedNewtypeDeriving+ , DeriveGeneric+ #-}++module Data.Aeson.JSONString (JSONString, jsonString, getJSONString) where++import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Aeson (ToJSON, FromJSON)+import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Instances ()+++newtype JSONString = JSONString Text+ deriving (Eq, Ord, Generic, ToJSON, FromJSON)+++jsonString :: Text -> JSONString+jsonString = JSONString -- . T.pack . show+++getJSONString :: JSONString -> Text+getJSONString (JSONString x) = x -- T.pack $ read $ T.unpack x+++instance Arbitrary JSONString where+ arbitrary = jsonString <$> arbitrary
src/Test/Serialization.hs view
@@ -10,9 +10,9 @@ module Test.Serialization where import Test.Serialization.Types- ( TestSuiteM, ChannelMsg (..), ServerToClient (..), TestTopic+ ( TestSuiteM, MsgType (..), ServerToClient (..), TestTopic , ClientToServer (..), TestSuiteState, TestTopicState (..), emptyTestSuiteState- , gotClientGenValue, serializeValueClientOrigin+ , gotClientGenValue, serializeValueClientOrigin, getTopicState , gotClientSerialize, gotClientDeSerialize , deserializeValueClientOrigin, verify, generateValue, getTopicState , HasTopic (..), DesValue (..), HasClientG (..), GenValue (..)@@ -23,6 +23,7 @@ import Data.UUID (UUID) import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.UTF8 as BS8 import qualified Data.Strict.Maybe as Strict@@ -31,14 +32,14 @@ import qualified Data.Set as Set import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Aeson (eitherDecode, encode)+import Data.Aeson (eitherDecode, encode, toJSON) import Control.Monad (forever, void, when) import Control.Monad.Reader (runReaderT) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Control (liftBaseWith) import Control.Concurrent.Async (async, link, cancel) import Control.Concurrent.STM- (STM, TVar, newTVar, atomically, modifyTVar, readTVar)+ (STM, TVar, newTVar, atomically, modifyTVar, readTVar, writeTVar) import System.ZMQ4.Monadic (ZMQ, runZMQ, Router (..), Dealer (..)) import qualified System.ZMQ4.Simple as Z@@ -89,7 +90,7 @@ Right (x :: ClientToServer) -> case x of GetTopics -> do ts <- liftIO $ registerClient serverParamsTestSuite serverStateRef addr- send addr server (TopicsAvailable ts)+ () <$ send addr server (TopicsAvailable ts) ClientToServerBadParse e -> error $ T.unpack e Finished t -> do liftIO $ putStrLn $ "success: " ++ show t -- FIXME compile report?@@ -101,83 +102,69 @@ if ts == Set.empty || ts == Set.singleton t then liftIO exitSuccess else liftIO $ atomically $ modifyTVar pendingTopicsRef $ Set.delete t- ClientToServer msg -> case msg of- -- order:- -- clientG- -- serverS- -- clientD- -- serverG- -- clientS- -- serverD- -- verify- GeneratedInput t y -> do- mSuiteState <- liftIO $ atomically $ getTestSuiteState serverStateRef addr- case mSuiteState of- Nothing -> error "No test suite state!"- Just suiteState -> do- mOk <- liftIO $ gotClientGenValue suiteState t y- if isOkay mOk- then do- mOutgoing <- liftIO $ serializeValueClientOrigin suiteState t- case mOutgoing of- HasTopic (HasClientG outgoing) ->- send addr server (ServerToClient outgoing)- _ -> do- liftIO $ dumpTopic serverStateRef addr t- error $ "Bad serialize: " ++ show t ++ ", " ++ show mOutgoing- else do- liftIO $ dumpTopic serverStateRef addr t- error $ "Bad got gen: " ++ show t ++ ", " ++ show mOk- DeSerialized t y -> do- mSuiteState <- liftIO $ atomically $ getTestSuiteState serverStateRef addr- case mSuiteState of- Nothing -> error "No test suite state!"- Just suiteState -> do- mOk <- liftIO $ gotClientDeSerialize suiteState t y- if isOkay mOk- then do- mOutgoing <- liftIO $ generateValue suiteState t- case mOutgoing of- HasTopic mOutgoing' -> case mOutgoing' of- GenValue outgoing ->- send addr server (ServerToClient outgoing)- DoneGenerating -> pure ()- -- FIXME should never occur - client dictates- -- number of quickchecks- _ -> do- liftIO $ dumpTopic serverStateRef addr t- error $ "Bad generate value: " ++ show t ++ ", " ++ show mOutgoing- else do- liftIO $ dumpTopic serverStateRef addr t- error $ "Bad got deserialize: " ++ show t ++ ", " ++ show mOk- Serialized t y -> do- mSuiteState <- liftIO $ atomically $ getTestSuiteState serverStateRef addr- case mSuiteState of- Nothing -> error "No test suite state!"- Just suiteState -> do- mOk <- liftIO $ gotClientSerialize suiteState t y- if isOkay mOk- then do- mOutgoing <- liftIO $ deserializeValueClientOrigin suiteState t- case mOutgoing of- HasTopic (HasClientS (DesValue outgoing)) -> do- send addr server (ServerToClient outgoing)- -- verify- mOk' <- liftIO $ verify suiteState t- if isOkay mOk'- then send addr server (Continue t)- else do- liftIO $ dumpTopic serverStateRef addr t- error $ "Bad verify: " ++ show t ++ ", " ++ show mOk'- _ -> do- liftIO $ dumpTopic serverStateRef addr t- error $ "Bad deserialize value: " ++ show t ++ ", " ++ show mOutgoing- else do+ -- order:+ -- clientG+ -- serverS+ -- clientD+ -- serverG+ -- clientS+ -- serverD+ -- verify+ ClientToServer t m y -> do+ mSuiteState <- liftIO $ atomically $ getTestSuiteState serverStateRef addr+ case mSuiteState of+ Nothing -> error "No test suite state!"+ Just suiteState -> do+ mState <- liftIO $ getTopicState suiteState t+ case mState of+ NoTopic -> error "No topic"+ HasTopic state -> case m of+ Failure -> do liftIO $ dumpTopic serverStateRef addr t- error $ "Bad got serialize: " ++ show t ++ ", " ++ show mOk- Failure t y -> do- liftIO $ dumpTopic serverStateRef addr t- error $ "Failure: " ++ show t ++ ", " ++ show y -- TODO compile report+ error $ "Failure: " ++ show t ++ ", " ++ show y -- TODO compile report+ GeneratedInput -> do+ liftIO $ atomically $ writeTVar (clientGReceived state) (Just incoming)+ mOk <- liftIO $ gotClientGenValue state y+ if isOkay mOk+ then do+ mOutgoing <- liftIO $ serializeValueClientOrigin state t+ case mOutgoing of+ HasClientG outgoing -> do+ o' <- send addr server outgoing+ liftIO $ atomically $ writeTVar (serverSSent state) (Just o')+ _ -> fail' serverStateRef server "Bad serialize: " addr t mOutgoing+ else fail' serverStateRef server "Bad got gen: " addr t mOk+ DeSerialized -> do+ liftIO $ atomically $ writeTVar (clientDReceived state) (Just incoming)+ mOk <- liftIO $ gotClientDeSerialize state y+ if isOkay mOk+ then do+ mOutgoing <- liftIO $ generateValue state t+ case mOutgoing of+ GenValue outgoing -> do+ o' <- send addr server outgoing+ liftIO $ atomically $ writeTVar (serverGSent state) (Just o')+ DoneGenerating -> pure ()+ -- FIXME should never occur - client dictates+ -- number of quickchecks+ else fail' serverStateRef server "Bad got deserialize: " addr t mOk+ Serialized -> do+ liftIO $ atomically $ writeTVar (clientSReceived state) (Just incoming)+ mOk <- liftIO $ gotClientSerialize state y+ if isOkay mOk+ then do+ mOutgoing <- liftIO $ deserializeValueClientOrigin state t+ case mOutgoing of+ HasClientS (DesValue outgoing) -> do+ o' <- send addr server outgoing+ liftIO $ atomically $ writeTVar (serverDSent state) (Just o')+ -- verify+ mOk' <- liftIO $ verify state+ if isOkay mOk'+ then () <$ send addr server (Continue t)+ else fail' serverStateRef server "Bad verify: " addr t mOk'+ _ -> fail' serverStateRef server "Bad deserialize value: " addr t mOutgoing+ else fail' serverStateRef server "Bad got serialize: " addr t mOk @@ -204,11 +191,28 @@ pure ks -send :: Z.ZMQIdent -> Z.Socket z Router Dealer Z.Bound -> ServerToClient -> ZMQ z ()-send addr server x = Z.sendJson addr server x+fail' :: Show a+ => ServerState+ -> Z.Socket z Router Dealer Z.Bound+ -> String+ -> Z.ZMQIdent+ -> TestTopic+ -> a+ -> ZMQ z ()+fail' serverStateRef server prefix addr t v = do+ liftIO $ dumpTopic serverStateRef addr t+ _ <- send addr server $ ServerToClient t Failure $ toJSON $ show v+ error $ prefix ++ show t ++ ", " ++ show v +send :: Z.ZMQIdent -> Z.Socket z Router Dealer Z.Bound -> ServerToClient -> ZMQ z ByteString+send addr server x = do+ let x' = LBS.toStrict (encode x)+ Z.send addr server (x' :| [])+ pure x' ++ dumpTopic :: ServerState -> Z.ZMQIdent -> TestTopic@@ -221,16 +225,28 @@ mState <- getTopicState suiteState t case mState of NoTopic -> error $ "No topic in test suite! " ++ show t- HasTopic (TestTopicState {serialize,clientG,serverS,clientD,serverG,clientS,serverD}) -> do+ HasTopic (TestTopicState {..}) -> do mClientG <- atomically (readTVar clientG) putStrLn $ "clientG: " ++ show (serialize <$> mClientG)+ mBS <- atomically (readTVar clientGReceived)+ putStrLn $ " - received: " ++ show mBS mServerS <- atomically (readTVar serverS) putStrLn $ "serverS: " ++ show mServerS+ mBS <- atomically (readTVar serverSSent)+ putStrLn $ " - sent: " ++ show mBS mClientD <- atomically (readTVar clientD) putStrLn $ "clientD: " ++ show (serialize <$> mClientD)+ mBS <- atomically (readTVar clientDReceived)+ putStrLn $ " - received: " ++ show mBS mServerG <- atomically (readTVar serverG) putStrLn $ "serverG: " ++ show (serialize <$> mServerG)+ mBS <- atomically (readTVar serverGSent)+ putStrLn $ " - sent: " ++ show mBS mClientS <- atomically (readTVar clientS) putStrLn $ "clientS: " ++ show mClientS+ mBS <- atomically (readTVar clientSReceived)+ putStrLn $ " - received: " ++ show mBS mServerD <- atomically (readTVar serverD) putStrLn $ "serverD: " ++ show (serialize <$> mServerD)+ mBS <- atomically (readTVar serverDSent)+ putStrLn $ " - sent: " ++ show mBS
src/Test/Serialization/Types.hs view
@@ -14,11 +14,11 @@ import Data.Text (Text) import qualified Data.Text as T+import Data.ByteString (ByteString) import Data.Set (Set) import qualified Data.Set as Set import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.UUID (UUID) import Data.Aeson (FromJSON (..), ToJSON (..), object, (.:), (.=), Value (..)) import Data.Aeson.Types (typeMismatch, Parser, parseEither)@@ -63,44 +63,45 @@ -data ChannelMsg- = GeneratedInput TestTopic Value- | Serialized TestTopic Value- | DeSerialized TestTopic Value- | Failure TestTopic Value+data MsgType+ = GeneratedInput+ | Serialized+ | DeSerialized+ | Failure deriving (Eq, Show, Generic) -instance Arbitrary ChannelMsg where+instance Arbitrary MsgType where arbitrary = oneof- [ GeneratedInput <$> arbitrary <*> arbitrary -- Json- , Serialized <$> arbitrary <*> arbitrary -- Json- , DeSerialized <$> arbitrary <*> arbitrary -- Json- , Failure <$> arbitrary <*> arbitrary -- Json+ [ pure GeneratedInput+ , pure Serialized+ , pure DeSerialized+ , pure Failure ]- -- where- -- arbitraryJson = pure (String "foo") -instance ToJSON ChannelMsg where- toJSON x = case x of- GeneratedInput t y -> object ["topic" .= t, "generated" .= y]- Serialized t y -> object ["topic" .= t, "serialized" .= y]- DeSerialized t y -> object ["topic" .= t, "deserialized" .= y]- Failure t y -> object ["topic" .= t, "failure" .= y]+instance ToJSON MsgType where+ toJSON x = String $ case x of+ GeneratedInput -> "generated"+ Serialized -> "serialized"+ DeSerialized -> "deserialized"+ Failure -> "failure" -instance FromJSON ChannelMsg where+instance FromJSON MsgType where parseJSON x = case x of- Object o -> do- let gen = GeneratedInput <$> o .: "topic" <*> o .: "generated"- ser = Serialized <$> o .: "topic" <*> o .: "serialized"- des = DeSerialized <$> o .: "topic" <*> o .: "deserialized"- fai = Failure <$> o .: "topic" <*> o .: "failure"- gen <|> ser <|> des <|> fai- _ -> typeMismatch "ChannelMsg" x+ String s+ | s == "generated" -> pure GeneratedInput+ | s == "serialized" -> pure Serialized+ | s == "deserialized" -> pure DeSerialized+ | s == "failure" -> pure Failure+ | otherwise -> fail'+ _ -> fail'+ where+ fail' = typeMismatch "MsgType" x + data ClientToServer = GetTopics- | ClientToServer ChannelMsg+ | ClientToServer TestTopic MsgType Value | ClientToServerBadParse Text | Finished TestTopic deriving (Eq, Show, Generic)@@ -108,7 +109,7 @@ instance Arbitrary ClientToServer where arbitrary = oneof [ pure GetTopics- , ClientToServer <$> arbitrary+ , ClientToServer <$> arbitrary <*> arbitrary <*> arbitrary , ClientToServerBadParse <$> arbitraryNonEmptyText , Finished <$> arbitrary ]@@ -118,14 +119,14 @@ instance ToJSON ClientToServer where toJSON x = case x of GetTopics -> String "getTopics"- ClientToServer y -> object ["channelMsg" .= y]+ ClientToServer t m y -> object ["topic" .= t, "msgType" .= m, "value" .= y] ClientToServerBadParse y -> object ["badParse" .= y] Finished y -> object ["finished" .= y] instance FromJSON ClientToServer where parseJSON json = case json of Object o -> do- let chn = ClientToServer <$> o .: "channelMsg"+ let chn = ClientToServer <$> o .: "topic" <*> o .: "msgType" <*> o .: "value" bd = ClientToServerBadParse <$> o .: "badParse" fin = Finished <$> o .: "finished" chn <|> bd <|> fin@@ -139,7 +140,7 @@ data ServerToClient = TopicsAvailable (Set TestTopic)- | ServerToClient ChannelMsg+ | ServerToClient TestTopic MsgType Value | ServerToClientBadParse Text | Continue TestTopic deriving (Eq, Show, Generic)@@ -147,7 +148,7 @@ instance Arbitrary ServerToClient where arbitrary = oneof [ TopicsAvailable <$> arbitrary- , ServerToClient <$> arbitrary+ , ServerToClient <$> arbitrary <*> arbitrary <*> arbitrary , ServerToClientBadParse <$> arbitraryNonEmptyText , Continue <$> arbitrary ]@@ -157,8 +158,8 @@ instance ToJSON ServerToClient where toJSON x = case x of TopicsAvailable xs -> object ["topics" .= Set.toList xs]- ServerToClient y -> object ["channelMsg" .= y]- ServerToClientBadParse x -> object ["badParse" .= x]+ ServerToClient t m y -> object ["topic" .= t, "msgType" .= m, "value" .= y]+ ServerToClientBadParse y -> object ["badParse" .= y] Continue y -> object ["continue" .= y] instance FromJSON ServerToClient where@@ -166,7 +167,7 @@ Object o -> do let available = TopicsAvailable . Set.fromList <$> o .: "topics" badParse = ServerToClientBadParse <$> o .: "badParse"- channel = ServerToClient <$> o .: "channelMsg"+ channel = ServerToClient <$> o .: "topic" <*> o .: "msgType" <*> o .: "value" continue = Continue <$> o .: "continue" available <|> badParse <|> channel <|> continue _ -> fail'@@ -187,11 +188,17 @@ , deserialize :: Value -> Parser a , size :: TVar Int , serverG :: TVar (Maybe a)+ , serverGSent :: TVar (Maybe ByteString) , clientS :: TVar (Maybe Value)+ , clientSReceived :: TVar (Maybe ByteString) , serverD :: TVar (Maybe a)+ , serverDSent :: TVar (Maybe ByteString) , clientG :: TVar (Maybe a)+ , clientGReceived :: TVar (Maybe ByteString) , serverS :: TVar (Maybe Value)+ , serverSSent :: TVar (Maybe ByteString) , clientD :: TVar (Maybe a)+ , clientDReceived :: TVar (Maybe ByteString) } emptyTestTopicState :: forall a@@ -203,19 +210,31 @@ emptyTestTopicState Proxy = do size <- newTVar 1 (serverG :: TVar (Maybe a)) <- newTVar Nothing+ serverGSent <- newTVar Nothing clientS <- newTVar Nothing+ clientSReceived <- newTVar Nothing (serverD :: TVar (Maybe a)) <- newTVar Nothing+ serverDSent <- newTVar Nothing (clientG :: TVar (Maybe a)) <- newTVar Nothing+ clientGReceived <- newTVar Nothing serverS <- newTVar Nothing+ serverSSent <- newTVar Nothing (clientD :: TVar (Maybe a)) <- newTVar Nothing+ clientDReceived <- newTVar Nothing pure TestTopicState { size , serverG+ , serverGSent , clientS+ , clientSReceived , serverD+ , serverDSent , clientG+ , clientGReceived , serverS+ , serverSSent , clientD+ , clientDReceived , generate = arbitrary , serialize = toJSON , deserialize = parseJSON@@ -417,166 +436,142 @@ Just x -> pure (HasTopic x) -generateValue :: TestSuiteState+generateValue :: TestTopicState -> TestTopic- -> IO (HasTopic (GenValue ChannelMsg))-generateValue xsRef topic = do- mState <- getTopicState xsRef topic- case mState of- NoTopic -> pure NoTopic- HasTopic (TestTopicState{size,generate,serialize,serverG}) -> fmap HasTopic $ do- s <- atomically (readTVar size)- if s >= 100- then pure DoneGenerating- else do- g <- newQCGen- let val = unGen generate g s- atomically $ do- modifyTVar size (+ 1)- writeTVar serverG $ Just val- pure $ GenValue $ GeneratedInput topic $ serialize val+ -> IO (GenValue ServerToClient)+generateValue TestTopicState{size,generate,serialize,serverG} topic = do+ s <- atomically (readTVar size)+ if s >= 100+ then pure DoneGenerating+ else do+ g <- newQCGen+ let val = unGen generate g s+ atomically $ do+ modifyTVar size (+ 1)+ writeTVar serverG $ Just val+ pure $ GenValue $ ServerToClient topic GeneratedInput $ serialize val -gotClientGenValue :: TestSuiteState- -> TestTopic+gotClientGenValue :: TestTopicState -> Value- -> IO (HasTopic (DesValue ()))-gotClientGenValue xsRef topic value = do- mState <- getTopicState xsRef topic- case mState of- NoTopic -> pure NoTopic- HasTopic (TestTopicState{deserialize,clientG}) -> fmap HasTopic $ do- case parseEither deserialize value of- Left e -> pure (CantDes e)- Right y -> do- atomically $ writeTVar clientG $ Just y- pure (DesValue ())+ -> IO (DesValue ())+gotClientGenValue TestTopicState{deserialize,clientG} value = do+ case parseEither deserialize value of+ Left e -> pure (CantDes e)+ Right y -> do+ atomically $ writeTVar clientG $ Just y+ pure (DesValue ()) -serializeValueClientOrigin :: TestSuiteState+serializeValueClientOrigin :: TestTopicState -> TestTopic- -> IO (HasTopic (HasClientG ChannelMsg))-serializeValueClientOrigin xsRef topic = do- mState <- getTopicState xsRef topic- case mState of- NoTopic -> pure NoTopic- HasTopic (TestTopicState{serialize,clientG,serverS}) -> fmap HasTopic $ do- mX <- atomically (readTVar clientG)- case mX of- Nothing -> pure NoClientG- Just x -> fmap HasClientG $ do- let val = serialize x- atomically $ writeTVar serverS $ Just val- pure $ Serialized topic val+ -> IO (HasClientG ServerToClient)+serializeValueClientOrigin TestTopicState{serialize,clientG,serverS} topic = do+ mX <- atomically (readTVar clientG)+ case mX of+ Nothing -> pure NoClientG+ Just x -> fmap HasClientG $ do+ let val = serialize x+ atomically $ writeTVar serverS $ Just val+ pure $ ServerToClient topic Serialized val -gotClientSerialize :: TestSuiteState- -> TestTopic+gotClientSerialize :: TestTopicState -> Value- -> IO (HasTopic ())-gotClientSerialize xsRef topic value = do- mState <- getTopicState xsRef topic- case mState of- NoTopic -> pure NoTopic- HasTopic (TestTopicState{deserialize,clientS}) -> fmap HasTopic $ do- atomically $ writeTVar clientS $ Just value- pure ()+ -> IO ()+gotClientSerialize TestTopicState{clientS} value = do+ atomically $ writeTVar clientS $ Just value -deserializeValueClientOrigin :: TestSuiteState+deserializeValueClientOrigin :: TestTopicState -> TestTopic- -> IO (HasTopic (HasClientS (DesValue ChannelMsg)))-deserializeValueClientOrigin xsRef topic = do- mState <- getTopicState xsRef topic- case mState of- NoTopic -> pure NoTopic- HasTopic (TestTopicState{deserialize,clientS,serverD,serialize}) -> fmap HasTopic $ do- mX <- atomically (readTVar clientS)- case mX of- Nothing -> pure NoClientS- Just x -> fmap HasClientS $ case parseEither deserialize x of- Left e -> pure (CantDes e)- Right y -> do- atomically $ writeTVar serverD $ Just y- pure $ DesValue $ DeSerialized topic $ serialize y+ -> IO (HasClientS (DesValue ServerToClient))+deserializeValueClientOrigin TestTopicState{deserialize,clientS,serverD,serialize} topic = do+ mX <- atomically (readTVar clientS)+ case mX of+ Nothing -> pure NoClientS+ Just x -> fmap HasClientS $ case parseEither deserialize x of+ Left e -> pure (CantDes e)+ Right y -> do+ atomically $ writeTVar serverD $ Just y+ pure $ DesValue $ ServerToClient topic DeSerialized $ serialize y -gotClientDeSerialize :: TestSuiteState- -> TestTopic+gotClientDeSerialize :: TestTopicState -> Value- -> IO (HasTopic (DesValue ()))-gotClientDeSerialize xsRef topic value = do- mState <- getTopicState xsRef topic- case mState of- NoTopic -> pure NoTopic- HasTopic (TestTopicState{deserialize,clientD}) -> fmap HasTopic $ do- case parseEither deserialize value of- Left e -> pure (CantDes e)- Right y -> do- atomically $ writeTVar clientD $ Just y- pure (DesValue ())+ -> IO (DesValue ())+gotClientDeSerialize TestTopicState{deserialize,clientD} value = do+ case parseEither deserialize value of+ Left e -> pure (CantDes e)+ Right y -> do+ atomically $ writeTVar clientD $ Just y+ pure (DesValue ()) -verify :: TestSuiteState- -> TestTopic+verify :: TestTopicState -> IO- ( HasTopic- ( HasServerG- ( HasClientS- ( ServerSerializedMatch- ( HasServerD- ( DesValue- ( ServerDeSerializedMatch- ( HasClientG- ( HasServerS- ( ClientSerializedMatch- ( HasClientD- ( DesValue- ( ClientDeSerializedMatch ())))))))))))))-verify xsRef topic = do- mState <- getTopicState xsRef topic- case mState of- NoTopic -> pure NoTopic- HasTopic TestTopicState{..} -> fmap HasTopic $ do- mServerG <- atomically (readTVar serverG)- case mServerG of- Nothing -> pure NoServerG- Just serverG' -> fmap HasServerG $ do- mClientS <- atomically (readTVar clientS)- case mClientS of- Nothing -> pure NoClientS- Just clientS' -> fmap HasClientS $ do- if serialize serverG' /= clientS'- then pure ServerSerializedMismatch- else fmap ServerSerializedMatch $ do- mServerD <- atomically (readTVar serverD)- case mServerD of- Nothing -> pure NoServerD- Just serverD' -> fmap HasServerD $ do- case parseEither deserialize clientS' of- Left e -> pure (CantDes e)- Right serverD''- | serverD'' /= serverD' -> pure (DesValue ServerDeSerializedMismatch)- | otherwise -> fmap (DesValue . ServerDeSerializedMatch) $ do- mClientG <- atomically (readTVar clientG)- case mClientG of- Nothing -> pure NoClientG- Just clientG' -> fmap HasClientG $ do- mServerS <- atomically (readTVar serverS)- case mServerS of- Nothing -> pure NoServerS- Just serverS' -> fmap HasServerS $ do- if serialize clientG' /= serverS'- then pure ClientSerializedMismatch- else fmap ClientSerializedMatch $ do- mClientD <- atomically (readTVar clientD)- case mClientD of- Nothing -> pure NoClientD- Just clientD' -> fmap HasClientD $ do- case parseEither deserialize serverS' of- Left e -> pure (CantDes e)- Right serverS''- | serverS'' /= clientD' -> pure (DesValue ClientDeSerializedMismatch)- | otherwise -> do- fmap (DesValue . ClientDeSerializedMatch) $ pure ()+ ( HasServerG+ ( HasClientS+ ( ServerSerializedMatch+ ( HasServerD+ ( DesValue+ ( ServerDeSerializedMatch+ ( HasClientG+ ( HasServerS+ ( ClientSerializedMatch+ ( HasClientD+ ( DesValue+ ( ClientDeSerializedMatch ()))))))))))))+verify+ TestTopicState+ { serverG+ , clientS+ , serverD+ , clientG+ , serverS+ , clientD+ , deserialize+ , serialize+ } = do+ mServerG <- atomically (readTVar serverG)+ case mServerG of+ Nothing -> pure NoServerG+ Just serverG' -> fmap HasServerG $ do+ mClientS <- atomically (readTVar clientS)+ case mClientS of+ Nothing -> pure NoClientS+ Just clientS' -> fmap HasClientS $ do+ if serialize serverG' /= clientS'+ then pure ServerSerializedMismatch+ else fmap ServerSerializedMatch $ do+ mServerD <- atomically (readTVar serverD)+ case mServerD of+ Nothing -> pure NoServerD+ Just serverD' -> fmap HasServerD $ do+ case parseEither deserialize clientS' of+ Left e -> pure (CantDes e)+ Right serverD''+ | serverD'' /= serverD' -> pure (DesValue ServerDeSerializedMismatch)+ | otherwise -> fmap (DesValue . ServerDeSerializedMatch) $ do+ mClientG <- atomically (readTVar clientG)+ case mClientG of+ Nothing -> pure NoClientG+ Just clientG' -> fmap HasClientG $ do+ mServerS <- atomically (readTVar serverS)+ case mServerS of+ Nothing -> pure NoServerS+ Just serverS' -> fmap HasServerS $ do+ if serialize clientG' /= serverS'+ then pure ClientSerializedMismatch+ else fmap ClientSerializedMatch $ do+ mClientD <- atomically (readTVar clientD)+ case mClientD of+ Nothing -> pure NoClientD+ Just clientD' -> fmap HasClientD $ do+ case parseEither deserialize serverS' of+ Left e -> pure (CantDes e)+ Right serverS''+ | serverS'' /= clientD' -> pure (DesValue ClientDeSerializedMismatch)+ | otherwise -> do+ fmap (DesValue . ClientDeSerializedMatch) $ pure ()
test/Spec.hs view
@@ -6,12 +6,13 @@ import Data.Aeson.JSONEither (JSONEither) import Data.Aeson.JSONTuple (JSONTuple) import Data.Aeson.JSONDateTime (JSONDateTime)+import Data.Aeson.JSONString (JSONString) import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Test.Serialization (ServerParams (..), startServer) import Test.Serialization.Types- (TestSuiteM, registerTopic, ChannelMsg, ClientToServer, ServerToClient)+ (TestSuiteM, registerTopic, MsgType, ClientToServer, ServerToClient, TestTopic) import Test.Tasty (defaultMain, testGroup) import qualified Test.Tasty.QuickCheck as QC import Test.QuickCheck.Property (succeeded, failed, Result)@@ -28,11 +29,11 @@ main = do putStrLn "Starting tests..." -- defaultMain $ testGroup "Self-check"- -- [ QC.testProperty "ChannelMsg" $ \x ->+ -- [ QC.testProperty "MsgType" $ \x -> -- let go = unsafePerformIO $ do -- print x -- pure id- -- in go (jsonIso (x :: ChannelMsg))+ -- in go (jsonIso (x :: MsgType)) -- ] startServer ServerParams@@ -43,7 +44,8 @@ tests :: TestSuiteM () tests = do- registerTopic "ChannelMsg" (Proxy :: Proxy ChannelMsg)+ registerTopic "TestTopic" (Proxy :: Proxy TestTopic)+ registerTopic "MsgType" (Proxy :: Proxy MsgType) registerTopic "ClientToServer" (Proxy :: Proxy ClientToServer) registerTopic "ServerToClient" (Proxy :: Proxy ServerToClient) registerTopic "JSONUnit" (Proxy :: Proxy JSONUnit)@@ -51,6 +53,7 @@ registerTopic "JSONTuple" (Proxy :: Proxy (JSONTuple JSONUnit JSONUnit)) registerTopic "JSONDate" (Proxy :: Proxy Day) registerTopic "JSONDateTime" (Proxy :: Proxy JSONDateTime)+ registerTopic "JSONString" (Proxy :: Proxy JSONString) jsonIso :: ToJSON a => FromJSON a => Eq a => a -> Result