diff --git a/executables/Tests.hs b/executables/Tests.hs --- a/executables/Tests.hs +++ b/executables/Tests.hs @@ -107,7 +107,8 @@ void $ PQ.exec c $ mconcat $ map (<> ";") $ [ "SET client_min_messages TO WARNING", - "SET client_encoding = 'UTF8'" + "SET client_encoding = 'UTF8'", + "SET intervalstyle = 'postgres'" ] getIntegerDatetimes :: PQ.Connection -> IO Bool @@ -134,7 +135,8 @@ microsTimeOfDayGen :: Gen TimeOfDay microsTimeOfDayGen = - timeToTimeOfDay <$> microsDiffTimeGen + fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ + choose (0, (10^6)*24*60*60) microsLocalTimeGen :: Gen LocalTime microsLocalTimeGen = @@ -144,9 +146,12 @@ microsUTCTimeGen = localTimeToUTC <$> timeZoneGen <*> microsLocalTimeGen -microsDiffTimeGen :: Gen DiffTime -microsDiffTimeGen = do - fmap picosecondsToDiffTime $ fmap (* (10^6)) $ choose (0, (10^6)*24*60*60) +intervalDiffTimeGen :: Gen DiffTime +intervalDiffTimeGen = do + unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer) + where + uMin = unsafeCoerce minInterval `div` 10^6 + uMax = unsafeCoerce maxInterval `div` 10^6 timeZoneGen :: Gen TimeZone timeZoneGen = @@ -184,7 +189,16 @@ where dimensionWidth (x, _) = fromIntegral x +-- * Constants +------------------------- +maxInterval :: DiffTime = + unsafeCoerce $ + (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer) + +minInterval :: DiffTime = + negate maxInterval + -- * Tests ------------------------- @@ -209,15 +223,36 @@ query "SELECT '550e8400-e29b-41d4-a716-446655440000' :: uuid" [] PQ.Binary prop_interval = - forAll microsDiffTimeGen $ + forAll intervalDiffTimeGen $ mappingP (PTI.oidOf PTI.interval) (nonNullRenderer Encoder.interval) (nonNullParser Decoder.interval) -test_intervalParsing = - assertEqual (Right (secondsToDiffTime (44 + 60 * (10 + 60 * 24 * (20 + 31 * 2))))) =<< do - fmap (Decoder.interval . fromJust) $ - query "SELECT 'P0000-02-20T00:10:44' :: interval" [] PQ.Binary +test_maxInterval = + let x = maxInterval + in + assertEqual (Just (Right x)) =<< do + let + p = + (,,) + (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) + (Encoder.interval x) + (PQ.Binary) + (fmap . fmap) Decoder.interval $ + query "SELECT $1" [Just p] PQ.Binary + +test_minInterval = + let x = minInterval + in + assertEqual (Just (Right x)) =<< do + let + p = + (,,) + (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) + (Encoder.interval x) + (PQ.Binary) + (fmap . fmap) Decoder.interval $ + query "SELECT $1" [Just p] PQ.Binary prop_timestamp = forAll microsUTCTimeGen $ diff --git a/library/PostgreSQLBinary/Decoder.hs b/library/PostgreSQLBinary/Decoder.hs --- a/library/PostgreSQLBinary/Decoder.hs +++ b/library/PostgreSQLBinary/Decoder.hs @@ -16,6 +16,7 @@ import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Integral as Integral import qualified PostgreSQLBinary.Numeric as Numeric +import qualified PostgreSQLBinary.Interval as Interval -- | @@ -155,13 +156,8 @@ ub <- state $ B.splitAt 8 db <- state $ B.splitAt 4 mb <- get - lift $ do - u <- int ub - d <- int db - m <- int mb - return $ picosecondsToDiffTime $ - 10 ^ 6 * fromIntegral (u + 10 ^ 6 * 60 * 60 * 24 * (d + 31 * m) :: Int64) - + i <- lift $ Interval.Interval <$> int ub <*> int db <*> int mb + return $ Interval.toDiffTime i -- * 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 @@ -15,6 +15,7 @@ import qualified PostgreSQLBinary.Array as Array import qualified PostgreSQLBinary.Time as Time import qualified PostgreSQLBinary.Numeric as Numeric +import qualified PostgreSQLBinary.Interval as Interval {-# INLINE run #-} @@ -70,13 +71,11 @@ {-# INLINE interval #-} interval :: DiffTime -> Builder -interval x = - flip evalState (unsafeCoerce x :: Integer) $ do - u <- state (`divMod` (10 ^ 6)) - d <- state (`divMod` (10 ^ 6 * 60 * 60 * 24)) - m <- get - return $ - int64BE (fromIntegral u) <> int32BE (fromIntegral d) <> int32BE (fromIntegral m) +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/library/PostgreSQLBinary/Interval.hs b/library/PostgreSQLBinary/Interval.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQLBinary/Interval.hs @@ -0,0 +1,43 @@ +module PostgreSQLBinary.Interval where + +import PostgreSQLBinary.Prelude +import qualified PostgreSQLBinary.Time as Time + + +data Interval = + Interval { + micros :: Int64, + days :: Int32, + months :: Int32 + } + deriving (Show, Eq) + + +-- | +-- Oddly enough despite a claim of support of up to 178000000 years in +-- +-- in practice it starts behaving unpredictable after a smaller limit. +maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.year +minDiffTime :: DiffTime = negate maxDiffTime + +fromDiffTime :: DiffTime -> Maybe Interval +fromDiffTime x = + if x > maxDiffTime || x < minDiffTime + then Nothing + else Just $ fromPicosUnsafe (unsafeCoerce x) + +fromPicosUnsafe :: Integer -> Interval +fromPicosUnsafe = + evalState $ do + modify $ flip div (10^6) + u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24) + d <- state $ swap . flip divMod (31) + m <- get + return $ Interval (fromIntegral u) (fromIntegral d) (fromIntegral m) + +toDiffTime :: Interval -> DiffTime +toDiffTime x = + picosecondsToDiffTime $ + (10 ^ 6) * + (fromIntegral (micros x) + + 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x))) diff --git a/library/PostgreSQLBinary/Time.hs b/library/PostgreSQLBinary/Time.hs --- a/library/PostgreSQLBinary/Time.hs +++ b/library/PostgreSQLBinary/Time.hs @@ -1,6 +1,6 @@ module PostgreSQLBinary.Time where -import PostgreSQLBinary.Prelude +import PostgreSQLBinary.Prelude hiding (second) import Data.Time.Calendar.Julian @@ -58,3 +58,21 @@ let p = truncate $ toRational s * 10 ^ 12 :: Integer return $ TimeOfDay h m (unsafeCoerce p) + + +-- * Constants in microseconds according to Julian dates standard +------------------------- +-- According to +-- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html +-- Postgres uses Julian dates internally +------------------------- + +year :: Int64 = truncate (365.2425 * fromIntegral day :: Rational) +day :: Int64 = 24 * hour +hour :: Int64 = 60 * minute +minute :: Int64 = 60 * second +second :: Int64 = 10 ^ 6 + +microsToDiffTime :: Int64 -> DiffTime +microsToDiffTime = + unsafeCoerce . (* (10^6)) . fromIntegral 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.2.1 + 0.2.2 synopsis: Encoders and decoders for the PostgreSQL's binary format description: @@ -56,6 +56,7 @@ PostgreSQLBinary.Integral PostgreSQLBinary.Numeric PostgreSQLBinary.Time + PostgreSQLBinary.Interval exposed-modules: PostgreSQLBinary.Array PostgreSQLBinary.Encoder