From 6b3c42d653db1482027b1c54587402fbea9c45b6 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Sun, 5 Jul 2020 15:59:08 +1000 Subject: [PATCH 1/7] Add proper support for Word64 Previously when the schema used `Word64` as the column type, Persistent would use `SqlInt64` as the SQL representation which means that `Word64` values above `maxBound :: Int64` would be stored as negative values in the database. That is fine for a database only accessed from Haskell but is a pain in the neck when the database is used as an interop layer for other languages. This commit fixes these issues by adding `SqlWord64` and `PersistWord64`. Closes: https://github.com/yesodweb/persistent/issues/1095 --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 ++ persistent/Database/Persist/Class/PersistField.hs | 8 +++++++- persistent/Database/Persist/Sql/Class.hs | 2 +- persistent/Database/Persist/Sql/Orphan/PersistQuery.hs | 2 ++ persistent/Database/Persist/Sql/Orphan/PersistStore.hs | 3 +++ persistent/Database/Persist/Types/Base.hs | 7 ++++++- 6 files changed, 21 insertions(+), 3 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 5f8777f1a..54274eada 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -428,6 +428,7 @@ instance PGTF.ToField P where toField (P (PersistText t)) = PGTF.toField t toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) toField (P (PersistInt64 i)) = PGTF.toField i + toField (P (PersistWord64 i)) = PGTF.toField i toField (P (PersistDouble d)) = PGTF.toField d toField (P (PersistRational r)) = PGTF.Plain $ BBB.fromString $ @@ -1110,6 +1111,7 @@ showSqlType :: SqlType -> Text showSqlType SqlString = "VARCHAR" showSqlType SqlInt32 = "INT4" showSqlType SqlInt64 = "INT8" +showSqlType SqlWord64 = "NUMERIC(20,0)" -- length (show (maxBound :: Word64)) == 20 showSqlType SqlReal = "DOUBLE PRECISION" showSqlType (SqlNumeric s prec) = T.concat [ "NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")" ] showSqlType SqlDay = "DATE" diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index 9a62045fe..44bf2c367 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -19,6 +19,7 @@ import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.IntMap as IM import qualified Data.Map as M import Data.Monoid ((<>)) +import Data.Ratio (denominator, numerator) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -101,6 +102,7 @@ instance {-# OVERLAPPING #-} PersistField [Char] where fromPersistValue (PersistByteString bs) = Right $ T.unpack $ TE.decodeUtf8With TERR.lenientDecode bs fromPersistValue (PersistInt64 i) = Right $ Prelude.show i + fromPersistValue (PersistWord64 i) = Right $ Prelude.show i fromPersistValue (PersistDouble d) = Right $ Prelude.show d fromPersistValue (PersistRational r) = Right $ Prelude.show r fromPersistValue (PersistDay d) = Right $ Prelude.show d @@ -226,8 +228,12 @@ instance PersistField Word32 where fromPersistValue x = Left $ fromPersistValueError "Word32" "integer" x instance PersistField Word64 where - toPersistValue = PersistInt64 . fromIntegral + toPersistValue = PersistWord64 . fromIntegral + fromPersistValue (PersistWord64 w) = Right $ fromIntegral w fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x@(PersistRational r) = if denominator r == 1 + then Right $ fromIntegral (numerator r) + else Left $ fromPersistValueError "Word64" "rational" x fromPersistValue x = Left $ fromPersistValueError "Word64" "integer" x instance PersistField Double where diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs index 22ed8b983..57400b320 100644 --- a/persistent/Database/Persist/Sql/Class.hs +++ b/persistent/Database/Persist/Sql/Class.hs @@ -1203,7 +1203,7 @@ instance PersistFieldSql Word16 where instance PersistFieldSql Word32 where sqlType _ = SqlInt64 instance PersistFieldSql Word64 where - sqlType _ = SqlInt64 + sqlType _ = SqlWord64 instance PersistFieldSql Double where sqlType _ = SqlReal instance PersistFieldSql Bool where diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 696bcb95d..e326c917b 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -46,6 +46,7 @@ instance PersistQueryRead SqlBackend where mm <- CL.head case mm of Just [PersistInt64 i] -> return $ fromIntegral i + Just [PersistWord64 i] -> return $ fromIntegral i Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle Just [PersistByteString i] -> case readInteger i of -- gb mssql Just (ret,"") -> return $ fromIntegral ret @@ -116,6 +117,7 @@ instance PersistQueryRead SqlBackend where Nothing -> case xs of [PersistInt64 x] -> return [PersistInt64 x] + [PersistWord64 x] -> return [PersistWord64 x] [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double _ -> return xs Just pdef -> diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index dfc51e87c..f2302d6f8 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -155,6 +155,9 @@ instance PersistStoreWrite SqlBackend where Just [PersistInt64 i] -> case keyFromValues [PersistInt64 i] of Left err -> error $ "SQL insert: keyFromValues: PersistInt64 " `mappend` show i `mappend` " " `mappend` unpack err Right k -> return k + Just [PersistWord64 i] -> case keyFromValues [PersistWord64 i] of + Left err -> error $ "SQL insert: keyFromValues: PersistWord64 " `mappend` show i `mappend` " " `mappend` unpack err + Right k -> return k Nothing -> error $ "SQL insert did not return a result giving the generated ID" Just vals' -> case keyFromValues vals' of Left e -> error $ "Invalid result from a SQL insert, got: " ++ show vals' ++ ". Error was: " ++ unpack e diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index f8686151e..0023be468 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -22,7 +22,7 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Time (Day, TimeOfDay, UTCTime) import Data.Typeable (Typeable) import qualified Data.Vector as V -import Data.Word (Word32) +import Data.Word (Word32, Word64) import Numeric (showHex, readHex) import Web.PathPieces (PathPiece(..)) import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData) @@ -368,6 +368,7 @@ instance Error PersistException where data PersistValue = PersistText Text | PersistByteString ByteString | PersistInt64 Int64 + | PersistWord64 Word64 -- @since 2.11.0 | PersistDouble Double | PersistRational Rational | PersistBool Bool @@ -417,6 +418,7 @@ instance ToHttpApiData PersistValue where instance FromHttpApiData PersistValue where parseUrlPiece input = PersistInt64 <$> parseUrlPiece input + PersistWord64 <$> parseUrlPiece input PersistList <$> readTextData input PersistText <$> return input where @@ -433,6 +435,7 @@ fromPersistValueText (PersistText s) = Right s fromPersistValueText (PersistByteString bs) = Right $ TE.decodeUtf8With lenientDecode bs fromPersistValueText (PersistInt64 i) = Right $ T.pack $ show i +fromPersistValueText (PersistWord64 w) = Right $ T.pack $ show w fromPersistValueText (PersistDouble d) = Right $ T.pack $ show d fromPersistValueText (PersistRational r) = Right $ T.pack $ show r fromPersistValueText (PersistDay d) = Right $ T.pack $ show d @@ -450,6 +453,7 @@ instance A.ToJSON PersistValue where toJSON (PersistText t) = A.String $ T.cons 's' t toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b toJSON (PersistInt64 i) = A.Number $ fromIntegral i + toJSON (PersistWord64 w) = A.Number $ fromIntegral w toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r toJSON (PersistBool b) = A.Bool b @@ -534,6 +538,7 @@ data SqlType = SqlString | SqlTime | SqlDayTime -- ^ Always uses UTC timezone | SqlBlob + | SqlWord64 -- @since 2.11.0 | SqlOther T.Text -- ^ a backend-specific name deriving (Show, Read, Eq, Typeable, Ord) From a7ee9163254dcff384657b3b40bb3b41666b04ca Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Sun, 5 Jul 2020 16:42:00 +1000 Subject: [PATCH 2/7] Update Changelog --- persistent-postgresql/ChangeLog.md | 2 ++ persistent/ChangeLog.md | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index fdbaaa7fe..ee6cf1796 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -11,6 +11,8 @@ * added `runConn_` to run a db connection and return result * Renamed `db` to `runConnAssert` in `test/PgInit.hs` for clarity * Ran `test/ArrayAggTest.hs` (which was previously written but not being run) +* [#1096](https://github.com/yesodweb/persistent/pull/1096) + * Add proper support for `Word64`. ## 2.10.1.2 diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index c6c8844e3..8720b55b0 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -20,6 +20,8 @@ * Fix a bug where unsafe migration error messages were being shown using `Show` prior to printing, resulting in less helpful output. [#1080](https://github.com/yesodweb/persistent/pull/1080) * [#1087](https://github.com/yesodweb/persistent/pull/1087) * `RawSql` now has tuple instances up to GHC's max tuple size (62) +* [#1096](https://github.com/yesodweb/persistent/pull/1096) + * Add proper support for `Word64`. ## 2.10.5.2 @@ -30,7 +32,7 @@ ## 2.10.5.1 * [#1024](https://github.com/yesodweb/persistent/pull/1024) - * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. + * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. * Add Haddock explainers for some of the supported entity syntax in `Database.Persist.Quasi` ## 2.10.5 From b3fcf1574e35eb5e15528719ea723fbdb995cc9a Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 6 Jul 2020 09:08:05 +1000 Subject: [PATCH 3/7] wip --- persistent-mongoDB/Database/Persist/MongoDB.hs | 1 + persistent-mysql/Database/Persist/MySQL.hs | 1 + persistent-redis/Database/Persist/Redis/Parser.hs | 10 +++++++--- persistent-sqlite/Database/Persist/Sqlite.hs | 1 + 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index d68e68966..ad71e275a 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -1024,6 +1024,7 @@ keyToOid = unMongoKey . toBackendKey instance DB.Val PersistValue where val (PersistInt64 x) = DB.Int64 x + val (PersistWord64 x) = DB.Word64 x val (PersistText x) = DB.String x val (PersistDouble x) = DB.Float x val (PersistBool x) = DB.Bool x diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 973eabd57..e714ebe6d 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -225,6 +225,7 @@ instance MySQL.Param P where render (P (PersistText t)) = MySQL.render t render (P (PersistByteString bs)) = MySQL.render bs render (P (PersistInt64 i)) = MySQL.render i + render (P (PersistWord64 i)) = MySQL.render i render (P (PersistDouble d)) = MySQL.render d render (P (PersistBool b)) = MySQL.render b render (P (PersistDay d)) = MySQL.render d diff --git a/persistent-redis/Database/Persist/Redis/Parser.hs b/persistent-redis/Database/Persist/Redis/Parser.hs index f75490ac3..52f6a8924 100644 --- a/persistent-redis/Database/Persist/Redis/Parser.hs +++ b/persistent-redis/Database/Persist/Redis/Parser.hs @@ -16,7 +16,7 @@ import Data.Int (Int64) import Data.Text (Text, unpack) import qualified Data.Text as T import Data.Time -import Data.Word (Word8) +import Data.Word (Word8, Word64) import Database.Persist.Types import Database.Persist.Redis.Exception @@ -126,6 +126,10 @@ instance Binary BinPersistValue where put (12 :: Word8) put x + put (BinPersistValue (PersistWord64 x)) = do + put (13 :: Word8) + put x + put (BinPersistValue (PersistArray _)) = throw $ NotSupportedValueType "PersistArray" put (BinPersistValue (PersistDbSpecific _)) = throw $ NotSupportedValueType "PersistDbSpecific" put (BinPersistValue (PersistObjectId _)) = throw $ NotSupportedValueType "PersistObjectId" @@ -149,7 +153,7 @@ instance Binary BinPersistValue where 10-> liftM (PersistList . map unBinPersistValue) (Q.get :: Get [BinPersistValue]) 11-> liftM (PersistMap . map (unBinText *** unBinPersistValue)) (Q.get :: Get [(BinText, BinPersistValue)]) 12-> liftM PersistRational (Q.get :: Get Rational) --- 13-> liftM (PersistZonedTime . unBinZT) (Q.get :: Get BinZT) + 13-> liftM PersistWord64 (Q.get :: Get Word64) z -> throw $ ParserError ("Incorrect tag " ++ show z ++ " came to Binary deserialization") liftM BinPersistValue pv @@ -160,4 +164,4 @@ castOne :: B.ByteString -> PersistValue castOne = unBinPersistValue . Q.decode . L.fromStrict redisToPerisistValues :: [(B.ByteString, B.ByteString)] -> [PersistValue] -redisToPerisistValues = map (castOne . snd) \ No newline at end of file +redisToPerisistValues = map (castOne . snd) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 51e90fe59..99dbe0e8d 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -382,6 +382,7 @@ showSqlType :: SqlType -> Text showSqlType SqlString = "VARCHAR" showSqlType SqlInt32 = "INTEGER" showSqlType SqlInt64 = "INTEGER" +showSqlType SqlWord64 = "INTEGER" showSqlType SqlReal = "REAL" showSqlType (SqlNumeric precision scale) = T.concat [ "NUMERIC(", T.pack (show precision), ",", T.pack (show scale), ")" ] showSqlType SqlDay = "DATE" From 54e09793bf4d01fa8f0149189f68a5522eb37e1b Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 6 Jul 2020 12:04:42 +1000 Subject: [PATCH 4/7] wip --- persistent-mongoDB/Database/Persist/MongoDB.hs | 2 +- persistent-mysql/Database/Persist/MySQL.hs | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index ad71e275a..a138949d1 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -1024,7 +1024,6 @@ keyToOid = unMongoKey . toBackendKey instance DB.Val PersistValue where val (PersistInt64 x) = DB.Int64 x - val (PersistWord64 x) = DB.Word64 x val (PersistText x) = DB.String x val (PersistDouble x) = DB.Float x val (PersistBool x) = DB.Bool x @@ -1041,6 +1040,7 @@ instance DB.Val PersistValue where val (PersistByteString x) = DB.Bin (DB.Binary x) val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "PersistTimeOfDay not implemented for the MongoDB backend. only PersistUTCTime currently implemented" + val (PersistWord64 _) = throw $ PersistMongoDBUnsupported "PersistWord64 not implemented for the MongoDB backend" val (PersistRational _) = throw $ PersistMongoDBUnsupported "PersistRational not implemented for the MongoDB backend" val (PersistArray a) = DB.val $ PersistList a val (PersistDbSpecific _) = throw $ PersistMongoDBUnsupported "PersistDbSpecific not implemented for the MongoDB backend" diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index e714ebe6d..87b94077d 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -786,6 +786,7 @@ showSqlType SqlDay _ _ = "DATE" showSqlType SqlDayTime _ _ = "DATETIME" showSqlType SqlInt32 _ _ = "INT(11)" showSqlType SqlInt64 _ _ = "BIGINT" +showSqlType SqlWord64 _ _ = "NUMERIC(20,0)" -- length (show (maxBound :: Word64)) showSqlType SqlReal _ _ = "DOUBLE" showSqlType (SqlNumeric s prec) _ _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")" showSqlType SqlString Nothing True = "TEXT CHARACTER SET utf8mb4" From 71fc9855c4eed08dfba4bdee6e129396910a4271 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 6 Jul 2020 15:44:32 +1000 Subject: [PATCH 5/7] wip --- persistent/Database/Persist/Class/PersistField.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index 44bf2c367..7de6331f7 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -234,6 +234,9 @@ instance PersistField Word64 where fromPersistValue x@(PersistRational r) = if denominator r == 1 then Right $ fromIntegral (numerator r) else Left $ fromPersistValueError "Word64" "rational" x + fromPersistValue x@(PersistDouble d) = if d == floor d + then Right $ floor d + else Left $ fromPersistValueError "Word64" "double" x fromPersistValue x = Left $ fromPersistValueError "Word64" "integer" x instance PersistField Double where From 4ee1d40a56333e6787784e17873ddb9d831b7f72 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 6 Jul 2020 15:51:02 +1000 Subject: [PATCH 6/7] wip --- persistent/Database/Persist/Class/PersistField.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index 7de6331f7..5818e8cf2 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -234,7 +234,7 @@ instance PersistField Word64 where fromPersistValue x@(PersistRational r) = if denominator r == 1 then Right $ fromIntegral (numerator r) else Left $ fromPersistValueError "Word64" "rational" x - fromPersistValue x@(PersistDouble d) = if d == floor d + fromPersistValue x@(PersistDouble d) = if ceiling d == (floor d :: Integer) then Right $ floor d else Left $ fromPersistValueError "Word64" "double" x fromPersistValue x = Left $ fromPersistValueError "Word64" "integer" x From 2babbc4b2bba7d77fd9d9d2fe9d023ad626b115d Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 6 Jul 2020 17:51:40 +1000 Subject: [PATCH 7/7] wip --- persistent/Database/Persist/Class/PersistField.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index 5818e8cf2..88f52290d 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -234,9 +234,7 @@ instance PersistField Word64 where fromPersistValue x@(PersistRational r) = if denominator r == 1 then Right $ fromIntegral (numerator r) else Left $ fromPersistValueError "Word64" "rational" x - fromPersistValue x@(PersistDouble d) = if ceiling d == (floor d :: Integer) - then Right $ floor d - else Left $ fromPersistValueError "Word64" "double" x + fromPersistValue x@(PersistDouble 0.0) = Right 0 fromPersistValue x = Left $ fromPersistValueError "Word64" "integer" x instance PersistField Double where