{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Mock.Ledger.State (
    -- * Config for the mock ledger
    MockConfig (..)
  , defaultMockConfig
    -- * State of the mock ledger
  , MockError (..)
  , MockState (..)
  , updateMockState
  , updateMockTip
  , updateMockUTxO
    -- * Supporting definitions
  , checkTxSize
  , txSize
    -- * Genesis state
  , genesisMockState
  ) where

import           Cardano.Binary (toCBOR)
import           Cardano.Crypto.Hash
import           Codec.Serialise (Serialise, serialise)
import           Control.Monad (guard)
import           Control.Monad.Except (Except, throwError, withExcept)
import qualified Data.ByteString.Lazy as BL
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..))
import           Ouroboros.Consensus.Mock.Ledger.Address
import           Ouroboros.Consensus.Mock.Ledger.UTxO
import           Ouroboros.Consensus.Util (ShowProxy (..), repeatedlyM)
import           Test.Util.Orphans.Serialise ()

{-------------------------------------------------------------------------------
  Config of the mock block
-------------------------------------------------------------------------------}

-- | Parameters needed to validate blocks/txs
data MockConfig = MockConfig {
    MockConfig -> Maybe ByteSize32
mockCfgMaxTxSize :: !(Maybe ByteSize32)
  }
  deriving stock (Int -> MockConfig -> ShowS
[MockConfig] -> ShowS
MockConfig -> String
(Int -> MockConfig -> ShowS)
-> (MockConfig -> String)
-> ([MockConfig] -> ShowS)
-> Show MockConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockConfig -> ShowS
showsPrec :: Int -> MockConfig -> ShowS
$cshow :: MockConfig -> String
show :: MockConfig -> String
$cshowList :: [MockConfig] -> ShowS
showList :: [MockConfig] -> ShowS
Show, MockConfig -> MockConfig -> Bool
(MockConfig -> MockConfig -> Bool)
-> (MockConfig -> MockConfig -> Bool) -> Eq MockConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MockConfig -> MockConfig -> Bool
== :: MockConfig -> MockConfig -> Bool
$c/= :: MockConfig -> MockConfig -> Bool
/= :: MockConfig -> MockConfig -> Bool
Eq, (forall x. MockConfig -> Rep MockConfig x)
-> (forall x. Rep MockConfig x -> MockConfig) -> Generic MockConfig
forall x. Rep MockConfig x -> MockConfig
forall x. MockConfig -> Rep MockConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MockConfig -> Rep MockConfig x
from :: forall x. MockConfig -> Rep MockConfig x
$cto :: forall x. Rep MockConfig x -> MockConfig
to :: forall x. Rep MockConfig x -> MockConfig
Generic)
  deriving anyclass (Context -> MockConfig -> IO (Maybe ThunkInfo)
Proxy MockConfig -> String
(Context -> MockConfig -> IO (Maybe ThunkInfo))
-> (Context -> MockConfig -> IO (Maybe ThunkInfo))
-> (Proxy MockConfig -> String)
-> NoThunks MockConfig
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> MockConfig -> IO (Maybe ThunkInfo)
noThunks :: Context -> MockConfig -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> MockConfig -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MockConfig -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy MockConfig -> String
showTypeOf :: Proxy MockConfig -> String
NoThunks)

defaultMockConfig :: MockConfig
defaultMockConfig :: MockConfig
defaultMockConfig = MockConfig {
      mockCfgMaxTxSize :: Maybe ByteSize32
mockCfgMaxTxSize = Maybe ByteSize32
forall a. Maybe a
Nothing
    }

{-------------------------------------------------------------------------------
  State of the mock ledger
-------------------------------------------------------------------------------}

data MockState blk = MockState {
      forall blk. MockState blk -> Utxo
mockUtxo      :: !Utxo
    , forall blk. MockState blk -> Set TxId
mockConfirmed :: !(Set TxId)
    , forall blk. MockState blk -> Point blk
mockTip       :: !(Point blk)
    }
  deriving (Int -> MockState blk -> ShowS
[MockState blk] -> ShowS
MockState blk -> String
(Int -> MockState blk -> ShowS)
-> (MockState blk -> String)
-> ([MockState blk] -> ShowS)
-> Show (MockState blk)
forall blk. StandardHash blk => Int -> MockState blk -> ShowS
forall blk. StandardHash blk => [MockState blk] -> ShowS
forall blk. StandardHash blk => MockState blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> MockState blk -> ShowS
showsPrec :: Int -> MockState blk -> ShowS
$cshow :: forall blk. StandardHash blk => MockState blk -> String
show :: MockState blk -> String
$cshowList :: forall blk. StandardHash blk => [MockState blk] -> ShowS
showList :: [MockState blk] -> ShowS
Show, MockState blk -> MockState blk -> Bool
(MockState blk -> MockState blk -> Bool)
-> (MockState blk -> MockState blk -> Bool) -> Eq (MockState blk)
forall blk.
StandardHash blk =>
MockState blk -> MockState blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
MockState blk -> MockState blk -> Bool
== :: MockState blk -> MockState blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
MockState blk -> MockState blk -> Bool
/= :: MockState blk -> MockState blk -> Bool
Eq, (forall x. MockState blk -> Rep (MockState blk) x)
-> (forall x. Rep (MockState blk) x -> MockState blk)
-> Generic (MockState blk)
forall x. Rep (MockState blk) x -> MockState blk
forall x. MockState blk -> Rep (MockState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (MockState blk) x -> MockState blk
forall blk x. MockState blk -> Rep (MockState blk) x
$cfrom :: forall blk x. MockState blk -> Rep (MockState blk) x
from :: forall x. MockState blk -> Rep (MockState blk) x
$cto :: forall blk x. Rep (MockState blk) x -> MockState blk
to :: forall x. Rep (MockState blk) x -> MockState blk
Generic, Context -> MockState blk -> IO (Maybe ThunkInfo)
Proxy (MockState blk) -> String
(Context -> MockState blk -> IO (Maybe ThunkInfo))
-> (Context -> MockState blk -> IO (Maybe ThunkInfo))
-> (Proxy (MockState blk) -> String)
-> NoThunks (MockState blk)
forall blk.
StandardHash blk =>
Context -> MockState blk -> IO (Maybe ThunkInfo)
forall blk. StandardHash blk => Proxy (MockState blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> MockState blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> MockState blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> MockState blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MockState blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk. StandardHash blk => Proxy (MockState blk) -> String
showTypeOf :: Proxy (MockState blk) -> String
NoThunks)

deriving instance Serialise (HeaderHash blk) => Serialise (MockState blk)

data MockError blk =
    MockExpired !SlotNo !SlotNo
    -- ^ The transaction expired in the first 'SlotNo', and it failed to
    -- validate in the second 'SlotNo'.
  | MockUtxoError UtxoError
  | MockInvalidHash (ChainHash blk) (ChainHash blk)
  | MockTxSizeTooBig ByteSize32 ByteSize32
  deriving ((forall x. MockError blk -> Rep (MockError blk) x)
-> (forall x. Rep (MockError blk) x -> MockError blk)
-> Generic (MockError blk)
forall x. Rep (MockError blk) x -> MockError blk
forall x. MockError blk -> Rep (MockError blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (MockError blk) x -> MockError blk
forall blk x. MockError blk -> Rep (MockError blk) x
$cfrom :: forall blk x. MockError blk -> Rep (MockError blk) x
from :: forall x. MockError blk -> Rep (MockError blk) x
$cto :: forall blk x. Rep (MockError blk) x -> MockError blk
to :: forall x. Rep (MockError blk) x -> MockError blk
Generic, Context -> MockError blk -> IO (Maybe ThunkInfo)
Proxy (MockError blk) -> String
(Context -> MockError blk -> IO (Maybe ThunkInfo))
-> (Context -> MockError blk -> IO (Maybe ThunkInfo))
-> (Proxy (MockError blk) -> String)
-> NoThunks (MockError blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Context -> MockError blk -> IO (Maybe ThunkInfo)
forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (MockError blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> MockError blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> MockError blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
(StandardHash blk, Typeable blk) =>
Context -> MockError blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MockError blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk.
(StandardHash blk, Typeable blk) =>
Proxy (MockError blk) -> String
showTypeOf :: Proxy (MockError blk) -> String
NoThunks)

deriving instance StandardHash blk => Show (MockError blk)
deriving instance StandardHash blk => Eq   (MockError blk)
deriving instance Serialise (HeaderHash blk) => Serialise (MockError blk)

instance Typeable blk => ShowProxy (MockError blk) where

updateMockState :: (GetPrevHash blk, HasMockTxs blk)
                => MockConfig
                -> blk
                -> MockState blk
                -> Except (MockError blk) (MockState blk)
updateMockState :: forall blk.
(GetPrevHash blk, HasMockTxs blk) =>
MockConfig
-> blk -> MockState blk -> Except (MockError blk) (MockState blk)
updateMockState MockConfig
cfg blk
blk MockState blk
st = do
    let hdr :: Header blk
hdr = blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk
    MockState blk
st' <- Header blk
-> MockState blk -> Except (MockError blk) (MockState blk)
forall blk.
GetPrevHash blk =>
Header blk
-> MockState blk -> Except (MockError blk) (MockState blk)
updateMockTip Header blk
hdr MockState blk
st
    MockConfig
-> SlotNo
-> blk
-> MockState blk
-> Except (MockError blk) (MockState blk)
forall a blk.
HasMockTxs a =>
MockConfig
-> SlotNo
-> a
-> MockState blk
-> Except (MockError blk) (MockState blk)
updateMockUTxO MockConfig
cfg (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr) blk
blk MockState blk
st'

updateMockTip :: GetPrevHash blk
              => Header blk
              -> MockState blk
              -> Except (MockError blk) (MockState blk)
updateMockTip :: forall blk.
GetPrevHash blk =>
Header blk
-> MockState blk -> Except (MockError blk) (MockState blk)
updateMockTip Header blk
hdr (MockState Utxo
u Set TxId
c Point blk
t)
    | Header blk -> ChainHash blk
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash Header blk
hdr ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk -> ChainHash blk
forall {k} (block :: k). Point block -> ChainHash block
pointHash Point blk
t
    = MockState blk -> ExceptT (MockError blk) Identity (MockState blk)
forall a. a -> ExceptT (MockError blk) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (MockState blk -> ExceptT (MockError blk) Identity (MockState blk))
-> MockState blk
-> ExceptT (MockError blk) Identity (MockState blk)
forall a b. (a -> b) -> a -> b
$ Utxo -> Set TxId -> Point blk -> MockState blk
forall blk. Utxo -> Set TxId -> Point blk -> MockState blk
MockState Utxo
u Set TxId
c (Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
hdr)
    | Bool
otherwise
    = MockError blk -> ExceptT (MockError blk) Identity (MockState blk)
forall a. MockError blk -> ExceptT (MockError blk) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockError blk -> ExceptT (MockError blk) Identity (MockState blk))
-> MockError blk
-> ExceptT (MockError blk) Identity (MockState blk)
forall a b. (a -> b) -> a -> b
$ ChainHash blk -> ChainHash blk -> MockError blk
forall blk. ChainHash blk -> ChainHash blk -> MockError blk
MockInvalidHash (Header blk -> ChainHash blk
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash Header blk
hdr) (Point blk -> ChainHash blk
forall {k} (block :: k). Point block -> ChainHash block
pointHash Point blk
t)

updateMockUTxO :: HasMockTxs a
               => MockConfig
               -> SlotNo
               -> a
               -> MockState blk
               -> Except (MockError blk) (MockState blk)
updateMockUTxO :: forall a blk.
HasMockTxs a =>
MockConfig
-> SlotNo
-> a
-> MockState blk
-> Except (MockError blk) (MockState blk)
updateMockUTxO MockConfig
cfg SlotNo
now = (Tx
 -> MockState blk
 -> ExceptT (MockError blk) Identity (MockState blk))
-> [Tx]
-> MockState blk
-> ExceptT (MockError blk) Identity (MockState blk)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM (MockConfig
-> SlotNo
-> Tx
-> MockState blk
-> ExceptT (MockError blk) Identity (MockState blk)
forall blk.
MockConfig
-> SlotNo
-> Tx
-> MockState blk
-> Except (MockError blk) (MockState blk)
updateMockUTxO1 MockConfig
cfg SlotNo
now) ([Tx]
 -> MockState blk
 -> ExceptT (MockError blk) Identity (MockState blk))
-> (a -> [Tx])
-> a
-> MockState blk
-> ExceptT (MockError blk) Identity (MockState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Tx]
forall a. HasMockTxs a => a -> [Tx]
getMockTxs

updateMockUTxO1 :: forall blk.
                   MockConfig
                -> SlotNo
                -> Tx
                -> MockState blk
                -> Except (MockError blk) (MockState blk)
updateMockUTxO1 :: forall blk.
MockConfig
-> SlotNo
-> Tx
-> MockState blk
-> Except (MockError blk) (MockState blk)
updateMockUTxO1 MockConfig
cfg SlotNo
now Tx
tx (MockState Utxo
u Set TxId
c Point blk
t) = case Maybe (MockError blk)
hasExpired of
    Just MockError blk
e  -> MockError blk -> Except (MockError blk) (MockState blk)
forall a. MockError blk -> ExceptT (MockError blk) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MockError blk
e
    Maybe (MockError blk)
Nothing -> do
      ByteSize32
_ <- MockConfig -> Tx -> Except (MockError blk) ByteSize32
forall blk. MockConfig -> Tx -> Except (MockError blk) ByteSize32
checkTxSize MockConfig
cfg Tx
tx
      Utxo
u' <- (UtxoError -> MockError blk)
-> Except UtxoError Utxo -> Except (MockError blk) Utxo
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept UtxoError -> MockError blk
forall blk. UtxoError -> MockError blk
MockUtxoError (Except UtxoError Utxo -> Except (MockError blk) Utxo)
-> Except UtxoError Utxo -> Except (MockError blk) Utxo
forall a b. (a -> b) -> a -> b
$ Tx -> Utxo -> Except UtxoError Utxo
forall a. HasMockTxs a => a -> Utxo -> Except UtxoError Utxo
updateUtxo Tx
tx Utxo
u
      MockState blk -> Except (MockError blk) (MockState blk)
forall a. a -> ExceptT (MockError blk) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (MockState blk -> Except (MockError blk) (MockState blk))
-> MockState blk -> Except (MockError blk) (MockState blk)
forall a b. (a -> b) -> a -> b
$ Utxo -> Set TxId -> Point blk -> MockState blk
forall blk. Utxo -> Set TxId -> Point blk -> MockState blk
MockState Utxo
u' (Set TxId
c Set TxId -> Set TxId -> Set TxId
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Tx -> Set TxId
forall a. HasMockTxs a => a -> Set TxId
confirmed Tx
tx) Point blk
t
  where
      Tx Expiry
expiry Set (TxId, Ix)
_ins [(Addr, Ix)]
_outs = Tx
tx

      hasExpired :: Maybe (MockError blk)
      hasExpired :: Maybe (MockError blk)
hasExpired = case Expiry
expiry of
          Expiry
DoNotExpire       -> Maybe (MockError blk)
forall a. Maybe a
Nothing
          ExpireAtOnsetOf SlotNo
s -> do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
now
            MockError blk -> Maybe (MockError blk)
forall a. a -> Maybe a
Just (MockError blk -> Maybe (MockError blk))
-> MockError blk -> Maybe (MockError blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> MockError blk
forall blk. SlotNo -> SlotNo -> MockError blk
MockExpired SlotNo
s SlotNo
now

checkTxSize :: MockConfig -> Tx -> Except (MockError blk) ByteSize32
checkTxSize :: forall blk. MockConfig -> Tx -> Except (MockError blk) ByteSize32
checkTxSize MockConfig
cfg Tx
tx
  | Just ByteSize32
maxTxSize <- MockConfig -> Maybe ByteSize32
mockCfgMaxTxSize MockConfig
cfg
  , ByteSize32
actualTxSize ByteSize32 -> ByteSize32 -> Bool
forall a. Ord a => a -> a -> Bool
> ByteSize32
maxTxSize =
      MockError blk -> ExceptT (MockError blk) Identity ByteSize32
forall a. MockError blk -> ExceptT (MockError blk) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockError blk -> ExceptT (MockError blk) Identity ByteSize32)
-> MockError blk -> ExceptT (MockError blk) Identity ByteSize32
forall a b. (a -> b) -> a -> b
$ ByteSize32 -> ByteSize32 -> MockError blk
forall blk. ByteSize32 -> ByteSize32 -> MockError blk
MockTxSizeTooBig ByteSize32
actualTxSize ByteSize32
maxTxSize
  | Bool
otherwise = ByteSize32 -> ExceptT (MockError blk) Identity ByteSize32
forall a. a -> ExceptT (MockError blk) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteSize32
actualTxSize
  where
    actualTxSize :: ByteSize32
actualTxSize = Tx -> ByteSize32
txSize Tx
tx

{-------------------------------------------------------------------------------
  Supporting definitions
-------------------------------------------------------------------------------}

txSize :: Tx -> ByteSize32
txSize :: Tx -> ByteSize32
txSize = Word32 -> ByteSize32
ByteSize32 (Word32 -> ByteSize32) -> (Tx -> Word32) -> Tx -> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> (Tx -> Int64) -> Tx -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> Int64) -> (Tx -> ByteString) -> Tx -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> ByteString
forall a. Serialise a => a -> ByteString
serialise

{-------------------------------------------------------------------------------
  Genesis
-------------------------------------------------------------------------------}

genesisMockState :: AddrDist -> MockState blk
genesisMockState :: forall blk. AddrDist -> MockState blk
genesisMockState AddrDist
addrDist = MockState {
      mockUtxo :: Utxo
mockUtxo      = AddrDist -> Utxo
genesisUtxo AddrDist
addrDist
    , mockConfirmed :: Set TxId
mockConfirmed = TxId -> Set TxId
forall a. a -> Set a
Set.singleton ((Tx -> Encoding) -> Tx -> TxId
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser Tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (AddrDist -> Tx
genesisTx AddrDist
addrDist))
    , mockTip :: Point blk
mockTip       = Point blk
forall {k} (block :: k). Point block
GenesisPoint
    }