purescript-iso 0.0.0 → 0.0.1
raw patch · 4 files changed
+854/−3 lines, 4 filesdep +asyncdep +attoparsec-uridep +bytestring
Dependencies added: async, attoparsec-uri, bytestring, containers, monad-control, mtl, quickcheck-instances, stm, strict, tasty, tasty-quickcheck, text, utf8-string, uuid, zeromq4-haskell, zeromq4-simple
Files
- purescript-iso.cabal +34/−2
- src/Test/Serialization.hs +191/−0
- src/Test/Serialization/Types.hs +581/−0
- test/Spec.hs +48/−1
purescript-iso.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: de96d00ba8e2fb7e53006e20f819121ac9341d70202233d317ccb59507c7e678+-- hash: 1c3c7db1aa94a3c286e9946bac4503e9f068bdf34c36297048f55d20d4488526 name: purescript-iso-version: 0.0.0+version: 0.0.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@@ -30,6 +30,8 @@ Data.Aeson.JSONEither Data.Aeson.JSONTuple Data.Aeson.JSONUnit+ Test.Serialization+ Test.Serialization.Types other-modules: Paths_purescript_iso hs-source-dirs:@@ -37,7 +39,21 @@ build-depends: QuickCheck , aeson+ , async+ , attoparsec-uri >=0.0.5.1 && <0.0.6 , base >=4.7 && <5+ , bytestring+ , containers+ , monad-control+ , mtl+ , quickcheck-instances+ , stm+ , strict+ , text+ , utf8-string+ , uuid+ , zeromq4-haskell+ , zeromq4-simple default-language: Haskell2010 test-suite purescript-iso-test@@ -51,6 +67,22 @@ build-depends: QuickCheck , aeson+ , async+ , attoparsec-uri >=0.0.5.1 && <0.0.6 , base >=4.7 && <5+ , bytestring+ , containers+ , monad-control+ , mtl , purescript-iso+ , quickcheck-instances+ , stm+ , strict+ , tasty+ , tasty-quickcheck+ , text+ , utf8-string+ , uuid+ , zeromq4-haskell+ , zeromq4-simple default-language: Haskell2010
+ src/Test/Serialization.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE+ OverloadedStrings+ , OverloadedLists+ , RecordWildCards+ , ScopedTypeVariables+ , DataKinds+ #-}++module Test.Serialization where++import Test.Serialization.Types+ ( TestSuiteM, ChannelMsg (..), ServerToClient (..), TestTopic+ , ClientToServer (..), TestSuiteState, emptyTestSuiteState+ , gotClientGenValue, serializeValueClientOrigin+ , gotClientSerialize, gotClientDeSerialize+ , deserializeValueClientOrigin, verify, generateValue+ , HasTopic (..), DesValue (..), HasClientG (..), GenValue (..)+ , HasClientS (..), isOkay)++import Data.URI (URI (..), printURI)+import Data.URI.Auth (URIAuth)+import Data.UUID (UUID)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.UTF8 as BS8+import qualified Data.Strict.Maybe as Strict+import Data.List.NonEmpty (NonEmpty (..))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Aeson (eitherDecode, encode)+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)+import System.ZMQ4.Monadic+ (ZMQ, runZMQ, Router (..), Dealer (..))+import qualified System.ZMQ4.Simple as Z+import System.Exit (exitSuccess)+++data ServerParams = ServerParams+ { serverParamsControlHost :: URIAuth+ , serverParamsTestSuite :: TestSuiteM ()+ }+++type TopicsPending = TVar (Set TestTopic)++-- TODO client threads?+type ServerState = TVar (Map Z.ZMQIdent (TestSuiteState, TopicsPending))++emptyServerState :: STM ServerState+emptyServerState = newTVar Map.empty++++startServer :: ServerParams -> IO ()+startServer ServerParams{..} = do+ runZMQ $ do+ server <- Z.socket Router Dealer+ Z.bind server $ T.unpack $ printURI $+ URI (Strict.Just "tcp") True serverParamsControlHost Strict.Nothing [] Strict.Nothing++ serverStateRef <- liftIO (atomically emptyServerState)++ liftIO $ do+ suiteState <- atomically emptyTestSuiteState+ runReaderT serverParamsTestSuite suiteState+ ts <- Map.keysSet <$> atomically (readTVar suiteState)+ when (ts == Set.empty) exitSuccess+ ++ forever $ do+ mIncoming <- Z.receive server+ case mIncoming of+ Nothing -> liftIO $ putStrLn $ "No incoming message?"+ Just (addr :: Z.ZMQIdent, incoming :| _) -> case eitherDecode (LBS.fromStrict incoming) of+ Left e -> do+ let err = LBS.toStrict $ encode $ ServerToClientBadParse $ T.decodeUtf8 incoming+ Z.send addr server (err :| [])+ error $ "Couldn't parse, sending `BadParse`: " ++ BS8.toString incoming ++ ", json error: " ++ e ++ ", original: " ++ BS8.toString incoming+ Right (x :: ClientToServer) -> case x of+ GetTopics -> do+ ts <- liftIO $ registerClient serverParamsTestSuite serverStateRef addr+ send addr server (TopicsAvailable ts)+ ClientToServerBadParse e -> error $ T.unpack e+ Finished t -> do+ liftIO $ putStrLn $ "success: " ++ show t -- FIXME compile report?+ mX <- liftIO $ atomically $ Map.lookup addr <$> readTVar serverStateRef+ case mX of+ Nothing -> error $ "Received `Finished` from nonexistent topic? " ++ show t+ Just (_, pendingTopicsRef) -> do+ ts <- liftIO $ atomically $ readTVar pendingTopicsRef+ 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)+ _ -> error $ show mOutgoing+ else error $ 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+ _ -> error $ show mOutgoing+ else error $ 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 error $ show mOk'+ _ -> error $ show mOutgoing+ else error $ show mOk+ Failure t y -> error $ "Failure: " ++ show t ++ ", " ++ show y -- TODO compile report+++++getTestSuiteState :: ServerState -> Z.ZMQIdent -> STM (Maybe TestSuiteState)+getTestSuiteState serverState clientKey =+ fmap fst . Map.lookup clientKey <$> readTVar serverState+++registerClient :: TestSuiteM ()+ -> ServerState+ -> Z.ZMQIdent+ -> IO (Set TestTopic)+registerClient tests serverState clientKey = do+ ss <- atomically $ readTVar serverState+ case Map.lookup clientKey ss of+ Just _ -> error "Client key already taken"+ Nothing -> do+ suiteState <- atomically emptyTestSuiteState+ runReaderT tests suiteState+ ks <- Map.keysSet <$> atomically (readTVar suiteState)+ y <- atomically $ newTVar ks+ atomically $ modifyTVar serverState (Map.insert clientKey (suiteState,y))+ pure ks+++send :: Z.ZMQIdent -> Z.Socket z Router Dealer Z.Bound -> ServerToClient -> ZMQ z ()+send addr server x = Z.sendJson addr server x
+ src/Test/Serialization/Types.hs view
@@ -0,0 +1,581 @@+{-# LANGUAGE+ DeriveGeneric+ , OverloadedStrings+ , GADTs+ , RankNTypes+ , ScopedTypeVariables+ , NamedFieldPuns+ , RecordWildCards+ , ExistentialQuantification+ , GeneralizedNewtypeDeriving+ #-}++module Test.Serialization.Types where++import Data.Text (Text)+import qualified Data.Text as T+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)+import Data.Proxy (Proxy (..))+import Data.String (IsString)+import Control.Applicative ((<|>))+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)+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Gen (Gen, unGen, oneof, listOf1, elements, scale)+import Test.QuickCheck.Random (newQCGen)+import Test.QuickCheck.Instances ()+import GHC.Generics (Generic)+++newtype TestTopic = TestTopic Text+ deriving (IsString, Eq, Ord, Generic, Show, ToJSON, FromJSON)++instance Arbitrary TestTopic where+ arbitrary = TestTopic . T.pack <$> listOf1 (elements ['a' .. 'z'])+++instance Arbitrary Value where+ arbitrary =+ oneof+ [ termNull+ , termNumber+ , termBool+ , termString+ , scale (`div` 2) (Array <$> arbitrary)+ , scale (`div` 2) (Object <$> arbitrary)+ ]+ where+ termNull = pure Null+ termNumber = Number <$> arbitrary+ termBool = Bool <$> arbitrary+ termString = String <$> arbitraryNonEmptyText+ arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z'])++++data ChannelMsg+ = GeneratedInput TestTopic Value+ | Serialized TestTopic Value+ | DeSerialized TestTopic Value+ | Failure TestTopic Value+ deriving (Eq, Show, Generic)++instance Arbitrary ChannelMsg where+ arbitrary = oneof+ [ GeneratedInput <$> arbitrary <*> arbitrary -- Json+ , Serialized <$> arbitrary <*> arbitrary -- Json+ , DeSerialized <$> arbitrary <*> arbitrary -- Json+ , Failure <$> arbitrary <*> arbitrary -- Json+ ]+ -- 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 FromJSON ChannelMsg 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+++data ClientToServer+ = GetTopics+ | ClientToServer ChannelMsg+ | ClientToServerBadParse Text+ | Finished TestTopic+ deriving (Eq, Show, Generic)++instance Arbitrary ClientToServer where+ arbitrary = oneof+ [ pure GetTopics+ , ClientToServer <$> arbitrary+ , ClientToServerBadParse <$> arbitraryNonEmptyText+ , Finished <$> arbitrary+ ]+ where+ arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z'])++instance ToJSON ClientToServer where+ toJSON x = case x of+ GetTopics -> String "getTopics"+ ClientToServer y -> object ["channelMsg" .= 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"+ bd = ClientToServerBadParse <$> o .: "badParse"+ fin = Finished <$> o .: "finished"+ chn <|> bd <|> fin+ String s+ | s == "getTopics" -> pure GetTopics+ | otherwise -> fail'+ _ -> fail'+ where+ fail' = typeMismatch "ClientToServer" json+++data ServerToClient+ = TopicsAvailable (Set TestTopic)+ | ServerToClient ChannelMsg+ | ServerToClientBadParse Text+ | Continue TestTopic+ deriving (Eq, Show, Generic)++instance Arbitrary ServerToClient where+ arbitrary = oneof+ [ TopicsAvailable <$> arbitrary+ , ServerToClient <$> arbitrary+ , ServerToClientBadParse <$> arbitraryNonEmptyText+ , Continue <$> arbitrary+ ]+ where+ arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z'])++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]+ Continue y -> object ["continue" .= y]++instance FromJSON ServerToClient where+ parseJSON x = case x of+ Object o -> do+ let available = TopicsAvailable . Set.fromList <$> o .: "topics"+ badParse = ServerToClientBadParse <$> o .: "badParse"+ channel = ServerToClient <$> o .: "channelMsg"+ continue = Continue <$> o .: "continue"+ available <|> badParse <|> channel <|> continue+ _ -> fail'+ where+ fail' = typeMismatch "ServerToClientControl" x++++data TestTopicState =+ forall a+ . ( Arbitrary a+ , ToJSON a+ , FromJSON a+ , Eq a+ ) => TestTopicState+ { generate :: Gen a+ , 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+ }++emptyTestTopicState :: forall a+ . ( Arbitrary a+ , ToJSON a+ , FromJSON a+ , Eq a+ ) => 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+ pure TestTopicState+ { size+ , serverG+ , clientS+ , serverD+ , clientG+ , serverS+ , clientD+ , generate = arbitrary+ , serialize = toJSON+ , deserialize = parseJSON+ }+++type TestSuiteState = TVar (Map TestTopic TestTopicState)++emptyTestSuiteState :: STM TestSuiteState+emptyTestSuiteState = newTVar Map.empty+++type TestSuiteM a = ReaderT TestSuiteState IO a+++registerTopic :: forall a+ . ( Arbitrary a+ , ToJSON a+ , FromJSON a+ , Eq a+ ) => TestTopic+ -> Proxy a+ -> TestSuiteM ()+registerTopic topic p = do+ xsRef <- ask+ liftIO $ atomically $ do+ state <- emptyTestTopicState p+ modifyTVar xsRef (Map.insert topic state)++++class IsOkay a where+ isOkay :: a -> Bool++instance IsOkay () where+ isOkay () = True++data HasTopic a+ = HasTopic a+ | NoTopic+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (HasTopic a) where+ isOkay x = case x of+ NoTopic -> False+ HasTopic y -> isOkay y+++data GenValue a+ = DoneGenerating+ | GenValue a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (GenValue a) where+ isOkay x = case x of+ DoneGenerating -> False+ GenValue y -> isOkay y+++data GotClientGenValue a+ = NoClientGenValue+ | GotClientGenValue a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (GotClientGenValue a) where+ isOkay x = case x of+ NoClientGenValue -> False+ GotClientGenValue y -> isOkay y+++data HasClientG a+ = NoClientG+ | HasClientG a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (HasClientG a) where+ isOkay x = case x of+ NoClientG -> False+ HasClientG y -> isOkay y+++data HasServerG a+ = NoServerG+ | HasServerG a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (HasServerG a) where+ isOkay x = case x of+ NoServerG -> False+ HasServerG y -> isOkay y+++data HasServerS a+ = NoServerS+ | HasServerS a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (HasServerS a) where+ isOkay x = case x of+ NoServerS -> False+ HasServerS y -> isOkay y+++data HasServerD a+ = NoServerD+ | HasServerD a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (HasServerD a) where+ isOkay x = case x of+ NoServerD -> False+ HasServerD y -> isOkay y+++data HasClientD a+ = NoClientD+ | HasClientD a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (HasClientD a) where+ isOkay x = case x of+ NoClientD -> False+ HasClientD y -> isOkay y+++data DesValue a+ = CantDes String+ | DesValue a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (DesValue a) where+ isOkay x = case x of+ CantDes _ -> False+ DesValue y -> isOkay y+++data HasClientS a+ = NoClientS+ | HasClientS a+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (HasClientS a) where+ isOkay x = case x of+ NoClientS -> False+ HasClientS y -> isOkay y+++data ServerSerializedMatch a+ = ServerSerializedMatch a+ | ServerSerializedMismatch+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (ServerSerializedMatch a) where+ isOkay x = case x of+ ServerSerializedMismatch -> False+ ServerSerializedMatch y -> isOkay y+++data ServerDeSerializedMatch a+ = ServerDeSerializedMatch a+ | ServerDeSerializedMismatch+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (ServerDeSerializedMatch a) where+ isOkay x = case x of+ ServerDeSerializedMismatch -> False+ ServerDeSerializedMatch y -> isOkay y+++data ClientSerializedMatch a+ = ClientSerializedMatch a+ | ClientSerializedMismatch+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (ClientSerializedMatch a) where+ isOkay x = case x of+ ClientSerializedMismatch -> False+ ClientSerializedMatch y -> isOkay y+++data ClientDeSerializedMatch a+ = ClientDeSerializedMatch a+ | ClientDeSerializedMismatch+ deriving (Eq, Show, Generic)++instance IsOkay a => IsOkay (ClientDeSerializedMatch a) where+ isOkay x = case x of+ ClientDeSerializedMismatch -> False+ ClientDeSerializedMatch y -> isOkay y+++getTopicState :: TestSuiteState+ -> TestTopic+ -> IO (HasTopic TestTopicState)+getTopicState xsRef topic = do+ xs <- atomically (readTVar xsRef)+ case Map.lookup topic xs of+ Nothing -> pure NoTopic+ Just x -> pure (HasTopic x)+++generateValue :: TestSuiteState+ -> 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)+ putTMVar serverG val+ pure $ GenValue $ GeneratedInput topic $ serialize val+++gotClientGenValue :: TestSuiteState+ -> TestTopic+ -> 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 (putTMVar clientG y)+ pure (DesValue ())+++serializeValueClientOrigin :: TestSuiteState+ -> 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 (tryReadTMVar clientG)+ case mX of+ Nothing -> pure NoClientG+ Just x -> fmap HasClientG $ do+ let val = serialize x+ atomically $ putTMVar serverS val+ pure $ Serialized topic val+++gotClientSerialize :: TestSuiteState+ -> TestTopic+ -> 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 (putTMVar clientS value)+ pure ()+++deserializeValueClientOrigin :: TestSuiteState+ -> 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 (tryReadTMVar 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)+ pure $ DesValue $ DeSerialized topic $ serialize y+++gotClientDeSerialize :: TestSuiteState+ -> TestTopic+ -> 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 (putTMVar clientD y)+ pure (DesValue ())+++verify :: TestSuiteState+ -> TestTopic+ -> 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 (tryTakeTMVar serverG)+ case mServerG of+ Nothing -> pure NoServerG+ Just serverG' -> fmap HasServerG $ do+ mClientS <- atomically (tryTakeTMVar 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)+ 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 (tryTakeTMVar clientG)+ case mClientG of+ Nothing -> pure NoClientG+ Just clientG' -> fmap HasClientG $ do+ mServerS <- atomically (tryTakeTMVar 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)+ 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 -> fmap (DesValue . ClientDeSerializedMatch) $ pure ()+
test/Spec.hs view
@@ -1,2 +1,49 @@+{-# LANGUAGE+ OverloadedStrings+ #-}++import Test.Serialization (ServerParams (..), startServer)+import Test.Serialization.Types+ (TestSuiteM, registerTopic, ChannelMsg, ClientToServer, ServerToClient)+import Test.Tasty (defaultMain, testGroup)+import qualified Test.Tasty.QuickCheck as QC+import Test.QuickCheck.Property (succeeded, failed, Result)++import Data.Aeson (ToJSON, FromJSON, encode, decode)+import Data.Proxy (Proxy (..))+import qualified Data.Strict.Maybe as Strict+import Data.URI.Auth (URIAuth (..))+import Data.URI.Auth.Host (URIAuthHost (Glob))+import System.IO.Unsafe (unsafePerformIO)++ main :: IO ()-main = putStrLn "Test suite not yet implemented"+main = do+ putStrLn "Starting tests..."+ -- defaultMain $ testGroup "Self-check"+ -- [ QC.testProperty "ChannelMsg" $ \x ->+ -- let go = unsafePerformIO $ do+ -- print x+ -- pure id+ -- in go (jsonIso (x :: ChannelMsg))+ -- ]+ startServer+ ServerParams+ { serverParamsControlHost = URIAuth Strict.Nothing Glob (Strict.Just 5561)+ , serverParamsTestSuite = tests+ }+++tests :: TestSuiteM ()+tests = do+ registerTopic "ChannelMsg" (Proxy :: Proxy ChannelMsg)+ registerTopic "ClientToServer" (Proxy :: Proxy ClientToServer)+ registerTopic "ServerToClient" (Proxy :: Proxy ServerToClient)+++jsonIso :: ToJSON a => FromJSON a => Eq a => a -> Result+jsonIso x = case decode (encode x) of+ Nothing -> failed+ Just y+ | y == x -> succeeded+ | otherwise -> failed