module Test.QuickCheck.ContractModel.Internal.ChainIndex where

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer

import Data.Ord
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map

import Cardano.Api
import Cardano.Api.Shelley
import Cardano.Ledger.Shelley.TxBody (WitVKey (..))
import Cardano.Ledger.Keys (hashKey, coerceKeyRole)

import Test.QuickCheck.ContractModel.Internal.Common
import Test.QuickCheck.ContractModel.Internal.Utils

data ChainState = ChainState
  { ChainState -> SlotNo
slot :: SlotNo
  , ChainState -> UTxO Era
utxo :: UTxO Era
  }

data TxInState = TxInState
  { TxInState -> Tx Era
tx         :: Tx Era
  , TxInState -> ChainState
chainState :: ChainState
  , TxInState -> Bool
accepted   :: Bool
  }

data ChainIndex = ChainIndex
  { ChainIndex -> [TxInState]
transactions :: [TxInState]
  , ChainIndex -> NetworkId
networkId    :: NetworkId
  }

instance Semigroup ChainIndex where
  ChainIndex
ci <> :: ChainIndex -> ChainIndex -> ChainIndex
<> ChainIndex
ci' = ChainIndex :: [TxInState] -> NetworkId -> ChainIndex
ChainIndex { transactions :: [TxInState]
transactions = (TxInState -> TxInState -> Ordering) -> [TxInState] -> [TxInState]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TxInState -> SlotNo) -> TxInState -> TxInState -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (ChainState -> SlotNo
slot (ChainState -> SlotNo)
-> (TxInState -> ChainState) -> TxInState -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInState -> ChainState
chainState))
                                        ([TxInState] -> [TxInState]) -> [TxInState] -> [TxInState]
forall a b. (a -> b) -> a -> b
$ ChainIndex -> [TxInState]
transactions ChainIndex
ci [TxInState] -> [TxInState] -> [TxInState]
forall a. [a] -> [a] -> [a]
++ ChainIndex -> [TxInState]
transactions ChainIndex
ci'
                         , networkId :: NetworkId
networkId    = ChainIndex -> NetworkId
networkId ChainIndex
ci
                         }

class HasChainIndex m where
  getChainIndex :: m ChainIndex
  getChainState :: m ChainState

allMinAda :: ChainIndex
          -> ProtocolParameters
          -> [Lovelace]
allMinAda :: ChainIndex -> ProtocolParameters -> [Lovelace]
allMinAda ChainIndex
ci ProtocolParameters
params =
  [ Value -> Lovelace
selectLovelace Value
v
  | TxInState{Bool
Tx Era
ChainState
accepted :: Bool
chainState :: ChainState
tx :: Tx Era
accepted :: TxInState -> Bool
chainState :: TxInState -> ChainState
tx :: TxInState -> Tx Era
..} <- ChainIndex -> [TxInState]
transactions ChainIndex
ci
  , TxOut CtxTx Era
txOut <- Tx Era -> [TxOut CtxTx Era]
getTxOuts Tx Era
tx
  , Right Value
v <- [ShelleyBasedEra Era
-> TxOut CtxTx Era
-> ProtocolParameters
-> Either MinimumUTxOError Value
forall era.
ShelleyBasedEra era
-> TxOut CtxTx era
-> ProtocolParameters
-> Either MinimumUTxOError Value
calculateMinimumUTxO ShelleyBasedEra Era
era TxOut CtxTx Era
txOut ProtocolParameters
params]
  , Bool
accepted
  ]

type FeeCalculation = NetworkId -> TxInState -> Map (AddressInEra Era) Value

signerPaysFees :: FeeCalculation
signerPaysFees :: FeeCalculation
signerPaysFees NetworkId
nid TxInState{tx :: TxInState -> Tx Era
tx = Tx Era
tx, accepted :: TxInState -> Bool
accepted = Bool
accepted}
  | Bool -> Bool
not Bool
accepted = [Char] -> Map (AddressInEra Era) Value
forall a. HasCallStack => [Char] -> a
error [Char]
"TODO: signerPaysFees rejected tx"
  | Tx (TxBody (TxBodyContent ViewTx Era -> TxFee Era
forall build era. TxBodyContent build era -> TxFee era
txFee -> TxFeeExplicit TxFeesExplicitInEra Era
_ Lovelace
lov)) [KeyWitness Era
wit] <- Tx Era
tx = AddressInEra Era -> Value -> Map (AddressInEra Era) Value
forall k a. k -> a -> Map k a
Map.singleton (Address ShelleyAddr -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
Address ShelleyAddr -> AddressInEra era
shelleyAddressInEra (Address ShelleyAddr -> AddressInEra Era)
-> Address ShelleyAddr -> AddressInEra Era
forall a b. (a -> b) -> a -> b
$ NetworkId -> KeyWitness Era -> Address ShelleyAddr
mkAddrFromWitness NetworkId
nid KeyWitness Era
wit) (Lovelace -> Value
lovelaceToValue Lovelace
lov)
  | Bool
otherwise = Map (AddressInEra Era) Value
forall a. Monoid a => a
mempty

-- TODO: is this really safe?? also - why is this so complicated??
mkAddrFromWitness :: NetworkId -> KeyWitness Era -> Address ShelleyAddr
mkAddrFromWitness :: NetworkId -> KeyWitness Era -> Address ShelleyAddr
mkAddrFromWitness NetworkId
nid KeyWitness Era
wit = NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
makeShelleyAddress NetworkId
nid (KeyWitness Era -> PaymentCredential
keyHashObj KeyWitness Era
wit) StakeAddressReference
NoStakeAddress
  where keyHashObj :: KeyWitness Era -> PaymentCredential
        keyHashObj :: KeyWitness Era -> PaymentCredential
keyHashObj (ShelleyKeyWitness ShelleyBasedEra Era
_ (WitVKey VKey 'Witness StandardCrypto
wit SignedDSIGN
  StandardCrypto (Hash StandardCrypto EraIndependentTxBody)
_)) =
            Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey
          (Hash PaymentKey -> PaymentCredential)
-> (VKey 'Witness StandardCrypto -> Hash PaymentKey)
-> VKey 'Witness StandardCrypto
-> PaymentCredential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash 'Payment StandardCrypto -> Hash PaymentKey
PaymentKeyHash
          (KeyHash 'Payment StandardCrypto -> Hash PaymentKey)
-> (VKey 'Witness StandardCrypto
    -> KeyHash 'Payment StandardCrypto)
-> VKey 'Witness StandardCrypto
-> Hash PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey 'Payment StandardCrypto -> KeyHash 'Payment StandardCrypto
forall crypto (kd :: KeyRole).
Crypto crypto =>
VKey kd crypto -> KeyHash kd crypto
hashKey
          (VKey 'Payment StandardCrypto -> KeyHash 'Payment StandardCrypto)
-> (VKey 'Witness StandardCrypto -> VKey 'Payment StandardCrypto)
-> VKey 'Witness StandardCrypto
-> KeyHash 'Payment StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey 'Witness StandardCrypto -> VKey 'Payment StandardCrypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
coerceKeyRole   -- TODO: is this really safe?!?!?!
          (VKey 'Witness StandardCrypto -> PaymentCredential)
-> VKey 'Witness StandardCrypto -> PaymentCredential
forall a b. (a -> b) -> a -> b
$ VKey 'Witness StandardCrypto
wit
        keyHashObj ShelleyBootstrapWitness{} = [Char] -> PaymentCredential
forall a. HasCallStack => [Char] -> a
error [Char]
"keyHashObj: ShelleyBootstrapWitness{}"

-- TODO: what about failing transactions?
getBalanceChangesDiscountingFees :: ChainIndex
                                 -> FeeCalculation
                                 -> Map (AddressInEra Era) Value
getBalanceChangesDiscountingFees :: ChainIndex -> FeeCalculation -> Map (AddressInEra Era) Value
getBalanceChangesDiscountingFees ChainIndex{[TxInState]
NetworkId
networkId :: NetworkId
transactions :: [TxInState]
networkId :: ChainIndex -> NetworkId
transactions :: ChainIndex -> [TxInState]
..} FeeCalculation
computeFees =
  (Map (AddressInEra Era) Value
 -> Map (AddressInEra Era) Value -> Map (AddressInEra Era) Value)
-> Map (AddressInEra Era) Value
-> [Map (AddressInEra Era) Value]
-> Map (AddressInEra Era) Value
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Value -> Value -> Value)
-> Map (AddressInEra Era) Value
-> Map (AddressInEra Era) Value
-> Map (AddressInEra Era) Value
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
(<>)) Map (AddressInEra Era) Value
forall a. Monoid a => a
mempty ([Map (AddressInEra Era) Value] -> Map (AddressInEra Era) Value)
-> [Map (AddressInEra Era) Value] -> Map (AddressInEra Era) Value
forall a b. (a -> b) -> a -> b
$  (TxInState -> Map (AddressInEra Era) Value)
-> [TxInState] -> [Map (AddressInEra Era) Value]
forall a b. (a -> b) -> [a] -> [b]
map TxInState -> Map (AddressInEra Era) Value
txBalanceChanges [TxInState]
transactions
                                    [Map (AddressInEra Era) Value]
-> [Map (AddressInEra Era) Value] -> [Map (AddressInEra Era) Value]
forall a. [a] -> [a] -> [a]
++ (TxInState -> Map (AddressInEra Era) Value)
-> [TxInState] -> [Map (AddressInEra Era) Value]
forall a b. (a -> b) -> [a] -> [b]
map (FeeCalculation
computeFees NetworkId
networkId) [TxInState]
transactions

txBalanceChanges :: TxInState
                 -> Map (AddressInEra Era) Value
txBalanceChanges :: TxInState -> Map (AddressInEra Era) Value
txBalanceChanges (TxInState Tx Era
tx ChainState{UTxO Era
SlotNo
utxo :: UTxO Era
slot :: SlotNo
utxo :: ChainState -> UTxO Era
slot :: ChainState -> SlotNo
..} Bool
accepted)
  | Bool
accepted = (Value -> Value -> Value)
-> [Map (AddressInEra Era) Value] -> Map (AddressInEra Era) Value
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
(<>) ([Map (AddressInEra Era) Value] -> Map (AddressInEra Era) Value)
-> [Map (AddressInEra Era) Value] -> Map (AddressInEra Era) Value
forall a b. (a -> b) -> a -> b
$ [ AddressInEra Era -> Value -> Map (AddressInEra Era) Value
forall k a. k -> a -> Map k a
Map.singleton AddressInEra Era
a (TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
v)
                                     | TxOut AddressInEra Era
a TxOutValue Era
v TxOutDatum CtxTx Era
_ ReferenceScript Era
_ <- Tx Era -> [TxOut CtxTx Era]
getTxOuts Tx Era
tx
                                     ] [Map (AddressInEra Era) Value]
-> [Map (AddressInEra Era) Value] -> [Map (AddressInEra Era) Value]
forall a. [a] -> [a] -> [a]
++
                                     [ AddressInEra Era -> Value -> Map (AddressInEra Era) Value
forall k a. k -> a -> Map k a
Map.singleton AddressInEra Era
a (Value -> Value
negateValue (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
v)
                                     | TxOut AddressInEra Era
a TxOutValue Era
v TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_ <- Tx Era -> UTxO Era -> [TxOut CtxUTxO Era]
getTxInputs Tx Era
tx UTxO Era
utxo
                                     ]
  | Bool
otherwise = [Char] -> Map (AddressInEra Era) Value
forall a. HasCallStack => [Char] -> a
error [Char]
"TODO txBalanceChanges when removing collateral"

instance (Monad m, HasChainIndex m) => HasChainIndex (StateT s m) where
  getChainIndex :: StateT s m ChainIndex
getChainIndex = m ChainIndex -> StateT s m ChainIndex
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ChainIndex -> StateT s m ChainIndex)
-> m ChainIndex -> StateT s m ChainIndex
forall a b. (a -> b) -> a -> b
$ m ChainIndex
forall (m :: * -> *). HasChainIndex m => m ChainIndex
getChainIndex
  getChainState :: StateT s m ChainState
getChainState = m ChainState -> StateT s m ChainState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ChainState -> StateT s m ChainState)
-> m ChainState -> StateT s m ChainState
forall a b. (a -> b) -> a -> b
$ m ChainState
forall (m :: * -> *). HasChainIndex m => m ChainState
getChainState

instance (Monad m, HasChainIndex m) => HasChainIndex (ReaderT r m) where
  getChainIndex :: ReaderT r m ChainIndex
getChainIndex = m ChainIndex -> ReaderT r m ChainIndex
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ChainIndex -> ReaderT r m ChainIndex)
-> m ChainIndex -> ReaderT r m ChainIndex
forall a b. (a -> b) -> a -> b
$ m ChainIndex
forall (m :: * -> *). HasChainIndex m => m ChainIndex
getChainIndex
  getChainState :: ReaderT r m ChainState
getChainState = m ChainState -> ReaderT r m ChainState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ChainState -> ReaderT r m ChainState)
-> m ChainState -> ReaderT r m ChainState
forall a b. (a -> b) -> a -> b
$ m ChainState
forall (m :: * -> *). HasChainIndex m => m ChainState
getChainState

instance (Monad m, Monoid w, HasChainIndex m) => HasChainIndex (WriterT w m) where
  getChainIndex :: WriterT w m ChainIndex
getChainIndex = m ChainIndex -> WriterT w m ChainIndex
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ChainIndex -> WriterT w m ChainIndex)
-> m ChainIndex -> WriterT w m ChainIndex
forall a b. (a -> b) -> a -> b
$ m ChainIndex
forall (m :: * -> *). HasChainIndex m => m ChainIndex
getChainIndex
  getChainState :: WriterT w m ChainState
getChainState = m ChainState -> WriterT w m ChainState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ChainState -> WriterT w m ChainState)
-> m ChainState -> WriterT w m ChainState
forall a b. (a -> b) -> a -> b
$ m ChainState
forall (m :: * -> *). HasChainIndex m => m ChainState
getChainState