diff --git a/cabal.project b/cabal.project index 76dc711de..447eb5faa 100644 --- a/cabal.project +++ b/cabal.project @@ -8,6 +8,10 @@ packages: persistent-redis persistent-qq +constraints: + -- https://github.com/mongodb-haskell/mongodb/pull/152 + mongoDB < 2.7.1.3 + -- GHC 9.4 shims for persistent -- These need hackage revisions but otherwise test fine in the repo diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 9d5510f28..ceb25f41a 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for persistent +## 2.14.6.1 + +* [#1528](https://github.com/yesodweb/persistent/pull/1528) + * The `PersistField Int{,8,16,32,64}` instances will now work with a + `PersistRational`, provided that the denominator is 1. This fixes the bug + where `SUM` in Postgres would change the type of a column being summed. + ## 2.14.6.0 * [#1477](https://github.com/yesodweb/persistent/pull/1477) diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index 560df6e77..1220e9e6a 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -33,6 +33,7 @@ import Numeric.Natural (Natural) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) import GHC.TypeLits +import Data.Ratio (numerator, denominator) import Database.Persist.Types.Base @@ -135,49 +136,49 @@ instance PersistField Html where instance PersistField Int where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int) -- oracle - fromPersistValue x = Left $ fromPersistValueError "Int" "integer" x + fromPersistValue = fromPersistValueIntegral "Int" "integer" instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int8" "integer" x + fromPersistValue = fromPersistValueIntegral "Int8" "integer" instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int16" "integer" x + fromPersistValue = fromPersistValueIntegral "Int16" "integer" instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int32" "integer" x + fromPersistValue = fromPersistValueIntegral "Int32" "integer" instance PersistField Int64 where toPersistValue = PersistInt64 - fromPersistValue (PersistInt64 i) = Right i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int64" "integer" x + fromPersistValue = fromPersistValueIntegral "Int64" "integer" + +fromPersistValueIntegral :: Integral a => Text -> Text -> PersistValue -> Either Text a +fromPersistValueIntegral haskellType sqlType pv = case pv of + PersistInt64 i -> + Right (fromIntegral i) + PersistDouble i -> + Right $ truncate i -- oracle + PersistRational i -> + case denominator i of + 1 -> + Right $ fromIntegral $ numerator i + _denom -> + boom + PersistByteString bs -> + case readInt bs of -- oracle + Just (i,"") -> + Right $ fromIntegral i + Just (i,extra) -> + Left $ extraInputError haskellType bs i extra + Nothing -> + Left $ intParseError haskellType bs + _ -> + boom + where + boom = + Left $ fromPersistValueError haskellType sqlType pv extraInputError :: (Show result) => Text -- ^ Haskell type diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 605401cb9..e50010262 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.6.0 +version: 2.14.6.1 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/stack.yaml b/stack.yaml index cc3a58e26..6988c907d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,3 +9,6 @@ packages: - ./persistent-postgresql - ./persistent-redis - ./persistent-qq + +extra-deps: + - attoparsec-aeson-2.1.0.0