diff --git a/cardano-streaming/cardano-streaming.cabal b/cardano-streaming/cardano-streaming.cabal index a5e81ace55..8dcedc2f7e 100644 --- a/cardano-streaming/cardano-streaming.cabal +++ b/cardano-streaming/cardano-streaming.cabal @@ -29,7 +29,10 @@ common lang library import: lang hs-source-dirs: src - exposed-modules: Cardano.Streaming + exposed-modules: + Cardano.Streaming + Cardano.Streaming.Callbacks + Cardano.Streaming.Helpers -------------------------- -- Other IOG dependencies @@ -42,9 +45,33 @@ library -- Non-IOG dependencies ------------------------ build-depends: + , aeson , async - , base >=4.9 && <5 + , base >=4.9 && <5 + , bytestring + , cardano-api + , cardano-binary + , cardano-crypto-class + , cardano-crypto-wrapper + , cardano-data + , cardano-ledger-alonzo + , cardano-ledger-byron + , cardano-ledger-core + , cardano-ledger-shelley + , cardano-protocol-tpraos + , cardano-slotting + , containers + , ouroboros-consensus + , ouroboros-consensus-byron + , ouroboros-consensus-cardano + , ouroboros-consensus-protocol + , ouroboros-consensus-shelley + , primitive + , small-steps , streaming + , transformers + , typed-protocols + , vector executable cardano-streaming-example-1 import: lang diff --git a/cardano-streaming/changelog.d/20221207_115251_markus.lall_plt_171_wip.md b/cardano-streaming/changelog.d/20221207_115251_markus.lall_plt_171_wip.md new file mode 100644 index 0000000000..9d115d422e --- /dev/null +++ b/cardano-streaming/changelog.d/20221207_115251_markus.lall_plt_171_wip.md @@ -0,0 +1,3 @@ +### Added + +- Fold blocks into ledger state at client side using local chainsync protocol, both pipelined and non-pipelined versions are provided. diff --git a/cardano-streaming/src/Cardano/Streaming.hs b/cardano-streaming/src/Cardano/Streaming.hs index 5d84c3ad46..17e503d52b 100644 --- a/cardano-streaming/src/Cardano/Streaming.hs +++ b/cardano-streaming/src/Cardano/Streaming.hs @@ -1,36 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} module Cardano.Streaming - ( withChainSyncEventStream, - ChainSyncEvent (..), - ChainSyncEventException (..), + ( withChainSyncEventStream + , CS.ChainSyncEvent (..) + , CS.ChainSyncEventException (..) + + -- + , CS.mkConnectInfo + , CS.mkLocalNodeConnectInfo + + -- * Stream blocks and ledger states + , blocks + , blocksPipelined + , ledgerStates + , ledgerStatesPipelined + , foldLedgerState + , getEnvAndInitialLedgerStateHistory + , CS.ignoreRollbacks ) where -import Cardano.Api (BlockInMode, CardanoMode, ChainPoint, ChainSyncClient (ChainSyncClient), ChainTip, - ConsensusModeParams (CardanoModeParams), EpochSlots (EpochSlots), - LocalChainSyncClient (LocalChainSyncClient), - LocalNodeClientProtocols (LocalNodeClientProtocols, localChainSyncClient, localStateQueryClient, localTxMonitoringClient, localTxSubmissionClient), - LocalNodeConnectInfo (LocalNodeConnectInfo, localConsensusModeParams, localNodeNetworkId, localNodeSocketPath), - NetworkId, connectToLocalNode) -import Cardano.Api.ChainSync.Client (ClientStIdle (SendMsgFindIntersect, SendMsgRequestNext), - ClientStIntersect (ClientStIntersect, recvMsgIntersectFound, recvMsgIntersectNotFound), - ClientStNext (ClientStNext, recvMsgRollBackward, recvMsgRollForward)) +import Control.Concurrent qualified as IO import Control.Concurrent.Async (ExceptionInLinkedThread (ExceptionInLinkedThread), link, withAsync) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) -import Control.Exception (Exception, SomeException (SomeException), catch, throw) -import GHC.Generics (Generic) +import Control.Exception (SomeException (SomeException), catch, throw) +import Control.Exception qualified as IO +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) +import Data.Foldable (forM_) +import Data.Function ((&)) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Word (Word32) import Streaming (Of, Stream) import Streaming.Prelude qualified as S -data ChainSyncEvent a - = RollForward a ChainTip - | RollBackward ChainPoint ChainTip - deriving (Show, Functor, Generic) - -data ChainSyncEventException - = NoIntersectionFound - deriving (Show) +import Cardano.Api qualified as C +import Cardano.Api.ChainSync.Client (ClientStIdle (SendMsgFindIntersect, SendMsgRequestNext), + ClientStIntersect (ClientStIntersect, recvMsgIntersectFound, recvMsgIntersectNotFound), + ClientStNext (ClientStNext, recvMsgRollBackward, recvMsgRollForward)) +import Cardano.Slotting.Slot (WithOrigin (At, Origin)) -instance Exception ChainSyncEventException +import Cardano.Streaming.Callbacks qualified as CS +import Cardano.Streaming.Helpers qualified as CS -- | `withChainSyncEventStream` uses the chain-sync mini-protocol to -- connect to a locally running node and fetch blocks from the given @@ -38,11 +52,11 @@ instance Exception ChainSyncEventException withChainSyncEventStream :: -- | Path to the node socket FilePath -> - NetworkId -> + C.NetworkId -> -- | The point on the chain to start streaming from - [ChainPoint] -> + [C.ChainPoint] -> -- | The stream consumer - (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r -> IO b) -> + (Stream (Of (CS.ChainSyncEvent (C.BlockInMode C.CardanoMode))) IO r -> IO b) -> IO b withChainSyncEventStream socketPath networkId points consumer = do -- The chain-sync client runs in a different thread passing the blocks it @@ -65,29 +79,16 @@ withChainSyncEventStream socketPath networkId points consumer = do nextBlockVar <- newEmptyMVar let client = chainSyncStreamingClient points nextBlockVar - localNodeClientProtocols = - LocalNodeClientProtocols - { localChainSyncClient = LocalChainSyncClient client, - localStateQueryClient = Nothing, - localTxMonitoringClient = Nothing, - localTxSubmissionClient = Nothing - } - - connectInfo = - LocalNodeConnectInfo - { localConsensusModeParams = CardanoModeParams epochSlots, - localNodeNetworkId = networkId, - localNodeSocketPath = socketPath + C.LocalNodeClientProtocols + { C.localChainSyncClient = C.LocalChainSyncClient client, + C.localStateQueryClient = Nothing, + C.localTxMonitoringClient = Nothing, + C.localTxSubmissionClient = Nothing } + connectInfo = CS.mkLocalNodeConnectInfo networkId socketPath - -- This a parameter needed only for the Byron era. Since the Byron - -- era is over and the parameter has never changed it is ok to - -- hardcode this. See comment on `Cardano.Api.ConsensusModeParams` in - -- cardano-node. - epochSlots = EpochSlots 21600 - - withAsync (connectToLocalNode connectInfo localNodeClientProtocols) $ \a -> do + withAsync (C.connectToLocalNode connectInfo localNodeClientProtocols) $ \a -> do -- Make sure all exceptions in the client thread are passed to the consumer thread link a -- Run the consumer @@ -103,21 +104,21 @@ withChainSyncEventStream socketPath networkId points consumer = do -- If the starting point is such that an intersection cannot be found, this -- client will throw a NoIntersectionFound exception. chainSyncStreamingClient :: - [ChainPoint] -> - MVar (ChainSyncEvent e) -> - ChainSyncClient e ChainPoint ChainTip IO () + [C.ChainPoint] -> + MVar (CS.ChainSyncEvent e) -> + C.ChainSyncClient e C.ChainPoint C.ChainTip IO () chainSyncStreamingClient points nextChainEventVar = - ChainSyncClient $ pure $ SendMsgFindIntersect points onIntersect + C.ChainSyncClient $ pure $ SendMsgFindIntersect points onIntersect where onIntersect = ClientStIntersect { recvMsgIntersectFound = \cp ct -> - ChainSyncClient $ do - putMVar nextChainEventVar (RollBackward cp ct) + C.ChainSyncClient $ do + putMVar nextChainEventVar (CS.RollBackward cp ct) sendRequestNext, recvMsgIntersectNotFound = -- There is nothing we can do here - throw NoIntersectionFound + throw CS.NoIntersectionFound } sendRequestNext = @@ -126,12 +127,145 @@ chainSyncStreamingClient points nextChainEventVar = onNext = ClientStNext { recvMsgRollForward = \bim ct -> - ChainSyncClient $ do - putMVar nextChainEventVar (RollForward bim ct) + C.ChainSyncClient $ do + putMVar nextChainEventVar (CS.RollForward bim ct) sendRequestNext, recvMsgRollBackward = \cp ct -> - ChainSyncClient $ do - putMVar nextChainEventVar (RollBackward cp ct) + C.ChainSyncClient $ do + putMVar nextChainEventVar (CS.RollBackward cp ct) sendRequestNext } +-- | Create stream of @ChainSyncEvent (BlockInMode CardanoMode)@ from +-- a node at @socketPath@ with @networkId@ starting at @point@. +blocks + :: C.LocalNodeConnectInfo C.CardanoMode -> C.ChainPoint + -> S.Stream (S.Of (CS.ChainSyncEvent (C.BlockInMode C.CardanoMode))) IO r +blocks con chainPoint = do + chan <- liftIO IO.newChan + void $ liftIO $ CS.linkedAsync $ CS.blocksCallback con chainPoint $ IO.writeChan chan + S.repeatM $ IO.readChan chan + +blocksPipelined + :: Word32 -> C.LocalNodeConnectInfo C.CardanoMode -> C.ChainPoint + -> S.Stream (S.Of (CS.ChainSyncEvent (C.BlockInMode C.CardanoMode))) IO r +blocksPipelined pipelineSize con chainPoint = do + chan <- liftIO IO.newChan + void $ liftIO $ CS.linkedAsync $ CS.blocksCallbackPipelined pipelineSize con chainPoint $ IO.writeChan chan + S.repeatM $ IO.readChan chan + +-- * Ledger states + +-- | Get a stream of permanent ledger states +ledgerStates :: FilePath -> FilePath -> C.ValidationMode -> S.Stream (S.Of C.LedgerState) IO r +ledgerStates config socket validationMode = do + (env, initialLedgerStateHistory) <- liftIO $ getEnvAndInitialLedgerStateHistory config + blocks (CS.mkConnectInfo env socket) C.ChainPointAtGenesis + & foldLedgerState env initialLedgerStateHistory validationMode + +-- | Get a stream of ledger states over a pipelined chain sync +ledgerStatesPipelined + :: Word32 -> FilePath -> FilePath -> C.ValidationMode -> S.Stream (S.Of C.LedgerState) IO r +ledgerStatesPipelined pipelineSize config socket validationMode = do + (env, initialLedgerStateHistory) <- liftIO $ getEnvAndInitialLedgerStateHistory config + blocksPipelined pipelineSize (CS.mkConnectInfo env socket) C.ChainPointAtGenesis + & foldLedgerState env initialLedgerStateHistory validationMode + +-- * Apply block + +-- | Fold a stream of blocks into a stream of ledger states. This is +-- implemented in a similar way as `foldBlocks` in +-- cardano-api:Cardano.Api.LedgerState, the difference being that this +-- keeps waiting for more blocks when chainsync server and client are +-- fully synchronized. +foldLedgerState + :: C.Env -> LedgerStateHistory -> C.ValidationMode + -> S.Stream (S.Of (CS.ChainSyncEvent (C.BlockInMode C.CardanoMode))) IO r + -> S.Stream (S.Of C.LedgerState) IO r +foldLedgerState env initialLedgerStateHistory validationMode = loop initialLedgerStateHistory + where + applyBlock_ :: C.LedgerState -> C.Block era -> IO (C.LedgerState, [C.LedgerEvent]) + applyBlock_ ledgerState block = applyBlockThrow env ledgerState validationMode block + + loop + :: LedgerStateHistory + -> S.Stream (S.Of (CS.ChainSyncEvent (C.BlockInMode C.CardanoMode))) IO r + -> S.Stream (S.Of C.LedgerState) IO r + loop ledgerStateHistory source = lift (S.next source) >>= \case + Left r -> pure r + Right (chainSyncEvent, source') -> do + ledgerStateHistory' <- case chainSyncEvent of + CS.RollForward (blockInMode@(C.BlockInMode block _)) _ct -> do + newLedgerState <- liftIO $ applyBlock_ (getLastLedgerState ledgerStateHistory) block + let (ledgerStateHistory', committedStates) = pushLedgerState env ledgerStateHistory (CS.bimSlotNo blockInMode) newLedgerState blockInMode + forM_ committedStates $ \(_, (ledgerState, _ledgerEvents), currBlockMay) -> case currBlockMay of + Origin -> return () + At _currBlock -> S.yield ledgerState + pure ledgerStateHistory' + CS.RollBackward cp _ct -> pure $ case cp of + C.ChainPointAtGenesis -> initialLedgerStateHistory + C.ChainPoint slotNo _ -> rollBackLedgerStateHist ledgerStateHistory slotNo + + loop ledgerStateHistory' source' + +getEnvAndInitialLedgerStateHistory :: FilePath -> IO (C.Env, LedgerStateHistory) +getEnvAndInitialLedgerStateHistory configPath = do + (env, initialLedgerState) <- either IO.throw pure =<< (runExceptT $ C.initialLedgerState configPath) + let initialLedgerStateHistory = singletonLedgerStateHistory initialLedgerState + return (env, initialLedgerStateHistory) + + +applyBlockThrow :: C.Env -> C.LedgerState -> C.ValidationMode -> C.Block era -> IO (C.LedgerState, [C.LedgerEvent]) +applyBlockThrow env ledgerState validationMode block = case C.applyBlock env ledgerState validationMode block of + Left err -> IO.throw err + Right ls -> pure ls + +-- * Copy-paste code +-- +-- The following is pasted in from cardano-api:Cardano.Api.LedgerState. +-- (`getLastLedgerState` and `singletonLedgerStateHistory` aren't a +-- direct copy-paste, but they are extracted from within `foldBlocks`) + + +-- | A history of k (security parameter) recent ledger states. The head is the +-- most recent item. Elements are: +-- +-- * Slot number that a new block occurred +-- * The ledger state and events after applying the new block +-- * The new block +-- +type LedgerStateHistory = History LedgerStateEvents +type History a = Seq (C.SlotNo, a, WithOrigin (C.BlockInMode C.CardanoMode)) + +type LedgerStateEvents = (C.LedgerState, [C.LedgerEvent]) + +-- | Add a new ledger state to the history +pushLedgerState + :: C.Env -- ^ Environment used to get the security param, k. + -> History a -- ^ History of k items. + -> C.SlotNo -- ^ Slot number of the new item. + -> a -- ^ New item to add to the history + -> C.BlockInMode C.CardanoMode + -- ^ The block that (when applied to the previous + -- item) resulted in the new item. + -> (History a, History a) + -- ^ ( The new history with the new item appended + -- , Any existing items that are now past the security parameter + -- and hence can no longer be rolled back. + -- ) +pushLedgerState env hist ix st block + = Seq.splitAt + (fromIntegral $ C.envSecurityParam env + 1) + ((ix, st, At block) Seq.:<| hist) + +rollBackLedgerStateHist :: History a -> C.SlotNo -> History a +rollBackLedgerStateHist hist maxInc = Seq.dropWhileL ((> maxInc) . (\(x,_,_) -> x)) hist + +getLastLedgerState :: LedgerStateHistory -> C.LedgerState +getLastLedgerState ledgerStates' = maybe + (error "Impossible! Missing Ledger state") + (\(_,(ledgerState, _),_) -> ledgerState) + (Seq.lookup 0 ledgerStates') + +singletonLedgerStateHistory :: C.LedgerState -> LedgerStateHistory +singletonLedgerStateHistory ledgerState = Seq.singleton (0, (ledgerState, []), Origin) diff --git a/cardano-streaming/src/Cardano/Streaming/Callbacks.hs b/cardano-streaming/src/Cardano/Streaming/Callbacks.hs new file mode 100644 index 0000000000..220cf5d8bd --- /dev/null +++ b/cardano-streaming/src/Cardano/Streaming/Callbacks.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Cardano.Streaming.Callbacks where + +import Control.Exception (throw) +import Data.Word (Word32) + +import Cardano.Api qualified as C +import Cardano.Slotting.Slot (WithOrigin (At, Origin)) +import Network.TypedProtocol.Pipelined (N (Z), Nat (Succ, Zero)) +import Ouroboros.Network.Protocol.ChainSync.Client qualified as CS +import Ouroboros.Network.Protocol.ChainSync.ClientPipelined qualified as CSP +import Ouroboros.Network.Protocol.ChainSync.PipelineDecision (PipelineDecision (Collect), pipelineDecisionMax) + +import Cardano.Streaming.Helpers qualified as H + +-- * Raw chain-sync clients using callback + +blocksCallbackPipelined + :: Word32 -> C.LocalNodeConnectInfo C.CardanoMode -> C.ChainPoint + -> (H.ChainSyncEvent (C.BlockInMode C.CardanoMode) -> IO ()) + -> IO () +blocksCallbackPipelined n con point callback = + C.connectToLocalNode con $ C.LocalNodeClientProtocols + { C.localChainSyncClient = C.LocalChainSyncClientPipelined $ CSP.ChainSyncClientPipelined $ pure $ CSP.SendMsgFindIntersect [point] onIntersect + , C.localTxSubmissionClient = Nothing + , C.localStateQueryClient = Nothing + , C.localTxMonitoringClient = Nothing + } + where + onIntersect = + CSP.ClientPipelinedStIntersect + { CSP.recvMsgIntersectFound = \_ _ -> pure $ work n + , CSP.recvMsgIntersectNotFound = throw H.NoIntersectionFound + } + + work :: Word32 -> CSP.ClientPipelinedStIdle 'Z (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + work pipelineSize = requestMore Origin Origin Zero + where + requestMore -- was clientIdle_RequestMoreN + :: WithOrigin C.BlockNo -> WithOrigin C.BlockNo -> Nat n + -> CSP.ClientPipelinedStIdle n (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + requestMore clientTip serverTip rqsInFlight = let + in case pipelineDecisionMax pipelineSize rqsInFlight clientTip serverTip of + -- handle a response + Collect -> case rqsInFlight of + Succ predN -> CSP.CollectResponse Nothing (clientNextN predN) + -- fire more requests + _ -> CSP.SendMsgRequestNextPipelined (requestMore clientTip serverTip (Succ rqsInFlight)) + + clientNextN + :: Nat n + -> CSP.ClientStNext n (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + clientNextN rqsInFlight = CSP.ClientStNext + { CSP.recvMsgRollForward = \bim ct -> do + callback $ H.RollForward bim ct + return $ requestMore (At $ H.bimBlockNo bim) (H.fromChainTip ct) rqsInFlight + , CSP.recvMsgRollBackward = \cp ct -> do + callback $ H.RollBackward cp ct + return $ requestMore Origin (H.fromChainTip ct) rqsInFlight + } + +blocksCallback + :: C.LocalNodeConnectInfo C.CardanoMode -> C.ChainPoint + -> (H.ChainSyncEvent (C.BlockInMode C.CardanoMode) -> IO ()) + -> IO () +blocksCallback con point callback = + C.connectToLocalNode con $ C.LocalNodeClientProtocols + { C.localChainSyncClient = C.LocalChainSyncClient $ CS.ChainSyncClient $ pure $ CS.SendMsgFindIntersect [point] onIntersect + , C.localTxSubmissionClient = Nothing + , C.localStateQueryClient = Nothing + , C.localTxMonitoringClient = Nothing + } + where + onIntersect = + CS.ClientStIntersect + { CS.recvMsgIntersectFound = \_ _ -> CS.ChainSyncClient sendRequestNext + , CS.recvMsgIntersectNotFound = throw H.NoIntersectionFound + } + sendRequestNext = pure $ CS.SendMsgRequestNext onNext (pure onNext) + where + onNext = CS.ClientStNext + { CS.recvMsgRollForward = \bim ct -> CS.ChainSyncClient $ do + callback $ H.RollForward bim ct + sendRequestNext + , CS.recvMsgRollBackward = \cp ct -> CS.ChainSyncClient $ do + callback $ H.RollBackward cp ct + sendRequestNext + } diff --git a/cardano-streaming/src/Cardano/Streaming/Helpers.hs b/cardano-streaming/src/Cardano/Streaming/Helpers.hs new file mode 100644 index 0000000000..11a4c7a08d --- /dev/null +++ b/cardano-streaming/src/Cardano/Streaming/Helpers.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +module Cardano.Streaming.Helpers where + +import Control.Concurrent.Async qualified as IO +import Control.Exception qualified as IO +import Data.SOP.Strict (NP ((:*))) +import GHC.Generics (Generic) +import Streaming.Prelude qualified as S + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as CS +import Cardano.Chain.Genesis qualified +import Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (RequiresMagic, RequiresNoMagic)) +import Cardano.Ledger.Shelley.LedgerState qualified as SL +import Cardano.Slotting.Slot (WithOrigin (At, Origin)) +import Ouroboros.Consensus.Cardano.Block qualified as O +import Ouroboros.Consensus.Cardano.CanHardFork qualified as Consensus +import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras qualified as HFC +import Ouroboros.Consensus.HardFork.Combinator.Basics qualified as HFC +import Ouroboros.Consensus.Shelley.Ledger qualified as O + +-- * ChainSyncEvent + +data ChainSyncEvent a + = RollForward a C.ChainTip + | RollBackward C.ChainPoint C.ChainTip + deriving (Show, Functor, Generic) + +data ChainSyncEventException + = NoIntersectionFound + deriving (Show) + +instance IO.Exception ChainSyncEventException + +data RollbackException = RollbackLocationNotFound C.ChainPoint C.ChainTip + deriving (Eq, Show) +instance IO.Exception RollbackException + +-- * Orphans + +instance IO.Exception C.LedgerStateError + +instance IO.Exception C.FoldBlocksError +deriving instance Show C.FoldBlocksError + +instance IO.Exception C.InitialLedgerStateError +deriving instance Show C.InitialLedgerStateError +deriving instance Show CS.GenesisConfigError + +-- * Block + +bimBlockNo :: C.BlockInMode C.CardanoMode -> C.BlockNo +bimBlockNo (C.BlockInMode (C.Block (C.BlockHeader _ _ blockNo) _) _) = blockNo + +bimSlotNo :: C.BlockInMode C.CardanoMode -> C.SlotNo +bimSlotNo (C.BlockInMode (C.Block (C.BlockHeader slotNo _ _) _) _) = slotNo + +getEpochNo :: C.LedgerState -> Maybe CS.EpochNo +getEpochNo ledgerState' = case ledgerState' of + C.LedgerStateByron _st -> Nothing + C.LedgerStateShelley st -> fromState st + C.LedgerStateAllegra st -> fromState st + C.LedgerStateMary st -> fromState st + C.LedgerStateAlonzo st -> fromState st + CS.LedgerState (O.LedgerStateBabbage st) -> fromState st -- TODO pattern missing from cardano-node: is it there on master? if not create PR. + where + fromState = Just . SL.nesEL . O.shelleyLedgerState + +fromChainTip :: C.ChainTip -> WithOrigin C.BlockNo +fromChainTip ct = case ct of + C.ChainTipAtGenesis -> Origin + C.ChainTip _ _ bno -> At bno + +-- * IO + +linkedAsync :: IO a -> IO () +linkedAsync action = IO.link =<< IO.async action + +-- * LocalNodeConnectInfo + +mkLocalNodeConnectInfo :: C.NetworkId -> FilePath -> C.LocalNodeConnectInfo C.CardanoMode +mkLocalNodeConnectInfo networkId socketPath = C.LocalNodeConnectInfo + { C.localConsensusModeParams = C.CardanoModeParams epochSlots + , C.localNodeNetworkId = networkId + , C.localNodeSocketPath = socketPath + } + -- This a parameter needed only for the Byron era. Since the Byron + -- era is over and the parameter has never changed it is ok to + -- hardcode this. See comment on `Cardano.Api.ConsensusModeParams` in + -- cardano-node. + where epochSlots = C.EpochSlots 21600 -- TODO: is this configurable? see below + +-- | Derive LocalNodeConnectInfo from Env. +mkConnectInfo :: C.Env -> FilePath -> C.LocalNodeConnectInfo C.CardanoMode +mkConnectInfo env socketPath = C.LocalNodeConnectInfo + { C.localConsensusModeParams = cardanoModeParams + , C.localNodeNetworkId = networkId' + , C.localNodeSocketPath = socketPath + } + where + -- Derive the NetworkId as described in network-magic.md from the + -- cardano-ledger-specs repo. + byronConfig + = (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig bc _) :* _) -> bc) + . HFC.getPerEraLedgerConfig + . HFC.hardForkLedgerConfigPerEra + $ C.envLedgerConfig env + + networkMagic + = C.NetworkMagic + $ unProtocolMagicId + $ Cardano.Chain.Genesis.gdProtocolMagicId + $ Cardano.Chain.Genesis.configGenesisData byronConfig + + networkId' = case Cardano.Chain.Genesis.configReqNetMagic byronConfig of + RequiresNoMagic -> C.Mainnet + RequiresMagic -> C.Testnet networkMagic + + cardanoModeParams = C.CardanoModeParams . C.EpochSlots $ 10 * C.envSecurityParam env + +-- | Ignore rollback events in the chainsync event stream. Useful for +-- monitor which blocks has been seen by the node, regardless whether +-- they are permanent. +ignoreRollbacks :: Monad m => S.Stream (S.Of (ChainSyncEvent a)) m r -> S.Stream (S.Of a) m r +ignoreRollbacks = S.mapMaybe (\case RollForward e _ -> Just e; _ -> Nothing) diff --git a/marconi/app/Main.hs b/marconi/app/Main.hs index dc4a0f271a..2af10ab7d4 100644 --- a/marconi/app/Main.hs +++ b/marconi/app/Main.hs @@ -27,7 +27,9 @@ main = do let indexers = filterIndexers (Cli.utxoDbPath o) (Cli.datumDbPath o) (Cli.scriptTxDbPath o) + (Cli.epochStakepoolSizeDbPath o) (Cli.optionsTargetAddresses o) + (Cli.optionsNodeConfigPath o) (cp, coordinator) <- startIndexers indexers let preferredChainPoints = -- If the user specifies the chain point then use that, diff --git a/marconi/changelog.d/20221205_182223_markus.lall_plt_171.md b/marconi/changelog.d/20221205_182223_markus.lall_plt_171.md new file mode 100644 index 0000000000..3864cd9bbf --- /dev/null +++ b/marconi/changelog.d/20221205_182223_markus.lall_plt_171.md @@ -0,0 +1,3 @@ +### Added + +- Epoch stakepool size indexer; the data indexed is roughly equivalent to the `epoch_stake` table in cardano-db-sync. diff --git a/marconi/marconi.cabal b/marconi/marconi.cabal index ec1ac29582..6166d4ecbb 100644 --- a/marconi/marconi.cabal +++ b/marconi/marconi.cabal @@ -51,6 +51,7 @@ library exposed-modules: Marconi.CLI Marconi.Index.Datum + Marconi.Index.EpochStakepoolSize Marconi.Index.ScriptTx Marconi.Index.Utxo Marconi.Indexers @@ -84,11 +85,14 @@ library , async , base , bytestring + , cardano-crypto-class , containers , filepath , lens , mwc-random , optparse-applicative + , ouroboros-consensus-cardano + , ouroboros-consensus-shelley , parsec , prettyprinter , raw-strings-qq @@ -98,6 +102,8 @@ library , streaming , text , time + , transformers + , vector-map executable marconi import: lang @@ -133,6 +139,8 @@ test-suite marconi-test main-is: Spec.hs hs-source-dirs: test other-modules: + EpochStakepoolSize + Helpers Integration Spec.Utxo @@ -160,6 +168,8 @@ test-suite marconi-test -- Non-IOG dependencies ------------------------ build-depends: + , aeson + , async , base >=4.9 && <5 , bytestring , containers @@ -180,5 +190,3 @@ test-suite marconi-test , tasty-hunit , temporary , text - --- , aeson diff --git a/marconi/src/Marconi/CLI.hs b/marconi/src/Marconi/CLI.hs index 602a04be33..b9c5837a56 100644 --- a/marconi/src/Marconi/CLI.hs +++ b/marconi/src/Marconi/CLI.hs @@ -11,6 +11,7 @@ module Marconi.CLI , utxoDbPath , datumDbPath , scriptTxDbPath + , epochStakepoolSizeDbPath ) where import Control.Applicative (optional, some) @@ -56,6 +57,7 @@ fromJustWithError v = case v of Left e -> error $ "\n!!!\n Abnormal Termination with Error: " <> show e <> "\n!!!\n" Right accounts -> accounts + -- TODO: `pNetworkId` and `pTestnetMagic` are copied from -- https://github.com/input-output-hk/cardano-node/blob/988c93085022ed3e2aea5d70132b778cd3e622b9/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs#L2009-L2027 -- Use them from there whenever they are exported. @@ -97,14 +99,16 @@ parseCardanoAddresses = nub -- 39920450|679a55b523ff8d61942b2583b76e5d49498468164802ef1ebe513c685d6fb5c2|X(002f9787436835852ea78d3c45fc3d436b324184 data Options = Options - { optionsSocketPath :: String, - optionsNetworkId :: NetworkId, - optionsChainPoint :: ChainPoint, - optionsDbPath :: FilePath, -- ^ SQLite database directory path - optionsDisableUtxo :: Bool, - optionsDisableDatum :: Bool, - optionsDisableScript :: Bool, - optionsTargetAddresses :: Maybe TargetAddresses + { optionsSocketPath :: String, + optionsNetworkId :: NetworkId, + optionsChainPoint :: ChainPoint, + optionsDbPath :: FilePath, -- ^ SQLite database directory path + optionsDisableUtxo :: Bool, + optionsDisableDatum :: Bool, + optionsDisableScript :: Bool, + optionsDisableStakepoolSize :: Bool, + optionsTargetAddresses :: Maybe TargetAddresses, + optionsNodeConfigPath :: Maybe FilePath } deriving (Show) @@ -148,22 +152,34 @@ optionsParser = <> Opt.help "disable script-tx indexers." <> Opt.showDefault ) + <*> Opt.switch (Opt.long "disable-epoch-stakepool-size" + <> Opt.help "disable epoch stakepool size indexers." + <> Opt.showDefault + ) <*> optAddressesParser (Opt.long "addresses-to-index" <> Opt.short 'a' <> Opt.help ("Becch32 Shelley addresses to index." <> " i.e \"--address-to-index address-1 --address-to-index address-2 ...\"" ) ) + <*> (optional $ Opt.strOption + $ Opt.long "node-config-path" + <> Opt.help "Path to node configuration which you are connecting to.") optAddressesParser :: Opt.Mod Opt.OptionFields [C.Address C.ShelleyAddr] -> Opt.Parser (Maybe TargetAddresses) optAddressesParser = optional . multiString +-- * Database names and paths + utxoDbName :: FilePath -utxoDbName = "utxodb" +utxoDbName = "utxo.db" datumDbName :: FilePath -datumDbName = "datumdb" +datumDbName = "datum.db" scriptTxDbName :: FilePath -scriptTxDbName = "scripttxdb" +scriptTxDbName = "scripttx.db" + +epochStakepoolSizeDbName :: FilePath +epochStakepoolSizeDbName = "epochstakepool.db" utxoDbPath :: Options -> Maybe FilePath utxoDbPath o = if optionsDisableUtxo o then Nothing; else Just (optionsDbPath o utxoDbName) @@ -173,3 +189,6 @@ datumDbPath o = if optionsDisableDatum o then Nothing; else Just (optionsDbPath scriptTxDbPath :: Options -> Maybe FilePath scriptTxDbPath o = if optionsDisableScript o then Nothing; else Just (optionsDbPath o scriptTxDbName) + +epochStakepoolSizeDbPath :: Options -> Maybe FilePath +epochStakepoolSizeDbPath o = if optionsDisableStakepoolSize o then Nothing else Just (optionsDbPath o epochStakepoolSizeDbName) diff --git a/marconi/src/Marconi/Index/EpochStakepoolSize.hs b/marconi/src/Marconi/Index/EpochStakepoolSize.hs new file mode 100644 index 0000000000..6c07ef5544 --- /dev/null +++ b/marconi/src/Marconi/Index/EpochStakepoolSize.hs @@ -0,0 +1,190 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Marconi.Index.EpochStakepoolSize where + +import Control.Monad.Trans.Class (lift) +import Data.Coerce (coerce) +import Data.Foldable (forM_) +import Data.Function (on, (&)) +import Data.List (groupBy) +import Data.Map qualified as M +import Data.Maybe qualified as P +import Data.Sequence qualified as Seq +import Data.Tuple (swap) +import Data.VMap qualified as VMap +import Database.SQLite.Simple qualified as SQL +import Database.SQLite.Simple.FromField qualified as SQL +import Database.SQLite.Simple.ToField qualified as SQL +import Streaming.Prelude qualified as S + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Streaming qualified as CS + +import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Compactible qualified as L +import Cardano.Ledger.Credential qualified as LC +import Cardano.Ledger.Era qualified as LE +import Cardano.Ledger.Keys qualified as LK +import Cardano.Ledger.Shelley.EpochBoundary qualified as Shelley +import Cardano.Ledger.Shelley.LedgerState qualified as SL +import Cardano.Ledger.Shelley.LedgerState qualified as Shelley +import Ouroboros.Consensus.Cardano.Block qualified as O +import Ouroboros.Consensus.Shelley.Ledger qualified as O + +import Cardano.Streaming.Helpers (getEpochNo) + +-- * Event + +newtype Event = Event (C.EpochNo, M.Map C.PoolId C.Lovelace) + +-- | Convert a stream of ledger states for every block to a stream of +-- ledger states for every epoch. We also skip the Byron era because +-- it doesn't have any staking information. +toEvents :: S.Stream (S.Of C.LedgerState) IO r -> S.Stream (S.Of Event) IO r +toEvents source = source + & S.mapMaybe toNoByron + & firstEventOfEveryEpoch + where + -- Skip Byron era as it doesn't have staking. + toNoByron :: C.LedgerState -> Maybe Event + toNoByron ls = if + | Just epochNo <- getEpochNo ls + , Just m <- getStakeMap ls -> Just $ Event (epochNo, m) + | otherwise -> Nothing + + -- We get LedgerState at every block from the ledgerStates + -- streamer but we only want the first one of every epoch, so we + -- zip them and only emit ledger states at epoch boundaries. + firstEventOfEveryEpoch :: S.Stream (S.Of Event) IO r -> S.Stream (S.Of Event) IO r + firstEventOfEveryEpoch source' = source' + & S.slidingWindow 2 + & S.mapMaybe (\case + (Event (e0, _) Seq.:<| t@(Event (e1, _)) Seq.:<| Seq.Empty) + | succ e0 == e1 -> Just t + | e0 == e1 -> Nothing + | otherwise -> error $ "This should never happen: consequent epochs wider apart than by one: " <> show (e0, e1) + _ -> error "This should never happen" + ) + +-- | From LedgerState get epoch stakepool size: a mapping of pool ID +-- to amount staked. We do this by getting the _pstatkeSet stake +-- snapshot and then use _delegations and _stake to resolve it into +-- the desired mapping. +getStakeMap :: C.LedgerState -> Maybe (M.Map C.PoolId C.Lovelace) +getStakeMap ledgerState' = case ledgerState' of + C.LedgerStateByron _st -> Nothing + C.LedgerStateShelley st -> fromState st + C.LedgerStateAllegra st -> fromState st + C.LedgerStateMary st -> fromState st + C.LedgerStateAlonzo st -> fromState st + -- TODO Pattern LedgerStateBabbage missing in cardano-node + -- https://github.com/input-output-hk/cardano-node/blob/release/1.35/cardano-api/src/Cardano/Api/LedgerState.hs#L252-L281, + -- swap this to a pattern when it appears. + C.LedgerState (O.LedgerStateBabbage st) -> fromState st + where + fromState + :: forall proto era c + . (c ~ LE.Crypto era, c ~ O.StandardCrypto) + => O.LedgerState (O.ShelleyBlock proto era) + -> Maybe (M.Map C.PoolId C.Lovelace) + fromState st = Just res + where + nes = O.shelleyLedgerState st :: SL.NewEpochState era + + stakeSnapshot = Shelley._pstakeSet . Shelley.esSnapshots . Shelley.nesEs $ nes :: Shelley.SnapShot c + stakes = Shelley.unStake $ Shelley._stake stakeSnapshot :: VMap.VMap VMap.VB VMap.VP (LC.Credential 'LK.Staking c) (L.CompactForm L.Coin) + + delegations :: VMap.VMap VMap.VB VMap.VB (LC.Credential 'LK.Staking c) (LK.KeyHash 'LK.StakePool c) + delegations = Shelley._delegations stakeSnapshot + + res :: M.Map C.PoolId C.Lovelace + res = M.fromListWith (+) $ map swap $ P.catMaybes $ VMap.elems $ + VMap.mapWithKey (\cred spkHash -> (\c -> (C.Lovelace $ coerce $ L.fromCompact c, f spkHash)) <$> VMap.lookup cred stakes) delegations + + f :: (LK.KeyHash 'LK.StakePool c) -> C.PoolId + f xk = C.StakePoolKeyHash xk + +indexer + :: FilePath -> FilePath -> SQL.Connection + -> S.Stream (S.Of Event) IO r +indexer conf socket dbCon = + CS.ledgerStates conf socket C.QuickValidation + & toEvents + & sqlite dbCon + +-- * Sqlite back-end + +-- | Consume a stream of events and write them to the database. Also +-- passes events on after they are persisted -- useful to knwow when +-- something has been persisted. +sqlite :: SQL.Connection -> S.Stream (S.Of Event) IO r -> S.Stream (S.Of Event) IO r +sqlite c source = do + lift $ SQL.execute_ c + "CREATE TABLE IF NOT EXISTS stakepool_delegation (poolId BLOB NOT NULL, lovelace INT NOT NULL, epochNo INT NOT NULL)" + loop source + + where + toRows :: Event -> [(C.EpochNo, C.PoolId, C.Lovelace)] + toRows (Event (epochNo, m)) = map (\(keyHash, lovelace) -> (epochNo, keyHash, lovelace)) $ M.toList m + + loop :: S.Stream (S.Of Event) IO r -> S.Stream (S.Of Event) IO r + loop source' = lift (S.next source') >>= \case + Left r -> pure r + Right (event, source'') -> do + lift $ forM_ (toRows event) $ \row -> + SQL.execute c "INSERT INTO stakepool_delegation (epochNo, poolId, lovelace) VALUES (?, ?, ?)" row + S.yield event + loop source'' + + +instance SQL.ToField C.EpochNo where + toField (C.EpochNo word64) = SQL.toField word64 +instance SQL.FromField C.EpochNo where + fromField f = C.EpochNo <$> SQL.fromField f + +instance SQL.ToField C.Lovelace where + toField = SQL.toField @Integer . coerce +instance SQL.FromField C.Lovelace where + fromField = coerce . SQL.fromField @Integer + +instance SQL.FromField C.PoolId where + fromField f = do + bs <- SQL.fromField f + case C.deserialiseFromRawBytes (C.AsHash C.AsStakePoolKey) bs of + Just h -> pure h + _ -> SQL.returnError SQL.ConversionFailed f " PoolId" + +instance SQL.ToField C.PoolId where + toField = SQL.toField . C.serialiseToRawBytes + +queryByEpoch :: SQL.Connection -> C.EpochNo -> IO Event +queryByEpoch c epochNo = do + xs :: [(C.PoolId, C.Lovelace)] <- SQL.query c "SELECT poolId, lovelace FROM stakepool_delegation WHERE epochNo = ?" (SQL.Only epochNo) + return $ Event (epochNo, M.fromList xs) + +queryPoolId :: SQL.Connection -> C.PoolId -> IO [(C.EpochNo, C.Lovelace)] +queryPoolId c poolId = do + SQL.query c "SELECT epochNo, lovelace FROM stakepool_delegation WHERE poolId = ?" (SQL.Only poolId) + +queryAll :: SQL.Connection -> IO [Event] +queryAll c = do + all' :: [(C.EpochNo, C.PoolId, C.Lovelace)] <- SQL.query_ c "SELECT epochNo, poolId, lovelace FROM stakepool_delegation ORDER BY epochNo ASC" + let + lastTwo (_, a, b) = (a, b) + result = all' + & groupBy ((==) `on` (\(e, _, _) -> e)) + & map (\case xs@((e, _, _) : _) -> Just $ Event (e, M.fromList $ map lastTwo xs); _ -> Nothing) + & P.catMaybes + pure result diff --git a/marconi/src/Marconi/Indexers.hs b/marconi/src/Marconi/Indexers.hs index b85687f05c..ff007c9807 100644 --- a/marconi/src/Marconi/Indexers.hs +++ b/marconi/src/Marconi/Indexers.hs @@ -13,13 +13,15 @@ import Control.Concurrent (MVar, forkIO, modifyMVar_, newMVar, readMVar) import Control.Concurrent.QSemN (QSemN, newQSemN, signalQSemN, waitQSemN) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan (TChan, dupTChan, newBroadcastTChanIO, readTChan, writeTChan) -import Control.Lens (view) +import Control.Lens (view, (&)) import Control.Lens.Operators ((^.)) import Control.Monad (void) +import Control.Monad.Trans.Class (lift) import Data.List (findIndex, foldl1', intersect) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe, mapMaybe) +import Database.SQLite.Simple qualified as SQL import Streaming.Prelude qualified as S import Cardano.Api (Block (Block), BlockHeader (BlockHeader), BlockInMode (BlockInMode), CardanoMode, @@ -28,9 +30,11 @@ import Cardano.Api qualified as C import "cardano-api" Cardano.Api.Shelley qualified as Shelley import Cardano.Ledger.Alonzo.TxWitness qualified as Alonzo import Cardano.Streaming (ChainSyncEvent (RollBackward, RollForward)) +import Cardano.Streaming qualified as CS import Control.Concurrent.STM.TMVar (TMVar) import Marconi.Index.Datum (DatumIndex) import Marconi.Index.Datum qualified as Datum +import Marconi.Index.EpochStakepoolSize qualified as EpochStakepoolSize import Marconi.Index.ScriptTx qualified as ScriptTx import Marconi.Index.Utxo qualified as Utxo import Marconi.Types (TargetAddresses) @@ -185,23 +189,52 @@ newtype UtxoQueryTMVar = UtxoQueryTMVar { unUtxoIndex :: TMVar Utxo.UtxoIndex -- ^ for query thread to access in-memory utxos } +epochStakepoolSizeWorker :: FilePath -> Worker +epochStakepoolSizeWorker configPath Coordinator{_barrier,_channel} dbPath = do + tchan <- atomically $ dupTChan _channel + let + -- Read blocks from TChan, emit them as a stream. + chainSyncEvents :: S.Stream (S.Of (ChainSyncEvent (BlockInMode CardanoMode))) IO () + chainSyncEvents = do + lift $ signalQSemN _barrier 1 + S.yield =<< (lift $ atomically $ readTChan tchan) + chainSyncEvents + + dbCon <- SQL.open dbPath + (env, initialLedgerStateHistory) <- CS.getEnvAndInitialLedgerStateHistory configPath + let + indexer = chainSyncEvents + & CS.foldLedgerState env initialLedgerStateHistory C.QuickValidation + & EpochStakepoolSize.toEvents + & EpochStakepoolSize.sqlite dbCon + + void . forkIO $ S.effects indexer + pure [ChainPointAtGenesis] + + filterIndexers :: Maybe FilePath -> Maybe FilePath -> Maybe FilePath + -> Maybe FilePath -> Maybe TargetAddresses + -> Maybe FilePath -> [(Worker, FilePath)] -filterIndexers utxoPath datumPath scriptTxPath maybeTargetAddresses = +filterIndexers utxoPath datumPath scriptTxPath epochStakepoolSizePath maybeTargetAddresses maybeConfigPath = mapMaybe liftMaybe pairs where liftMaybe (worker, maybePath) = case maybePath of Just path -> Just (worker, path) _ -> Nothing + epochStakepoolSizeIndexer = case maybeConfigPath of + Just configPath -> [(epochStakepoolSizeWorker configPath, epochStakepoolSizePath)] + _ -> [] + pairs = [ (utxoWorker pure maybeTargetAddresses, utxoPath) , (datumWorker, datumPath) , (scriptTxWorker (\_ -> pure []), scriptTxPath) - ] + ] <> epochStakepoolSizeIndexer startIndexers :: [(Worker, FilePath)] diff --git a/marconi/test/EpochStakepoolSize.hs b/marconi/test/EpochStakepoolSize.hs new file mode 100644 index 0000000000..52dc489e22 --- /dev/null +++ b/marconi/test/EpochStakepoolSize.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module EpochStakepoolSize where + +import Control.Concurrent qualified as IO +import Control.Concurrent.Async qualified as IO +import Control.Monad (forever, void, when) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=)) +import Data.Aeson qualified as J +import Data.ByteString.Lazy qualified as BL +import Data.Function ((&)) +import Data.Map qualified as Map +import Database.SQLite.Simple qualified as SQL +import Streaming.Prelude qualified as S +import System.Directory qualified as IO +import System.FilePath.Posix (()) + +import Hedgehog qualified as H +import Hedgehog.Extras.Test qualified as HE +import Test.Base qualified as H +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testPropertyNamed) + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Streaming qualified as CS +import Testnet.Cardano qualified as TN + +import Helpers qualified as TN +import Marconi.Index.EpochStakepoolSize qualified as EpochStakepoolSize + + +tests :: TestTree +tests = testGroup "EpochStakepoolSize" + [ testPropertyNamed "prop_epoch_stakepool_size" "test" test + ] + +-- This test creates two sets of payment and stake addresses, +-- transfers funds to them from the genesis address, then creates a +-- stakepool, then stakes the transferred funds in that pool, then +-- waits for when the staked ADA appears in the epoch stakepool size +-- indexer. +-- +-- Most of this was done by following relevant sections on Cardano +-- Developer Portal starting from this page: +-- https://developers.cardano.org/docs/stake-pool-course/handbook/create-stake-pool-keys, +-- and discovering how cardano-cli implements its command line +-- interface. +test :: H.Property +test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath -> do + + -- start testnet + base <- HE.noteM $ liftIO . IO.canonicalizePath =<< HE.getProjectBase + let testnetOptions = TN.defaultTestnetOptions + { TN.epochLength = 10 -- Set very short epochs: 0.2 seconds per slot * 10 slots per epoch = 2 seconds per epoch + } + (con, conf, runtime) <- TN.startTestnet testnetOptions base tempAbsPath + let networkId = TN.getNetworkId runtime + socketPath <- TN.getSocketPathAbs conf runtime + pparams <- TN.getAlonzoProtocolParams con + + -- Load genesis keys, these already exist (were already created when testnet started) + genesisVKey :: C.VerificationKey C.GenesisUTxOKey <- TN.readAs (C.AsVerificationKey C.AsGenesisUTxOKey) $ tempAbsPath "shelley/utxo-keys/utxo1.vkey" + genesisSKey :: C.SigningKey C.GenesisUTxOKey <- TN.readAs (C.AsSigningKey C.AsGenesisUTxOKey) $ tempAbsPath "shelley/utxo-keys/utxo1.skey" + let + paymentKeyFromGenesisKey = C.castVerificationKey genesisVKey :: C.VerificationKey C.PaymentKey + genesisVKeyHash = C.PaymentCredentialByKey $ C.verificationKeyHash paymentKeyFromGenesisKey + genesisAddress :: C.Address C.ShelleyAddr + genesisAddress = C.makeShelleyAddress networkId genesisVKeyHash C.NoStakeAddress :: C.Address C.ShelleyAddr + + -- Create two payment and stake keys + (paymentAddress, stakeSKey, stakeCredential) <- liftIO $ createPaymentAndStakeKey networkId + (paymentAddress2, stakeSKey2, stakeCredential2) <- liftIO $ createPaymentAndStakeKey networkId + + -- Transfer 50 and 70 ADA to both respectively + let stakedLovelace = 50_000_000 + stakedLovelace2 = 70_000_000 + totalStakedLovelace = stakedLovelace + stakedLovelace2 + TN.submitAwaitTx con =<< TN.mkTransferTx networkId con genesisAddress paymentAddress [C.WitnessGenesisUTxOKey genesisSKey] stakedLovelace + TN.submitAwaitTx con =<< TN.mkTransferTx networkId con genesisAddress paymentAddress2 [C.WitnessGenesisUTxOKey genesisSKey] stakedLovelace2 + + -- Register stake addresses + TN.submitAwaitTx con =<< registerStakeAddress networkId con pparams genesisAddress genesisSKey stakeCredential + TN.submitAwaitTx con =<< registerStakeAddress networkId con pparams genesisAddress genesisSKey stakeCredential2 + + -- Register a stake pool + let keyWitnesses = + [ C.WitnessGenesisUTxOKey genesisSKey + , C.WitnessStakeKey stakeSKey + , C.WitnessStakeKey stakeSKey2 + ] + + -- Prepare transaction to register stakepool and stake funds + (poolVKey :: C.PoolId, tx, txBody) <- registerPool con networkId pparams tempAbsPath keyWitnesses [stakeCredential, stakeCredential2] genesisAddress + + -- start indexer + found <- liftIO IO.newEmptyMVar + let dbPath = tempAbsPath "epoch_stakepool_sizes.db" + dbCon <- liftIO $ SQL.open dbPath + void $ liftIO $ do + chan <- IO.newChan + let indexer = CS.ledgerStates (TN.configurationFile runtime) socketPath C.QuickValidation + & EpochStakepoolSize.toEvents + & EpochStakepoolSize.sqlite dbCon + & S.chain (IO.writeChan chan) -- After indexer has written the event to database, we write it to the chan + void $ (IO.link =<<) $ IO.async $ void $ S.effects indexer + + -- Consume the channel until an event is found which (1) has the + -- pool ID and (2) has the right amount of lovelace staked. + (IO.link =<<) $ IO.async $ forever $ do + EpochStakepoolSize.Event (_epochNo, stakeMap) <- IO.readChan chan + case Map.lookup poolVKey stakeMap of + Just lovelace -> when (lovelace == totalStakedLovelace) $ IO.putMVar found () -- Event found! + _ -> return () + + -- Submit transaction to create stakepool and stake the funds + TN.submitAwaitTx con (tx, txBody) + + -- This is filled when the epoch stakepool size has been indexed + liftIO $ IO.takeMVar found + + -- Let's find it in the database as well + epochStakes <- liftIO $ EpochStakepoolSize.queryPoolId dbCon poolVKey + case epochStakes of + ((_, lovelace) : _) -> H.assert $ lovelace == totalStakedLovelace + _ -> fail "Can't find the stake for pool in sqlite!" + +-- | This is a pure version of `runStakePoolRegistrationCert` defined in /cardano-node/cardano-cli/src/Cardano/CLI/Shelley/Run/Pool.hs::60 +makeStakePoolRegistrationCert_ + :: C.VerificationKey C.StakePoolKey + -> C.VerificationKey C.VrfKey + -> C.Lovelace + -> C.Lovelace + -> Rational + -> C.VerificationKey C.StakeKey + -> [C.VerificationKey C.StakeKey] + -> [C.StakePoolRelay] + -> Maybe C.StakePoolMetadataReference + -> C.NetworkId + -> C.Certificate +makeStakePoolRegistrationCert_ stakePoolVerKey vrfVerKey pldg pCost pMrgn rwdStakeVerKey sPoolOwnerVkeys relays mbMetadata network = let + -- Pool verification key + stakePoolId' = C.verificationKeyHash stakePoolVerKey + -- VRF verification key + vrfKeyHash' = C.verificationKeyHash vrfVerKey + -- Pool reward account + stakeCred = C.StakeCredentialByKey (C.verificationKeyHash rwdStakeVerKey) + rewardAccountAddr = C.makeStakeAddress network stakeCred + -- Pool owner(s) + stakePoolOwners' = map C.verificationKeyHash sPoolOwnerVkeys + stakePoolParams = + C.StakePoolParameters + { C.stakePoolId = stakePoolId' + , C.stakePoolVRF = vrfKeyHash' + , C.stakePoolCost = pCost + , C.stakePoolMargin = pMrgn + , C.stakePoolRewardAccount = rewardAccountAddr + , C.stakePoolPledge = pldg + , C.stakePoolOwners = stakePoolOwners' + , C.stakePoolRelays = relays + , C.stakePoolMetadata = mbMetadata + } + in C.makeStakePoolRegistrationCertificate stakePoolParams + +-- | Create a payment and related stake keys +createPaymentAndStakeKey :: C.NetworkId -> IO (C.Address C.ShelleyAddr, C.SigningKey C.StakeKey, C.StakeCredential) +createPaymentAndStakeKey networkId = do + -- Payment key pair: cardano-cli address key-gen + paymentSKey :: C.SigningKey C.PaymentKey <- C.generateSigningKey C.AsPaymentKey + let paymentVKey = C.getVerificationKey paymentSKey :: C.VerificationKey C.PaymentKey + paymentVKeyHash = C.PaymentCredentialByKey $ C.verificationKeyHash paymentVKey + + -- Stake key pair, cardano-cli stake-address key-gen + stakeSKey :: C.SigningKey C.StakeKey <- C.generateSigningKey C.AsStakeKey + let stakeVKey = C.getVerificationKey stakeSKey :: C.VerificationKey C.StakeKey + stakeCredential = C.StakeCredentialByKey $ C.verificationKeyHash stakeVKey :: C.StakeCredential + stakeAddressReference = C.StakeAddressByValue stakeCredential :: C.StakeAddressReference + + -- Payment address that references the stake address, cardano-cli address build + let paymentAddress = C.makeShelleyAddress networkId paymentVKeyHash stakeAddressReference :: C.Address C.ShelleyAddr + return (paymentAddress, stakeSKey, stakeCredential) + + +registerStakeAddress + :: C.NetworkId -> C.LocalNodeConnectInfo C.CardanoMode -> C.ProtocolParameters -> C.Address C.ShelleyAddr -> C.SigningKey C.GenesisUTxOKey -> C.StakeCredential + -> HE.Integration (C.Tx C.AlonzoEra, C.TxBody C.AlonzoEra) +registerStakeAddress networkId con pparams payerAddress payerSKey stakeCredential = do + + -- Create a registration certificate: cardano-cli stake-address registration-certificate + let stakeAddressRegCert = C.makeStakeAddressRegistrationCertificate stakeCredential :: C.Certificate + + -- Draft transaction & Calculate fees; Submit the certificate with a transaction + -- cardano-cli transaction build + -- cardano-cli transaction sign + -- cardano-cli transaction submit + (txIns, totalLovelace) <- TN.getAddressTxInsValue con payerAddress + let + dummyFee = 0 + tx0 = (TN.emptyTxBodyContent dummyFee pparams) + { C.txIns = map (, C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending) txIns + , C.txOuts = [TN.mkAddressAdaTxOut payerAddress $ totalLovelace - dummyFee] + , C.txCertificates = C.TxCertificates C.CertificatesInAlonzoEra [stakeAddressRegCert] (C.BuildTxWith mempty) + } + keyWitnesses = [C.WitnessGenesisUTxOKey payerSKey] + txBody0 :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx0 + let + feeLovelace = TN.calculateFee pparams (length $ C.txIns tx0) (length $ C.txOuts tx0) 0 (length keyWitnesses) networkId txBody0 :: C.Lovelace + fee = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra feeLovelace + tx1 = tx0 { C.txFee = fee, C.txOuts = [TN.mkAddressAdaTxOut payerAddress $ totalLovelace - feeLovelace] } + + txBody <- HE.leftFail $ C.makeTransactionBody tx1 + let tx = C.signShelleyTransaction txBody keyWitnesses + return (tx, txBody) + +registerPool + :: C.LocalNodeConnectInfo C.CardanoMode -> C.NetworkId -> C.ProtocolParameters -> FilePath + -> [C.ShelleyWitnessSigningKey] -> [C.StakeCredential] -> C.Address C.ShelleyAddr + -> HE.Integration (C.PoolId, C.Tx C.AlonzoEra, C.TxBody C.AlonzoEra) +registerPool con networkId pparams tempAbsPath keyWitnesses stakeCredentials payerAddress = do + + -- Create the metadata file + HE.lbsWriteFile (tempAbsPath "poolMetadata.json") . J.encode $ J.object + -- [ "heavyDelThd" .= J.toJSON @String "300000000000" + [ "name" .= id @String "TestPool" + , "description" .= id @String "The pool that tests all the pools" + , "ticker" .= id @String "TEST" + , "homepage" .= id @String "https://teststakepool.com" + ] + lbs <- HE.lbsReadFile (tempAbsPath "poolMetadata.json") + -- cardano-cli stake-pool metadata-hash --pool-metadata-file + (_poolMetadata, poolMetadataHash) <- HE.leftFail $ C.validateAndHashStakePoolMetadata $ BL.toStrict lbs + + -- TODO: these are missing from the tutorial? https://developers.cardano.org/docs/stake-pool-course/handbook/register-stake-pool-metadata + coldSKey :: C.SigningKey C.StakePoolKey <- liftIO $ C.generateSigningKey C.AsStakePoolKey + let coldVKey = C.getVerificationKey coldSKey :: C.VerificationKey C.StakePoolKey + coldVKeyHash = (C.verificationKeyHash coldVKey :: C.Hash C.StakePoolKey) :: C.PoolId + skeyVrf :: C.SigningKey C.VrfKey <- liftIO $ C.generateSigningKey C.AsVrfKey + let vkeyVrf = C.getVerificationKey skeyVrf :: C.VerificationKey C.VrfKey + + -- A key for where stakepool rewards go + stakeSKey :: C.SigningKey C.StakeKey <- liftIO $ C.generateSigningKey C.AsStakeKey + let stakeVKey = C.getVerificationKey stakeSKey :: C.VerificationKey C.StakeKey + + -- Generate Stake pool registration certificate: cardano-cli stake-pool registration-certificate + let poolRegistration :: C.Certificate + poolRegistration = makeStakePoolRegistrationCert_ + coldVKey -- stakePoolVerKey; :: C.VerificationKey C.StakePoolKey; node key-gen + vkeyVrf -- vrfVerKey -> C.VerificationKey C.VrfKey + 0 -- pldg -> C.Lovelace + 0 -- pCost -> C.Lovelace + 0 -- pMrgn -> Rational + stakeVKey -- rwdStakeVerKey -> C.VerificationKey C.StakeKey -- TODO correct key used? + [] -- sPoolOwnerVkeys -> [C.VerificationKey C.StakeKey] + [] -- relays -> [C.StakePoolRelay] + (Just $ C.StakePoolMetadataReference "" poolMetadataHash) -- -> Maybe C.StakePoolMetadataReference + networkId -- -> C.NetworkId + + -- Generate delegation certificate pledge: cardano-cli stake-address delegation-certificate + let delegationCertificates = map (\c -> C.makeStakeAddressDelegationCertificate c coldVKeyHash) stakeCredentials + keyWitnesses' = keyWitnesses <> [ C.WitnessStakePoolKey coldSKey ] + + -- Create transaction + do (txIns, totalLovelace) <- TN.getAddressTxInsValue con payerAddress + let + dummyFee = 0 + tx0 = (TN.emptyTxBodyContent dummyFee pparams) + { C.txIns = (map (, C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending) txIns) + , C.txOuts = [TN.mkAddressAdaTxOut payerAddress $ totalLovelace - dummyFee] + , C.txCertificates = C.TxCertificates C.CertificatesInAlonzoEra + ([poolRegistration] <> delegationCertificates) + (C.BuildTxWith mempty) -- BuildTxWith build (Map StakeCredential (Witness WitCtxStake era)) + } + txBody0 :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx0 + let + -- cardano-cli transaction calculate-min-fee + feeLovelace = TN.calculateFee pparams (length $ C.txIns tx0) (length $ C.txOuts tx0) 0 (length keyWitnesses') networkId txBody0 :: C.Lovelace + fee = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra feeLovelace + tx1 = tx0 { C.txFee = fee, C.txOuts = [TN.mkAddressAdaTxOut payerAddress $ totalLovelace - feeLovelace] } + + txBody :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx1 + let tx = C.signShelleyTransaction txBody keyWitnesses' + + return (coldVKeyHash, tx, txBody) diff --git a/marconi/test/Helpers.hs b/marconi/test/Helpers.hs new file mode 100644 index 0000000000..62bea4fbb7 --- /dev/null +++ b/marconi/test/Helpers.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} + +module Helpers where + +import Control.Concurrent qualified as IO +import Control.Concurrent.Async qualified as IO +import Control.Monad (void, when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Function ((&)) +import Data.Map qualified as Map +import Data.Set qualified as Set +import GHC.Stack qualified as GHC +import Streaming.Prelude qualified as S +import System.Directory qualified as IO +import System.Environment qualified as IO +import System.FilePath (()) +import System.IO qualified as IO +import System.IO.Temp qualified as IO +import System.Info qualified as IO + +import Hedgehog (MonadTest) +import Hedgehog qualified as H +import Hedgehog.Extras.Stock.CallStack qualified as H +import Hedgehog.Extras.Stock.IO.Network.Sprocket qualified as IO +import Hedgehog.Extras.Test qualified as HE +import Hedgehog.Extras.Test.Base qualified as H + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Streaming qualified as CS +import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (SubmitFail, SubmitSuccess)) +import Test.Runtime qualified as TN +import Testnet.Cardano qualified as TN +import Testnet.Conf qualified as TC (Conf (..), ProjectBase (ProjectBase), YamlFilePath (YamlFilePath), mkConf) + +-- | Start a testnet. +startTestnet + :: TN.TestnetOptions + -> FilePath + -> FilePath + -> H.Integration (C.LocalNodeConnectInfo C.CardanoMode, TC.Conf, TN.TestnetRuntime) +startTestnet testnetOptions base tempAbsBasePath' = do + configurationTemplate <- H.noteShow $ base "configuration/defaults/byron-mainnet/configuration.yaml" + conf :: TC.Conf <- HE.noteShowM $ + TC.mkConf (TC.ProjectBase base) (TC.YamlFilePath configurationTemplate) + (tempAbsBasePath' <> "/") + Nothing + tn <- TN.testnet testnetOptions conf + + -- Boilerplate codecs used for protocol serialisation. The number + -- of epochSlots is specific to each blockchain instance. This value + -- what the cardano main and testnet uses. Only applies to the Byron + -- era. + socketPathAbs <- getSocketPathAbs conf tn + let epochSlots = C.EpochSlots 21600 + localNodeConnectInfo = + C.LocalNodeConnectInfo + { C.localConsensusModeParams = C.CardanoModeParams epochSlots + , C.localNodeNetworkId = getNetworkId tn + , C.localNodeSocketPath = socketPathAbs + } + + pure (localNodeConnectInfo, conf, tn) + +getNetworkId :: TN.TestnetRuntime -> C.NetworkId +getNetworkId tn = C.Testnet $ C.NetworkMagic $ fromIntegral (TN.testnetMagic tn) + +getSocketPathAbs :: (MonadTest m, MonadIO m) => TC.Conf -> TN.TestnetRuntime -> m FilePath +getSocketPathAbs conf tn = do + let tempAbsPath = TC.tempAbsPath conf + socketPath <- IO.sprocketArgumentName <$> H.headM (TN.nodeSprocket <$> TN.bftNodes tn) + socketPathAbs <- H.note =<< (liftIO $ IO.canonicalizePath $ tempAbsPath socketPath) + pure socketPathAbs + +getPoolSocketPathAbs :: (MonadTest m, MonadIO m) => TC.Conf -> TN.TestnetRuntime -> m FilePath +getPoolSocketPathAbs conf tn = do + let tempAbsPath = TC.tempAbsPath conf + socketPath <- IO.sprocketArgumentName <$> H.headM (TN.poolNodeSprocket <$> TN.poolNodes tn) + socketPathAbs <- H.note =<< (liftIO $ IO.canonicalizePath $ tempAbsPath socketPath) + pure socketPathAbs + +readAs :: (C.HasTextEnvelope a, MonadIO m, MonadTest m) => C.AsType a -> FilePath -> m a +readAs as path = do + path' <- H.note path + H.leftFailM . liftIO $ C.readFileTextEnvelope as path' + +-- | An empty transaction +emptyTxBodyContent :: C.Lovelace -> C.ProtocolParameters -> C.TxBodyContent C.BuildTx C.AlonzoEra +emptyTxBodyContent fee pparams = C.TxBodyContent + { C.txIns = [] + , C.txInsCollateral = C.TxInsCollateralNone + , C.txInsReference = C.TxInsReferenceNone + , C.txOuts = [] + , C.txTotalCollateral = C.TxTotalCollateralNone + , C.txReturnCollateral = C.TxReturnCollateralNone + , C.txFee = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra fee + , C.txValidityRange = (C.TxValidityNoLowerBound, C.TxValidityNoUpperBound C.ValidityNoUpperBoundInAlonzoEra) + , C.txMetadata = C.TxMetadataNone + , C.txAuxScripts = C.TxAuxScriptsNone + , C.txExtraKeyWits = C.TxExtraKeyWitnessesNone + , C.txProtocolParams = C.BuildTxWith $ Just pparams + , C.txWithdrawals = C.TxWithdrawalsNone + , C.txCertificates = C.TxCertificatesNone + , C.txUpdateProposal = C.TxUpdateProposalNone + , C.txMintValue = C.TxMintNone + , C.txScriptValidity = C.TxScriptValidityNone + } + +getAlonzoProtocolParams :: (MonadIO m, MonadTest m) => C.LocalNodeConnectInfo C.CardanoMode -> m C.ProtocolParameters +getAlonzoProtocolParams localNodeConnectInfo = H.leftFailM . H.leftFailM . liftIO + $ C.queryNodeLocalState localNodeConnectInfo Nothing + $ C.QueryInEra C.AlonzoEraInCardanoMode + $ C.QueryInShelleyBasedEra C.ShelleyBasedEraAlonzo C.QueryProtocolParameters + +findUTxOByAddress + :: (MonadIO m, MonadTest m) + => C.LocalNodeConnectInfo C.CardanoMode -> C.Address a -> m (C.UTxO C.AlonzoEra) +findUTxOByAddress localNodeConnectInfo address = let + query = C.QueryInShelleyBasedEra C.ShelleyBasedEraAlonzo $ C.QueryUTxO $ + C.QueryUTxOByAddress $ Set.singleton (C.toAddressAny address) + in + H.leftFailM . H.leftFailM . liftIO $ C.queryNodeLocalState localNodeConnectInfo Nothing $ + C.QueryInEra C.AlonzoEraInCardanoMode query + +-- | Get [TxIn] and total value for an address. +getAddressTxInsValue + :: (MonadIO m, MonadTest m) + => C.LocalNodeConnectInfo C.CardanoMode -> C.Address a -> m ([C.TxIn], C.Lovelace) +getAddressTxInsValue con address = do + utxo <- findUTxOByAddress con address + let + (txIns, txOuts) = unzip $ Map.toList $ C.unUTxO utxo + values = map (\case C.TxOut _ v _ _ -> C.txOutValueToLovelace v) txOuts + pure (txIns, sum values) + +submitTx :: (MonadIO m, MonadTest m) => C.LocalNodeConnectInfo C.CardanoMode -> C.Tx C.AlonzoEra -> m () +submitTx localNodeConnectInfo tx = do + submitResult :: SubmitResult (C.TxValidationErrorInMode C.CardanoMode) <- + liftIO $ C.submitTxToNodeLocal localNodeConnectInfo $ C.TxInMode tx C.AlonzoEraInCardanoMode + failOnTxSubmitFail submitResult + where + failOnTxSubmitFail :: (Show a, MonadTest m) => SubmitResult a -> m () + failOnTxSubmitFail = \case + SubmitFail reason -> H.failMessage GHC.callStack $ "Transaction failed: " <> show reason + SubmitSuccess -> pure () + +-- | Block until a transaction with @txId@ is sent over the local chainsync protocol. +awaitTxId :: C.LocalNodeConnectInfo C.CardanoMode -> C.TxId -> IO () +awaitTxId con txId = do + chan :: IO.Chan [C.TxId] <- IO.newChan + let indexer = CS.blocks con C.ChainPointAtGenesis + & CS.ignoreRollbacks + & S.map bimTxIds + & S.chain (IO.writeChan chan) + void $ (IO.link =<<) $ IO.async $ void $ S.effects indexer + let loop = do + txIds <- IO.readChan chan + when (not $ txId `elem` txIds) loop + loop + +-- | Submit the argument transaction and await for it to be accepted into the blockhain. +submitAwaitTx + :: (MonadIO m, MonadTest m) + => C.LocalNodeConnectInfo C.CardanoMode -> (C.Tx C.AlonzoEra, C.TxBody C.AlonzoEra) -> m () +submitAwaitTx con (tx, txBody) = do + submitTx con tx + liftIO $ awaitTxId con $ C.getTxId txBody + +mkTransferTx + :: (MonadIO m, MonadTest m, MonadFail m) + => C.NetworkId -> C.LocalNodeConnectInfo C.CardanoMode -> C.Address C.ShelleyAddr -> C.Address C.ShelleyAddr -> [C.ShelleyWitnessSigningKey] -> C.Lovelace + -> m (C.Tx C.AlonzoEra, C.TxBody C.AlonzoEra) +mkTransferTx networkId con from to keyWitnesses howMuch = do + pparams <- getAlonzoProtocolParams con + (txIns, totalLovelace) <- getAddressTxInsValue con from + let + fee0 = 0 + tx0 = (emptyTxBodyContent fee0 pparams) + { C.txIns = map (, C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending) txIns + , C.txOuts = [mkAddressAdaTxOut to $ totalLovelace - fee0] + } + txBody0 :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx0 + let fee = calculateFee pparams (length $ C.txIns tx0) (length $ C.txOuts tx0) 0 (length keyWitnesses) networkId txBody0 :: C.Lovelace + + when (howMuch + fee >= totalLovelace) $ fail "Not enough funds" + let + tx = tx0 { C.txFee = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra fee + , C.txOuts = [ mkAddressAdaTxOut to howMuch + , mkAddressAdaTxOut from $ totalLovelace - howMuch - fee + ]} + txBody :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx + return (C.signShelleyTransaction txBody keyWitnesses, txBody) + +mkAddressAdaTxOut :: C.Address C.ShelleyAddr -> C.Lovelace -> C.TxOut ctx C.AlonzoEra +mkAddressAdaTxOut address lovelace = + C.TxOut + (C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraAlonzo) address) + (C.TxOutValue C.MultiAssetInAlonzoEra $ C.lovelaceToValue lovelace) + C.TxOutDatumNone + C.ReferenceScriptNone + +-- | Adapted from: +-- https://github.com/input-output-hk/cardano-node/blob/d15ff2b736452857612dd533c1ddeea2405a2630/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs#L1105-L1112 +-- https://github.com/input-output-hk/cardano-node/blob/d15ff2b736452857612dd533c1ddeea2405a2630/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs#L1121-L1128 +calculateFee :: C.IsShelleyBasedEra era => C.ProtocolParameters -> Int -> Int -> Int -> Int -> C.NetworkId -> C.TxBody era -> C.Lovelace +calculateFee pparams nInputs nOutputs nByronKeyWitnesses nShelleyKeyWitnesses networkId txBody = C.estimateTransactionFee + networkId + (C.protocolParamTxFeeFixed pparams) + (C.protocolParamTxFeePerByte pparams) + (C.makeSignedTransaction [] txBody) + nInputs nOutputs + nByronKeyWitnesses nShelleyKeyWitnesses + +-- | This is a copy of the workspace from +-- hedgehog-extras:Hedgehog.Extras.Test.Base, which for darwin sets +-- the systemTemp folder to /tmp. +-- +-- It creates a temporary folder with @prefixPath@, which is removed +-- after the supplied function @f@ returns. +workspace :: (MonadTest m, MonadIO m, GHC.HasCallStack) => FilePath -> (FilePath -> m ()) -> m () +workspace prefixPath f = GHC.withFrozenCallStack $ do + systemTemp <- case IO.os of + "darwin" -> pure "/tmp" + _ -> H.evalIO IO.getCanonicalTemporaryDirectory + maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE" + let systemPrefixPath = systemTemp <> "/" <> prefixPath + H.evalIO $ IO.createDirectoryIfMissing True systemPrefixPath + ws <- H.evalIO $ IO.createTempDirectory systemPrefixPath "test" + H.annotate $ "Workspace: " <> ws + liftIO $ IO.writeFile (ws <> "/module") H.callerModuleName + f ws + when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do + H.evalIO $ IO.removeDirectoryRecursive ws + +-- * Accessors + +bimTxIds :: C.BlockInMode mode -> [C.TxId] +bimTxIds (C.BlockInMode block _) = blockTxIds block + +blockTxIds :: C.Block era -> [C.TxId] +blockTxIds (C.Block (C.BlockHeader _slotNo _ _blockNo) txs) = map (C.getTxId . C.getTxBody) txs + +bimSlotNo :: C.BlockInMode mode -> C.SlotNo +bimSlotNo (C.BlockInMode (C.Block (C.BlockHeader slotNo _ _blockNo) _txs) _era) = slotNo + +bimBlockNo :: C.BlockInMode mode -> C.BlockNo +bimBlockNo (C.BlockInMode (C.Block (C.BlockHeader _slotNo _ blockNo) _txs) _era) = blockNo diff --git a/marconi/test/Integration.hs b/marconi/test/Integration.hs index 0bba78ae5a..f80f261314 100644 --- a/marconi/test/Integration.hs +++ b/marconi/test/Integration.hs @@ -14,24 +14,21 @@ import Control.Concurrent qualified as IO import Control.Concurrent.STM qualified as IO import Control.Exception (catch) import Control.Monad (void, when) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Short qualified as SBS import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map -import Data.Set qualified as Set -import GHC.Stack qualified as GHC import Streaming.Prelude qualified as S import System.Directory qualified as IO import System.Environment qualified as IO import System.FilePath (()) import System.Info qualified as IO -import Hedgehog (MonadTest, Property, assert, (===)) +import Hedgehog (Property, assert, (===)) import Hedgehog qualified as H -import Hedgehog.Extras.Stock.IO.Network.Sprocket qualified as IO import Hedgehog.Extras.Test qualified as HE import Hedgehog.Extras.Test.Base qualified as H import Test.Tasty (TestTree, testGroup) @@ -44,14 +41,16 @@ import Cardano.BM.Trace (logError) import Cardano.BM.Tracing (defaultConfigStdout) import Cardano.Streaming (ChainSyncEventException (NoIntersectionFound), withChainSyncEventStream) import Gen.Cardano.Api.Typed qualified as CGen -import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (SubmitFail, SubmitSuccess)) import Plutus.V1.Ledger.Scripts qualified as Plutus import PlutusTx qualified import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty, (<+>)) import Prettyprinter.Render.Text (renderStrict) import Test.Base qualified as H + +import Helpers qualified as TN import Testnet.Cardano qualified as TN -import Testnet.Conf qualified as TC (Conf (..), ProjectBase (ProjectBase), YamlFilePath (YamlFilePath), mkConf) +-- ^ Although these are defined in this cabal component, they are +-- helpers for interacting with the testnet, thus TN import Marconi.Index.ScriptTx qualified as ScriptTx import Marconi.Indexers qualified as M @@ -78,9 +77,12 @@ tests = testGroup "Integration" the indexer to see if it was indexed properly -} testIndex :: Property -testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.workspace "." $ \tempAbsBasePath' -> do +testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.workspace "." $ \tempAbsPath -> do base <- HE.noteM $ liftIO . IO.canonicalizePath =<< HE.getProjectBase - (socketPathAbs, networkId, tempAbsPath) <- startTestnet base tempAbsBasePath' + + (localNodeConnectInfo, conf, runtime) <- TN.startTestnet TN.defaultTestnetOptions base tempAbsPath + let networkId = TN.getNetworkId runtime + socketPathAbs <- TN.getSocketPathAbs conf runtime -- Create a channel that is passed into the indexer, such that it -- can write index updates to it and we can await for them (also @@ -114,9 +116,6 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo return indexer - utxoVKeyFile <- H.note $ tempAbsPath "shelley/utxo-keys/utxo1.vkey" - utxoSKeyFile <- H.note $ tempAbsPath "shelley/utxo-keys/utxo1.skey" - let -- Create an always succeeding validator script plutusScript :: C.PlutusScript C.PlutusScriptV1 @@ -134,9 +133,9 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo -- in order to accomodate this. genesisVKey :: C.VerificationKey C.GenesisUTxOKey <- - readAs (C.AsVerificationKey C.AsGenesisUTxOKey) utxoVKeyFile + TN.readAs (C.AsVerificationKey C.AsGenesisUTxOKey) $ tempAbsPath "shelley/utxo-keys/utxo1.vkey" genesisSKey :: C.SigningKey C.GenesisUTxOKey <- - readAs (C.AsSigningKey C.AsGenesisUTxOKey) utxoSKeyFile + TN.readAs (C.AsSigningKey C.AsGenesisUTxOKey) $ tempAbsPath "shelley/utxo-keys/utxo1.skey" let paymentKey = C.castVerificationKey genesisVKey :: C.VerificationKey C.PaymentKey @@ -146,27 +145,12 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo (C.PaymentCredentialByKey (C.verificationKeyHash paymentKey :: C.Hash C.PaymentKey)) C.NoStakeAddress :: C.Address C.ShelleyAddr - -- Boilerplate codecs used for protocol serialisation. The number - -- of epochSlots is specific to each blockchain instance. This value - -- what the cardano main and testnet uses. Only applies to the Byron - -- era. - let epochSlots = C.EpochSlots 21600 - localNodeConnectInfo = - C.LocalNodeConnectInfo - { C.localConsensusModeParams = C.CardanoModeParams epochSlots - , C.localNodeNetworkId = networkId - , C.localNodeSocketPath = socketPathAbs - } - (tx1in, C.TxOut _ v _ _) <- do - utxo <- findUTxOByAddress localNodeConnectInfo (C.toAddressAny address) - headM $ Map.toList $ C.unUTxO utxo + utxo <- TN.findUTxOByAddress localNodeConnectInfo address + H.headM $ Map.toList $ C.unUTxO utxo let totalLovelace = C.txOutValueToLovelace v - pparams <- H.leftFailM . H.leftFailM . liftIO - $ C.queryNodeLocalState localNodeConnectInfo Nothing - $ C.QueryInEra C.AlonzoEraInCardanoMode - $ C.QueryInShelleyBasedEra C.ShelleyBasedEraAlonzo C.QueryProtocolParameters + pparams <- TN.getAlonzoProtocolParams localNodeConnectInfo let scriptDatum = C.ScriptDataNumber 42 :: C.ScriptData scriptDatumHash = C.hashScriptData scriptDatum @@ -191,25 +175,10 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo C.TxOutDatumNone C.ReferenceScriptNone txBodyContent :: C.TxBodyContent C.BuildTx C.AlonzoEra - txBodyContent = - C.TxBodyContent { - C.txIns = [(tx1in, C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending)], - C.txInsCollateral = C.TxInsCollateralNone, - C.txInsReference = C.TxInsReferenceNone, - C.txOuts = [txOut1, txOut2], - C.txTotalCollateral = C.TxTotalCollateralNone, - C.txReturnCollateral = C.TxReturnCollateralNone, - C.txFee = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra tx1fee, - C.txValidityRange = (C.TxValidityNoLowerBound, C.TxValidityNoUpperBound C.ValidityNoUpperBoundInAlonzoEra), - C.txMetadata = C.TxMetadataNone, - C.txAuxScripts = C.TxAuxScriptsNone, - C.txExtraKeyWits = C.TxExtraKeyWitnessesNone, - C.txProtocolParams = C.BuildTxWith $ Just pparams, - C.txWithdrawals = C.TxWithdrawalsNone, - C.txCertificates = C.TxCertificatesNone, - C.txUpdateProposal = C.TxUpdateProposalNone, - C.txMintValue = C.TxMintNone, - C.txScriptValidity = C.TxScriptValidityNone + txBodyContent = (TN.emptyTxBodyContent tx1fee pparams) + { C.txIns = [(tx1in, C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending)] + , C.txOuts = [txOut1, txOut2] + , C.txProtocolParams = C.BuildTxWith $ Just pparams } tx1body :: C.TxBody C.AlonzoEra <- H.leftFail $ C.makeTransactionBody txBodyContent let @@ -217,17 +186,17 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo kw = C.makeShelleyKeyWitness tx1body (C.WitnessPaymentKey $ C.castSigningKey genesisSKey) tx1 = C.makeSignedTransaction [kw] tx1body - submitTx localNodeConnectInfo tx1 + TN.submitTx localNodeConnectInfo tx1 -- Second transaction: spend the UTXO specified in the first transaction _ <- liftIO $ IO.readChan indexedTxs -- wait for the first transaction to be accepted - tx2collateralTxIn <- headM . Map.keys . C.unUTxO =<< findUTxOByAddress localNodeConnectInfo (C.toAddressAny address) + tx2collateralTxIn <- H.headM . Map.keys . C.unUTxO =<< TN.findUTxOByAddress localNodeConnectInfo address (scriptTxIn, C.TxOut _ valueAtScript _ _) <- do - scriptUtxo <- findUTxOByAddress localNodeConnectInfo $ C.toAddressAny plutusScriptAddr - headM $ Map.toList $ C.unUTxO scriptUtxo + scriptUtxo <- TN.findUTxOByAddress localNodeConnectInfo plutusScriptAddr + H.headM $ Map.toList $ C.unUTxO scriptUtxo let lovelaceAtScript = C.txOutValueToLovelace valueAtScript assert $ lovelaceAtScript == 10_000_000 -- script has the 10 ADA we put there in tx1 @@ -247,43 +216,17 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo C.PlutusScriptWitness C.PlutusScriptV1InAlonzo C.PlutusScriptV1 (C.PScript plutusScript) (C.ScriptDatumForTxIn scriptDatum) redeemer executionUnits - collateral = C.TxInsCollateral C.CollateralInAlonzoEra [tx2collateralTxIn] - - tx2out :: C.TxOut ctx C.AlonzoEra - tx2out = - C.TxOut - (C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraAlonzo) address) - -- send ADA back to the original genesis address ^ - (C.TxOutValue C.MultiAssetInAlonzoEra $ C.lovelaceToValue $ lovelaceAtScript - tx2fee) - C.TxOutDatumNone - C.ReferenceScriptNone - tx2bodyContent :: C.TxBodyContent C.BuildTx C.AlonzoEra - tx2bodyContent = - C.TxBodyContent { - C.txIns = [(scriptTxIn, C.BuildTxWith scriptWitness)], - C.txInsCollateral = collateral, - C.txInsReference = C.TxInsReferenceNone, - C.txOuts = [tx2out], - C.txTotalCollateral = C.TxTotalCollateralNone, - C.txReturnCollateral = C.TxReturnCollateralNone, - C.txFee = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra tx2fee, - C.txValidityRange = (C.TxValidityNoLowerBound, C.TxValidityNoUpperBound C.ValidityNoUpperBoundInAlonzoEra), - C.txMetadata = C.TxMetadataNone, - C.txAuxScripts = C.TxAuxScriptsNone, - C.txExtraKeyWits = C.TxExtraKeyWitnessesNone, - C.txProtocolParams = C.BuildTxWith $ Just pparams, - C.txWithdrawals = C.TxWithdrawalsNone, - C.txCertificates = C.TxCertificatesNone, - C.txUpdateProposal = C.TxUpdateProposalNone, - C.txMintValue = C.TxMintNone, - C.txScriptValidity = C.TxScriptValidityNone + tx2bodyContent = (TN.emptyTxBodyContent tx2fee pparams) + { C.txIns = [(scriptTxIn, C.BuildTxWith scriptWitness)] + , C.txInsCollateral = C.TxInsCollateral C.CollateralInAlonzoEra [tx2collateralTxIn] + , C.txOuts = [TN.mkAddressAdaTxOut address (lovelaceAtScript - tx2fee)] } tx2body :: C.TxBody C.AlonzoEra <- H.leftFail $ C.makeTransactionBody tx2bodyContent let tx2 = C.signShelleyTransaction tx2body [C.WitnessGenesisUTxOKey genesisSKey] - submitTx localNodeConnectInfo tx2 + TN.submitTx localNodeConnectInfo tx2 {- Test if what the indexer got is what we sent. @@ -301,7 +244,7 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo -- For more details see https://github.com/input-output-hk/plutus-apps/issues/775 let (ScriptTx.TxCbor tx, indexedScriptHashes) = head $ NE.filter (\(_, hashes) -> hashes /= []) indexedWithScriptHashes - ScriptTx.ScriptTxAddress indexedScriptHash <- headM indexedScriptHashes + ScriptTx.ScriptTxAddress indexedScriptHash <- H.headM indexedScriptHashes indexedTx2 :: C.Tx C.AlonzoEra <- H.leftFail $ C.deserialiseFromCBOR (C.AsTx C.AsAlonzoEra) tx @@ -318,49 +261,5 @@ testIndex = H.integration $ (liftIO setDarwinTmpdir >>) $ HE.runFinallies $ H.wo -- * Helpers -startTestnet :: FilePath -> FilePath -> H.Integration (String, C.NetworkId, FilePath) -startTestnet base tempAbsBasePath' = do - configurationTemplate <- H.noteShow $ base "configuration/defaults/byron-mainnet/configuration.yaml" - conf@TC.Conf { TC.tempBaseAbsPath, TC.tempAbsPath } <- HE.noteShowM $ - TC.mkConf (TC.ProjectBase base) (TC.YamlFilePath configurationTemplate) - (tempAbsBasePath' <> "/") - Nothing - assert $ tempAbsPath == (tempAbsBasePath' <> "/") - && tempAbsPath == (tempBaseAbsPath <> "/") - tn <- TN.testnet TN.defaultTestnetOptions conf - let networkId = C.Testnet $ C.NetworkMagic $ fromIntegral (TN.testnetMagic tn) - socketPath <- IO.sprocketArgumentName <$> headM (TN.nodeSprocket <$> TN.bftNodes tn) - socketPathAbs <- H.note =<< (liftIO $ IO.canonicalizePath $ tempAbsPath socketPath) - pure (socketPathAbs, networkId, tempAbsPath) - -readAs :: (C.HasTextEnvelope a, MonadIO m, MonadTest m) => C.AsType a -> FilePath -> m a -readAs as path = H.leftFailM . liftIO $ C.readFileTextEnvelope as path - -findUTxOByAddress - :: (MonadIO m, MonadTest m) - => C.LocalNodeConnectInfo C.CardanoMode -> C.AddressAny -> m (C.UTxO C.AlonzoEra) -findUTxOByAddress localNodeConnectInfo address = let - query = C.QueryInShelleyBasedEra C.ShelleyBasedEraAlonzo $ C.QueryUTxO $ - C.QueryUTxOByAddress $ Set.singleton address - in - H.leftFailM . H.leftFailM . liftIO $ C.queryNodeLocalState localNodeConnectInfo Nothing $ - C.QueryInEra C.AlonzoEraInCardanoMode query - -submitTx :: (MonadIO m, MonadTest m) => C.LocalNodeConnectInfo C.CardanoMode -> C.Tx C.AlonzoEra -> m () -submitTx localNodeConnectInfo tx = do - submitResult :: SubmitResult (C.TxValidationErrorInMode C.CardanoMode) <- - liftIO $ C.submitTxToNodeLocal localNodeConnectInfo $ C.TxInMode tx C.AlonzoEraInCardanoMode - failOnTxSubmitFail submitResult - where - failOnTxSubmitFail :: (Show a, MonadTest m) => SubmitResult a -> m () - failOnTxSubmitFail = \case - SubmitFail reason -> H.failMessage GHC.callStack $ "Transaction failed: " <> show reason - SubmitSuccess -> pure () - --- TODO: remove when this is exported from hedgehog-extras/src/Hedgehog/Extras/Test/Base.hs -headM :: (MonadTest m, GHC.HasCallStack) => [a] -> m a -headM (a:_) = return a -headM [] = GHC.withFrozenCallStack $ H.failMessage GHC.callStack "Cannot take head of empty list" - setDarwinTmpdir :: IO () setDarwinTmpdir = when (IO.os == "darwin") $ IO.setEnv "TMPDIR" "/tmp" diff --git a/marconi/test/Spec.hs b/marconi/test/Spec.hs index 5e065fb5fb..a902e69ae3 100644 --- a/marconi/test/Spec.hs +++ b/marconi/test/Spec.hs @@ -17,8 +17,10 @@ import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as Shelley import Gen.Cardano.Api.Typed qualified as CGen -import Integration qualified import Marconi.Index.ScriptTx qualified as ScriptTx + +-- See TODO below, import EpochStakepoolSize qualified +import Integration qualified import Spec.Utxo qualified main :: IO () @@ -29,6 +31,8 @@ tests = testGroup "Marconi" [ testPropertyNamed "prop_script_hashes_in_tx_match" "getTxBodyScriptsRoundtrip" getTxBodyScriptsRoundtrip , Spec.Utxo.tests , Integration.tests + -- , EpochStakepoolSize.tests + -- TODO Enable above when the following PR in cardano-node is merged: https://github.com/input-output-hk/cardano-node/pull/4680/ ] -- | Create @nScripts@ scripts, add them to a transaction body, then @@ -99,4 +103,4 @@ genWitnessAndHashInEra era = do -- | TODO Copy-paste from cardano-node: cardano-api/gen/Gen/Cardano/Api/Typed.hs genExecutionUnits :: Gen C.ExecutionUnits genExecutionUnits = C.ExecutionUnits <$> Gen.integral (Range.constant 0 1000) - <*> Gen.integral (Range.constant 0 1000) + <*> Gen.integral (Range.constant 0 1000)