diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index aab41f640..5049a8d9c 100644 --- a/.github/workflows/haskell.yml +++ b/.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 diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index b91d977df..4500e1aac 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,14 @@ # Changelog for persistent-postgresql +## 2.14.0.0 + +* [#1604](https://github.com/yesodweb/persistent/pull/1604) + * Changed the representation of intervals to use the `Interval` type from [the `postgresql-simple-interval` package](https://hackage.haskell.org/package/postgresql-simple-interval). + This changes the behavior of `PgInterval` for very small and very large values. + * Previously `PgInterval 0.000_000_9` would be rounded to `0.000_001` seconds, but now it is truncated to 0 seconds. + * 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. + * The SQL representation of `PgInterval` now always includes the `interval` prefix, like `interval '1 second'`. + ## 2.13.7.0 * [#1600](https://github.com/yesodweb/persistent/pull/1600) diff --git a/persistent-postgresql/Database/Persist/Postgresql/Internal.hs b/persistent-postgresql/Database/Persist/Postgresql/Internal.hs index 4d4f57fdc..e4092e876 100644 --- a/persistent-postgresql/Database/Persist/Postgresql/Internal.hs +++ b/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) @@ -233,114 +236,50 @@ unBinary (PG.Binary x) = x -- | Represent Postgres interval using NominalDiffTime -- +-- 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. +-- -- @since 2.11.0.0 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 diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 992d7b7e6..982715227 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/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 >=1 && < 1.1 , 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 diff --git a/persistent-postgresql/test/PgIntervalTest.hs b/persistent-postgresql/test/PgIntervalTest.hs index 2e5cd4105..0c42ade68 100644 --- a/persistent-postgresql/test/PgIntervalTest.hs +++ b/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