{-# 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           Cardano.Binary (ToCBOR (..))
import           Cardano.Crypto.Hash
import           Codec.Serialise (Serialise (..))
import           Control.DeepSeq (NFData (..), force, rwhnf)
import           Control.Monad (forM, when)
import           Control.Monad.Except (Except, throwError)
import           Control.Monad.State (execStateT, get, modify, put)
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           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Mock.Ledger.Address
import           Ouroboros.Consensus.Util (repeatedlyM)
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.Mock.Chain (Chain, toOldestFirst)

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

pattern Tx :: Expiry -> Set TxIn -> [TxOut] -> Tx
pattern $mTx :: forall {r}.
Tx -> (Expiry -> Set TxIn -> [TxOut] -> r) -> ((# #) -> r) -> r
$bTx :: Expiry -> Set TxIn -> [TxOut] -> Tx
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
$c== :: UtxoError -> UtxoError -> Bool
== :: UtxoError -> UtxoError -> Bool
$c/= :: UtxoError -> UtxoError -> Bool
/= :: 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
$cshowsPrec :: Int -> UtxoError -> ShowS
showsPrec :: Int -> UtxoError -> ShowS
$cshow :: UtxoError -> String
show :: UtxoError -> String
$cshowList :: [UtxoError] -> ShowS
showList :: [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
$cfrom :: forall x. UtxoError -> Rep UtxoError x
from :: forall x. UtxoError -> Rep UtxoError x
$cto :: forall x. Rep UtxoError x -> UtxoError
to :: forall x. Rep UtxoError x -> UtxoError
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
$cencode :: UtxoError -> Encoding
encode :: UtxoError -> Encoding
$cdecode :: forall s. Decoder s UtxoError
decode :: forall s. Decoder s UtxoError
$cencodeList :: [UtxoError] -> Encoding
encodeList :: [UtxoError] -> Encoding
$cdecodeList :: forall s. Decoder s [UtxoError]
decodeList :: forall s. Decoder s [UtxoError]
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
$cnoThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
noThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> UtxoError -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy UtxoError -> String
showTypeOf :: Proxy UtxoError -> String
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 :: forall a. HasMockTxs a => 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 :: forall a. HasMockTxs a => 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
$ (Word -> TxOut -> (TxIn, TxOut))
-> [Word] -> [TxOut] -> [(TxIn, TxOut)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word -> TxOut -> (TxIn, TxOut)
aux [Word
0..] [TxOut]
outs
      where
        aux :: Ix -> TxOut -> (TxIn, TxOut)
        aux :: Word -> TxOut -> (TxIn, TxOut)
aux Word
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, Word
ix), TxOut
out)

-- | @confirmed@ stands for all the transaction hashes present in the given
-- collection.
confirmed :: HasMockTxs a => a -> Set TxId
confirmed :: forall a. HasMockTxs a => 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 :: forall a. HasMockTxs a => 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
        Word
inputAmount <- ([Word] -> Word) -> StateT Utxo m [Word] -> StateT Utxo m Word
forall a b. (a -> b) -> StateT Utxo m a -> StateT Utxo m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word] -> Word
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (StateT Utxo m [Word] -> StateT Utxo m Word)
-> StateT Utxo m [Word] -> StateT Utxo m Word
forall a b. (a -> b) -> a -> b
$ [TxIn] -> (TxIn -> StateT Utxo m Word) -> StateT Utxo m [Word]
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 Word) -> StateT Utxo m [Word])
-> (TxIn -> StateT Utxo m Word) -> StateT Utxo m [Word]
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 Word
forall a. UtxoError -> StateT Utxo m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UtxoError -> StateT Utxo m Word)
-> UtxoError -> StateT Utxo m Word
forall a b. (a -> b) -> a -> b
$ TxIn -> UtxoError
MissingInput TxIn
txIn
            (Just (Addr
_addr, Word
amount), Utxo
u') -> Utxo -> StateT Utxo m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Utxo
u' StateT Utxo m () -> Word -> StateT Utxo m Word
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word
amount

        -- Check that the sum of the inputs is equal to the sum of the outputs
        let outputAmount :: Word
outputAmount = [Word] -> Word
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Word] -> Word) -> [Word] -> Word
forall a b. (a -> b) -> a -> b
$ (TxOut -> Word) -> [TxOut] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map TxOut -> Word
forall a b. (a, b) -> b
snd ([TxOut] -> [Word]) -> [TxOut] -> [Word]
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 (Word
inputAmount Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
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 a. UtxoError -> StateT Utxo m a
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
$ Word -> Word -> UtxoError
InputOutputMismatch Word
inputAmount Word
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, Word
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)