{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Mock.Ledger.State ( -- * State of the mock ledger MockError (..) , MockState (..) , updateMockState , updateMockTip , updateMockUTxO -- * Genesis state , genesisMockState ) where import Cardano.Binary (toCBOR) import Codec.Serialise (Serialise) import Control.Monad.Except import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Cardano.Crypto.Hash import Ouroboros.Consensus.Block import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.UTxO import Ouroboros.Consensus.Util (ShowProxy (..), repeatedlyM) {------------------------------------------------------------------------------- State of the mock ledger -------------------------------------------------------------------------------} data MockState blk = MockState { MockState blk -> Utxo mockUtxo :: !Utxo , MockState blk -> Set TxId mockConfirmed :: !(Set TxId) , 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 showList :: [MockState blk] -> ShowS $cshowList :: forall blk. StandardHash blk => [MockState blk] -> ShowS show :: MockState blk -> String $cshow :: forall blk. StandardHash blk => MockState blk -> String showsPrec :: Int -> MockState blk -> ShowS $cshowsPrec :: forall blk. StandardHash blk => Int -> 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 /= :: MockState blk -> MockState blk -> Bool $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 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 $cto :: forall blk x. Rep (MockState blk) x -> MockState blk $cfrom :: forall blk x. MockState blk -> Rep (MockState blk) x 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 showTypeOf :: Proxy (MockState blk) -> String $cshowTypeOf :: forall blk. StandardHash blk => Proxy (MockState blk) -> String wNoThunks :: Context -> MockState blk -> IO (Maybe ThunkInfo) $cwNoThunks :: forall blk. StandardHash blk => Context -> MockState blk -> IO (Maybe ThunkInfo) noThunks :: Context -> MockState blk -> IO (Maybe ThunkInfo) $cnoThunks :: forall blk. StandardHash blk => Context -> MockState blk -> IO (Maybe ThunkInfo) 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) 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 $cto :: forall blk x. Rep (MockError blk) x -> MockError blk $cfrom :: forall blk x. MockError blk -> Rep (MockError blk) x 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 showTypeOf :: Proxy (MockError blk) -> String $cshowTypeOf :: forall blk. (StandardHash blk, Typeable blk) => Proxy (MockError blk) -> String wNoThunks :: Context -> MockError blk -> IO (Maybe ThunkInfo) $cwNoThunks :: forall blk. (StandardHash blk, Typeable blk) => Context -> MockError blk -> IO (Maybe ThunkInfo) noThunks :: Context -> MockError blk -> IO (Maybe ThunkInfo) $cnoThunks :: forall blk. (StandardHash blk, Typeable blk) => Context -> MockError blk -> IO (Maybe ThunkInfo) 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) => blk -> MockState blk -> Except (MockError blk) (MockState blk) updateMockState :: blk -> MockState blk -> Except (MockError blk) (MockState blk) updateMockState 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 SlotNo -> blk -> MockState blk -> Except (MockError blk) (MockState blk) forall a blk. HasMockTxs a => SlotNo -> a -> MockState blk -> Except (MockError blk) (MockState blk) updateMockUTxO (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 :: 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 block. Point block -> ChainHash block pointHash Point blk t = MockState blk -> Except (MockError blk) (MockState blk) 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 (Header blk -> Point blk forall blk. HasHeader (Header blk) => Header blk -> Point blk headerPoint Header blk hdr) | Bool otherwise = MockError blk -> Except (MockError blk) (MockState blk) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (MockError blk -> Except (MockError blk) (MockState blk)) -> MockError blk -> Except (MockError blk) (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 block. Point block -> ChainHash block pointHash Point blk t) updateMockUTxO :: HasMockTxs a => SlotNo -> a -> MockState blk -> Except (MockError blk) (MockState blk) updateMockUTxO :: SlotNo -> a -> MockState blk -> Except (MockError blk) (MockState blk) updateMockUTxO SlotNo now = (Tx -> MockState blk -> Except (MockError blk) (MockState blk)) -> [Tx] -> MockState blk -> Except (MockError blk) (MockState blk) forall (m :: * -> *) a b. Monad m => (a -> b -> m b) -> [a] -> b -> m b repeatedlyM (SlotNo -> Tx -> MockState blk -> Except (MockError blk) (MockState blk) forall blk. SlotNo -> Tx -> MockState blk -> Except (MockError blk) (MockState blk) updateMockUTxO1 SlotNo now) ([Tx] -> MockState blk -> Except (MockError blk) (MockState blk)) -> (a -> [Tx]) -> a -> MockState blk -> Except (MockError blk) (MockState blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> [Tx] forall a. HasMockTxs a => a -> [Tx] getMockTxs updateMockUTxO1 :: forall blk. SlotNo -> Tx -> MockState blk -> Except (MockError blk) (MockState blk) updateMockUTxO1 :: SlotNo -> Tx -> MockState blk -> Except (MockError blk) (MockState blk) updateMockUTxO1 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 e (m :: * -> *) a. MonadError e m => e -> m a throwError MockError blk e Maybe (MockError blk) Nothing -> do 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 (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 TxIn _ins [TxOut] _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 {------------------------------------------------------------------------------- Genesis -------------------------------------------------------------------------------} genesisMockState :: AddrDist -> MockState blk genesisMockState :: AddrDist -> MockState blk genesisMockState AddrDist addrDist = MockState :: forall blk. Utxo -> Set TxId -> Point blk -> MockState blk 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 block. Point block GenesisPoint }