{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
module Plutus.ChainIndex.ChainIndexError (ChainIndexError(..), InsertUtxoFailed(..), RollbackFailed(..)) where

import Control.Monad.Freer.Extras.Beam (BeamError)
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Ledger.Tx.CardanoAPI.Internal (ToCardanoError)
import Plutus.ChainIndex.Types (Point (..), Tip (..))
import Prettyprinter (Pretty (..), colon, (<+>))

data ChainIndexError =
    InsertionFailed InsertUtxoFailed
    | RollbackFailed RollbackFailed
    | ResumeNotSupported
    | QueryFailedNoTip -- ^ Query failed because the chain index does not have a tip (not synchronised with node)
    | BeamEffectError BeamError
    | ToCardanoError ToCardanoError
    deriving stock (ChainIndexError -> ChainIndexError -> Bool
(ChainIndexError -> ChainIndexError -> Bool)
-> (ChainIndexError -> ChainIndexError -> Bool)
-> Eq ChainIndexError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainIndexError -> ChainIndexError -> Bool
$c/= :: ChainIndexError -> ChainIndexError -> Bool
== :: ChainIndexError -> ChainIndexError -> Bool
$c== :: ChainIndexError -> ChainIndexError -> Bool
Eq, Int -> ChainIndexError -> ShowS
[ChainIndexError] -> ShowS
ChainIndexError -> String
(Int -> ChainIndexError -> ShowS)
-> (ChainIndexError -> String)
-> ([ChainIndexError] -> ShowS)
-> Show ChainIndexError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainIndexError] -> ShowS
$cshowList :: [ChainIndexError] -> ShowS
show :: ChainIndexError -> String
$cshow :: ChainIndexError -> String
showsPrec :: Int -> ChainIndexError -> ShowS
$cshowsPrec :: Int -> ChainIndexError -> ShowS
Show, (forall x. ChainIndexError -> Rep ChainIndexError x)
-> (forall x. Rep ChainIndexError x -> ChainIndexError)
-> Generic ChainIndexError
forall x. Rep ChainIndexError x -> ChainIndexError
forall x. ChainIndexError -> Rep ChainIndexError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChainIndexError x -> ChainIndexError
$cfrom :: forall x. ChainIndexError -> Rep ChainIndexError x
Generic)
    deriving anyclass (Value -> Parser [ChainIndexError]
Value -> Parser ChainIndexError
(Value -> Parser ChainIndexError)
-> (Value -> Parser [ChainIndexError]) -> FromJSON ChainIndexError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ChainIndexError]
$cparseJSONList :: Value -> Parser [ChainIndexError]
parseJSON :: Value -> Parser ChainIndexError
$cparseJSON :: Value -> Parser ChainIndexError
FromJSON, [ChainIndexError] -> Encoding
[ChainIndexError] -> Value
ChainIndexError -> Encoding
ChainIndexError -> Value
(ChainIndexError -> Value)
-> (ChainIndexError -> Encoding)
-> ([ChainIndexError] -> Value)
-> ([ChainIndexError] -> Encoding)
-> ToJSON ChainIndexError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ChainIndexError] -> Encoding
$ctoEncodingList :: [ChainIndexError] -> Encoding
toJSONList :: [ChainIndexError] -> Value
$ctoJSONList :: [ChainIndexError] -> Value
toEncoding :: ChainIndexError -> Encoding
$ctoEncoding :: ChainIndexError -> Encoding
toJSON :: ChainIndexError -> Value
$ctoJSON :: ChainIndexError -> Value
ToJSON)

instance Pretty ChainIndexError where
  pretty :: ChainIndexError -> Doc ann
pretty = \case
    InsertionFailed InsertUtxoFailed
err -> Doc ann
"Insertion failed" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> InsertUtxoFailed -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty InsertUtxoFailed
err
    RollbackFailed RollbackFailed
err  -> Doc ann
"Rollback failed" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> RollbackFailed -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty RollbackFailed
err
    ChainIndexError
ResumeNotSupported  -> Doc ann
"Resume is not supported"
    ChainIndexError
QueryFailedNoTip    -> Doc ann
"Query failed" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"No tip."
    BeamEffectError BeamError
err -> Doc ann
"Error during Beam operation" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> BeamError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BeamError
err
    ToCardanoError ToCardanoError
err  -> ToCardanoError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ToCardanoError
err


-- | 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 (InsertUtxoFailed -> InsertUtxoFailed -> Bool
(InsertUtxoFailed -> InsertUtxoFailed -> Bool)
-> (InsertUtxoFailed -> InsertUtxoFailed -> Bool)
-> Eq InsertUtxoFailed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
$c/= :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
== :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
$c== :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
Eq, Eq InsertUtxoFailed
Eq InsertUtxoFailed
-> (InsertUtxoFailed -> InsertUtxoFailed -> Ordering)
-> (InsertUtxoFailed -> InsertUtxoFailed -> Bool)
-> (InsertUtxoFailed -> InsertUtxoFailed -> Bool)
-> (InsertUtxoFailed -> InsertUtxoFailed -> Bool)
-> (InsertUtxoFailed -> InsertUtxoFailed -> Bool)
-> (InsertUtxoFailed -> InsertUtxoFailed -> InsertUtxoFailed)
-> (InsertUtxoFailed -> InsertUtxoFailed -> InsertUtxoFailed)
-> Ord InsertUtxoFailed
InsertUtxoFailed -> InsertUtxoFailed -> Bool
InsertUtxoFailed -> InsertUtxoFailed -> Ordering
InsertUtxoFailed -> InsertUtxoFailed -> InsertUtxoFailed
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InsertUtxoFailed -> InsertUtxoFailed -> InsertUtxoFailed
$cmin :: InsertUtxoFailed -> InsertUtxoFailed -> InsertUtxoFailed
max :: InsertUtxoFailed -> InsertUtxoFailed -> InsertUtxoFailed
$cmax :: InsertUtxoFailed -> InsertUtxoFailed -> InsertUtxoFailed
>= :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
$c>= :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
> :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
$c> :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
<= :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
$c<= :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
< :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
$c< :: InsertUtxoFailed -> InsertUtxoFailed -> Bool
compare :: InsertUtxoFailed -> InsertUtxoFailed -> Ordering
$ccompare :: InsertUtxoFailed -> InsertUtxoFailed -> Ordering
$cp1Ord :: Eq InsertUtxoFailed
Ord, Int -> InsertUtxoFailed -> ShowS
[InsertUtxoFailed] -> ShowS
InsertUtxoFailed -> String
(Int -> InsertUtxoFailed -> ShowS)
-> (InsertUtxoFailed -> String)
-> ([InsertUtxoFailed] -> ShowS)
-> Show InsertUtxoFailed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InsertUtxoFailed] -> ShowS
$cshowList :: [InsertUtxoFailed] -> ShowS
show :: InsertUtxoFailed -> String
$cshow :: InsertUtxoFailed -> String
showsPrec :: Int -> InsertUtxoFailed -> ShowS
$cshowsPrec :: Int -> InsertUtxoFailed -> ShowS
Show, (forall x. InsertUtxoFailed -> Rep InsertUtxoFailed x)
-> (forall x. Rep InsertUtxoFailed x -> InsertUtxoFailed)
-> Generic InsertUtxoFailed
forall x. Rep InsertUtxoFailed x -> InsertUtxoFailed
forall x. InsertUtxoFailed -> Rep InsertUtxoFailed x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InsertUtxoFailed x -> InsertUtxoFailed
$cfrom :: forall x. InsertUtxoFailed -> Rep InsertUtxoFailed x
Generic)
    deriving anyclass (Value -> Parser [InsertUtxoFailed]
Value -> Parser InsertUtxoFailed
(Value -> Parser InsertUtxoFailed)
-> (Value -> Parser [InsertUtxoFailed])
-> FromJSON InsertUtxoFailed
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [InsertUtxoFailed]
$cparseJSONList :: Value -> Parser [InsertUtxoFailed]
parseJSON :: Value -> Parser InsertUtxoFailed
$cparseJSON :: Value -> Parser InsertUtxoFailed
FromJSON, [InsertUtxoFailed] -> Encoding
[InsertUtxoFailed] -> Value
InsertUtxoFailed -> Encoding
InsertUtxoFailed -> Value
(InsertUtxoFailed -> Value)
-> (InsertUtxoFailed -> Encoding)
-> ([InsertUtxoFailed] -> Value)
-> ([InsertUtxoFailed] -> Encoding)
-> ToJSON InsertUtxoFailed
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [InsertUtxoFailed] -> Encoding
$ctoEncodingList :: [InsertUtxoFailed] -> Encoding
toJSONList :: [InsertUtxoFailed] -> Value
$ctoJSONList :: [InsertUtxoFailed] -> Value
toEncoding :: InsertUtxoFailed -> Encoding
$ctoEncoding :: InsertUtxoFailed -> Encoding
toJSON :: InsertUtxoFailed -> Value
$ctoJSON :: InsertUtxoFailed -> Value
ToJSON)

instance Pretty InsertUtxoFailed where
  pretty :: InsertUtxoFailed -> Doc ann
pretty = \case
    DuplicateBlock Tip
_ -> Doc ann
"UTxO insertion failed - already a block with the given number"
    InsertUtxoFailed
InsertUtxoNoTip  -> Doc ann
"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 { RollbackFailed -> Tip
foundTip :: Tip, RollbackFailed -> Point
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 (RollbackFailed -> RollbackFailed -> Bool
(RollbackFailed -> RollbackFailed -> Bool)
-> (RollbackFailed -> RollbackFailed -> Bool) -> Eq RollbackFailed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RollbackFailed -> RollbackFailed -> Bool
$c/= :: RollbackFailed -> RollbackFailed -> Bool
== :: RollbackFailed -> RollbackFailed -> Bool
$c== :: RollbackFailed -> RollbackFailed -> Bool
Eq, Eq RollbackFailed
Eq RollbackFailed
-> (RollbackFailed -> RollbackFailed -> Ordering)
-> (RollbackFailed -> RollbackFailed -> Bool)
-> (RollbackFailed -> RollbackFailed -> Bool)
-> (RollbackFailed -> RollbackFailed -> Bool)
-> (RollbackFailed -> RollbackFailed -> Bool)
-> (RollbackFailed -> RollbackFailed -> RollbackFailed)
-> (RollbackFailed -> RollbackFailed -> RollbackFailed)
-> Ord RollbackFailed
RollbackFailed -> RollbackFailed -> Bool
RollbackFailed -> RollbackFailed -> Ordering
RollbackFailed -> RollbackFailed -> RollbackFailed
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RollbackFailed -> RollbackFailed -> RollbackFailed
$cmin :: RollbackFailed -> RollbackFailed -> RollbackFailed
max :: RollbackFailed -> RollbackFailed -> RollbackFailed
$cmax :: RollbackFailed -> RollbackFailed -> RollbackFailed
>= :: RollbackFailed -> RollbackFailed -> Bool
$c>= :: RollbackFailed -> RollbackFailed -> Bool
> :: RollbackFailed -> RollbackFailed -> Bool
$c> :: RollbackFailed -> RollbackFailed -> Bool
<= :: RollbackFailed -> RollbackFailed -> Bool
$c<= :: RollbackFailed -> RollbackFailed -> Bool
< :: RollbackFailed -> RollbackFailed -> Bool
$c< :: RollbackFailed -> RollbackFailed -> Bool
compare :: RollbackFailed -> RollbackFailed -> Ordering
$ccompare :: RollbackFailed -> RollbackFailed -> Ordering
$cp1Ord :: Eq RollbackFailed
Ord, Int -> RollbackFailed -> ShowS
[RollbackFailed] -> ShowS
RollbackFailed -> String
(Int -> RollbackFailed -> ShowS)
-> (RollbackFailed -> String)
-> ([RollbackFailed] -> ShowS)
-> Show RollbackFailed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RollbackFailed] -> ShowS
$cshowList :: [RollbackFailed] -> ShowS
show :: RollbackFailed -> String
$cshow :: RollbackFailed -> String
showsPrec :: Int -> RollbackFailed -> ShowS
$cshowsPrec :: Int -> RollbackFailed -> ShowS
Show, (forall x. RollbackFailed -> Rep RollbackFailed x)
-> (forall x. Rep RollbackFailed x -> RollbackFailed)
-> Generic RollbackFailed
forall x. Rep RollbackFailed x -> RollbackFailed
forall x. RollbackFailed -> Rep RollbackFailed x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RollbackFailed x -> RollbackFailed
$cfrom :: forall x. RollbackFailed -> Rep RollbackFailed x
Generic)
    deriving anyclass (Value -> Parser [RollbackFailed]
Value -> Parser RollbackFailed
(Value -> Parser RollbackFailed)
-> (Value -> Parser [RollbackFailed]) -> FromJSON RollbackFailed
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RollbackFailed]
$cparseJSONList :: Value -> Parser [RollbackFailed]
parseJSON :: Value -> Parser RollbackFailed
$cparseJSON :: Value -> Parser RollbackFailed
FromJSON, [RollbackFailed] -> Encoding
[RollbackFailed] -> Value
RollbackFailed -> Encoding
RollbackFailed -> Value
(RollbackFailed -> Value)
-> (RollbackFailed -> Encoding)
-> ([RollbackFailed] -> Value)
-> ([RollbackFailed] -> Encoding)
-> ToJSON RollbackFailed
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RollbackFailed] -> Encoding
$ctoEncodingList :: [RollbackFailed] -> Encoding
toJSONList :: [RollbackFailed] -> Value
$ctoJSONList :: [RollbackFailed] -> Value
toEncoding :: RollbackFailed -> Encoding
$ctoEncoding :: RollbackFailed -> Encoding
toJSON :: RollbackFailed -> Value
$ctoJSON :: RollbackFailed -> Value
ToJSON)

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