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: 288de828bb3fd2e14f409f4bd84bc2117c0794f83f469214bc6c0108da1ff70f +-- hash: fcbf6153f422f16a84a384b5bcc7532b82e4cca20717465e0b064bc795a44b67 name: purescript-iso -version: 0.0.1.4 +version: 0.0.1.5 synopsis: Isomorphic trivial data type definitions over JSON description: Please see the README on GitHub at category: Web @@ -30,6 +30,9 @@ Data.Aeson.JSONDateTime Data.Aeson.JSONEither Data.Aeson.JSONEmailAddress + Data.Aeson.JSONInt + Data.Aeson.JSONInteger + Data.Aeson.JSONScientific Data.Aeson.JSONString Data.Aeson.JSONTuple Data.Aeson.JSONUnit @@ -43,7 +46,9 @@ build-depends: QuickCheck , aeson + , aeson-attoparsec , async + , attoparsec , attoparsec-uri >=0.0.5.1 && <0.0.6 , base >=4.7 && <5 , bytestring @@ -52,6 +57,7 @@ , monad-control , mtl , quickcheck-instances + , scientific , stm , strict , text @@ -73,7 +79,9 @@ build-depends: QuickCheck , aeson + , aeson-attoparsec , async + , attoparsec , attoparsec-uri >=0.0.5.1 && <0.0.6 , base >=4.7 && <5 , bytestring @@ -83,6 +91,7 @@ , mtl , purescript-iso , quickcheck-instances + , scientific , stm , strict , tasty diff --git a/src/Data/Aeson/JSONEmailAddress.hs b/src/Data/Aeson/JSONEmailAddress.hs --- a/src/Data/Aeson/JSONEmailAddress.hs +++ b/src/Data/Aeson/JSONEmailAddress.hs @@ -8,10 +8,12 @@ import Text.EmailAddress (EmailAddress, emailAddressFromString) import Data.Aeson (ToJSON, FromJSON) import qualified Data.Char as Char +import Control.Monad (replicateM) import Test.QuickCheck (Arbitrary (..)) -import Test.QuickCheck.Gen (listOf1, elements, scale) +import Test.QuickCheck.Gen (elements, scale, choose) import GHC.Generics (Generic) +-- FIXME restrict to 64 x 63 chars newtype JSONEmailAddress = JSONEmailAddress { getJSONEmailAddress :: EmailAddress @@ -19,11 +21,13 @@ instance Arbitrary JSONEmailAddress where arbitrary = do - name <- arbitraryNonEmptyAscii -- listOf1 (arbitrary `suchThat` Char.isAlphaNum) - domain <- arbitraryNonEmptyAscii -- listOf1 (arbitrary `suchThat` Char.isAlphaNum) + name <- arbitraryNonEmptyAscii 64 + domain <- arbitraryNonEmptyAscii 63 let x = name ++ "@" ++ domain ++ ".com" case emailAddressFromString x of Just e -> pure (JSONEmailAddress e) Nothing -> error x where - arbitraryNonEmptyAscii = scale (`div` 2) $ listOf1 (elements ['a' .. 'z']) + arbitraryNonEmptyAscii s = do + l <- choose (1,s) + replicateM l (elements ['a' .. 'z']) diff --git a/src/Data/Aeson/JSONInt.hs b/src/Data/Aeson/JSONInt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/JSONInt.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE + DeriveGeneric + , GeneralizedNewtypeDeriving + #-} + +module Data.Aeson.JSONInt where + +import Data.Aeson (ToJSON, FromJSON) +import Data.Int (Int32) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (scale) +import System.IO.Unsafe (unsafePerformIO) + + +newtype JSONInt = JSONInt + { getJSONInt :: Int32 + } deriving (Eq, Ord, Enum, Show, Read, Generic, Num, Real, Integral, ToJSON, FromJSON, Arbitrary) diff --git a/src/Data/Aeson/JSONInteger.hs b/src/Data/Aeson/JSONInteger.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/JSONInteger.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE + DeriveGeneric + , GeneralizedNewtypeDeriving + #-} + +module Data.Aeson.JSONInteger where + +import Data.Aeson (ToJSON (..), FromJSON (..), Value (String)) +import Data.Aeson.Types (typeMismatch) +import Data.Aeson.Attoparsec (attoAeson) +import Data.Attoparsec.Text (decimal, signed) +import Data.Scientific (Scientific, coefficient, base10Exponent) +import qualified Data.Text as T +import Text.Read (readMaybe) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (scale, elements, listOf1) +import System.IO.Unsafe (unsafePerformIO) + + +newtype JSONInteger = JSONInteger + { getJSONInt :: Scientific + } deriving (Eq, Ord{-, Enum-}, Show, Read, Generic, Num, Real{-, Integral-}) + +instance ToJSON JSONInteger where + toJSON (JSONInteger x) = toJSON $ + let c = coefficient x + e = let g | c > 0 = length (show c) - 1 + | c == 0 = 0 + | otherwise = length (show c) - 2 + in base10Exponent x + g + q | c > 0 = dropZeros (show c) + | c == 0 = "0" + | otherwise = "-" ++ dropZeros (drop 1 $ show c) + c' | c > 0 = + if read q < 10 + then q + else take 1 q ++ "." ++ drop 1 q + | c == 0 = show c + | otherwise = dropZeros $ + if read q > -10 + then q + else take 2 q ++ "." ++ drop 2 q + dropZeros = reverse . dropWhile (== '0') . reverse + in c' ++ "e" ++ (if e >= 0 then "+" else "") ++ show e + +instance FromJSON JSONInteger where + parseJSON json = case json of + String s -> case readMaybe (T.unpack s) of + Just x -> pure (JSONInteger x) + _ -> fail' + _ -> fail' + where + fail' = typeMismatch "JSONInteger" json + +instance Arbitrary JSONInteger where + arbitrary = JSONInteger {-. go-} <$> {-scale (^ 10)-} arbitraryInt + where + arbitraryInt = do + s <- listOf1 (elements ['0'..'9']) + case readMaybe s of + Just x -> pure x + go x = unsafePerformIO $ do + print x + pure x diff --git a/src/Data/Aeson/JSONScientific.hs b/src/Data/Aeson/JSONScientific.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/JSONScientific.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE + DeriveGeneric + , GeneralizedNewtypeDeriving + #-} + +module Data.Aeson.JSONScientific where + +import Data.Aeson (ToJSON (..), FromJSON (..), Value (String)) +import Data.Aeson.Types (typeMismatch) +import Data.Aeson.Attoparsec (attoAeson) +import Data.Attoparsec.Text (decimal, signed) +import Data.Scientific (Scientific, coefficient, base10Exponent) +import qualified Data.Text as T +import Text.Read (readMaybe) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (scale, elements, listOf1, listOf) +import System.IO.Unsafe (unsafePerformIO) + + +newtype JSONScientific = JSONScientific + { getJSONInt :: Scientific + } deriving (Eq, Ord{-, Enum-}, Show, Read, Generic, Num, Real{-, Integral-}) + +instance ToJSON JSONScientific where + toJSON (JSONScientific x) = toJSON $ + let c = coefficient x + e = let g | c > 0 = length (show c) - 1 + | c == 0 = 0 + | otherwise = length (show c) - 2 + in base10Exponent x + g + q | c > 0 = dropZeros (show c) + | c == 0 = "0" + | otherwise = "-" ++ dropZeros (drop 1 $ show c) + c' | c > 0 = + if read q < 10 + then q + else take 1 q ++ "." ++ drop 1 q + | c == 0 = show c + | otherwise = dropZeros $ + if read q > -10 + then q + else take 2 q ++ "." ++ drop 2 q + dropZeros = reverse . dropWhile (== '0') . reverse + in c' ++ "e" ++ (if e >= 0 then "+" else "") ++ show e + +instance FromJSON JSONScientific where + parseJSON json = case json of + String s -> case readMaybe (T.unpack s) of + Just x -> pure (JSONScientific x) + _ -> fail' + _ -> fail' + where + fail' = typeMismatch "JSONScientific" json + +instance Arbitrary JSONScientific where + arbitrary = JSONScientific {-. go-} <$> {-scale (^ 10)-} arbitraryInt + where + arbitraryInt = do + s <- listOf1 (elements ['0'..'9']) + p <- listOf (elements ['0'..'9']) + case readMaybe (s ++ (if length p == 0 then "" else "." ++ p)) of + Just x -> pure x + go x = unsafePerformIO $ do + print x + pure x diff --git a/src/Test/Serialization.hs b/src/Test/Serialization.hs --- a/src/Test/Serialization.hs +++ b/src/Test/Serialization.hs @@ -49,6 +49,7 @@ data ServerParams = ServerParams { serverParamsControlHost :: URIAuth , serverParamsTestSuite :: TestSuiteM () + , serverParamsMaxSize :: Int } @@ -139,12 +140,12 @@ mOk <- liftIO $ gotClientDeSerialize state y if isOkay mOk then do - mOutgoing <- liftIO $ generateValue state t + mOutgoing <- liftIO $ generateValue state t serverParamsMaxSize case mOutgoing of GenValue outgoing -> do o' <- send addr server outgoing liftIO $ atomically $ writeTVar (serverGSent state) (Just o') - DoneGenerating -> pure () + DoneGenerating -> error "Server finished before client" -- FIXME should never occur - client dictates -- number of quickchecks else fail' serverStateRef server "Bad got deserialize: " addr t mOk @@ -161,14 +162,33 @@ -- verify mOk' <- liftIO $ verify state if isOkay mOk' - then () <$ send addr server (Continue t) + then do + liftIO $ clearState state + () <$ 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 +clearState :: TestTopicState + -> IO () +clearState TestTopicState{..} = atomically $ do + writeTVar clientG Nothing + writeTVar clientGReceived Nothing + writeTVar clientS Nothing + writeTVar clientSReceived Nothing + writeTVar clientD Nothing + writeTVar clientDReceived Nothing + writeTVar serverG Nothing + writeTVar serverGSent Nothing + writeTVar serverS Nothing + writeTVar serverSSent Nothing + writeTVar serverD Nothing + writeTVar serverDSent Nothing + + getTestSuiteState :: ServerState -> Z.ZMQIdent -> STM (Maybe TestSuiteState) getTestSuiteState serverState clientKey = fmap fst . Map.lookup clientKey <$> readTVar serverState @@ -226,6 +246,8 @@ case mState of NoTopic -> error $ "No topic in test suite! " ++ show t HasTopic (TestTopicState {..}) -> do + size' <- atomically $ readTVar size + putStrLn $ "size: " ++ show size' mClientG <- atomically (readTVar clientG) putStrLn $ "clientG: " ++ show (serialize <$> mClientG) mBS <- atomically (readTVar clientGReceived) @@ -233,7 +255,7 @@ mServerS <- atomically (readTVar serverS) putStrLn $ "serverS: " ++ show mServerS mBS <- atomically (readTVar serverSSent) - putStrLn $ " - sent: " ++ show mBS + putStrLn $ " - sent: " ++ show mBS mClientD <- atomically (readTVar clientD) putStrLn $ "clientD: " ++ show (serialize <$> mClientD) mBS <- atomically (readTVar clientDReceived) @@ -241,7 +263,7 @@ mServerG <- atomically (readTVar serverG) putStrLn $ "serverG: " ++ show (serialize <$> mServerG) mBS <- atomically (readTVar serverGSent) - putStrLn $ " - sent: " ++ show mBS + putStrLn $ " - sent: " ++ show mBS mClientS <- atomically (readTVar clientS) putStrLn $ "clientS: " ++ show mClientS mBS <- atomically (readTVar clientSReceived) @@ -249,4 +271,4 @@ mServerD <- atomically (readTVar serverD) putStrLn $ "serverD: " ++ show (serialize <$> mServerD) mBS <- atomically (readTVar serverDSent) - putStrLn $ " - sent: " ++ show mBS + putStrLn $ " - sent: " ++ show mBS 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 @@ -438,10 +438,11 @@ generateValue :: TestTopicState -> TestTopic + -> Int -> IO (GenValue ServerToClient) -generateValue TestTopicState{size,generate,serialize,serverG} topic = do +generateValue TestTopicState{size,generate,serialize,serverG} topic maxSize = do s <- atomically (readTVar size) - if s >= 100 + if s >= maxSize then pure DoneGenerating else do g <- newQCGen diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,6 +8,9 @@ import Data.Aeson.JSONDateTime (JSONDateTime) import Data.Aeson.JSONString (JSONString) import Data.Aeson.JSONEmailAddress (JSONEmailAddress) +import Data.Aeson.JSONInt (JSONInt) +import Data.Aeson.JSONInteger (JSONInteger) +import Data.Aeson.JSONScientific (JSONScientific) import Data.Time (UTCTime) import Data.Time.Calendar (Day) @@ -40,6 +43,7 @@ ServerParams { serverParamsControlHost = URIAuth Strict.Nothing Glob (Strict.Just 5561) , serverParamsTestSuite = tests + , serverParamsMaxSize = 200 } @@ -56,6 +60,9 @@ registerTopic "JSONDateTime" (Proxy :: Proxy JSONDateTime) registerTopic "JSONString" (Proxy :: Proxy JSONString) registerTopic "JSONEmailAddress" (Proxy :: Proxy JSONEmailAddress) + registerTopic "JSONInt" (Proxy :: Proxy JSONInt) + registerTopic "JSONInteger" (Proxy :: Proxy JSONInteger) + registerTopic "JSONScientific" (Proxy :: Proxy JSONScientific) jsonIso :: ToJSON a => FromJSON a => Eq a => a -> Result