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: #1095

Author: erikd

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"

persistent/Database/Persist/Class/PersistField.hs

@@ -101,6 +101,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,7 +227,8 @@ 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 = Left $ fromPersistValueError "Word64" "integer" x
 

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

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 ->

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

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)