From da8150edcca5328d820ac10e0ea412751d79c4c1 Mon Sep 17 00:00:00 2001 From: VyacheslavHashov Date: Tue, 11 Jul 2017 05:10:54 +0300 Subject: [PATCH] QuickCheck tests for date/time types and numeric --- .../PostgreSQL/Protocol/Codecs/Decoders.hs | 26 ++-- .../PostgreSQL/Protocol/Codecs/Encoders.hs | 31 ++-- .../PostgreSQL/Protocol/Codecs/Numeric.hs | 48 +++++-- .../PostgreSQL/Protocol/Codecs/Time.hs | 15 +- tests/Codecs/QuickCheck.hs | 136 +++++++++++++++--- tests/test.hs | 1 + 6 files changed, 195 insertions(+), 62 deletions(-) diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs b/src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs index 87c621c..0841ec0 100644 --- a/src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs +++ b/src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs @@ -3,8 +3,8 @@ module Database.PostgreSQL.Protocol.Codecs.Decoders where import Data.Word import Data.Int import Data.Maybe -import Data.Fixed import Data.Char +import Data.Scientific import Data.UUID (UUID, fromWords) import Data.Time (Day, UTCTime, LocalTime, DiffTime) import qualified Data.ByteString as B @@ -94,7 +94,7 @@ char _ = chr . fromIntegral <$> getWord8 {-# INLINE date #-} date :: FieldDecoder Day -date _ = pgjToDay <$> getWord32BE +date _ = pgjToDay <$> getInt32BE {-# INLINE float4 #-} float4 :: FieldDecoder Float @@ -130,15 +130,15 @@ bsJsonText = getByteString bsJsonBytes :: FieldDecoder B.ByteString bsJsonBytes len = getWord8 *> getByteString (len - 1) -numeric :: HasResolution a => FieldDecoder (Fixed a) -numeric _ = do - ndigits <- getWord16BE - weight <- getInt16BE - msign <- numericSign <$> getWord16BE - sign <- maybe (fail "unknown numeric") pure msign - dscale <- getWord16BE - digits <- replicateM (fromIntegral ndigits) getWord16BE - pure $ undefined +{-# INLINE numeric #-} +numeric :: FieldDecoder Scientific +numeric _ = do + ndigits <- getWord16BE + weight <- getInt16BE + sign <- getWord16BE >>= fromNumericSign + _ <- getWord16BE + numericToScientific sign weight <$> + replicateM (fromIntegral ndigits) getWord16BE -- | Decodes text without applying encoding. {-# INLINE bsText #-} @@ -147,11 +147,11 @@ bsText = getByteString {-# INLINE timestamp #-} timestamp :: FieldDecoder LocalTime -timestamp _ = microsToLocalTime <$> getWord64BE +timestamp _ = microsToLocalTime <$> getInt64BE {-# INLINE timestamptz #-} timestamptz :: FieldDecoder UTCTime -timestamptz _ = microsToUTC <$> getWord64BE +timestamptz _ = microsToUTC <$> getInt64BE {-# INLINE uuid #-} uuid :: FieldDecoder UUID diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs b/src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs index df4d619..c28c90b 100644 --- a/src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs +++ b/src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs @@ -4,8 +4,8 @@ import Data.Word import Data.Monoid ((<>)) import Data.Int import Data.Char -import Data.Fixed -import Data.UUID (UUID, toByteString) +import Data.Scientific +import Data.UUID (UUID, toWords) import Data.Time (Day, UTCTime, LocalTime, DiffTime) import qualified Data.ByteString as B import qualified Data.Vector as V @@ -35,7 +35,7 @@ char = putWord8 . fromIntegral . ord {-# INLINE date #-} date :: Day -> Encode -date = putWord32BE . dayToPgj +date = putInt32BE . dayToPgj {-# INLINE float4 #-} float4 :: Float -> Encode @@ -72,15 +72,15 @@ bsJsonText = putByteString bsJsonBytes :: B.ByteString -> Encode bsJsonBytes bs = putWord8 1 <> putByteString bs -numeric :: HasResolution a => (Fixed a) -> Encode -numeric _ = do undefined - -- ndigits <- putWord16BE - -- weight <- putInt16BE - -- msign <- numericSign <$> putWord16BE - -- sign <- maybe (fail "unknown numeric") pure msign - -- dscale <- putWord16BE - -- digits <- replicateM (fromIntegral ndigits) putWord16BE - -- pure $ undefined +{-# INLINE numeric #-} +numeric :: Scientific -> Encode +numeric n = + let (weight, scale, digits) = scientificToNumeric n + in putWord16BE (fromIntegral $ length digits) + <> putInt16BE weight + <> putWord16BE (toNumericSign n) + <> putWord16BE scale + <> foldMap putWord16BE digits -- | Encodes text. {-# INLINE bsText #-} @@ -89,12 +89,13 @@ bsText = putByteString {-# INLINE timestamp #-} timestamp :: LocalTime -> Encode -timestamp = putWord64BE . localTimeToMicros +timestamp = putInt64BE . localTimeToMicros {-# INLINE timestamptz #-} timestamptz :: UTCTime -> Encode -timestamptz = putWord64BE . utcToMicros +timestamptz = putInt64BE . utcToMicros {-# INLINE uuid #-} uuid :: UUID -> Encode -uuid = undefined +uuid v = let (a, b, c, d) = toWords v + in putWord32BE a <> putWord32BE b <> putWord32BE c <> putWord32BE d diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Numeric.hs b/src/Database/PostgreSQL/Protocol/Codecs/Numeric.hs index c904468..d696e74 100644 --- a/src/Database/PostgreSQL/Protocol/Codecs/Numeric.hs +++ b/src/Database/PostgreSQL/Protocol/Codecs/Numeric.hs @@ -1,21 +1,51 @@ +{-# language LambdaCase #-} module Database.PostgreSQL.Protocol.Codecs.Numeric where -- TODO test it +import Data.Tuple import Data.Word import Data.Int import Data.Foldable -import Data.Fixed +import Data.Scientific +import Data.List (unfoldr) -numericDigit :: [Word16] -> Integer -numericDigit = foldl' (\acc n -> acc * nBase + fromIntegral n) 0 +integerToDigits :: Integer -> [Word16] +integerToDigits = (reverse.) . unfoldr $ \case + 0 -> Nothing + n -> let (rest, rem) = n `divMod` nBase in Just (fromIntegral rem, rest) -numericSign :: Num a => Word16 -> Maybe a -numericSign 0x0000 = Just 1 -numericSign 0x4000 = Just $ -1 -numericSign _ = Nothing -- NaN code is 0xC000, it is not supported. +toNumericSign :: Scientific -> Word16 +toNumericSign s | s >= 0 = 0x0000 + | otherwise = 0x4000 -fixedFromNumeric :: HasResolution a => Int16 -> [Word16] -> Fixed a -fixedFromNumeric weight digits = undefined +scientificToNumeric :: Scientific -> (Int16, Word16, [Word16]) +scientificToNumeric number = + let a = base10Exponent number `mod` nBaseDigits + adjExp = base10Exponent number - a + adjCoef = coefficient number * (10 ^ a) + digits = integerToDigits $ abs adjCoef + weight = fromIntegral $ length digits + adjExp `div` nBaseDigits - 1 + scale = fromIntegral . negate $ min (base10Exponent number) 0 + in (weight, scale, digits) + +digitsToInteger :: [Word16] -> Integer +digitsToInteger = foldl' (\acc n -> acc * nBase + fromIntegral n) 0 + +fromNumericSign :: (Monad m, Num a) => Word16 -> m a +fromNumericSign 0x0000 = pure 1 +fromNumericSign 0x4000 = pure $ -1 +-- NaN code is 0xC000, it is not supported. +fromNumericSign _ = fail "Unknown numeric sign" + +numericToScientific :: Integer -> Int16 -> [Word16] -> Scientific +numericToScientific sign weight digits = + let coef = digitsToInteger digits * sign + exp' = (fromIntegral weight + 1 - length digits) * nBaseDigits + in scientific coef exp' nBase :: Num a => a nBase = 10000 + +nBaseDigits :: Num a => a +nBaseDigits = 4 + diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Time.hs b/src/Database/PostgreSQL/Protocol/Codecs/Time.hs index 7f7a211..cbde8ad 100644 --- a/src/Database/PostgreSQL/Protocol/Codecs/Time.hs +++ b/src/Database/PostgreSQL/Protocol/Codecs/Time.hs @@ -9,8 +9,7 @@ module Database.PostgreSQL.Protocol.Codecs.Time , diffTimeToInterval ) where -import Data.Int (Int64, Int32) -import Data.Word (Word32, Word64) +import Data.Int (Int64, Int32, Int64) import Data.Time (Day(..), UTCTime(..), LocalTime(..), DiffTime, TimeOfDay, picosecondsToDiffTime, timeToTimeOfDay, diffTimeToPicoseconds, timeOfDayToTime) @@ -21,11 +20,11 @@ dayToPgj = fromIntegral .(+ (modifiedJulianEpoch - postgresEpoch)) . toModifiedJulianDay {-# INLINE utcToMicros #-} -utcToMicros :: UTCTime -> Word64 +utcToMicros :: UTCTime -> Int64 utcToMicros (UTCTime day diffTime) = dayToMcs day + diffTimeToMcs diffTime {-# INLINE localTimeToMicros #-} -localTimeToMicros :: LocalTime -> Word64 +localTimeToMicros :: LocalTime -> Int64 localTimeToMicros (LocalTime day time) = dayToMcs day + timeOfDayToMcs time {-# INLINE pgjToDay #-} @@ -34,13 +33,13 @@ pgjToDay = ModifiedJulianDay . fromIntegral . subtract (modifiedJulianEpoch - postgresEpoch) {-# INLINE microsToUTC #-} -microsToUTC :: Word64 -> UTCTime +microsToUTC :: Int64 -> UTCTime microsToUTC mcs = let (d, r) = mcs `divMod` microsInDay in UTCTime (pgjToDay d) (mcsToDiffTime r) {-# INLINE microsToLocalTime #-} -microsToLocalTime :: Word64 -> LocalTime +microsToLocalTime :: Int64 -> LocalTime microsToLocalTime mcs = let (d, r) = mcs `divMod` microsInDay in LocalTime (pgjToDay d) (mcsToTimeOfDay r) @@ -87,14 +86,18 @@ pcsToMcs = (`div` 10 ^ 6) mcsToPcs :: Integral a => a -> a mcsToPcs = (* 10 ^ 6) +{-# INLINE modifiedJulianEpoch #-} modifiedJulianEpoch :: Num a => a modifiedJulianEpoch = 2400001 +{-# INLINE postgresEpoch #-} postgresEpoch :: Num a => a postgresEpoch = 2451545 +{-# INLINE microsInDay #-} microsInDay :: Num a => a microsInDay = 24 * 60 * 60 * 10 ^ 6 +{-# INLINE daysInMonth #-} daysInMonth :: Num a => a daysInMonth = 30 diff --git a/tests/Codecs/QuickCheck.hs b/tests/Codecs/QuickCheck.hs index ba27907..20976ca 100644 --- a/tests/Codecs/QuickCheck.hs +++ b/tests/Codecs/QuickCheck.hs @@ -1,11 +1,17 @@ module Codecs.QuickCheck where +import Data.Monoid ((<>)) import Test.Tasty import Test.QuickCheck import Test.QuickCheck.Arbitrary import Test.QuickCheck.Monadic +import Data.Scientific as S +import Data.Time +import Data.UUID (UUID, fromWords) +import Data.String (IsString) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC import qualified Data.Vector as V import Database.PostgreSQL.Driver @@ -23,7 +29,7 @@ import Codecs.Runner -- | Makes property that if here is a value then encoding and sending it -- to PostgreSQL, and receiving back returns the same value. makeCodecProperty - :: (Eq a, Arbitrary a ) + :: (Show a, Eq a, Arbitrary a) => Connection -> Oid -> (a -> Encode) -> PD.FieldDecoder a -> a -> Property @@ -38,7 +44,39 @@ makeCodecProperty c oid encoder fd v = monadicIO $ do waitReadyForQuery c either (error . show) (pure . decodeOneRow decoder) dr - assert $ v == r + assertQCEqual v r + +-- | Makes a property that encoded value is correctly parsed and printed +-- by PostgreSQL. +makeCodecEncodeProperty + :: Arbitrary a + => Connection + -> Oid + -> B.ByteString + -> (a -> Encode) + -> (a -> String) + -> a -> Property +makeCodecEncodeProperty c oid queryString encoder fPrint v = monadicIO $ do + let bs = runEncode $ encoder v + q = Query queryString (V.fromList [(oid, Just bs)]) + Binary Text AlwaysCache + decoder = PD.dataRowHeader *> PD.getNonNullable PD.bytea + r <- run $ do + sendBatchAndSync c [q] + dr <- readNextData c + waitReadyForQuery c + r <- either (error . show) (pure . BC.unpack . decodeOneRow decoder) dr + -- print $ fPrint v <> " " <> r + pure r + + assertQCEqual (fPrint v) r + +assertQCEqual :: (Eq a, Show a, Monad m) => a -> a -> PropertyM m () +assertQCEqual a b + | a == b = pure () + | otherwise = fail $ + "Equal assertion failed. Expected:\n" <> show a + <> "\nbut got:\n" <> show b -- | Makes Tasty test tree. mkCodecTest @@ -48,33 +86,93 @@ mkCodecTest mkCodecTest name oids encoder decoder = testPropertyConn name $ \c -> makeCodecProperty c (PGT.oidType oids) encoder decoder +mkCodecEncodeTest + :: (Arbitrary a, Show a) + => TestName -> PGT.Oids -> B.ByteString -> (a -> Encode) -> (a -> String) + -> TestTree +mkCodecEncodeTest name oids queryString encoder fPrint = + testPropertyConn name $ \c -> + makeCodecEncodeProperty c (PGT.oidType oids) queryString encoder fPrint + testCodecsEncodeDecode :: TestTree testCodecsEncodeDecode = testGroup "Codecs property 'encode . decode = id'" - [ mkCodecTest "bool" PGT.bool PE.bool PD.bool + [ {-mkCodecTest "bool" PGT.bool PE.bool PD.bool , mkCodecTest "bytea" PGT.bytea PE.bytea PD.bytea , mkCodecTest "char" PGT.char PE.char PD.char - -- TODO instance - -- , mkCodecTest "date" PGT.date PE.date PD.date + , mkCodecTest "date" PGT.date PE.date PD.date , mkCodecTest "float4" PGT.float4 PE.float4 PD.float4 , mkCodecTest "float8" PGT.float8 PE.float8 PD.float8 , mkCodecTest "int2" PGT.int2 PE.int2 PD.int2 , mkCodecTest "int4" PGT.int4 PE.int4 PD.int4 , mkCodecTest "int8" PGT.int8 PE.int8 PD.int8 - -- TODO intstance - -- , mkCodecTest "interval" PGT.interval PE.interval PD.interval - , mkCodecTest "json" PGT.json PE.bsJsonText PD.bsJsonText - , mkCodecTest "jsonb" PGT.jsonb PE.bsJsonBytes PD.bsJsonBytes + , mkCodecTest "interval" PGT.interval PE.interval PD.interval + , mkCodecTest "json" PGT.json (PE.bsJsonText . unJsonString ) + (fmap JsonString <$> PD.bsJsonText) + , mkCodecTest "jsonb" PGT.jsonb (PE.bsJsonBytes .unJsonString) + (fmap JsonString <$> PD.bsJsonBytes) -- TODO - -- , mkCodecTest "numeric" PGT.numeric PE.numeric PD.numeric - , mkCodecTest "text" PGT.text PE.bsText PD.bsText - -- TODO make instance - -- , mkCodecTest "timestamp" PGT.timestamp PE.timestamp PD.timestamp - -- TODO make instance - -- , mkCodecTest "timestamptz" PGT.timestamptz PE.timestamptz PD.timestamptz - -- TODO make instance - -- , mkCodecTest "uuid" PGT.uuid PE.uuid PD.uuid + , -}mkCodecTest "numeric" PGT.numeric PE.numeric PD.numeric + {-, mkCodecTest "text" PGT.text PE.bsText PD.bsText + , mkCodecTest "timestamp" PGT.timestamp PE.timestamp PD.timestamp + , mkCodecTest "timestamptz" PGT.timestamptz PE.timestamptz PD.timestamptz + , mkCodecTest "uuid" PGT.uuid PE.uuid PD.uuid-} ] --- TODO right instance +testCodecsEncodePrint :: TestTree +testCodecsEncodePrint = testGroup + "Codecs property 'Encoded value Postgres = value in Haskell'" + [ mkCodecEncodeTest "uuid" PGT.uuid qBasic PE.uuid show + , mkCodecEncodeTest "date" PGT.date qBasic PE.date show + , mkCodecEncodeTest "timestamp" PGT.timestamp qBasic PE.timestamp show + , mkCodecEncodeTest "timestamptz" PGT.timestamptz + "SELECT ($1 at time zone 'UTC')||' UTC'" PE.timestamptz show + , mkCodecEncodeTest "interval" PGT.interval + "SELECT extract(epoch from $1)||'s'" PE.interval show + , mkCodecEncodeTest "numeric" PGT.numeric qBasic PE.numeric + displayScientific + ] + where + qBasic = "SELECT $1" + displayScientific s | isInteger s = show $ ceiling s + | otherwise = formatScientific S.Fixed Nothing s +-- +-- Orphan instances +-- + +-- Helper to generate valid json strings +newtype JsonString = JsonString { unJsonString :: B.ByteString } + deriving (Show, Eq, IsString) + +instance Arbitrary JsonString where + arbitrary = oneof $ map pure + [ "{}" + , "{\"a\": 5}" + , "{\"b\": [1, 2, 3]}" + ] + instance Arbitrary B.ByteString where - arbitrary = oneof [pure "1", pure "2"] + arbitrary = do + len <- choose (0, 1024) + B.pack <$> vectorOf len (choose (1, 127)) + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> choose (-100000, 100000) + +instance Arbitrary DiffTime where + arbitrary = secondsToDiffTime <$> choose (0, 86400 - 1) + +instance Arbitrary LocalTime where + arbitrary = LocalTime <$> arbitrary <*> fmap timeToTimeOfDay arbitrary + +instance Arbitrary UTCTime where + arbitrary = UTCTime <$> arbitrary <*> arbitrary + +instance Arbitrary UUID where + arbitrary = fromWords <$> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + +instance Arbitrary Scientific where + arbitrary = do + c <- choose (-100000000, 100000000) + e <- choose (-10, 10) + pure . normalize $ scientific c e diff --git a/tests/test.hs b/tests/test.hs index 5efe928..035ef17 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -14,5 +14,6 @@ main = defaultMain $ testGroup "Postgres-wire" , testFaults , testMisc , testCodecsEncodeDecode + , testCodecsEncodePrint ]