diff --git a/purescript-iso.cabal b/purescript-iso.cabal --- a/purescript-iso.cabal +++ b/purescript-iso.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 1c3c7db1aa94a3c286e9946bac4503e9f068bdf34c36297048f55d20d4488526 +-- hash: c6397c41d058e0b7c2155fd2e147eb98d3f4dd5c7b0782c38520d8c5f2ac8f78 name: purescript-iso -version: 0.0.1 +version: 0.0.1.1 synopsis: Isomorphic trivial data type definitions over JSON description: Please see the README on GitHub at category: Web @@ -81,6 +81,7 @@ , tasty , tasty-quickcheck , text + , time , utf8-string , uuid , zeromq4-haskell diff --git a/src/Data/Aeson/JSONUnit.hs b/src/Data/Aeson/JSONUnit.hs --- a/src/Data/Aeson/JSONUnit.hs +++ b/src/Data/Aeson/JSONUnit.hs @@ -6,10 +6,14 @@ import Data.Aeson (ToJSON (..), FromJSON (..), Value (String)) import Data.Aeson.Types (typeMismatch) +import Test.QuickCheck (Arbitrary (..)) data JSONUnit = JSONUnit deriving (Eq, Show) + +instance Arbitrary JSONUnit where + arbitrary = pure JSONUnit instance ToJSON JSONUnit where toJSON JSONUnit = String "" diff --git a/src/Test/Serialization.hs b/src/Test/Serialization.hs --- a/src/Test/Serialization.hs +++ b/src/Test/Serialization.hs @@ -4,16 +4,17 @@ , RecordWildCards , ScopedTypeVariables , DataKinds + , NamedFieldPuns #-} module Test.Serialization where import Test.Serialization.Types ( TestSuiteM, ChannelMsg (..), ServerToClient (..), TestTopic - , ClientToServer (..), TestSuiteState, emptyTestSuiteState + , ClientToServer (..), TestSuiteState, TestTopicState (..), emptyTestSuiteState , gotClientGenValue, serializeValueClientOrigin , gotClientSerialize, gotClientDeSerialize - , deserializeValueClientOrigin, verify, generateValue + , deserializeValueClientOrigin, verify, generateValue, getTopicState , HasTopic (..), DesValue (..), HasClientG (..), GenValue (..) , HasClientS (..), isOkay) @@ -121,8 +122,12 @@ case mOutgoing of HasTopic (HasClientG outgoing) -> send addr server (ServerToClient outgoing) - _ -> error $ show mOutgoing - else error $ show mOk + _ -> 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 @@ -139,8 +144,12 @@ DoneGenerating -> pure () -- FIXME should never occur - client dictates -- number of quickchecks - _ -> error $ show mOutgoing - else error $ show mOk + _ -> 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 @@ -157,10 +166,18 @@ mOk' <- liftIO $ verify suiteState t if isOkay mOk' then send addr server (Continue t) - else error $ show mOk' - _ -> error $ show mOutgoing - else error $ show mOk - Failure t y -> error $ "Failure: " ++ show t ++ ", " ++ show y -- TODO compile report + 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 + 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 @@ -189,3 +206,31 @@ send :: Z.ZMQIdent -> Z.Socket z Router Dealer Z.Bound -> ServerToClient -> ZMQ z () send addr server x = Z.sendJson addr server x + + + +dumpTopic :: ServerState + -> Z.ZMQIdent + -> TestTopic + -> IO () +dumpTopic serverStateRef addr t = do + mSuiteState <- liftIO $ atomically $ getTestSuiteState serverStateRef addr + case mSuiteState of + Nothing -> error "No test suite state!" + Just suiteState -> do + 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 + mClientG <- atomically (readTVar clientG) + putStrLn $ "clientG: " ++ show (serialize <$> mClientG) + mServerS <- atomically (readTVar serverS) + putStrLn $ "serverS: " ++ show mServerS + mClientD <- atomically (readTVar clientD) + putStrLn $ "clientD: " ++ show (serialize <$> mClientD) + mServerG <- atomically (readTVar serverG) + putStrLn $ "serverG: " ++ show (serialize <$> mServerG) + mClientS <- atomically (readTVar clientS) + putStrLn $ "clientS: " ++ show mClientS + mServerD <- atomically (readTVar serverD) + putStrLn $ "serverD: " ++ show (serialize <$> mServerD) diff --git a/src/Test/Serialization/Types.hs b/src/Test/Serialization/Types.hs --- a/src/Test/Serialization/Types.hs +++ b/src/Test/Serialization/Types.hs @@ -28,8 +28,8 @@ import Control.Monad.Reader (ReaderT, ask) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM - ( STM, TVar, TMVar, newTVar, newEmptyTMVar, atomically, modifyTVar, readTVar - , putTMVar, tryReadTMVar, tryTakeTMVar) + ( STM, TVar, newTVar, atomically, modifyTVar, readTVar + , writeTVar) import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Gen (Gen, unGen, oneof, listOf1, elements, scale) import Test.QuickCheck.Random (newQCGen) @@ -186,12 +186,12 @@ , serialize :: a -> Value , deserialize :: Value -> Parser a , size :: TVar Int - , serverG :: TMVar a - , clientS :: TMVar Value - , serverD :: TMVar a - , clientG :: TMVar a - , serverS :: TMVar Value - , clientD :: TMVar a + , serverG :: TVar (Maybe a) + , clientS :: TVar (Maybe Value) + , serverD :: TVar (Maybe a) + , clientG :: TVar (Maybe a) + , serverS :: TVar (Maybe Value) + , clientD :: TVar (Maybe a) } emptyTestTopicState :: forall a @@ -202,12 +202,12 @@ ) => Proxy a -> STM TestTopicState emptyTestTopicState Proxy = do size <- newTVar 1 - (serverG :: TMVar a) <- newEmptyTMVar - clientS <- newEmptyTMVar - (serverD :: TMVar a) <- newEmptyTMVar - (clientG :: TMVar a) <- newEmptyTMVar - serverS <- newEmptyTMVar - (clientD :: TMVar a) <- newEmptyTMVar + (serverG :: TVar (Maybe a)) <- newTVar Nothing + clientS <- newTVar Nothing + (serverD :: TVar (Maybe a)) <- newTVar Nothing + (clientG :: TVar (Maybe a)) <- newTVar Nothing + serverS <- newTVar Nothing + (clientD :: TVar (Maybe a)) <- newTVar Nothing pure TestTopicState { size , serverG @@ -433,7 +433,7 @@ let val = unGen generate g s atomically $ do modifyTVar size (+ 1) - putTMVar serverG val + writeTVar serverG $ Just val pure $ GenValue $ GeneratedInput topic $ serialize val @@ -449,7 +449,7 @@ case parseEither deserialize value of Left e -> pure (CantDes e) Right y -> do - atomically (putTMVar clientG y) + atomically $ writeTVar clientG $ Just y pure (DesValue ()) @@ -461,12 +461,12 @@ case mState of NoTopic -> pure NoTopic HasTopic (TestTopicState{serialize,clientG,serverS}) -> fmap HasTopic $ do - mX <- atomically (tryReadTMVar clientG) + mX <- atomically (readTVar clientG) case mX of Nothing -> pure NoClientG Just x -> fmap HasClientG $ do let val = serialize x - atomically $ putTMVar serverS val + atomically $ writeTVar serverS $ Just val pure $ Serialized topic val @@ -479,7 +479,7 @@ case mState of NoTopic -> pure NoTopic HasTopic (TestTopicState{deserialize,clientS}) -> fmap HasTopic $ do - atomically (putTMVar clientS value) + atomically $ writeTVar clientS $ Just value pure () @@ -491,13 +491,13 @@ case mState of NoTopic -> pure NoTopic HasTopic (TestTopicState{deserialize,clientS,serverD,serialize}) -> fmap HasTopic $ do - mX <- atomically (tryReadTMVar clientS) + 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 (putTMVar serverD y) + atomically $ writeTVar serverD $ Just y pure $ DesValue $ DeSerialized topic $ serialize y @@ -513,7 +513,7 @@ case parseEither deserialize value of Left e -> pure (CantDes e) Right y -> do - atomically (putTMVar clientD y) + atomically $ writeTVar clientD $ Just y pure (DesValue ()) @@ -538,18 +538,18 @@ case mState of NoTopic -> pure NoTopic HasTopic TestTopicState{..} -> fmap HasTopic $ do - mServerG <- atomically (tryTakeTMVar serverG) + mServerG <- atomically (readTVar serverG) case mServerG of Nothing -> pure NoServerG Just serverG' -> fmap HasServerG $ do - mClientS <- atomically (tryTakeTMVar clientS) + 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 (tryTakeTMVar serverD) + mServerD <- atomically (readTVar serverD) case mServerD of Nothing -> pure NoServerD Just serverD' -> fmap HasServerD $ do @@ -558,18 +558,18 @@ Right serverD'' | serverD'' /= serverD' -> pure (DesValue ServerDeSerializedMismatch) | otherwise -> fmap (DesValue . ServerDeSerializedMatch) $ do - mClientG <- atomically (tryTakeTMVar clientG) + mClientG <- atomically (readTVar clientG) case mClientG of Nothing -> pure NoClientG Just clientG' -> fmap HasClientG $ do - mServerS <- atomically (tryTakeTMVar serverS) + 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 (tryTakeTMVar clientD) + mClientD <- atomically (readTVar clientD) case mClientD of Nothing -> pure NoClientD Just clientD' -> fmap HasClientD $ do @@ -577,5 +577,6 @@ Left e -> pure (CantDes e) Right serverS'' | serverS'' /= clientD' -> pure (DesValue ClientDeSerializedMismatch) - | otherwise -> fmap (DesValue . ClientDeSerializedMatch) $ pure () + | otherwise -> do + fmap (DesValue . ClientDeSerializedMatch) $ pure () diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,6 +2,12 @@ OverloadedStrings #-} +import Data.Aeson.JSONUnit (JSONUnit) +import Data.Aeson.JSONEither (JSONEither) +import Data.Aeson.JSONTuple (JSONTuple) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) + import Test.Serialization (ServerParams (..), startServer) import Test.Serialization.Types (TestSuiteM, registerTopic, ChannelMsg, ClientToServer, ServerToClient) @@ -39,6 +45,11 @@ registerTopic "ChannelMsg" (Proxy :: Proxy ChannelMsg) registerTopic "ClientToServer" (Proxy :: Proxy ClientToServer) registerTopic "ServerToClient" (Proxy :: Proxy ServerToClient) + registerTopic "JSONUnit" (Proxy :: Proxy JSONUnit) + registerTopic "JSONEither" (Proxy :: Proxy (JSONEither JSONUnit JSONUnit)) + registerTopic "JSONTuple" (Proxy :: Proxy (JSONTuple JSONUnit JSONUnit)) + registerTopic "JSONDate" (Proxy :: Proxy Day) + -- registerTopic "JSONDateTime" (Proxy :: Proxy UTCTime) jsonIso :: ToJSON a => FromJSON a => Eq a => a -> Result