Skip to content

Commit 1d109e6

Browse files
tfausakparsonsmatt
tfausak
and
parsonsmatt
authored
Improve handling of PostgreSQL intervals (#1604)
* Use Interval type from postgresql-simple-interval * Allow building with older versions of base * Allow older bytestring * Fix imports * Avoid generating invalid intervals * Fix formatting * Use upstream Persistent instances * Upgrade to postgresql-simple-interval 0.2025.7.11 * Avoid building dependencies separately * Upgrade to postgresql-simple-interval 0.2025.7.12 * Limit microsecond range * Fix clamp * Fix tests * Remove unnecessary dependency * Upgrade to postgresql-simple-interval 0.2025.8.27 * Upgrade to postgresql-simple-interval 0.2025.9.5 * Add more documentation to PgInterval * Update change log * Update change log * Update postgresql-simple-interval version constraint * Rerun CI * Move `@since` annotation to the end Co-authored-by: Matt Parsons <parsonsmatt@gmail.com> --------- Co-authored-by: Matt Parsons <parsonsmatt@gmail.com>
1 parent f4176c5 commit 1d109e6

File tree

5 files changed

+89
-114
lines changed

5 files changed

+89
-114
lines changed

‎.github/workflows/haskell.yml‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -86,7 +86,6 @@ jobs:
8686
restore-keys: |
8787
${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
8888
${{ runner.os }}-${{ matrix.ghc }}-
89-
- run: cabal v2-build all --disable-optimization --only-dependencies $CONFIG
9089
- run: cabal v2-build all --disable-optimization $CONFIG
9190
- run: cabal v2-test all --disable-optimization $CONFIG --test-options "--fail-on-focus"
9291
- run: cabal v2-bench all --disable-optimization $CONFIG

‎persistent-postgresql/ChangeLog.md‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,14 @@
11
# Changelog for persistent-postgresql
22

3+
## 2.14.0.0
4+
5+
* [#1604](https://github.com/yesodweb/persistent/pull/1604)
6+
* Changed the representation of intervals to use the `Interval` type from [the `postgresql-simple-interval` package](https://hackage.haskell.org/package/postgresql-simple-interval).
7+
This changes the behavior of `PgInterval` for very small and very large values.
8+
* Previously `PgInterval 0.000_000_9` would be rounded to `0.000_001` seconds, but now it is truncated to 0 seconds.
9+
* Previously `PgInterval 9_223_372_036_854.775_808` would overflow and throw a SQL error, but now it saturates to `9_223_372_036_854.775_807` seconds.
10+
* The SQL representation of `PgInterval` now always includes the `interval` prefix, like `interval '1 second'`.
11+
312
## 2.13.7.0
413

514
* [#1600](https://github.com/yesodweb/persistent/pull/1600)

‎persistent-postgresql/Database/Persist/Postgresql/Internal.hs‎

Lines changed: 44 additions & 105 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE FlexibleContexts #-}
22
{-# LANGUAGE NamedFieldPuns #-}
33
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE TypeApplications #-}
45
{-# LANGUAGE ViewPatterns #-}
56

67
module Database.Persist.Postgresql.Internal
@@ -35,6 +36,7 @@ module Database.Persist.Postgresql.Internal
3536
import qualified Database.PostgreSQL.Simple as PG
3637
import qualified Database.PostgreSQL.Simple.FromField as PGFF
3738
import qualified Database.PostgreSQL.Simple.Internal as PG
39+
import qualified Database.PostgreSQL.Simple.Interval as Interval
3840
import qualified Database.PostgreSQL.Simple.ToField as PGTF
3941
import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS
4042
import qualified Database.PostgreSQL.Simple.Types as PG
@@ -46,29 +48,30 @@ import Control.Monad.Except
4648
import Control.Monad.IO.Unlift (MonadIO (..))
4749
import Control.Monad.Trans.Class (lift)
4850
import Data.Acquire (with)
49-
import qualified Data.Attoparsec.ByteString.Char8 as P
50-
import Data.Bits ((.&.))
51+
import Data.Bits (toIntegralSized)
5152
import Data.ByteString (ByteString)
5253
import qualified Data.ByteString.Builder as BB
53-
import qualified Data.ByteString.Char8 as B8
54-
import Data.Char (ord)
5554
import Data.Conduit
5655
import qualified Data.Conduit.List as CL
5756
import Data.Data (Typeable)
5857
import Data.Either (partitionEithers)
59-
import Data.Fixed (Fixed (..), Pico)
58+
import Data.Fixed (Fixed (..), Micro, Pico)
6059
import Data.Function (on)
61-
import Data.Int (Int64)
6260
import qualified Data.IntMap as I
6361
import Data.List as List (find, foldl', groupBy, sort)
6462
import qualified Data.List.NonEmpty as NEL
6563
import qualified Data.Map as Map
6664
import Data.Maybe
67-
import Data.String.Conversions.Monomorphic (toStrictByteString)
6865
import Data.Text (Text)
6966
import qualified Data.Text as T
7067
import qualified Data.Text.Encoding as T
71-
import Data.Time (NominalDiffTime, localTimeToUTC, utc)
68+
import Data.Time
69+
( NominalDiffTime
70+
, localTimeToUTC
71+
, nominalDiffTimeToSeconds
72+
, secondsToNominalDiffTime
73+
, utc
74+
)
7275
import Database.Persist.Sql
7376
import qualified Database.Persist.Sql.Util as Util
7477

@@ -165,7 +168,7 @@ builtinGetters =
165168
, (k PS.time, convertPV PersistTimeOfDay)
166169
, (k PS.timestamp, convertPV (PersistUTCTime . localTimeToUTC utc))
167170
, (k PS.timestamptz, convertPV PersistUTCTime)
168-
, (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs))
171+
, (k PS.interval, convertPV $ toPersistValue @Interval.Interval)
169172
, (k PS.bit, convertPV PersistInt64)
170173
, (k PS.varbit, convertPV PersistInt64)
171174
, (k PS.numeric, convertPV PersistRational)
@@ -195,7 +198,7 @@ builtinGetters =
195198
, (1183, listOf PersistTimeOfDay)
196199
, (1115, listOf PersistUTCTime)
197200
, (1185, listOf PersistUTCTime)
198-
, (1187, listOf (PersistLiteralEscaped . pgIntervalToBs))
201+
, (1187, listOf $ toPersistValue @Interval.Interval)
199202
, (1561, listOf PersistInt64)
200203
, (1563, listOf PersistInt64)
201204
, (1231, listOf PersistRational)
@@ -233,114 +236,50 @@ unBinary (PG.Binary x) = x
233236

234237
-- | Represent Postgres interval using NominalDiffTime
235238
--
239+
-- Note that this type cannot be losslessly round tripped through PostgreSQL.
240+
-- For example the value @'PgInterval' 0.0000009@ will truncate extra
241+
-- precision. And the value @'PgInterval' 9223372036854.775808@ will overflow.
242+
-- Use the 'Interval.Interval' type if that is a problem for you.
243+
--
236244
-- @since 2.11.0.0
237245
newtype PgInterval = PgInterval {getPgInterval :: NominalDiffTime}
238246
deriving (Eq, Show)
239247

240-
pgIntervalToBs :: PgInterval -> ByteString
241-
pgIntervalToBs = toStrictByteString . show . getPgInterval
242-
243248
instance PGTF.ToField PgInterval where
244-
toField (PgInterval t) = PGTF.toField t
249+
toField = PGTF.toField . pgIntervalToInterval
245250

246251
instance PGFF.FromField PgInterval where
247-
fromField f mdata =
248-
if PGFF.typeOid f /= PS.typoid PS.interval
249-
then PGFF.returnError PGFF.Incompatible f ""
250-
else case mdata of
251-
Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""
252-
Just dat -> case P.parseOnly (nominalDiffTime <* P.endOfInput) dat of
253-
Left msg -> PGFF.returnError PGFF.ConversionFailed f msg
254-
Right t -> return $ PgInterval t
255-
where
256-
toPico :: Integer -> Pico
257-
toPico = MkFixed
258-
259-
-- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser
260-
twoDigits :: P.Parser Int
261-
twoDigits = do
262-
a <- P.digit
263-
b <- P.digit
264-
let
265-
c2d c = ord c .&. 15
266-
return $! c2d a * 10 + c2d b
267-
268-
-- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser
269-
seconds :: P.Parser Pico
270-
seconds = do
271-
real <- twoDigits
272-
mc <- P.peekChar
273-
case mc of
274-
Just '.' -> do
275-
t <- P.anyChar *> P.takeWhile1 P.isDigit
276-
return $! parsePicos (fromIntegral real) t
277-
_ -> return $! fromIntegral real
278-
where
279-
parsePicos :: Int64 -> B8.ByteString -> Pico
280-
parsePicos a0 t = toPico (fromIntegral (t' * 10 ^ n))
281-
where
282-
n = max 0 (12 - B8.length t)
283-
t' =
284-
B8.foldl'
285-
(\a c -> 10 * a + fromIntegral (ord c .&. 15))
286-
a0
287-
(B8.take 12 t)
288-
289-
parseSign :: P.Parser Bool
290-
parseSign = P.choice [P.char '-' >> return True, return False]
291-
292-
-- Db stores it in [-]HHH:MM:SS.[SSSS]
293-
-- For example, nominalDay is stored as 24:00:00
294-
interval :: P.Parser (Bool, Int, Int, Pico)
295-
interval = do
296-
s <- parseSign
297-
h <- P.decimal <* P.char ':'
298-
m <- twoDigits <* P.char ':'
299-
ss <- seconds
300-
if m < 60 && ss <= 60
301-
then return (s, h, m, ss)
302-
else fail "Invalid interval"
303-
304-
nominalDiffTime :: P.Parser NominalDiffTime
305-
nominalDiffTime = do
306-
(s, h, m, ss) <- interval
307-
let
308-
pico = ss + 60 * (fromIntegral m) + 60 * 60 * (fromIntegral (abs h))
309-
return . fromRational . toRational $ if s then (-pico) else pico
310-
311-
fromPersistValueError
312-
:: Text
313-
-- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
314-
-> Text
315-
-- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
316-
-> PersistValue
317-
-- ^ Incorrect value
318-
-> Text
319-
-- ^ Error message
320-
fromPersistValueError haskellType databaseType received =
321-
T.concat
322-
[ "Failed to parse Haskell type `"
323-
, haskellType
324-
, "`; expected "
325-
, databaseType
326-
, " from database, but received: "
327-
, T.pack (show received)
328-
, ". Potential solution: Check that your database schema matches your Persistent model definitions."
329-
]
252+
fromField f =
253+
maybe (PGFF.returnError PGFF.ConversionFailed f "invalid interval") pure
254+
. intervalToPgInterval
255+
<=< PGFF.fromField f
330256

331257
instance PersistField PgInterval where
332-
toPersistValue = PersistLiteralEscaped . pgIntervalToBs
333-
fromPersistValue (PersistLiteral_ DbSpecific bs) =
334-
fromPersistValue (PersistLiteralEscaped bs)
335-
fromPersistValue x@(PersistLiteral_ Escaped bs) =
336-
case P.parseOnly (P.signed P.rational <* P.char 's' <* P.endOfInput) bs of
337-
Left _ -> Left $ fromPersistValueError "PgInterval" "Interval" x
338-
Right i -> Right $ PgInterval i
339-
fromPersistValue x = Left $ fromPersistValueError "PgInterval" "Interval" x
258+
toPersistValue =
259+
toPersistValue
260+
. pgIntervalToInterval
261+
fromPersistValue =
262+
maybe (Left "invalid interval") pure
263+
. intervalToPgInterval
264+
<=< fromPersistValue
340265

341266
instance PersistFieldSql PgInterval where
342267
sqlType _ = SqlOther "interval"
343268

269+
pgIntervalToInterval :: PgInterval -> Interval.Interval
270+
pgIntervalToInterval =
271+
Interval.fromTimeSaturating mempty
272+
. getPgInterval
273+
274+
intervalToPgInterval :: Interval.Interval -> Maybe PgInterval
275+
intervalToPgInterval interval =
276+
let
277+
(calendarDiffDays, nominalDiffTime) = Interval.intoTime interval
278+
in
279+
if calendarDiffDays == mempty
280+
then Just $ PgInterval nominalDiffTime
281+
else Nothing
282+
344283
-- | Indicates whether a Postgres Column is safe to drop.
345284
--
346285
-- @since 2.17.1.0

‎persistent-postgresql/persistent-postgresql.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ library
2828
, persistent >=2.13.3 && <3
2929
, postgresql-libpq >=0.9.4.2 && <0.12
3030
, postgresql-simple >=0.6.1 && <0.8
31+
, postgresql-simple-interval >=1 && < 1.1
3132
, resource-pool
3233
, resourcet >=1.1.9
3334
, string-conversions
@@ -82,6 +83,7 @@ test-suite test
8283
, persistent-postgresql
8384
, persistent-qq
8485
, persistent-test
86+
, postgresql-simple-interval
8587
, QuickCheck
8688
, quickcheck-instances
8789
, resourcet

‎persistent-postgresql/test/PgIntervalTest.hs‎

Lines changed: 34 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -17,8 +17,10 @@
1717

1818
module PgIntervalTest where
1919

20-
import Data.Time.Clock (NominalDiffTime)
20+
import Data.Fixed (Fixed (MkFixed), Micro, Pico)
21+
import Data.Time.Clock (secondsToNominalDiffTime)
2122
import Database.Persist.Postgresql (PgInterval (..))
23+
import qualified Database.PostgreSQL.Simple.Interval as Interval
2224
import PgInit
2325
import Test.Hspec.QuickCheck
2426

@@ -29,20 +31,44 @@ PgIntervalDb
2931
interval_field PgInterval
3032
deriving Eq
3133
deriving Show
34+
35+
IntervalDb
36+
interval_field Interval.Interval
37+
deriving Eq Show
3238
|]
3339

34-
-- Postgres Interval has a 1 microsecond resolution, while NominalDiffTime has
35-
-- picosecond resolution. Round to the nearest microsecond so that we can be
36-
-- fine in the tests.
37-
truncate' :: NominalDiffTime -> NominalDiffTime
38-
truncate' x = (fromIntegral (round (x * 10 ^ 6))) / 10 ^ 6
40+
clamp :: (Ord a) => a -> a -> a -> a
41+
clamp lo hi = max lo . min hi
42+
43+
-- Before version 15, PostgreSQL can't parse all possible intervals.
44+
-- Each component is limited to the range of Int32.
45+
-- So anything beyond 2,147,483,647 hours will fail to parse.
46+
47+
microsecondLimit :: Int64
48+
microsecondLimit = 2147483647 * 60 * 60 * 1000000
3949

4050
specs :: Spec
4151
specs = do
4252
describe "Postgres Interval Property tests" $ do
43-
prop "Round trips" $ \time -> runConnAssert $ do
53+
prop "Round trips" $ \int64 -> runConnAssert $ do
4454
let
45-
eg = PgIntervalDb $ PgInterval (truncate' time)
55+
eg =
56+
PgIntervalDb
57+
. PgInterval
58+
. secondsToNominalDiffTime
59+
. (realToFrac :: Micro -> Pico)
60+
. MkFixed
61+
. toInteger
62+
$ clamp (-microsecondLimit) microsecondLimit int64
4663
rid <- insert eg
4764
r <- getJust rid
4865
liftIO $ r `shouldBe` eg
66+
67+
prop "interval round trips" $ \(m, d, u) -> runConnAssert $ do
68+
let
69+
expected =
70+
IntervalDb . Interval.MkInterval m d $
71+
clamp (-microsecondLimit) microsecondLimit u
72+
key <- insert expected
73+
actual <- getJust key
74+
liftIO $ actual `shouldBe` expected

0 commit comments

Comments
 (0)