Merge pull request #844 from input-output-hk/nhenin/burn-roletokens

Burn roles tokens
input-output-hk · Apr 11, 2024 · 642ebc0 · 642ebc0
2 parents 577ccae + 9df612d
commit 642ebc0
Show file tree

Hide file tree

Showing 138 changed files with 8,613 additions and 2,877 deletions.
diff --git a/marlowe-chain-sync/.golden/ChainSeekQuery/golden b/marlowe-chain-sync/.golden/ChainSeekQuery/golden
@@ -2,6 +2,18 @@ Show: MsgDone Nothing
 Binary: 0000
 Show: MsgRequest Nothing (ReqBin (ReqLeaf GetSecurityParameter) (ReqLeaf GetSecurityParameter))
 Binary: 01000100010001
+Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsBabbage (fromList [""])))
+Binary: 0100000a0000000000000000010000000000000000
+Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsBabbage (fromList ["61"])))
+Binary: 0100000a000000000000000001000000000000000161
+Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsBabbage (fromList [])))
+Binary: 0100000a000000000000000000
+Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsConway (fromList [""])))
+Binary: 0100000a0100000000000000010000000000000000
+Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsConway (fromList ["61"])))
+Binary: 0100000a010000000000000001000000000000000161
+Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsConway (fromList [])))
+Binary: 0100000a010000000000000000
 Show: MsgRequest Nothing (ReqLeaf (GetUTxOs (GetUTxOsAtAddresses (fromList [""]))))
 Binary: 010000060100000000000000010000000000000000
 Show: MsgRequest Nothing (ReqLeaf (GetUTxOs (GetUTxOsAtAddresses (fromList ["61"]))))
@@ -128,6 +140,18 @@ Show: MsgRespond (UTxOs {unUTxOs = fromList [(TxOutRef {txId = "61", txIx = TxIx
 Binary: 000000000000000100000000000000016100010000000000000000000000000000000100000000000000000000
 Show: MsgRespond (UTxOs {unUTxOs = fromList []})
 Binary: 0000000000000000
+Show: MsgRespond (fromList [("",ScriptInEra PlutusScriptV1InBabbage (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))])
+Binary: 0000000000000001000000000000000000000000000000084701000022220011
+Show: MsgRespond (fromList [("",ScriptInEra PlutusScriptV1InConway (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))])
+Binary: 0000000000000001000000000000000000000000000000084701000022220011
+Show: MsgRespond (fromList [("61",ScriptInEra PlutusScriptV1InBabbage (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))])
+Binary: 000000000000000100000000000000016100000000000000084701000022220011
+Show: MsgRespond (fromList [("61",ScriptInEra PlutusScriptV1InConway (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))])
+Binary: 000000000000000100000000000000016100000000000000084701000022220011
+Show: MsgRespond (fromList [])
+Binary: 0000000000000000
+Show: MsgRespond (fromList [])
+Binary: 0000000000000000
 Show: MsgRespond 1
 Binary: 0000000000000001
 Show: MsgRespond Genesis

diff --git a/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer.hs b/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer.hs
@@ -152,6 +152,16 @@ renderDatabaseSelectorOTel dbName dbUser host port = \case
   CopyTxIns -> renderCopy "txIn"
   CopyAssetOuts -> renderCopy "assetOut"
   CopyAssetMints -> renderCopy "assetMint"
+  CopyScripts ->
+    OTelRendered
+      { eventName = "INSERT INTO chain.script"
+      , eventKind = Internal
+      , renderField = \rows ->
+          standardAttributes
+            <> [ ("db.statement", "INSERT INTO chain.script VALUES (?,?,?) ON CONFLICT (id) DO NOTHING")
+               , ("db.rowsAffected", toAttribute rows)
+               ]
+      }
   where
     standardAttributes =
       catMaybes

diff --git a/...owe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs b/...owe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs
@@ -57,17 +57,21 @@ import Data.ByteString.Short (fromShort, toShort)
 import Data.Csv (ToRecord)
 import Data.Csv.Incremental (Builder, encode, encodeRecord)
 import Data.Foldable (traverse_)
+import Data.Function (on)
 import Data.Int (Int64)
+import Data.List (nubBy)
 import Data.Profunctor (rmap)
 import qualified Data.Set as Set
 import Data.String (IsString (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Vector (Vector)
 import qualified Data.Vector as V
+import Database.PostgreSQL.Simple (executeMany)
 import qualified Database.PostgreSQL.Simple as PS
 import Database.PostgreSQL.Simple.Copy (copy, putCopyData, putCopyEnd, putCopyError)
 import qualified Database.PostgreSQL.Simple.Internal as PS
+import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Transaction (withTransactionSerializable)
 import qualified Database.PostgreSQL.Simple.Types as PS
 import Hasql.Connection (withLibPQConnection)
@@ -117,6 +121,7 @@ data QuerySelector f where
   CopyTxIns :: QuerySelector Int64
   CopyAssetOuts :: QuerySelector Int64
   CopyAssetMints :: QuerySelector Int64
+  CopyScripts :: QuerySelector Int64
 
 data QueryField
   = SqlStatement ByteString
@@ -331,7 +336,7 @@ commitBlocks
 commitBlocks runInIO = CommitBlocks \blocks -> do
   liftIO $ runInIO $ logInfo $ "Saving " <> T.pack (show $ length blocks) <> " blocks"
   let blockGroups = blockToRows <$> blocks
-  let (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows) = flattenBlockGroups blockGroups
+  let (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows, scripts) = flattenBlockGroups blockGroups
   sessionConnection <- ask
   liftIO $ withLibPQConnection sessionConnection \libPqConnection -> do
     connectionHandle <- newMVar libPqConnection
@@ -345,26 +350,34 @@ commitBlocks runInIO = CommitBlocks \blocks -> do
       runInIO $ copyTxIns connection txInRows
       runInIO $ copyAssetOuts connection assetOutRows
       runInIO $ copyAssetMints connection assetMintRows
+      runInIO $ copyScripts connection $ nubBy (on (==) scriptHash) scripts
 
-flattenBlockGroups :: [BlockRowGroup] -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow])
-flattenBlockGroups = foldr foldBlockGroup ([], [], [], [], [], [])
+flattenBlockGroups
+  :: [BlockRowGroup] -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow])
+flattenBlockGroups = foldr foldBlockGroup ([], [], [], [], [], [], [])
   where
     foldBlockGroup
       :: BlockRowGroup
-      -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow])
-      -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow])
-    foldBlockGroup (blockRow, txGroups) (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows) =
-      (blockRow : blockRows, txRows', txOutRows', txInRows', assetOutRows', assetMintRows')
+      -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow])
+      -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow])
+    foldBlockGroup (blockRow, txGroups) (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows, scriptRows) =
+      (blockRow : blockRows, txRows', txOutRows', txInRows', assetOutRows', assetMintRows', scriptRows')
       where
-        (txRows', txOutRows', txInRows', assetOutRows', assetMintRows') =
-          foldr foldTxGroup (txRows, txOutRows, txInRows, assetOutRows, assetMintRows) txGroups
+        (txRows', txOutRows', txInRows', assetOutRows', assetMintRows', scriptRows') =
+          foldr foldTxGroup (txRows, txOutRows, txInRows, assetOutRows, assetMintRows, scriptRows) txGroups
 
     foldTxGroup
       :: TxRowGroup
-      -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow])
-      -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow])
-    foldTxGroup (txRow, txInRows, txOutGroups, assetMintRows) (txRows, txOutRows, txInRows', assetOutRows, assetMintRows') =
-      (txRow : txRows, txOutRows', foldr (:) txInRows' txInRows, assetOutRows', foldr (:) assetMintRows' assetMintRows)
+      -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow])
+      -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow])
+    foldTxGroup (txRow, txInRows, txOutGroups, assetMintRows, scripts) (txRows, txOutRows, txInRows', assetOutRows, assetMintRows', scripts') =
+      ( txRow : txRows
+      , txOutRows'
+      , foldr (:) txInRows' txInRows
+      , assetOutRows'
+      , foldr (:) assetMintRows' assetMintRows
+      , foldr (:) scripts' scripts
+      )
       where
         (txOutRows', assetOutRows') =
           foldr foldTxOutGroup (txOutRows, assetOutRows) txOutGroups
@@ -414,6 +427,18 @@ copyAssetMints conn =
   copyBuilder CopyAssetMints conn "assetMint (txId, slotNo, policyId, name, quantity)"
     . foldMap encodeRecord
 
+copyScripts
+  :: (MonadInjectEvent r QuerySelector s m, MonadUnliftIO m)
+  => PS.Connection
+  -> [ScriptRow]
+  -> m ()
+copyScripts conn rows = do
+  let query = [sql| INSERT INTO chain.script VALUES (?,?) ON CONFLICT (id) DO NOTHING |]
+  withEvent CopyScripts \ev -> do
+    count <- liftIO $ executeMany conn query rows
+    addField ev count
+    pure ()
+
 copyBuilder
   :: ( MonadInjectEvent r QuerySelector s m
      , MonadUnliftIO m

diff --git a/marlowe-chain-sync/deploy/scripts.sql b/marlowe-chain-sync/deploy/scripts.sql
@@ -0,0 +1,20 @@
+-- Deploy chain:scripts to pg
+-- requires: appschema
+
+BEGIN;
+
+-- NOTE this migration requires a reset of the entire database, as the chain
+-- needs to be re-synchronized.
+TRUNCATE chain.block CASCADE;
+TRUNCATE chain.tx CASCADE;
+TRUNCATE chain.txIn CASCADE;
+TRUNCATE chain.txOut CASCADE;
+TRUNCATE chain.assetOut;
+TRUNCATE chain.assetMint;
+
+CREATE TABLE chain.script
+  ( id BYTEA PRIMARY KEY
+  , bytes BYTEA NOT NULL
+  );
+
+COMMIT;
diff --git a/marlowe-chain-sync/gen/Language/Marlowe/Runtime/ChainSync/Gen.hs b/marlowe-chain-sync/gen/Language/Marlowe/Runtime/ChainSync/Gen.hs
@@ -1,19 +1,28 @@
 {-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Language.Marlowe.Runtime.ChainSync.Gen where
 
 import Cardano.Api (
   AddressAny (..),
   AlonzoEraOnwards (..),
+  AnyShelleyBasedEra (..),
   AsType (..),
+  BabbageEra,
+  BabbageEraOnwards (..),
   CardanoEra (..),
+  ConwayEra,
   EraHistory (..),
   Key (verificationKeyHash),
   NetworkId (..),
   NetworkMagic (..),
   PlutusScriptVersion (..),
+  ScriptInEra,
   SerialiseAsRawBytes (..),
   ShelleyBasedEra (..),
   SystemStart (..),
@@ -60,6 +69,7 @@ import Test.Gen.Cardano.Api.Typed (
   genPlutusScript,
   genProtocolParameters,
   genScriptHash,
+  genScriptInEra,
   genTx,
   genVerificationKey,
  )
@@ -393,6 +403,17 @@ instance Arbitrary AnyCardanoEra where
       , AnyCardanoEra ConwayEra
       ]
 
+instance Arbitrary AnyShelleyBasedEra where
+  arbitrary =
+    elements
+      [ AnyShelleyBasedEra ShelleyBasedEraShelley
+      , AnyShelleyBasedEra ShelleyBasedEraAllegra
+      , AnyShelleyBasedEra ShelleyBasedEraMary
+      , AnyShelleyBasedEra ShelleyBasedEraAlonzo
+      , AnyShelleyBasedEra ShelleyBasedEraBabbage
+      , AnyShelleyBasedEra ShelleyBasedEraConway
+      ]
+
 instance Query.ArbitraryRequest ChainSyncQuery where
   arbitraryTag =
     elements
@@ -414,6 +435,8 @@ instance Query.ArbitraryRequest ChainSyncQuery where
     TagGetNodeTip -> pure GetNodeTip
     TagGetTip -> pure GetTip
     TagGetEra -> pure GetEra
+    TagGetScripts BabbageEraOnwardsBabbage -> GetScripts BabbageEraOnwardsBabbage <$> arbitrary
+    TagGetScripts BabbageEraOnwardsConway -> GetScripts BabbageEraOnwardsConway <$> arbitrary
 
   arbitraryResult = \case
     TagGetSecurityParameter -> arbitrary
@@ -427,6 +450,8 @@ instance Query.ArbitraryRequest ChainSyncQuery where
     TagGetNodeTip -> arbitrary
     TagGetTip -> arbitrary
     TagGetEra -> arbitrary
+    TagGetScripts BabbageEraOnwardsBabbage -> arbitrary
+    TagGetScripts BabbageEraOnwardsConway -> arbitrary
 
   shrinkReq = \case
     GetSecurityParameter -> []
@@ -438,6 +463,7 @@ instance Query.ArbitraryRequest ChainSyncQuery where
     GetNodeTip -> []
     GetTip -> []
     GetEra -> []
+    GetScripts era scripts -> GetScripts era <$> shrink scripts
 
   shrinkResult = \case
     TagGetSecurityParameter -> shrink
@@ -451,6 +477,14 @@ instance Query.ArbitraryRequest ChainSyncQuery where
     TagGetNodeTip -> shrink
     TagGetTip -> shrink
     TagGetEra -> shrink
+    TagGetScripts BabbageEraOnwardsBabbage -> shrink
+    TagGetScripts BabbageEraOnwardsConway -> shrink
+
+instance Arbitrary (ScriptInEra BabbageEra) where
+  arbitrary = hedgehog $ genScriptInEra ShelleyBasedEraBabbage
+
+instance Arbitrary (ScriptInEra ConwayEra) where
+  arbitrary = hedgehog $ genScriptInEra ShelleyBasedEraConway
 
 genEraHistory :: Gen EraHistory
 genEraHistory =
@@ -525,6 +559,8 @@ instance Query.RequestEq ChainSyncQuery where
     TagGetNodeTip -> (==)
     TagGetTip -> (==)
     TagGetEra -> (==)
+    TagGetScripts BabbageEraOnwardsBabbage -> (==)
+    TagGetScripts BabbageEraOnwardsConway -> (==)
 
 instance Command.ArbitraryCommand ChainSyncCommand where
   arbitraryTag =

diff --git a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database.hs b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database.hs
@@ -3,8 +3,11 @@
 
 module Language.Marlowe.Runtime.ChainSync.Database where
 
+import Cardano.Api (BabbageEraOnwards, ScriptInEra)
 import Data.List.NonEmpty (NonEmpty)
-import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint, GetUTxOsQuery, Move, UTxOs)
+import Data.Map (Map)
+import Data.Set (Set)
+import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint, GetUTxOsQuery, Move, ScriptHash, UTxOs)
 import Numeric.Natural (Natural)
 
 -- Queries
@@ -15,6 +18,9 @@ newtype GetTip m = GetTip
 newtype GetUTxOs m = GetUTxOs
   {runGetUTxOs :: GetUTxOsQuery -> m UTxOs}
 
+newtype GetScripts m = GetScripts
+  {runGetScripts :: forall era. BabbageEraOnwards era -> Set ScriptHash -> m (Map ScriptHash (ScriptInEra era))}
+
 data MoveResult err result
   = RollForward result BlockHeader ChainPoint
   | RollBack ChainPoint ChainPoint
@@ -39,6 +45,9 @@ newtype Collect err result m = Collect
 hoistGetUTxOs :: (forall a. m a -> n a) -> GetUTxOs m -> GetUTxOs n
 hoistGetUTxOs transformation = GetUTxOs . fmap transformation . runGetUTxOs
 
+hoistGetScripts :: (forall a. m a -> n a) -> GetScripts m -> GetScripts n
+hoistGetScripts transformation GetScripts{..} = GetScripts \era -> transformation . runGetScripts era
+
 hoistGetTip :: (forall a. m a -> n a) -> GetTip m -> GetTip n
 hoistGetTip transformation = GetTip . transformation . runGetTip
 
@@ -65,6 +74,7 @@ hoistCollectResult transformation = \case
 
 data DatabaseQueries m = DatabaseQueries
   { getUTxOs :: GetUTxOs m
+  , getScripts :: GetScripts m
   , getTip :: GetTip m
   , moveClient :: MoveClient m
   , scan :: Scan m
@@ -74,6 +84,7 @@ hoistDatabaseQueries :: (Functor m) => (forall a. m a -> n a) -> DatabaseQueries
 hoistDatabaseQueries transformation DatabaseQueries{..} =
   DatabaseQueries
     { getUTxOs = hoistGetUTxOs transformation getUTxOs
+    , getScripts = hoistGetScripts transformation getScripts
     , getTip = hoistGetTip transformation getTip
     , moveClient = hoistMoveClient transformation moveClient
     , scan = hoistScan transformation scan