purescript-iso 0.0.1 → 0.0.1.1
raw patch · 5 files changed
+103/−41 lines, 5 filesdep +time
Dependencies added: time
Files
- purescript-iso.cabal +3/−2
- src/Data/Aeson/JSONUnit.hs +4/−0
- src/Test/Serialization.hs +55/−10
- src/Test/Serialization/Types.hs +30/−29
- test/Spec.hs +11/−0
purescript-iso.cabal view
@@ -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 <https://github.com/githubuser/purescript-iso#readme> category: Web@@ -81,6 +81,7 @@ , tasty , tasty-quickcheck , text+ , time , utf8-string , uuid , zeromq4-haskell
src/Data/Aeson/JSONUnit.hs view
@@ -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 ""
src/Test/Serialization.hs view
@@ -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)
src/Test/Serialization/Types.hs view
@@ -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 ()
test/Spec.hs view
@@ -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