Skip to content

Commit

Permalink
Refactor ChainIndexError and ChainIndexLog
Browse files Browse the repository at this point in the history
  • Loading branch information
sjoerdvisscher committed Sep 14, 2021
1 parent 386acbb commit a2a9540
Show file tree
Hide file tree
Showing 10 changed files with 143 additions and 113 deletions.
2 changes: 1 addition & 1 deletion playground-common/src/PSGenerator/Common.hs
Expand Up @@ -36,7 +36,7 @@ import Ledger.TimeSlot (SlotConfig, SlotConv
import Ledger.Typed.Tx (ConnectionError, WrongOutTypeError)
import Ledger.Value (AssetClass, CurrencySymbol, TokenName, Value)
import Playground.Types (ContractCall, FunctionSchema, KnownCurrency)
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexError, ChainIndexLog)
import Plutus.ChainIndex (ChainIndexError, ChainIndexLog)
import Plutus.ChainIndex.Tx (ChainIndexTx, ChainIndexTxOutputs)
import Plutus.ChainIndex.Types (BlockNumber, Depth, Page, PageSize, Point, Tip, TxStatus,
TxValidity)
Expand Down
8 changes: 5 additions & 3 deletions plutus-chain-index/app/Main.hs
Expand Up @@ -38,11 +38,12 @@ import CommandLine (AppConfig (..), Command (.
import qualified Config
import Ledger (Slot (..))
import qualified Logging
import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog (..))
import Plutus.ChainIndex.Compatibility (fromCardanoBlock, fromCardanoPoint, tipFromCardanoBlock)
import Plutus.ChainIndex.Effects (ChainIndexControlEffect (..), ChainIndexQueryEffect (..),
appendBlock, rollback)
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState (..), ChainIndexError (..),
ChainIndexLog (..), handleControl, handleQuery)
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState (..), handleControl, handleQuery)
import Plutus.Monitoring.Util (runLogEffects)

type ChainIndexEffects
Expand All @@ -64,7 +65,8 @@ runChainIndex trace emulatorState effect = do
logMessages <- liftIO $ STM.atomically $ do
oldEmulatorState <- STM.readTVar emulatorState
let (result, logMessages')
= interpret handleControl effect
= effect
& interpret handleControl
& interpret handleQuery
& runState oldEmulatorState
& runError
Expand Down
2 changes: 2 additions & 0 deletions plutus-chain-index/plutus-chain-index.cabal
Expand Up @@ -32,6 +32,8 @@ library
exposed-modules:
Plutus.ChainIndex
Plutus.ChainIndex.Api
Plutus.ChainIndex.ChainIndexError
Plutus.ChainIndex.ChainIndexLog
Plutus.ChainIndex.Effects
Plutus.ChainIndex.Emulator.DiskState
Plutus.ChainIndex.Emulator.Handlers
Expand Down
2 changes: 2 additions & 0 deletions plutus-chain-index/src/Plutus/ChainIndex.hs
Expand Up @@ -5,6 +5,8 @@ module Plutus.ChainIndex(
, module Emulator
) where

import Plutus.ChainIndex.ChainIndexError as Export
import Plutus.ChainIndex.ChainIndexLog as Export
import Plutus.ChainIndex.Effects as Export
import Plutus.ChainIndex.Emulator.DiskState as Emulator hiding (fromTx)
import Plutus.ChainIndex.Emulator.Handlers as Emulator
Expand Down
55 changes: 55 additions & 0 deletions plutus-chain-index/src/Plutus/ChainIndex/ChainIndexError.hs
@@ -0,0 +1,55 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Plutus.ChainIndex.ChainIndexError (ChainIndexError(..), InsertUtxoFailed(..), RollbackFailed(..)) where

import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Plutus.ChainIndex.Types (Point (..), Tip (..))
import Prettyprinter (Pretty (..), colon, (<+>))

data ChainIndexError =
InsertionFailed InsertUtxoFailed
| RollbackFailed RollbackFailed
| QueryFailedNoTip -- ^ Query failed because the chain index does not have a tip (not synchronised with node)
deriving stock (Eq, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty ChainIndexError where
pretty = \case
InsertionFailed err -> "Insertion failed" <> colon <+> pretty err
RollbackFailed err -> "Rollback failed" <> colon <+> pretty err
QueryFailedNoTip -> "Query failed" <> colon <+> "No tip."

-- | UTXO state could not be inserted into the chain index
data InsertUtxoFailed =
DuplicateBlock Tip -- ^ Insertion failed as there was already a block with the given number
| InsertUtxoNoTip -- ^ The '_usTip' field of the argument was 'Last Nothing'
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty InsertUtxoFailed where
pretty = \case
DuplicateBlock _ -> "UTxO insertion failed - already a block with the given number"
InsertUtxoNoTip -> "UTxO insertion failed - no tip"

-- | Reason why the 'rollback' operation failed
data RollbackFailed =
RollbackNoTip -- ^ Rollback failed because the utxo index had no tip (not synchronised)
| TipMismatch { foundTip :: Tip, targetPoint :: Point } -- ^ Unable to roll back to 'expectedTip' because the tip at that position was different
| OldPointNotFound Point -- ^ Unable to find the old tip
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty RollbackFailed where
pretty = \case
RollbackNoTip -> "UTxO index had no tip (not synchronised)"
TipMismatch{..} ->
"Unable to rollback to"
<+> pretty targetPoint
<+> "because the tip at that position"
<+> pretty foundTip
<+> "was different"
OldPointNotFound t -> "Unable to find the old tip" <+> pretty t
55 changes: 55 additions & 0 deletions plutus-chain-index/src/Plutus/ChainIndex/ChainIndexLog.hs
@@ -0,0 +1,55 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Plutus.ChainIndex.ChainIndexLog (ChainIndexLog(..), InsertUtxoPosition(..)) where

import Cardano.BM.Data.Tracer (ToObject (..))
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Ledger (TxId, TxOut, TxOutRef)
import Plutus.ChainIndex.ChainIndexError (ChainIndexError)
import Plutus.ChainIndex.Types (Tip (..))
import Plutus.Contract.CardanoAPI (FromCardanoError (..))
import Prettyprinter (Pretty (..), colon, (<+>))

data ChainIndexLog =
InsertionSuccess Tip InsertUtxoPosition
| ConversionFailed FromCardanoError
| RollbackSuccess Tip
| Err ChainIndexError
| TxNotFound TxId
| TxOutNotFound TxOutRef
| TipIsGenesis
| NoDatumScriptAddr TxOut
deriving stock (Eq, Show, Generic)
deriving anyclass (FromJSON, ToJSON, ToObject)

instance Pretty ChainIndexLog where
pretty = \case
InsertionSuccess t p ->
"InsertionSuccess"
<> colon
<+> "New tip is"
<+> pretty t
<> "."
<+> pretty p
RollbackSuccess t -> "RollbackSuccess: New tip is" <+> pretty t
ConversionFailed cvError -> "Conversion failed: " <+> pretty cvError
Err ciError -> "ChainIndexError:" <+> pretty ciError
TxNotFound txid -> "TxNotFound:" <+> pretty txid
TxOutNotFound ref -> "TxOut not found with:" <+> pretty ref
TipIsGenesis -> "TipIsGenesis"
NoDatumScriptAddr txout -> "The following transaction output from a script adress does not have a datum:" <+> pretty txout

-- | Outcome of inserting a 'UtxoState' into the utxo index
data InsertUtxoPosition =
InsertAtEnd -- ^ The utxo state was added to the end. Returns the new index
| InsertBeforeEnd -- ^ The utxo state was added somewhere before the end. Returns the new index and the tip
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty InsertUtxoPosition where
pretty = \case
InsertAtEnd -> "UTxO state was added to the end."
InsertBeforeEnd -> "UTxO state was added somewhere before the end."
54 changes: 4 additions & 50 deletions plutus-chain-index/src/Plutus/ChainIndex/Emulator/Handlers.hs
Expand Up @@ -19,17 +19,13 @@ module Plutus.ChainIndex.Emulator.Handlers(
, ChainIndexEmulatorState(..)
, diskState
, utxoIndex
, ChainIndexError(..)
, ChainIndexLog(..)
) where

import Cardano.BM.Data.Tracer (ToObject (..))
import Control.Lens (at, ix, makeLenses, over, preview, set, to, view, (&))
import Control.Monad.Freer (Eff, Member, type (~>))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logError, logWarn)
import Control.Monad.Freer.State (State, get, gets, modify, put)
import Data.Aeson (FromJSON, ToJSON)
import Data.Default (Default (..))
import Data.FingerTree (Measured (..))
import Data.Maybe (catMaybes, fromMaybe)
Expand All @@ -40,18 +36,18 @@ import Ledger (Address (addressCredentia
ChainIndexTxOut (PublicKeyChainIndexTxOut), TxId,
TxOut (txOutAddress), TxOutRef (..), txOutDatumHash, txOutValue)
import Ledger.Tx (ChainIndexTxOut (ScriptChainIndexTxOut))
import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog (..))
import Plutus.ChainIndex.Effects (ChainIndexControlEffect (..), ChainIndexQueryEffect (..))
import Plutus.ChainIndex.Emulator.DiskState (DiskState, addressMap, dataMap, diagnostics, mintingPolicyMap,
redeemerMap, stakeValidatorMap, txMap, validatorMap)
import qualified Plutus.ChainIndex.Emulator.DiskState as DiskState
import Plutus.ChainIndex.Tx (ChainIndexTx, _ValidTx, citxOutputs)
import Plutus.ChainIndex.Types (Tip (..), pageOf)
import Plutus.ChainIndex.UtxoState (InsertUtxoPosition, InsertUtxoSuccess (..), RollbackResult (..),
TxUtxoBalance, UtxoIndex, isUnspentOutput, tip)
import Plutus.ChainIndex.UtxoState (InsertUtxoSuccess (..), RollbackResult (..), TxUtxoBalance,
UtxoIndex, isUnspentOutput, tip)
import qualified Plutus.ChainIndex.UtxoState as UtxoState
import Plutus.Contract.CardanoAPI (FromCardanoError (..))
import Plutus.V1.Ledger.Api (Credential (PubKeyCredential, ScriptCredential))
import Prettyprinter (Pretty (..), colon, (<+>))

data ChainIndexEmulatorState =
ChainIndexEmulatorState
Expand Down Expand Up @@ -182,45 +178,3 @@ handleControl = \case
newDiskState <- foldMap DiskState.fromTx . catMaybes <$> mapM getTxFromTxId utxos
modify $ set diskState newDiskState
GetDiagnostics -> diagnostics . _diskState <$> get @ChainIndexEmulatorState

data ChainIndexError =
InsertionFailed UtxoState.InsertUtxoFailed
| RollbackFailed UtxoState.RollbackFailed
| QueryFailedNoTip -- ^ Query failed because the chain index does not have a tip (not synchronised with node)
deriving stock (Eq, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty ChainIndexError where
pretty = \case
InsertionFailed err -> "Insertion failed" <> colon <+> pretty err
RollbackFailed err -> "Rollback failed" <> colon <+> pretty err
QueryFailedNoTip -> "Query failed" <> colon <+> "No tip."

data ChainIndexLog =
InsertionSuccess Tip InsertUtxoPosition
| ConversionFailed FromCardanoError
| RollbackSuccess Tip
| Err ChainIndexError
| TxNotFound TxId
| TxOutNotFound TxOutRef
| TipIsGenesis
| NoDatumScriptAddr TxOut
deriving stock (Eq, Show, Generic)
deriving anyclass (FromJSON, ToJSON, ToObject)

instance Pretty ChainIndexLog where
pretty = \case
InsertionSuccess t p ->
"InsertionSuccess"
<> colon
<+> "New tip is"
<+> pretty t
<> "."
<+> pretty p
RollbackSuccess t -> "RollbackSuccess: New tip is" <+> pretty t
ConversionFailed cvError -> "Conversion failed: " <+> pretty cvError
Err ciError -> "ChainIndexError:" <+> pretty ciError
TxNotFound txid -> "TxNotFound:" <+> pretty txid
TxOutNotFound ref -> "TxOut not found with:" <+> pretty ref
TipIsGenesis -> "TipIsGenesis"
NoDatumScriptAddr txout -> "The following transaction output from a script adress does not have a datum:" <+> pretty txout
5 changes: 3 additions & 2 deletions plutus-chain-index/src/Plutus/ChainIndex/Server.hs
Expand Up @@ -24,10 +24,11 @@ import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai.Handler.Warp as Warp
import Plutus.ChainIndex.Api (API, FromHashAPI)
import Plutus.ChainIndex.ChainIndexError (ChainIndexError)
import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog)
import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect)
import qualified Plutus.ChainIndex.Effects as E
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState (..), ChainIndexError, ChainIndexLog,
handleControl, handleQuery)
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState (..), handleControl, handleQuery)
import Servant.API ((:<|>) (..))
import Servant.API.ContentTypes (NoContent (..))
import Servant.Server (Handler, ServerError, ServerT, err404, err500, errBody,
Expand Down
71 changes: 15 additions & 56 deletions plutus-chain-index/src/Plutus/ChainIndex/UtxoState.hs
Expand Up @@ -38,19 +38,21 @@ module Plutus.ChainIndex.UtxoState(
, viewTip
) where

import Control.Lens (makeLenses, view)
import Data.Aeson (FromJSON, ToJSON)
import Data.FingerTree (FingerTree, Measured (..))
import qualified Data.FingerTree as FT
import Data.Function (on)
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Ledger (TxIn (txInRef), TxOutRef (..))
import Plutus.ChainIndex.Tx (ChainIndexTx (..), citxInputs, txOutsWithRef)
import Plutus.ChainIndex.Types (Point (..), Tip (..), pointsToTip)
import Prettyprinter (Pretty (..), (<+>))
import Control.Lens (makeLenses, view)
import Data.Aeson (FromJSON, ToJSON)
import Data.FingerTree (FingerTree, Measured (..))
import qualified Data.FingerTree as FT
import Data.Function (on)
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Ledger (TxIn (txInRef), TxOutRef (..))
import Plutus.ChainIndex.ChainIndexError (InsertUtxoFailed (..), RollbackFailed (..))
import Plutus.ChainIndex.ChainIndexLog (InsertUtxoPosition (..))
import Plutus.ChainIndex.Tx (ChainIndexTx (..), citxInputs, txOutsWithRef)
import Plutus.ChainIndex.Types (Point (..), Tip (..), pointsToTip)
import Prettyprinter (Pretty (..))

-- | The effect of a transaction (or a number of them) on the utxo set.
data TxUtxoBalance =
Expand Down Expand Up @@ -126,18 +128,6 @@ fromBlock tip_ transactions =
, _usTip = tip_
}

-- | Outcome of inserting a 'UtxoState' into the utxo index
data InsertUtxoPosition =
InsertAtEnd -- ^ The utxo state was added to the end. Returns the new index
| InsertBeforeEnd -- ^ The utxo state was added somewhere before the end. Returns the new index and the tip
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty InsertUtxoPosition where
pretty = \case
InsertAtEnd -> "UTxO state was added to the end."
InsertBeforeEnd -> "UTxO state was added somewhere before the end."

data InsertUtxoSuccess a =
InsertUtxoSuccess
{ newIndex :: UtxoIndex a
Expand All @@ -148,18 +138,6 @@ instance Pretty (InsertUtxoSuccess a) where
pretty = \case
InsertUtxoSuccess _ insertPosition -> pretty insertPosition

-- | UTXO state could not be inserted into the chain index
data InsertUtxoFailed =
DuplicateBlock Tip -- ^ Insertion failed as there was already a block with the given number
| InsertUtxoNoTip -- ^ The '_usTip' field of the argument was 'Last Nothing'
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty InsertUtxoFailed where
pretty = \case
DuplicateBlock _ -> "UTxO insertion failed - already a block with the given number"
InsertUtxoNoTip -> "UTxO insertion failed - no tip"

-- | Insert a 'UtxoState' into the index
insert ::
( Measured (UtxoState a) (UtxoState a)
Expand All @@ -176,25 +154,6 @@ insert s@UtxoState{_usTip=thisTip} ix =
t | t > thisTip -> Right $ InsertUtxoSuccess{newIndex = (before FT.|> s) <> after, insertPosition = InsertBeforeEnd}
| otherwise -> Left $ DuplicateBlock t

-- | Reason why the 'rollback' operation failed
data RollbackFailed =
RollbackNoTip -- ^ Rollback failed because the utxo index had no tip (not synchronised)
| TipMismatch { foundTip :: Tip, targetPoint :: Point } -- ^ Unable to roll back to 'expectedTip' because the tip at that position was different
| OldPointNotFound Point -- ^ Unable to find the old tip
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (FromJSON, ToJSON)

instance Pretty RollbackFailed where
pretty = \case
RollbackNoTip -> "UTxO index had no tip (not synchronised)"
TipMismatch foundTip targetPoint ->
"Unable to rollback to"
<+> pretty targetPoint
<+> "because the tip at that position"
<+> pretty foundTip
<+> "was different"
OldPointNotFound t -> "Unable to find the old tip" <+> pretty t

data RollbackResult a =
RollbackResult
{ newTip :: Tip
Expand Down
2 changes: 1 addition & 1 deletion plutus-playground-client/src/Transaction/View.purs
Expand Up @@ -40,7 +40,7 @@ import Plutus.V1.Ledger.TxId (TxId(TxId))
import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName)
import Prelude (const, map, show, unit, ($), (<$>), (<<<), (<>))
import Wallet.Emulator.Chain (ChainEvent(..))
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexLog(..))
import Plutus.ChainIndex (ChainIndexLog(..))
import Wallet.Emulator.MultiAgent (EmulatorEvent'(..))
import Wallet.Emulator.MultiAgent as MultiAgent
import Wallet.Emulator.NodeClient (NodeClientEvent(..))
Expand Down

0 comments on commit a2a9540

Please sign in to comment.