Improve handling of PostgreSQL intervals

.github/workflows/haskell.yml

@@ -86,7 +86,6 @@ jobs:
           restore-keys: |
             ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
             ${{ runner.os }}-${{ matrix.ghc }}-
-      - run: cabal v2-build all --disable-optimization --only-dependencies $CONFIG
       - run: cabal v2-build all --disable-optimization $CONFIG
       - run: cabal v2-test all --disable-optimization $CONFIG --test-options "--fail-on-focus"
       - run: cabal v2-bench all --disable-optimization $CONFIG

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Database.Persist.Postgresql.Internal
@@ -35,6 +36,7 @@ module Database.Persist.Postgresql.Internal
 import qualified Database.PostgreSQL.Simple as PG
 import qualified Database.PostgreSQL.Simple.FromField as PGFF
 import qualified Database.PostgreSQL.Simple.Internal as PG
+import qualified Database.PostgreSQL.Simple.Interval as Interval
 import qualified Database.PostgreSQL.Simple.ToField as PGTF
 import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS
 import qualified Database.PostgreSQL.Simple.Types as PG
@@ -46,29 +48,30 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadIO (..))
 import Control.Monad.Trans.Class (lift)
 import Data.Acquire (with)
-import qualified Data.Attoparsec.ByteString.Char8 as P
-import Data.Bits ((.&.))
+import Data.Bits (toIntegralSized)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Builder as BB
-import qualified Data.ByteString.Char8 as B8
-import Data.Char (ord)
 import Data.Conduit
 import qualified Data.Conduit.List as CL
 import Data.Data (Typeable)
 import Data.Either (partitionEithers)
-import Data.Fixed (Fixed (..), Pico)
+import Data.Fixed (Fixed (..), Micro, Pico)
 import Data.Function (on)
-import Data.Int (Int64)
 import qualified Data.IntMap as I
 import Data.List as List (find, foldl', groupBy, sort)
 import qualified Data.List.NonEmpty as NEL
 import qualified Data.Map as Map
 import Data.Maybe
-import Data.String.Conversions.Monomorphic (toStrictByteString)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
-import Data.Time (NominalDiffTime, localTimeToUTC, utc)
+import Data.Time
+    ( NominalDiffTime
+    , localTimeToUTC
+    , nominalDiffTimeToSeconds
+    , secondsToNominalDiffTime
+    , utc
+    )
 import Database.Persist.Sql
 import qualified Database.Persist.Sql.Util as Util
 
@@ -165,7 +168,7 @@ builtinGetters =
         , (k PS.time, convertPV PersistTimeOfDay)
         , (k PS.timestamp, convertPV (PersistUTCTime . localTimeToUTC utc))
         , (k PS.timestamptz, convertPV PersistUTCTime)
-        , (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs))
+        , (k PS.interval, convertPV $ toPersistValue @Interval.Interval)
         , (k PS.bit, convertPV PersistInt64)
         , (k PS.varbit, convertPV PersistInt64)
         , (k PS.numeric, convertPV PersistRational)
@@ -195,7 +198,7 @@ builtinGetters =
         , (1183, listOf PersistTimeOfDay)
         , (1115, listOf PersistUTCTime)
         , (1185, listOf PersistUTCTime)
-        , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs))
+        , (1187, listOf $ toPersistValue @Interval.Interval)
         , (1561, listOf PersistInt64)
         , (1563, listOf PersistInt64)
         , (1231, listOf PersistRational)
@@ -234,113 +237,49 @@ unBinary (PG.Binary x) = x
 -- | Represent Postgres interval using NominalDiffTime
 --
 -- @since 2.11.0.0
+--
+-- Note that this type cannot be losslessly round tripped through PostgreSQL.
+-- For example the value @'PgInterval' 0.0000009@ will truncate extra
+-- precision. And the value @'PgInterval'  9223372036854.775808@ will overflow.
+-- Use the 'Interval.Interval' type if that is a problem for you.
 newtype PgInterval = PgInterval {getPgInterval :: NominalDiffTime}
     deriving (Eq, Show)
 
-pgIntervalToBs :: PgInterval -> ByteString
-pgIntervalToBs = toStrictByteString . show . getPgInterval
-
 instance PGTF.ToField PgInterval where
-    toField (PgInterval t) = PGTF.toField t
+    toField = PGTF.toField . pgIntervalToInterval
 
 instance PGFF.FromField PgInterval where
-    fromField f mdata =
-        if PGFF.typeOid f /= PS.typoid PS.interval
-            then PGFF.returnError PGFF.Incompatible f ""
-            else case mdata of
-                Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""
-                Just dat -> case P.parseOnly (nominalDiffTime <* P.endOfInput) dat of
-                    Left msg -> PGFF.returnError PGFF.ConversionFailed f msg
-                    Right t -> return $ PgInterval t
-      where
-        toPico :: Integer -> Pico
-        toPico = MkFixed
-
-        -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser
-        twoDigits :: P.Parser Int
-        twoDigits = do
-            a <- P.digit
-            b <- P.digit
-            let
-                c2d c = ord c .&. 15
-            return $! c2d a * 10 + c2d b
-
-        -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser
-        seconds :: P.Parser Pico
-        seconds = do
-            real <- twoDigits
-            mc <- P.peekChar
-            case mc of
-                Just '.' -> do
-                    t <- P.anyChar *> P.takeWhile1 P.isDigit
-                    return $! parsePicos (fromIntegral real) t
-                _ -> return $! fromIntegral real
-          where
-            parsePicos :: Int64 -> B8.ByteString -> Pico
-            parsePicos a0 t = toPico (fromIntegral (t' * 10 ^ n))
-              where
-                n = max 0 (12 - B8.length t)
-                t' =
-                    B8.foldl'
-                        (\a c -> 10 * a + fromIntegral (ord c .&. 15))
-                        a0
-                        (B8.take 12 t)
-
-        parseSign :: P.Parser Bool
-        parseSign = P.choice [P.char '-' >> return True, return False]
-
-        -- Db stores it in [-]HHH:MM:SS.[SSSS]
-        -- For example, nominalDay is stored as 24:00:00
-        interval :: P.Parser (Bool, Int, Int, Pico)
-        interval = do
-            s <- parseSign
-            h <- P.decimal <* P.char ':'
-            m <- twoDigits <* P.char ':'
-            ss <- seconds
-            if m < 60 && ss <= 60
-                then return (s, h, m, ss)
-                else fail "Invalid interval"
-
-        nominalDiffTime :: P.Parser NominalDiffTime
-        nominalDiffTime = do
-            (s, h, m, ss) <- interval
-            let
-                pico = ss + 60 * (fromIntegral m) + 60 * 60 * (fromIntegral (abs h))
-            return . fromRational . toRational $ if s then (-pico) else pico
-
-fromPersistValueError
-    :: Text
-    -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
-    -> Text
-    -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
-    -> PersistValue
-    -- ^ Incorrect value
-    -> Text
-    -- ^ Error message
-fromPersistValueError haskellType databaseType received =
-    T.concat
-        [ "Failed to parse Haskell type `"
-        , haskellType
-        , "`; expected "
-        , databaseType
-        , " from database, but received: "
-        , T.pack (show received)
-        , ". Potential solution: Check that your database schema matches your Persistent model definitions."
-        ]
+    fromField f =
+        maybe (PGFF.returnError PGFF.ConversionFailed f "invalid interval") pure
+            . intervalToPgInterval
+            <=< PGFF.fromField f
 
 instance PersistField PgInterval where
-    toPersistValue = PersistLiteralEscaped . pgIntervalToBs
-    fromPersistValue (PersistLiteral_ DbSpecific bs) =
-        fromPersistValue (PersistLiteralEscaped bs)
-    fromPersistValue x@(PersistLiteral_ Escaped bs) =
-        case P.parseOnly (P.signed P.rational <* P.char 's' <* P.endOfInput) bs of
-            Left _ -> Left $ fromPersistValueError "PgInterval" "Interval" x
-            Right i -> Right $ PgInterval i
-    fromPersistValue x = Left $ fromPersistValueError "PgInterval" "Interval" x
+    toPersistValue =
+        toPersistValue
+            . pgIntervalToInterval
+    fromPersistValue =
+        maybe (Left "invalid interval") pure
+            . intervalToPgInterval
+            <=< fromPersistValue
 
 instance PersistFieldSql PgInterval where
     sqlType _ = SqlOther "interval"
 
+pgIntervalToInterval :: PgInterval -> Interval.Interval
+pgIntervalToInterval =
+    Interval.fromTimeSaturating mempty
+        . getPgInterval
+
+intervalToPgInterval :: Interval.Interval -> Maybe PgInterval
+intervalToPgInterval interval =
+    let
+        (calendarDiffDays, nominalDiffTime) = Interval.intoTime interval
+     in
+        if calendarDiffDays == mempty
+            then Just $ PgInterval nominalDiffTime
+            else Nothing
+
 -- | Indicates whether a Postgres Column is safe to drop.
 --
 -- @since 2.17.1.0

persistent-postgresql/persistent-postgresql.cabal

@@ -28,6 +28,7 @@ library
     , persistent          >=2.13.3  && <3
     , postgresql-libpq    >=0.9.4.2 && <0.12
     , postgresql-simple   >=0.6.1   && <0.8
+    , postgresql-simple-interval ==0.2025.9.5
     , resource-pool
     , resourcet           >=1.1.9
     , string-conversions
@@ -82,6 +83,7 @@ test-suite test
     , persistent-postgresql
     , persistent-qq
     , persistent-test
+    , postgresql-simple-interval
     , QuickCheck
     , quickcheck-instances
     , resourcet

persistent-postgresql/test/PgIntervalTest.hs

@@ -17,8 +17,10 @@
 
 module PgIntervalTest where
 
-import Data.Time.Clock (NominalDiffTime)
+import Data.Fixed (Fixed (MkFixed), Micro, Pico)
+import Data.Time.Clock (secondsToNominalDiffTime)
 import Database.Persist.Postgresql (PgInterval (..))
+import qualified Database.PostgreSQL.Simple.Interval as Interval
 import PgInit
 import Test.Hspec.QuickCheck
 
@@ -29,20 +31,44 @@ PgIntervalDb
     interval_field PgInterval
     deriving Eq
     deriving Show
+
+IntervalDb
+    interval_field Interval.Interval
+    deriving Eq Show
 |]
 
--- Postgres Interval has a 1 microsecond resolution, while NominalDiffTime has
--- picosecond resolution. Round to the nearest microsecond so that we can be
--- fine in the tests.
-truncate' :: NominalDiffTime -> NominalDiffTime
-truncate' x = (fromIntegral (round (x * 10 ^ 6))) / 10 ^ 6
+clamp :: (Ord a) => a -> a -> a -> a
+clamp lo hi = max lo . min hi
+
+-- Before version 15, PostgreSQL can't parse all possible intervals.
+-- Each component is limited to the range of Int32.
+-- So anything beyond 2,147,483,647 hours will fail to parse.
+
+microsecondLimit :: Int64
+microsecondLimit = 2147483647 * 60 * 60 * 1000000
 
 specs :: Spec
 specs = do
     describe "Postgres Interval Property tests" $ do
-        prop "Round trips" $ \time -> runConnAssert $ do
+        prop "Round trips" $ \int64 -> runConnAssert $ do
             let
-                eg = PgIntervalDb $ PgInterval (truncate' time)
+                eg =
+                    PgIntervalDb
+                        . PgInterval
+                        . secondsToNominalDiffTime
+                        . (realToFrac :: Micro -> Pico)
+                        . MkFixed
+                        . toInteger
+                        $ clamp (-microsecondLimit) microsecondLimit int64
             rid <- insert eg
             r <- getJust rid
             liftIO $ r `shouldBe` eg
+
+        prop "interval round trips" $ \(m, d, u) -> runConnAssert $ do
+            let
+                expected =
+                    IntervalDb . Interval.MkInterval m d $
+                        clamp (-microsecondLimit) microsecondLimit u
+            key <- insert expected
+            actual <- getJust key
+            liftIO $ actual `shouldBe` expected