QuickCheck tests for date/time types and numeric

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

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

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
+

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

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

tests/test.hs

@@ -14,5 +14,6 @@ main = defaultMain $ testGroup "Postgres-wire"
     , testFaults
     , testMisc
     , testCodecsEncodeDecode
+    , testCodecsEncodePrint
     ]