{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingVia          #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE PatternSynonyms      #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Mock.Ledger.UTxO (
    -- * Basic definitions
    Addr
  , Amount
  , Expiry (..)
  , Ix
  , Tx (Tx)
  , TxId
  , TxIn
  , TxOut
  , Utxo
    -- * Computing UTxO
  , HasMockTxs (..)
  , UtxoError (..)
  , confirmed
  , txIns
  , txOuts
  , updateUtxo
    -- * Genesis
  , genesisTx
  , genesisUtxo
  ) where

import           Codec.Serialise (Serialise (..))
import           Control.DeepSeq (NFData (..), force, rwhnf)
import           Control.Monad.Except
import           Control.Monad.State
import           Data.Functor (($>))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           GHC.Generics (Generic)
import           NoThunks.Class (InspectHeap (..), NoThunks)

import           Cardano.Binary (ToCBOR (..))
import           Cardano.Crypto.Hash

import           Ouroboros.Network.MockChain.Chain (Chain, toOldestFirst)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util (repeatedlyM)
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Orphans ()

import           Ouroboros.Consensus.Mock.Ledger.Address

{-------------------------------------------------------------------------------
  Basic definitions
-------------------------------------------------------------------------------}

data Expiry
  = DoNotExpire
  | ExpireAtOnsetOf !SlotNo
  deriving stock    (Int -> Expiry -> ShowS
[Expiry] -> ShowS
Expiry -> String
(Int -> Expiry -> ShowS)
-> (Expiry -> String) -> ([Expiry] -> ShowS) -> Show Expiry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expiry] -> ShowS
$cshowList :: [Expiry] -> ShowS
show :: Expiry -> String
$cshow :: Expiry -> String
showsPrec :: Int -> Expiry -> ShowS
$cshowsPrec :: Int -> Expiry -> ShowS
Show, Expiry -> Expiry -> Bool
(Expiry -> Expiry -> Bool)
-> (Expiry -> Expiry -> Bool) -> Eq Expiry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expiry -> Expiry -> Bool
$c/= :: Expiry -> Expiry -> Bool
== :: Expiry -> Expiry -> Bool
$c== :: Expiry -> Expiry -> Bool
Eq, Eq Expiry
Eq Expiry
-> (Expiry -> Expiry -> Ordering)
-> (Expiry -> Expiry -> Bool)
-> (Expiry -> Expiry -> Bool)
-> (Expiry -> Expiry -> Bool)
-> (Expiry -> Expiry -> Bool)
-> (Expiry -> Expiry -> Expiry)
-> (Expiry -> Expiry -> Expiry)
-> Ord Expiry
Expiry -> Expiry -> Bool
Expiry -> Expiry -> Ordering
Expiry -> Expiry -> Expiry
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 :: Expiry -> Expiry -> Expiry
$cmin :: Expiry -> Expiry -> Expiry
max :: Expiry -> Expiry -> Expiry
$cmax :: Expiry -> Expiry -> Expiry
>= :: Expiry -> Expiry -> Bool
$c>= :: Expiry -> Expiry -> Bool
> :: Expiry -> Expiry -> Bool
$c> :: Expiry -> Expiry -> Bool
<= :: Expiry -> Expiry -> Bool
$c<= :: Expiry -> Expiry -> Bool
< :: Expiry -> Expiry -> Bool
$c< :: Expiry -> Expiry -> Bool
compare :: Expiry -> Expiry -> Ordering
$ccompare :: Expiry -> Expiry -> Ordering
$cp1Ord :: Eq Expiry
Ord, (forall x. Expiry -> Rep Expiry x)
-> (forall x. Rep Expiry x -> Expiry) -> Generic Expiry
forall x. Rep Expiry x -> Expiry
forall x. Expiry -> Rep Expiry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Expiry x -> Expiry
$cfrom :: forall x. Expiry -> Rep Expiry x
Generic)
  deriving anyclass ([Expiry] -> Encoding
Expiry -> Encoding
(Expiry -> Encoding)
-> (forall s. Decoder s Expiry)
-> ([Expiry] -> Encoding)
-> (forall s. Decoder s [Expiry])
-> Serialise Expiry
forall s. Decoder s [Expiry]
forall s. Decoder s Expiry
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: Decoder s [Expiry]
$cdecodeList :: forall s. Decoder s [Expiry]
encodeList :: [Expiry] -> Encoding
$cencodeList :: [Expiry] -> Encoding
decode :: Decoder s Expiry
$cdecode :: forall s. Decoder s Expiry
encode :: Expiry -> Encoding
$cencode :: Expiry -> Encoding
Serialise, Context -> Expiry -> IO (Maybe ThunkInfo)
Proxy Expiry -> String
(Context -> Expiry -> IO (Maybe ThunkInfo))
-> (Context -> Expiry -> IO (Maybe ThunkInfo))
-> (Proxy Expiry -> String)
-> NoThunks Expiry
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Expiry -> String
$cshowTypeOf :: Proxy Expiry -> String
wNoThunks :: Context -> Expiry -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Expiry -> IO (Maybe ThunkInfo)
noThunks :: Context -> Expiry -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Expiry -> IO (Maybe ThunkInfo)
NoThunks)

instance NFData Expiry where rnf :: Expiry -> ()
rnf = Expiry -> ()
forall a. a -> ()
rwhnf

instance Condense Expiry where
  condense :: Expiry -> String
condense = Expiry -> String
forall a. Show a => a -> String
show

data Tx = UnsafeTx Expiry (Set TxIn) [TxOut]
  deriving stock    (Int -> Tx -> ShowS
[Tx] -> ShowS
Tx -> String
(Int -> Tx -> ShowS)
-> (Tx -> String) -> ([Tx] -> ShowS) -> Show Tx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tx] -> ShowS
$cshowList :: [Tx] -> ShowS
show :: Tx -> String
$cshow :: Tx -> String
showsPrec :: Int -> Tx -> ShowS
$cshowsPrec :: Int -> Tx -> ShowS
Show, Tx -> Tx -> Bool
(Tx -> Tx -> Bool) -> (Tx -> Tx -> Bool) -> Eq Tx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tx -> Tx -> Bool
$c/= :: Tx -> Tx -> Bool
== :: Tx -> Tx -> Bool
$c== :: Tx -> Tx -> Bool
Eq, Eq Tx
Eq Tx
-> (Tx -> Tx -> Ordering)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Tx)
-> (Tx -> Tx -> Tx)
-> Ord Tx
Tx -> Tx -> Bool
Tx -> Tx -> Ordering
Tx -> Tx -> Tx
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 :: Tx -> Tx -> Tx
$cmin :: Tx -> Tx -> Tx
max :: Tx -> Tx -> Tx
$cmax :: Tx -> Tx -> Tx
>= :: Tx -> Tx -> Bool
$c>= :: Tx -> Tx -> Bool
> :: Tx -> Tx -> Bool
$c> :: Tx -> Tx -> Bool
<= :: Tx -> Tx -> Bool
$c<= :: Tx -> Tx -> Bool
< :: Tx -> Tx -> Bool
$c< :: Tx -> Tx -> Bool
compare :: Tx -> Tx -> Ordering
$ccompare :: Tx -> Tx -> Ordering
$cp1Ord :: Eq Tx
Ord, (forall x. Tx -> Rep Tx x)
-> (forall x. Rep Tx x -> Tx) -> Generic Tx
forall x. Rep Tx x -> Tx
forall x. Tx -> Rep Tx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Tx x -> Tx
$cfrom :: forall x. Tx -> Rep Tx x
Generic)
  deriving anyclass ([Tx] -> Encoding
Tx -> Encoding
(Tx -> Encoding)
-> (forall s. Decoder s Tx)
-> ([Tx] -> Encoding)
-> (forall s. Decoder s [Tx])
-> Serialise Tx
forall s. Decoder s [Tx]
forall s. Decoder s Tx
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: Decoder s [Tx]
$cdecodeList :: forall s. Decoder s [Tx]
encodeList :: [Tx] -> Encoding
$cencodeList :: [Tx] -> Encoding
decode :: Decoder s Tx
$cdecode :: forall s. Decoder s Tx
encode :: Tx -> Encoding
$cencode :: Tx -> Encoding
Serialise, Tx -> ()
(Tx -> ()) -> NFData Tx
forall a. (a -> ()) -> NFData a
rnf :: Tx -> ()
$crnf :: Tx -> ()
NFData)
  deriving Context -> Tx -> IO (Maybe ThunkInfo)
Proxy Tx -> String
(Context -> Tx -> IO (Maybe ThunkInfo))
-> (Context -> Tx -> IO (Maybe ThunkInfo))
-> (Proxy Tx -> String)
-> NoThunks Tx
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Tx -> String
$cshowTypeOf :: Proxy Tx -> String
wNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
noThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
NoThunks via InspectHeap Tx

pattern Tx :: Expiry -> Set TxIn -> [TxOut] -> Tx
pattern $bTx :: Expiry -> Set TxIn -> [TxOut] -> Tx
$mTx :: forall r.
Tx -> (Expiry -> Set TxIn -> [TxOut] -> r) -> (Void# -> r) -> r
Tx expiry ins outs <- UnsafeTx expiry ins outs where
  Tx Expiry
expiry Set TxIn
ins [TxOut]
outs = Tx -> Tx
forall a. NFData a => a -> a
force (Tx -> Tx) -> Tx -> Tx
forall a b. (a -> b) -> a -> b
$ Expiry -> Set TxIn -> [TxOut] -> Tx
UnsafeTx Expiry
expiry Set TxIn
ins [TxOut]
outs

{-# COMPLETE Tx #-}

instance ToCBOR Tx where
  toCBOR :: Tx -> Encoding
toCBOR = Tx -> Encoding
forall a. Serialise a => a -> Encoding
encode

instance Condense Tx where
  condense :: Tx -> String
condense (Tx Expiry
expiry Set TxIn
ins [TxOut]
outs) = (Expiry, Set TxIn, [TxOut]) -> String
forall a. Condense a => a -> String
condense (Expiry
expiry, Set TxIn
ins, [TxOut]
outs)

type Ix     = Word
type Amount = Word
type TxId   = Hash SHA256 Tx
type TxIn   = (TxId, Ix)
type TxOut  = (Addr, Amount)
type Utxo   = Map TxIn TxOut

{-------------------------------------------------------------------------------
  Computing UTxO
-------------------------------------------------------------------------------}

data UtxoError
  = MissingInput TxIn
  | InputOutputMismatch
      Amount  -- ^ Input
      Amount  -- ^ Output
  deriving stock    (UtxoError -> UtxoError -> Bool
(UtxoError -> UtxoError -> Bool)
-> (UtxoError -> UtxoError -> Bool) -> Eq UtxoError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UtxoError -> UtxoError -> Bool
$c/= :: UtxoError -> UtxoError -> Bool
== :: UtxoError -> UtxoError -> Bool
$c== :: UtxoError -> UtxoError -> Bool
Eq, Int -> UtxoError -> ShowS
[UtxoError] -> ShowS
UtxoError -> String
(Int -> UtxoError -> ShowS)
-> (UtxoError -> String)
-> ([UtxoError] -> ShowS)
-> Show UtxoError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UtxoError] -> ShowS
$cshowList :: [UtxoError] -> ShowS
show :: UtxoError -> String
$cshow :: UtxoError -> String
showsPrec :: Int -> UtxoError -> ShowS
$cshowsPrec :: Int -> UtxoError -> ShowS
Show, (forall x. UtxoError -> Rep UtxoError x)
-> (forall x. Rep UtxoError x -> UtxoError) -> Generic UtxoError
forall x. Rep UtxoError x -> UtxoError
forall x. UtxoError -> Rep UtxoError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UtxoError x -> UtxoError
$cfrom :: forall x. UtxoError -> Rep UtxoError x
Generic)
  deriving anyclass ([UtxoError] -> Encoding
UtxoError -> Encoding
(UtxoError -> Encoding)
-> (forall s. Decoder s UtxoError)
-> ([UtxoError] -> Encoding)
-> (forall s. Decoder s [UtxoError])
-> Serialise UtxoError
forall s. Decoder s [UtxoError]
forall s. Decoder s UtxoError
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: Decoder s [UtxoError]
$cdecodeList :: forall s. Decoder s [UtxoError]
encodeList :: [UtxoError] -> Encoding
$cencodeList :: [UtxoError] -> Encoding
decode :: Decoder s UtxoError
$cdecode :: forall s. Decoder s UtxoError
encode :: UtxoError -> Encoding
$cencode :: UtxoError -> Encoding
Serialise, Context -> UtxoError -> IO (Maybe ThunkInfo)
Proxy UtxoError -> String
(Context -> UtxoError -> IO (Maybe ThunkInfo))
-> (Context -> UtxoError -> IO (Maybe ThunkInfo))
-> (Proxy UtxoError -> String)
-> NoThunks UtxoError
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy UtxoError -> String
$cshowTypeOf :: Proxy UtxoError -> String
wNoThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
noThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
NoThunks)

instance Condense UtxoError where
  condense :: UtxoError -> String
condense = UtxoError -> String
forall a. Show a => a -> String
show

class HasMockTxs a where
  -- | The transactions in the order they are to be applied
  --
  getMockTxs :: a -> [Tx]

instance HasMockTxs Tx where
  getMockTxs :: Tx -> [Tx]
getMockTxs = (Tx -> [Tx] -> [Tx]
forall a. a -> [a] -> [a]
:[])

instance HasMockTxs a => HasMockTxs [a] where
  getMockTxs :: [a] -> [Tx]
getMockTxs = (a -> [Tx]) -> [a] -> [Tx]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [Tx]
forall a. HasMockTxs a => a -> [Tx]
getMockTxs

instance HasMockTxs a => HasMockTxs (Chain a) where
  getMockTxs :: Chain a -> [Tx]
getMockTxs = [a] -> [Tx]
forall a. HasMockTxs a => a -> [Tx]
getMockTxs ([a] -> [Tx]) -> (Chain a -> [a]) -> Chain a -> [Tx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain a -> [a]
forall block. Chain block -> [block]
toOldestFirst

txIns :: HasMockTxs a => a -> Set TxIn
txIns :: a -> Set TxIn
txIns = [Set TxIn] -> Set TxIn
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set TxIn] -> Set TxIn) -> (a -> [Set TxIn]) -> a -> Set TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Set TxIn) -> [Tx] -> [Set TxIn]
forall a b. (a -> b) -> [a] -> [b]
map Tx -> Set TxIn
each ([Tx] -> [Set TxIn]) -> (a -> [Tx]) -> a -> [Set TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Tx]
forall a. HasMockTxs a => a -> [Tx]
getMockTxs
  where
    each :: Tx -> Set TxIn
each (Tx Expiry
_expiry Set TxIn
ins [TxOut]
_outs) = Set TxIn
ins

txOuts :: HasMockTxs a => a -> Utxo
txOuts :: a -> Utxo
txOuts = [Utxo] -> Utxo
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Utxo] -> Utxo) -> (a -> [Utxo]) -> a -> Utxo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Utxo) -> [Tx] -> [Utxo]
forall a b. (a -> b) -> [a] -> [b]
map Tx -> Utxo
each ([Tx] -> [Utxo]) -> (a -> [Tx]) -> a -> [Utxo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Tx]
forall a. HasMockTxs a => a -> [Tx]
getMockTxs
  where
    each :: Tx -> Utxo
each tx :: Tx
tx@(Tx Expiry
_expiry Set TxIn
_ins [TxOut]
outs) =
        [(TxIn, TxOut)] -> Utxo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut)] -> Utxo) -> [(TxIn, TxOut)] -> Utxo
forall a b. (a -> b) -> a -> b
$ (Ix -> TxOut -> (TxIn, TxOut))
-> [Ix] -> [TxOut] -> [(TxIn, TxOut)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Ix -> TxOut -> (TxIn, TxOut)
aux [Ix
0..] [TxOut]
outs
      where
        aux :: Ix -> TxOut -> (TxIn, TxOut)
        aux :: Ix -> TxOut -> (TxIn, TxOut)
aux Ix
ix TxOut
out = (((Tx -> Encoding) -> Tx -> Hash SHA256 Tx
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser Tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Tx
tx, Ix
ix), TxOut
out)

-- | @confirmed@ stands for all the transaction hashes present in the given
-- collection.
confirmed :: HasMockTxs a => a -> Set TxId
confirmed :: a -> Set (Hash SHA256 Tx)
confirmed = [Hash SHA256 Tx] -> Set (Hash SHA256 Tx)
forall a. Ord a => [a] -> Set a
Set.fromList ([Hash SHA256 Tx] -> Set (Hash SHA256 Tx))
-> (a -> [Hash SHA256 Tx]) -> a -> Set (Hash SHA256 Tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx -> Hash SHA256 Tx) -> [Tx] -> [Hash SHA256 Tx]
forall a b. (a -> b) -> [a] -> [b]
map ((Tx -> Encoding) -> Tx -> Hash SHA256 Tx
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser Tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR) ([Tx] -> [Hash SHA256 Tx]) -> (a -> [Tx]) -> a -> [Hash SHA256 Tx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Tx]
forall a. HasMockTxs a => a -> [Tx]
getMockTxs

-- |Update the Utxo with the transactions from the given @a@, by removing the
-- inputs and adding the outputs.
updateUtxo :: HasMockTxs a => a -> Utxo -> Except UtxoError Utxo
updateUtxo :: a -> Utxo -> Except UtxoError Utxo
updateUtxo = (Tx -> Utxo -> Except UtxoError Utxo)
-> [Tx] -> Utxo -> Except UtxoError Utxo
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM Tx -> Utxo -> Except UtxoError Utxo
forall (m :: * -> *) a.
(MonadError UtxoError m, HasMockTxs a) =>
a -> Utxo -> m Utxo
each ([Tx] -> Utxo -> Except UtxoError Utxo)
-> (a -> [Tx]) -> a -> Utxo -> Except UtxoError Utxo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Tx]
forall a. HasMockTxs a => a -> [Tx]
getMockTxs
  where
    each :: a -> Utxo -> m Utxo
each a
tx = StateT Utxo m () -> Utxo -> m Utxo
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT Utxo m () -> Utxo -> m Utxo)
-> StateT Utxo m () -> Utxo -> m Utxo
forall a b. (a -> b) -> a -> b
$ do
        -- Remove all inputs from the Utxo and calculate the sum of all the
        -- input amounts
        Ix
inputAmount <- ([Ix] -> Ix) -> StateT Utxo m [Ix] -> StateT Utxo m Ix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Ix] -> Ix
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (StateT Utxo m [Ix] -> StateT Utxo m Ix)
-> StateT Utxo m [Ix] -> StateT Utxo m Ix
forall a b. (a -> b) -> a -> b
$ [TxIn] -> (TxIn -> StateT Utxo m Ix) -> StateT Utxo m [Ix]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (a -> Set TxIn
forall a. HasMockTxs a => a -> Set TxIn
txIns a
tx)) ((TxIn -> StateT Utxo m Ix) -> StateT Utxo m [Ix])
-> (TxIn -> StateT Utxo m Ix) -> StateT Utxo m [Ix]
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn -> do
          Utxo
u <- StateT Utxo m Utxo
forall s (m :: * -> *). MonadState s m => m s
get
          case (TxIn -> TxOut -> Maybe TxOut)
-> TxIn -> Utxo -> (Maybe TxOut, Utxo)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\TxIn
_ TxOut
_ -> Maybe TxOut
forall a. Maybe a
Nothing) TxIn
txIn Utxo
u of
            (Maybe TxOut
Nothing,              Utxo
_)  -> UtxoError -> StateT Utxo m Ix
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UtxoError -> StateT Utxo m Ix) -> UtxoError -> StateT Utxo m Ix
forall a b. (a -> b) -> a -> b
$ TxIn -> UtxoError
MissingInput TxIn
txIn
            (Just (Addr
_addr, Ix
amount), Utxo
u') -> Utxo -> StateT Utxo m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Utxo
u' StateT Utxo m () -> Ix -> StateT Utxo m Ix
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ix
amount

        -- Check that the sum of the inputs is equal to the sum of the outputs
        let outputAmount :: Ix
outputAmount = [Ix] -> Ix
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Ix] -> Ix) -> [Ix] -> Ix
forall a b. (a -> b) -> a -> b
$ (TxOut -> Ix) -> [TxOut] -> [Ix]
forall a b. (a -> b) -> [a] -> [b]
map TxOut -> Ix
forall a b. (a, b) -> b
snd ([TxOut] -> [Ix]) -> [TxOut] -> [Ix]
forall a b. (a -> b) -> a -> b
$ Utxo -> [TxOut]
forall k a. Map k a -> [a]
Map.elems (Utxo -> [TxOut]) -> Utxo -> [TxOut]
forall a b. (a -> b) -> a -> b
$ a -> Utxo
forall a. HasMockTxs a => a -> Utxo
txOuts a
tx
        Bool -> StateT Utxo m () -> StateT Utxo m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ix
inputAmount Ix -> Ix -> Bool
forall a. Eq a => a -> a -> Bool
/= Ix
outputAmount) (StateT Utxo m () -> StateT Utxo m ())
-> StateT Utxo m () -> StateT Utxo m ()
forall a b. (a -> b) -> a -> b
$
          UtxoError -> StateT Utxo m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UtxoError -> StateT Utxo m ()) -> UtxoError -> StateT Utxo m ()
forall a b. (a -> b) -> a -> b
$ Ix -> Ix -> UtxoError
InputOutputMismatch Ix
inputAmount Ix
outputAmount

        -- Add the outputs to the Utxo
        (Utxo -> Utxo) -> StateT Utxo m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Utxo -> Utxo -> Utxo
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` a -> Utxo
forall a. HasMockTxs a => a -> Utxo
txOuts a
tx)

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

-- | Transaction giving initial stake to the nodes
genesisTx :: AddrDist -> Tx
genesisTx :: AddrDist -> Tx
genesisTx AddrDist
addrDist =
    Expiry -> Set TxIn -> [TxOut] -> Tx
Tx Expiry
DoNotExpire Set TxIn
forall a. Monoid a => a
mempty [(Addr
addr, Ix
1000) | Addr
addr <- AddrDist -> [Addr]
forall k a. Map k a -> [k]
Map.keys AddrDist
addrDist]

genesisUtxo :: AddrDist -> Utxo
genesisUtxo :: AddrDist -> Utxo
genesisUtxo AddrDist
addrDist = Tx -> Utxo
forall a. HasMockTxs a => a -> Utxo
txOuts (AddrDist -> Tx
genesisTx AddrDist
addrDist)