{-# 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
    }