diff --git a/executables/Decoding.hs b/executables/Decoding.hs --- a/executables/Decoding.hs +++ b/executables/Decoding.hs @@ -32,7 +32,7 @@ b "timetz" (D.timetz True) (E.timetz True (read "(10:41:06, +0300)")), b "timestamp" (D.timestamp True) (E.timestamp True (read "2000-01-19 10:41:06")), b "timestamptz" (D.timestamptz True) (E.timestamptz True (read "2000-01-19 10:41:06")), - b "interval" D.interval (E.interval (secondsToDiffTime 23472391128374)), + b "interval" (D.interval True) (E.interval True (secondsToDiffTime 23472391128374)), b "uuid" D.uuid (E.uuid (read "550e8400-e29b-41d4-a716-446655440000")), b "array" D.array (E.array (Array.fromListUnsafe diff --git a/executables/Encoding.hs b/executables/Encoding.hs --- a/executables/Encoding.hs +++ b/executables/Encoding.hs @@ -32,7 +32,7 @@ b "timetz" (E.timetz True) (read "(10:41:06, +0300)"), b "timestamp" (E.timestamp True) (read "2000-01-19 10:41:06"), b "timestamptz" (E.timestamptz True) (read "2000-01-19 10:41:06"), - b "interval" E.interval (secondsToDiffTime 23472391128374), + b "interval" (E.interval True) (secondsToDiffTime 23472391128374), b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"), b "array" E.array (Array.fromListUnsafe [Array.fromSingleton (Just "dfs") True 0, diff --git a/executables/Tests.hs b/executables/Tests.hs --- a/executables/Tests.hs +++ b/executables/Tests.hs @@ -257,11 +257,18 @@ fmap (Decoder.uuid . fromJust) $ query "SELECT '550e8400-e29b-41d4-a716-446655440000' :: uuid" [] PQ.Binary +test_intervalParsing = + let p = 10^6 * (332211 + 10^6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12)))))) + in + assertEqual (Just (Right (picosecondsToDiffTime p))) =<< do + (fmap . fmap) (Decoder.interval integerDatetimes) $ + query "SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval" [] PQ.Binary + prop_interval = forAll intervalDiffTimeGen $ mappingP (PTI.oidOf PTI.interval) - (nonNullRenderer Encoder.interval) - (nonNullParser Decoder.interval) + (nonNullRenderer (Encoder.interval integerDatetimes)) + (nonNullParser (Decoder.interval integerDatetimes)) test_maxInterval = let x = maxInterval @@ -271,9 +278,9 @@ p = (,,) (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) - (Encoder.interval x) + ((Encoder.interval integerDatetimes) x) (PQ.Binary) - (fmap . fmap) Decoder.interval $ + (fmap . fmap) (Decoder.interval integerDatetimes) $ query "SELECT $1" [Just p] PQ.Binary test_minInterval = @@ -284,9 +291,9 @@ p = (,,) (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) - (Encoder.interval x) + ((Encoder.interval integerDatetimes) x) (PQ.Binary) - (fmap . fmap) Decoder.interval $ + (fmap . fmap) (Decoder.interval integerDatetimes) $ query "SELECT $1" [Just p] PQ.Binary prop_timestamp = diff --git a/library/PostgreSQLBinary/Decoder.hs b/library/PostgreSQLBinary/Decoder.hs --- a/library/PostgreSQLBinary/Decoder.hs +++ b/library/PostgreSQLBinary/Decoder.hs @@ -2,7 +2,7 @@ import PostgreSQLBinary.Prelude hiding (bool) import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy.Builder as BB import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -81,7 +81,7 @@ fmap (Time.postgresJulianToDay . fromIntegral) . (int :: D Int32) -- | --- Decoding strategy depends on whether the server supports @integer_datetimes@. +-- The decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE time #-} time :: Bool -> D TimeOfDay time = @@ -92,7 +92,7 @@ fmap Time.secsToTimeOfDay . float8 -- | --- Decoding strategy depends on whether the server supports @integer_datetimes@. +-- The decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE timetz #-} timetz :: Bool -> D (TimeOfDay, TimeZone) timetz integer_datetimes = @@ -104,7 +104,7 @@ fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32) -- | --- Decoding strategy depends on whether the server supports @integer_datetimes@. +-- The decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE timestamptz #-} timestamp :: Bool -> D LocalTime timestamp = @@ -115,7 +115,7 @@ fmap Time.secsToLocalTime . float8 -- | --- Decoding strategy depends on whether the server supports @integer_datetimes@. +-- The decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE timestamp #-} timestamptz :: Bool -> D UTCTime timestamptz = @@ -125,15 +125,22 @@ False -> fmap Time.secsToUTC . float8 +-- | +-- The decoding strategy depends on whether the server supports @integer_datetimes@. {-# INLINABLE interval #-} -interval :: D DiffTime -interval = - evalStateT $ do - ub <- state $ B.splitAt 8 - db <- state $ B.splitAt 4 - mb <- get - i <- lift $ Interval.Interval <$> int ub <*> int db <*> int mb - return $ Interval.toDiffTime i +interval :: Bool -> D DiffTime +interval integerDatetimes = + evalState $ do + t <- state $ B.splitAt 8 + d <- state $ B.splitAt 4 + m <- get + return $ do + ux <- if integerDatetimes + then int t + else float8 t >>= return . round . (* (10^6)) . toRational + dx <- int d + mx <- int m + return $ Interval.toDiffTime $ Interval.Interval ux dx mx -- * Misc diff --git a/library/PostgreSQLBinary/Encoder.hs b/library/PostgreSQLBinary/Encoder.hs --- a/library/PostgreSQLBinary/Encoder.hs +++ b/library/PostgreSQLBinary/Encoder.hs @@ -3,7 +3,7 @@ import PostgreSQLBinary.Prelude import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy.Builder as BB import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.Text as T @@ -14,6 +14,7 @@ import qualified PostgreSQLBinary.Array as Array import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Integral as Integral +import qualified PostgreSQLBinary.Interval as Interval import qualified PostgreSQLBinary.Numeric as Numeric @@ -140,9 +141,17 @@ False -> float8 . Time.utcToSecs {-# INLINABLE interval #-} -interval :: E DiffTime -interval = - Builder.run . Builder.interval +interval :: Bool -> E DiffTime +interval integerDatetimes x = + Builder.run $ + (if integerDatetimes then BB.int64BE u else BB.doubleBE s) <> + BB.int32BE d <> + BB.int32BE m + where + Interval.Interval u d m = + fromMaybe (error "Too large DiffTime value for an interval") $ + Interval.fromDiffTime x + s = fromIntegral u / (10^6) -- * Misc ------------------------- 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 @@ -1,7 +1,7 @@ module PostgreSQLBinary.Encoder.Builder where import PostgreSQLBinary.Prelude hiding (bool) -import Data.ByteString.Builder +import Data.ByteString.Lazy.Builder import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL @@ -54,14 +54,6 @@ date :: Day -> Builder date = int32BE . fromIntegral . Time.dayToPostgresJulian - -{-# INLINE interval #-} -interval :: DiffTime -> Builder -interval = - Interval.fromDiffTime >>> - fromMaybe (error "Too large DiffTime value for an interval") >>> - \(Interval.Interval u d m) -> int64BE u <> int32BE d <> int32BE m - {-# INLINE numeric #-} numeric :: Scientific -> Builder 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.3.1 + 0.4.0 synopsis: Encoders and decoders for the PostgreSQL's binary format description: @@ -11,7 +11,8 @@ E.g., is based on this library. . - It's tested against Postgres versions 8.3 and 9.3 + It supports all Postgres versions starting from 8.3 + and is tested against 8.3, 9.3 and 9.4 with the @integer_datetimes@ setting off and on. category: Database, Codecs, Parsing @@ -69,7 +70,7 @@ -- data: uuid == 1.3.*, time >= 1.4 && < 1.6, - scientific == 0.3.*, + scientific < 0.4, text >= 1 && < 1.3, bytestring >= 0.10 && < 0.11, -- errors: @@ -107,7 +108,7 @@ -- data: uuid == 1.3.*, time >= 1.4 && < 1.6, - scientific == 0.3.*, + scientific < 0.4, text >= 1 && < 1.3, bytestring >= 0.10 && < 0.11, -- general: @@ -137,7 +138,7 @@ criterion == 1.0.*, -- data: time >= 1.4 && < 1.6, - scientific == 0.3.*, + scientific < 0.4, text >= 1 && < 1.3, bytestring >= 0.10 && < 0.11, -- general: @@ -169,7 +170,7 @@ criterion == 1.0.*, -- data: time >= 1.4 && < 1.6, - scientific == 0.3.*, + scientific < 0.4, text >= 1 && < 1.3, bytestring >= 0.10 && < 0.11, -- general: