diff --git a/executables/Decoding.hs b/executables/Decoding.hs --- a/executables/Decoding.hs +++ b/executables/Decoding.hs @@ -28,8 +28,8 @@ b "text" D.text (E.text (Left "alsdjflskjдывлоаы оады")), b "bytea" D.bytea (E.bytea (Left "alskdfj;dasjfl;dasjflksdj")), b "date" D.date (E.date (read "2000-01-19")), - b "time" D.time (E.time (read "10:41:06")), - b "timetz" D.timetz (E.timetz (read "(10:41:06, +0300)")), + b "time" (D.time True) (E.time True (read "10:41:06")), + b "timetz" (D.timetz True) (E.timetz True (read "(10:41:06, +0300)")), b "timestamp" D.timestamp (E.timestamp (read "2000-01-19 10:41:06")), b "timestamptz" D.timestamptz (E.timestamptz (read "2000-01-19 10:41:06")), b "interval" D.interval (E.interval (secondsToDiffTime 23472391470128374)), diff --git a/executables/Encoding.hs b/executables/Encoding.hs --- a/executables/Encoding.hs +++ b/executables/Encoding.hs @@ -17,26 +17,26 @@ main = defaultMain [ - b "bool" E.bool True, - b "int2" E.int2 (Left 1000), - b "int4" E.int4 (Left 1000), - b "int8" E.int8 (Left 1000), - b "float4" E.float4 12.65468468, - b "float8" E.float8 12.65468468, - b "numeric" E.numeric (read "20.213290183"), - b "char" E.char 'Я', - b "text" E.text (Left "alsdjflskjдывлоаы оады"), - b "bytea" E.bytea (Left "alskdfj;dasjfl;dasjflksdj"), - b "date" E.date (read "2000-01-19"), - b "time" E.time (read "10:41:06"), - b "timetz" E.timetz (read "(10:41:06, +0300)"), - b "timestamp" E.timestamp (read "2000-01-19 10:41:06"), - b "timestamptz" E.timestamptz (read "2000-01-19 10:41:06"), - b "interval" E.interval (secondsToDiffTime 23472391470128374), - b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"), - b "array" E.array (Array.fromListUnsafe - [Array.fromSingleton (Just "dfs") True 0, - Array.fromSingleton Nothing True 0]) + b "bool" E.bool True, + b "int2" E.int2 (Left 1000), + b "int4" E.int4 (Left 1000), + b "int8" E.int8 (Left 1000), + b "float4" E.float4 12.65468468, + b "float8" E.float8 12.65468468, + b "numeric" E.numeric (read "20.213290183"), + b "char" E.char 'Я', + b "text" E.text (Left "alsdjflskjдывлоаы оады"), + b "bytea" E.bytea (Left "alskdfj;dasjfl;dasjflksdj"), + b "date" E.date (read "2000-01-19"), + b "time" (E.time True) (read "10:41:06"), + b "timetz" (E.timetz True) (read "(10:41:06, +0300)"), + b "timestamp" E.timestamp (read "2000-01-19 10:41:06"), + b "timestamptz" E.timestamptz (read "2000-01-19 10:41:06"), + b "interval" E.interval (secondsToDiffTime 23472391470128374), + b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"), + b "array" E.array (Array.fromListUnsafe + [Array.fromSingleton (Just "dfs") True 0, + Array.fromSingleton Nothing True 0]) ] where b name encoder value = diff --git a/executables/Tests.hs b/executables/Tests.hs --- a/executables/Tests.hs +++ b/executables/Tests.hs @@ -105,12 +105,20 @@ initConnection :: PQ.Connection -> IO () initConnection c = void $ PQ.exec c $ mconcat $ map (<> ";") $ - [ "SET standard_conforming_strings TO on", - "SET datestyle TO ISO", - "SET client_encoding = 'UTF8'", + [ "SET client_min_messages TO WARNING", - "SET bytea_output = 'hex'" ] + "SET client_encoding = 'UTF8'" + ] +getIntegerDatetimes :: PQ.Connection -> IO Bool +getIntegerDatetimes c = + fmap parseResult $ PQ.parameterStatus c "integer_datetimes" + where + parseResult = + \case + Just "on" -> True + _ -> False + nonNullParser p = fromMaybe (Left "Unexpected NULL") . fmap p @@ -177,9 +185,18 @@ dimensionWidth (x, _) = fromIntegral x --- * Properties +-- * Tests ------------------------- +-- | This is a dummy, the sole point of which is to output the value of 'integer_datetimes' +test_integerDatetimes = + do + connection <- connect + initConnection connection + x <- getIntegerDatetimes connection + putStrLn $ "'integer_datetimes' is " <> show x + PQ.finish connection + prop_uuid = forAll uuidGen $ mappingP (PTI.oidOf PTI.uuid) @@ -220,30 +237,72 @@ (nonNullParser Decoder.timestamptz) prop_timetz = - forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ - mappingP (PTI.oidOf PTI.timetz) - (nonNullRenderer Encoder.timetz) - (nonNullParser Decoder.timetz) + forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ \x -> + Right x === do + unsafePerformIO $ do + connection <- connect + initConnection connection + integerDatetimes <- getIntegerDatetimes connection + Just result <- + let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timetz, Encoder.timetz integerDatetimes x, PQ.Binary)] + in PQ.execParams connection "SELECT $1" params PQ.Binary + encodedResult <- PQ.getvalue result 0 0 + PQ.finish connection + return $ + Decoder.timetz integerDatetimes (fromJust encodedResult) -test_timetzParsing1 = +test_timetzParsing = assertEqual (Right (read "(10:41:06.002897, +0500)" :: (TimeOfDay, TimeZone))) =<< do - fmap (Decoder.timetz . fromJust) $ - query "SELECT '10:41:06.002897+05' :: timetz" [] PQ.Binary + connection <- connect + initConnection connection + integerDatetimes <- getIntegerDatetimes connection + Just result <- PQ.execParams connection "SELECT '10:41:06.002897+05' :: timetz" [] PQ.Binary + encodedResult <- PQ.getvalue result 0 0 + PQ.finish connection + return $ + Decoder.timetz integerDatetimes (fromJust encodedResult) -prop_timeOfDay = - forAll microsTimeOfDayGen $ - mappingP (PTI.oidOf PTI.time) - (nonNullRenderer Encoder.time) - (nonNullParser Decoder.time) +prop_timeFromIntegerIsomorphism = + forAll microsTimeOfDayGen $ \x -> + Right x === Decoder.time True (Encoder.time True x) -prop_timeOfDayParsing = +prop_timeFromDoubleIsomorphism = forAll microsTimeOfDayGen $ \x -> + let Right x' = Decoder.time False (Encoder.time False x) + in floatEqProp (toFloat x) (toFloat x') + where + toFloat (TimeOfDay h m s) = + s + fromIntegral (60 * (m + 60 * h)) + +prop_time = + forAll microsTimeOfDayGen $ \x -> Right x === do - unsafePerformIO $ - fmap (Decoder.time . fromJust) $ - query "SELECT $1" - [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, (fromString . show) x, PQ.Text)] - PQ.Binary + unsafePerformIO $ do + connection <- connect + initConnection connection + integerDatetimes <- getIntegerDatetimes connection + Just result <- + let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, Encoder.time integerDatetimes x, PQ.Binary)] + in PQ.execParams connection "SELECT $1" params PQ.Binary + encodedResult <- PQ.getvalue result 0 0 + PQ.finish connection + return $ + Decoder.time integerDatetimes (fromJust encodedResult) + +prop_timeParsing = + forAll microsTimeOfDayGen $ \x -> + Right x === do + unsafePerformIO $ do + connection <- connect + initConnection connection + integerDatetimes <- getIntegerDatetimes connection + Just result <- + let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, (fromString . show) x, PQ.Text)] + in PQ.execParams connection "SELECT $1" params PQ.Binary + encodedResult <- PQ.getvalue result 0 0 + PQ.finish connection + return $ + Decoder.time integerDatetimes (fromJust encodedResult) prop_scientific (c, e) = let x = Scientific.scientific c e diff --git a/library/PostgreSQLBinary/Date.hs b/library/PostgreSQLBinary/Date.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Date.hs +++ /dev/null @@ -1,39 +0,0 @@ -module PostgreSQLBinary.Date where - -import PostgreSQLBinary.Prelude -import Data.Time.Calendar.Julian - - -type YMD = (Integer, Int, Int) - -{-# INLINE dayToJulianYMD #-} -dayToJulianYMD :: Day -> YMD -dayToJulianYMD = - toJulian - -{-# INLINE dayToGregorianYMD #-} -dayToGregorianYMD :: Day -> YMD -dayToGregorianYMD = - toGregorian - -{-# INLINABLE ymdToInt #-} -ymdToInt :: YMD -> Int -ymdToInt (y, m, d) = - let (m', y') = if m > 2 then (m + 1, fromIntegral $ y + 4800) - else (m + 13, fromIntegral $ y + 4799) - century = y' `div` 100 - in - y' * 365 - 32167 + - y' `div` 4 - century + century `div` 4 + - 7834 * m' `div` 256 + d - -{-# INLINABLE dayToPostgresJulian #-} -dayToPostgresJulian :: Day -> Integer -dayToPostgresJulian = - (+ (2400001 - 2451545)) . toModifiedJulianDay - -{-# INLINABLE postgresJulianToDay #-} -postgresJulianToDay :: Integer -> Day -postgresJulianToDay = - ModifiedJulianDay . (subtract (2400001 - 2451545)) - diff --git a/library/PostgreSQLBinary/Decoder.hs b/library/PostgreSQLBinary/Decoder.hs --- a/library/PostgreSQLBinary/Decoder.hs +++ b/library/PostgreSQLBinary/Decoder.hs @@ -13,7 +13,7 @@ import qualified PostgreSQLBinary.Decoder.Atto as Atto import qualified PostgreSQLBinary.Decoder.Zepto as Zepto import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Date as Date +import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Integral as Integral import qualified PostgreSQLBinary.Numeric as Numeric @@ -95,20 +95,27 @@ {-# INLINABLE date #-} date :: D Day date = - fmap (Date.postgresJulianToDay . fromIntegral) . (int :: D Int32) + fmap (Time.postgresJulianToDay . fromIntegral) . (int :: D Int32) +-- | +-- Decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE time #-} -time :: D TimeOfDay +time :: Bool -> D TimeOfDay time = - fmap (timeToTimeOfDay . picosecondsToDiffTime . (* (10^6)) . fromIntegral) . - (int :: D Word64) + \case + True -> + fmap Time.microsToTimeOfDay . int + False -> + fmap Time.secondsToTimeOfDay . float8 +-- | +-- Decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE timetz #-} -timetz :: D (TimeOfDay, TimeZone) -timetz = +timetz :: Bool -> D (TimeOfDay, TimeZone) +timetz integer_datetimes = \x -> let (timeX, zoneX) = B.splitAt 8 x - in (,) <$> time timeX <*> tz zoneX + in (,) <$> time integer_datetimes timeX <*> tz zoneX where tz = fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32) @@ -116,7 +123,7 @@ {-# INLINABLE timestamp #-} timestamp :: D UTCTime timestamp = - fmap fromMicros . (int :: D Int64) + fmap fromMicros . int where fromMicros = evalState $ do @@ -124,13 +131,13 @@ micros <- get return $ UTCTime - (Date.postgresJulianToDay . fromIntegral $ days) + (Time.postgresJulianToDay days) (picosecondsToDiffTime . (* (10^6)) . fromIntegral $ micros) {-# INLINABLE timestamptz #-} timestamptz :: D LocalTime timestamptz = - fmap fromMicros . (int :: D Int64) + fmap fromMicros . int where fromMicros = evalState $ do @@ -138,8 +145,8 @@ micros <- get return $ LocalTime - (Date.postgresJulianToDay . fromIntegral $ days) - (timeToTimeOfDay . picosecondsToDiffTime . (* (10^6)) . fromIntegral $ micros) + (Time.postgresJulianToDay days) + (Time.microsToTimeOfDay micros) {-# INLINABLE interval #-} interval :: D DiffTime diff --git a/library/PostgreSQLBinary/Encoder.hs b/library/PostgreSQLBinary/Encoder.hs --- a/library/PostgreSQLBinary/Encoder.hs +++ b/library/PostgreSQLBinary/Encoder.hs @@ -12,7 +12,7 @@ import qualified Data.Text.Lazy.Encoding as TLE import qualified PostgreSQLBinary.Encoder.Builder as Builder import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Date as Date +import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Integral as Integral import qualified PostgreSQLBinary.Numeric as Numeric @@ -99,15 +99,31 @@ date = Builder.run . Builder.date +-- | +-- Encoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE time #-} -time :: E TimeOfDay -time = - Builder.run . Builder.time +time :: Bool -> E TimeOfDay +time integer_datetimes (TimeOfDay h m s) = + let + p = unsafeCoerce s :: Integer + u = p `div` (10^6) + in if integer_datetimes + then + Integral.unpackBySize 8 $ + fromIntegral u + 10^6 * 60 * (m + 60 * h) + else + inline float8 $ + fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h)) +-- | +-- Encoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE timetz #-} -timetz :: E (TimeOfDay, TimeZone) -timetz = - Builder.run . Builder.timetz +timetz :: Bool -> E (TimeOfDay, TimeZone) +timetz integer_datetimes (timeX, tzX) = + inline time integer_datetimes timeX <> tz tzX + where + tz = + Integral.unpackBySize 4 . (*60) . negate . timeZoneMinutes {-# INLINABLE timestamp #-} timestamp :: E UTCTime diff --git a/library/PostgreSQLBinary/Encoder/Builder.hs b/library/PostgreSQLBinary/Encoder/Builder.hs --- a/library/PostgreSQLBinary/Encoder/Builder.hs +++ b/library/PostgreSQLBinary/Encoder/Builder.hs @@ -13,7 +13,7 @@ import qualified Data.Scientific as Scientific import qualified Data.UUID as UUID import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Date as Date +import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Numeric as Numeric @@ -52,34 +52,19 @@ {-# INLINE date #-} date :: Day -> Builder date = - int32BE . fromIntegral . Date.dayToPostgresJulian - -{-# INLINE time #-} -time :: TimeOfDay -> Builder -time = - word64BE . (`div` (10^6)) . unsafeCoerce timeOfDayToTime - -{-# INLINE timetz #-} -timetz :: (TimeOfDay, TimeZone) -> Builder -timetz (timeX, tzX) = - time timeX <> tz tzX - -{-# INLINE tz #-} -tz :: TimeZone -> Builder -tz = - int32BE . fromIntegral . (*60) . negate . timeZoneMinutes + int32BE . fromIntegral . Time.dayToPostgresJulian {-# INLINE timestamp #-} timestamp :: UTCTime -> Builder timestamp (UTCTime dayX timeX) = - let days = Date.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24 + let days = Time.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24 time = (`div` (10^6)) . unsafeCoerce $ timeX in int64BE $ fromIntegral $ days + time {-# INLINE timestamptz #-} timestamptz :: LocalTime -> Builder timestamptz (LocalTime dayX timeX) = - let days = Date.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24 + let days = Time.dayToPostgresJulian dayX * 10^6 * 60 * 60 * 24 time = (`div` (10^6)) . unsafeCoerce timeOfDayToTime $ timeX in int64BE $ fromIntegral $ days + time diff --git a/library/PostgreSQLBinary/Time.hs b/library/PostgreSQLBinary/Time.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Time.hs @@ -0,0 +1,60 @@ +module PostgreSQLBinary.Time where + +import PostgreSQLBinary.Prelude +import Data.Time.Calendar.Julian + + +type YMD = (Integer, Int, Int) + +{-# INLINE dayToJulianYMD #-} +dayToJulianYMD :: Day -> YMD +dayToJulianYMD = + toJulian + +{-# INLINE dayToGregorianYMD #-} +dayToGregorianYMD :: Day -> YMD +dayToGregorianYMD = + toGregorian + +{-# INLINABLE ymdToInt #-} +ymdToInt :: YMD -> Int +ymdToInt (y, m, d) = + let (m', y') = if m > 2 then (m + 1, fromIntegral $ y + 4800) + else (m + 13, fromIntegral $ y + 4799) + century = y' `div` 100 + in + y' * 365 - 32167 + + y' `div` 4 - century + century `div` 4 + + 7834 * m' `div` 256 + d + +{-# INLINABLE dayToPostgresJulian #-} +dayToPostgresJulian :: Day -> Integer +dayToPostgresJulian = + (+ (2400001 - 2451545)) . toModifiedJulianDay + +{-# INLINABLE postgresJulianToDay #-} +postgresJulianToDay :: Int -> Day +postgresJulianToDay = + ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) + +{-# INLINABLE microsToTimeOfDay #-} +microsToTimeOfDay :: Int -> TimeOfDay +microsToTimeOfDay = + evalState $ do + h <- state $ flip divMod (10 ^ 6 * 60 * 60) + m <- state $ flip divMod (10 ^ 6 * 60) + u <- get + let p = fromIntegral u * 10 ^ 6 :: Integer + return $ + TimeOfDay h m (unsafeCoerce p) + +{-# INLINABLE secondsToTimeOfDay #-} +secondsToTimeOfDay :: Double -> TimeOfDay +secondsToTimeOfDay = + evalState $ do + h <- state $ flip divMod' (60 * 60) + m <- state $ flip divMod' (60) + s <- get + let p = truncate $ toRational s * 10 ^ 12 :: Integer + return $ + TimeOfDay h m (unsafeCoerce p) diff --git a/postgresql-binary.cabal b/postgresql-binary.cabal --- a/postgresql-binary.cabal +++ b/postgresql-binary.cabal @@ -1,7 +1,7 @@ name: postgresql-binary version: - 0.1.0 + 0.2.0 synopsis: Encoders and decoders for the PostgreSQL's binary format description: @@ -55,7 +55,7 @@ PostgreSQLBinary.Decoder.Zepto PostgreSQLBinary.Integral PostgreSQLBinary.Numeric - PostgreSQLBinary.Date + PostgreSQLBinary.Time exposed-modules: PostgreSQLBinary.Array PostgreSQLBinary.Encoder