Merge pull request #201 from input-output-hk/erikd/word128-outsum

db: Fix for the outsum column of the epoch table

Author: erikd

cardano-db/cardano-db.cabal

@@ -42,6 +42,7 @@ library
                         Cardano.Db.Run
                         Cardano.Db.Schema
                         Cardano.Db.Schema.Types
+                        Cardano.Db.Schema.Orphans
                         Cardano.Db.Types
 
 
@@ -76,6 +77,7 @@ library
                       , transformers
                       -- This is never intended to run on non-POSIX systems.
                       , unix
+                      , wide-word
 
 executable cardano-db-tool
   default-language:     Haskell2010
@@ -133,7 +135,9 @@ test-suite test
                       , aeson
                       , cardano-db
                       , cardano-ledger
+                      , persistent
                       , hedgehog
+                      , wide-word
 
 test-suite test-db
   default-language:     Haskell2010

cardano-db/src/Cardano/Db/Schema.hs

@@ -16,11 +16,14 @@
 
 module Cardano.Db.Schema where
 
+import Cardano.Db.Schema.Orphans ()
+
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word16, Word64)
+import Data.WideWord.Word128 (Word128)
 
 -- Do not use explicit imports from this module as the imports can change
 -- from version to version due to changes to the TH code in Persistent.
@@ -128,7 +131,7 @@ share
   -- hold 204 times the total Lovelace distribution. The chance of that much being transacted
   -- in a single epoch is relatively low.
   Epoch
-    outSum              Word64              sqltype=outsum
+    outSum              Word128             sqltype=word128
     txCount             Word64              sqltype=uinteger
     blkCount            Word64              sqltype=uinteger
     no                  Word64              sqltype=uinteger

cardano-db/src/Cardano/Db/Schema/Orphans.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.Db.Schema.Orphans where
+
+import Data.WideWord.Word128 (Word128)
+
+import qualified Data.Text as Text
+
+import Database.Persist.Class (PersistField (..))
+import Database.Persist.Types (PersistValue (..))
+
+
+instance PersistField Word128 where
+  toPersistValue = PersistText . Text.pack . show
+  fromPersistValue (PersistText bs) = Right $ read (Text.unpack bs)
+  fromPersistValue x =
+    Left $ mconcat [ "Failed to parse Haskell type Word128: ", Text.pack (show x) ]
+

cardano-db/test/Test/Property/Cardano/Db/Types.hs

@@ -9,6 +9,9 @@ import           Cardano.Chain.Common (maxLovelaceVal)
 
 import qualified Data.Aeson as Aeson
 import           Data.Word (Word64)
+import           Data.WideWord.Word128 (Word128 (..))
+
+import           Database.Persist.Class (PersistField (..))
 
 import           Cardano.Db
 
@@ -24,6 +27,12 @@ prop_roundtrip_Ada_via_JSON =
     mv <- H.forAll genAda
     H.tripping mv Aeson.encode Aeson.eitherDecode
 
+prop_roundtrip_Word128_PersistField :: Property
+prop_roundtrip_Word128_PersistField =
+  H.withTests 5000 . H.property $ do
+    w128 <- H.forAll genWord128
+    H.tripping w128 toPersistValue fromPersistValue
+
 -- -----------------------------------------------------------------------------
 
 genAda :: Gen Ada
@@ -38,6 +47,17 @@ genAda =
         , Gen.word64 (Range.linear (maxLovelaceVal - 5000) maxLovelaceVal) -- Near max.
         ]
 
+genWord128 :: Gen Word128
+genWord128 = Word128 <$> genWord64 <*> genWord64
+
+genWord64 :: Gen Word64
+genWord64 =
+  Gen.choice
+    [ Gen.word64 Range.constantBounded
+    , Gen.word64 (Range.linear 0 5000)           -- Small values
+    , Gen.word64 (Range.linear (maxBound - 5000) maxBound) -- Near max.
+    ]
+
 -- -----------------------------------------------------------------------------
 
 tests :: IO Bool

cardano-db/test/cardano-db-test.cabal

@@ -61,3 +61,4 @@ library
                       , transformers
                       -- This is never intended to run on non-POSIX systems.
                       , unix
+                      , wide-word

schema/migration-1-0001-20190730.sql

@@ -21,6 +21,10 @@ BEGIN
     -- Stake addresses are a 28 byte hash prepended with a byte describing the address.
     EXECUTE 'CREATE DOMAIN addr29type AS bytea CHECK (octet_length (VALUE) = 29);';
 
+    -- 'maxBound :: Word128' as a decimal has 39 digits, so we only need to check that it
+    -- is positive.
+    EXECUTE 'CREATE DOMAIN word128type AS numeric (38, 0) CHECK (VALUE >= 0);';
+
     UPDATE "schema_version" SET stage_one = 1;
     RAISE NOTICE 'DB has been migrated to stage_one version %', next_version;
   END IF;

schema/migration-1-0003-20200211.sql

@@ -9,8 +9,11 @@ BEGIN
   SELECT stage_one + 1 INTO next_version FROM "schema_version";
   IF next_version = 2 THEN
     -- Used as the sum of tx outputs for an epoch.
-    -- Need this to catch possible overflow.
-    EXECUTE 'CREATE DOMAIN outsum AS bigint CHECK (VALUE >= 0);';
+    -- Persistent does not support more precision than 'Int64' (support for 'Word64'
+    -- is done as a 'cast' to/from 'Int64' resulting in values greater than
+    -- 'maxBound :: Int64' being represented in the database as negative values.
+    -- Instead we we use 'Word128'.
+    EXECUTE 'CREATE DOMAIN outsum AS word128type;';
 
     UPDATE "schema_version" SET stage_one = next_version;
     RAISE NOTICE 'DB has been migrated to stage_one version %', next_version;