{-# OPTIONS_GHC -Wno-orphans #-}

-- | A simplistic type of transactions useful for modelling purpose.
-- a `Payment` is a simple transaction type that moves some amount of ADAs between
-- to `CardanoSigningKey`.
module Hydra.Model.Payment where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (Any, label)

import Data.List qualified as List
import Data.Set ((\\))
import Data.Set qualified as Set
import Hydra.Tx.IsTx (IsTx (..))
import Test.Hydra.Tx.Fixture (testNetworkId)
import Test.Hydra.Tx.Gen (genKeyPair)
import Test.QuickCheck (choose)
import Test.QuickCheck.StateModel (HasVariables)
import Test.QuickCheck.StateModel.Variables (HasVariables (..))
import Prelude qualified

-- NOTE: New type wrapper to add Ord and Eq instances to signing keys
newtype CardanoSigningKey = CardanoSigningKey {CardanoSigningKey -> SigningKey PaymentKey
signingKey :: SigningKey PaymentKey}

instance Show CardanoSigningKey where
  show :: CardanoSigningKey -> String
show CardanoSigningKey{SigningKey PaymentKey
$sel:signingKey:CardanoSigningKey :: CardanoSigningKey -> SigningKey PaymentKey
signingKey :: SigningKey PaymentKey
signingKey} =
    AddressInEra Era -> String
forall b a. (Show a, IsString b) => a -> b
show (AddressInEra Era -> String)
-> (SigningKey PaymentKey -> AddressInEra Era)
-> SigningKey PaymentKey
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress @Era NetworkId
testNetworkId (VerificationKey PaymentKey -> AddressInEra Era)
-> (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> SigningKey PaymentKey
-> AddressInEra Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> String)
-> SigningKey PaymentKey -> String
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey
signingKey

instance Eq CardanoSigningKey where
  CardanoSigningKey SigningKey PaymentKey
ska == :: CardanoSigningKey -> CardanoSigningKey -> Bool
== CardanoSigningKey SigningKey PaymentKey
skb =
    VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
ska) Hash PaymentKey -> Hash PaymentKey -> Bool
forall a. Eq a => a -> a -> Bool
== VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
skb)

instance Ord CardanoSigningKey where
  CardanoSigningKey SigningKey PaymentKey
a <= :: CardanoSigningKey -> CardanoSigningKey -> Bool
<= CardanoSigningKey SigningKey PaymentKey
b = SigningKey PaymentKey -> Hash PaymentKey
hashOf SigningKey PaymentKey
a Hash PaymentKey -> Hash PaymentKey -> Bool
forall a. Ord a => a -> a -> Bool
<= SigningKey PaymentKey -> Hash PaymentKey
hashOf SigningKey PaymentKey
b
   where
    hashOf :: SigningKey PaymentKey -> Hash PaymentKey
hashOf = VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey PaymentKey -> Hash PaymentKey)
-> (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> SigningKey PaymentKey
-> Hash PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey

instance ToJSON CardanoSigningKey where
  toJSON :: CardanoSigningKey -> Value
toJSON = Text -> CardanoSigningKey -> Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance FromJSON CardanoSigningKey where
  parseJSON :: Value -> Parser CardanoSigningKey
parseJSON = Text -> Value -> Parser CardanoSigningKey
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance ToCBOR CardanoSigningKey where
  toCBOR :: CardanoSigningKey -> Encoding
toCBOR = Text -> CardanoSigningKey -> Encoding
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance FromCBOR CardanoSigningKey where
  fromCBOR :: forall s. Decoder s CardanoSigningKey
fromCBOR = Text -> Decoder s CardanoSigningKey
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance Arbitrary CardanoSigningKey where
  arbitrary :: Gen CardanoSigningKey
arbitrary = SigningKey PaymentKey -> CardanoSigningKey
CardanoSigningKey (SigningKey PaymentKey -> CardanoSigningKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey)
    -> SigningKey PaymentKey)
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> CardanoSigningKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VerificationKey PaymentKey, SigningKey PaymentKey)
-> SigningKey PaymentKey
forall a b. (a, b) -> b
snd ((VerificationKey PaymentKey, SigningKey PaymentKey)
 -> CardanoSigningKey)
-> Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> Gen CardanoSigningKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair

-- | A single Ada-payment only transaction in our model.
data Payment = Payment
  { Payment -> CardanoSigningKey
from :: CardanoSigningKey
  , Payment -> CardanoSigningKey
to :: CardanoSigningKey
  , Payment -> Value
value :: Value
  }
  deriving stock (Payment -> Payment -> Bool
(Payment -> Payment -> Bool)
-> (Payment -> Payment -> Bool) -> Eq Payment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Payment -> Payment -> Bool
== :: Payment -> Payment -> Bool
$c/= :: Payment -> Payment -> Bool
/= :: Payment -> Payment -> Bool
Eq, (forall x. Payment -> Rep Payment x)
-> (forall x. Rep Payment x -> Payment) -> Generic Payment
forall x. Rep Payment x -> Payment
forall x. Payment -> Rep Payment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Payment -> Rep Payment x
from :: forall x. Payment -> Rep Payment x
$cto :: forall x. Rep Payment x -> Payment
to :: forall x. Rep Payment x -> Payment
Generic)
  deriving anyclass ([Payment] -> Value
[Payment] -> Encoding
Payment -> Bool
Payment -> Value
Payment -> Encoding
(Payment -> Value)
-> (Payment -> Encoding)
-> ([Payment] -> Value)
-> ([Payment] -> Encoding)
-> (Payment -> Bool)
-> ToJSON Payment
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Payment -> Value
toJSON :: Payment -> Value
$ctoEncoding :: Payment -> Encoding
toEncoding :: Payment -> Encoding
$ctoJSONList :: [Payment] -> Value
toJSONList :: [Payment] -> Value
$ctoEncodingList :: [Payment] -> Encoding
toEncodingList :: [Payment] -> Encoding
$comitField :: Payment -> Bool
omitField :: Payment -> Bool
ToJSON, Maybe Payment
Value -> Parser [Payment]
Value -> Parser Payment
(Value -> Parser Payment)
-> (Value -> Parser [Payment]) -> Maybe Payment -> FromJSON Payment
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Payment
parseJSON :: Value -> Parser Payment
$cparseJSONList :: Value -> Parser [Payment]
parseJSONList :: Value -> Parser [Payment]
$comittedField :: Maybe Payment
omittedField :: Maybe Payment
FromJSON)

instance Show Payment where
  -- NOTE: We display derived addresses instead of raw signing keys in order to help troubleshooting
  -- tests failures or errors.
  show :: Payment -> String
show Payment{CardanoSigningKey
$sel:from:Payment :: Payment -> CardanoSigningKey
from :: CardanoSigningKey
from, CardanoSigningKey
$sel:to:Payment :: Payment -> CardanoSigningKey
to :: CardanoSigningKey
to, Value
$sel:value:Payment :: Payment -> Value
value :: Value
value} =
    String
"Payment { from = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CardanoSigningKey -> String
forall b a. (Show a, IsString b) => a -> b
show CardanoSigningKey
from
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", to = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CardanoSigningKey -> String
forall b a. (Show a, IsString b) => a -> b
show CardanoSigningKey
to
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", value = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall b a. (Show a, IsString b) => a -> b
show Value
value
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" }"

instance Arbitrary Payment where
  arbitrary :: Gen Payment
arbitrary = Text -> Gen Payment
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance ToCBOR Payment where
  toCBOR :: Payment -> Encoding
toCBOR = Text -> Payment -> Encoding
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance FromCBOR Payment where
  fromCBOR :: forall s. Decoder s Payment
fromCBOR = Text -> Decoder s Payment
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance HasVariables Payment where
  getAllVariables :: Payment -> Set (Any Var)
getAllVariables Payment
_ = Set (Any Var)
forall a. Monoid a => a
mempty

-- | Making `Payment` an instance of `IsTx` allows us to use it with `HeadLogic'`s messages.
instance IsTx Payment where
  type TxIdType Payment = Int
  type TxOutType Payment = (CardanoSigningKey, Value)
  type UTxOType Payment = [(CardanoSigningKey, Value)]
  type ValueType Payment = Value
  txId :: Payment -> TxIdType Payment
txId = Text -> Payment -> Int
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"undefined"
  balance :: UTxOType Payment -> ValueType Payment
balance = ((CardanoSigningKey, Value) -> Value)
-> [(CardanoSigningKey, Value)] -> Value
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CardanoSigningKey, Value) -> Value
forall a b. (a, b) -> b
snd
  hashUTxO :: UTxOType Payment -> ByteString
hashUTxO = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString)
-> ([(CardanoSigningKey, Value)] -> Text)
-> [(CardanoSigningKey, Value)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show @Text
  txSpendingUTxO :: UTxOType Payment -> Payment
txSpendingUTxO = \case
    [] -> Text -> Payment
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"nothing to spend spending"
    [(CardanoSigningKey
from, Value
value)] -> Payment{CardanoSigningKey
$sel:from:Payment :: CardanoSigningKey
from :: CardanoSigningKey
from, $sel:to:Payment :: CardanoSigningKey
to = CardanoSigningKey
from, Value
$sel:value:Payment :: Value
value :: Value
value}
    UTxOType Payment
_ -> Text -> Payment
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"cant spend from multiple utxo in one payment"
  utxoFromTx :: Payment -> UTxOType Payment
utxoFromTx Payment{CardanoSigningKey
$sel:to:Payment :: Payment -> CardanoSigningKey
to :: CardanoSigningKey
to, Value
$sel:value:Payment :: Payment -> Value
value :: Value
value} = [(CardanoSigningKey
to, Value
value)]
  outputsOfUTxO :: UTxOType Payment -> [TxOutType Payment]
outputsOfUTxO = [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
UTxOType Payment -> [TxOutType Payment]
forall a. a -> a
id
  withoutUTxO :: UTxOType Payment -> UTxOType Payment -> UTxOType Payment
withoutUTxO UTxOType Payment
a UTxOType Payment
b =
    let as :: [(CardanoSigningKey, [(AssetId, Quantity)])]
as = (Value -> [(AssetId, Quantity)])
-> (CardanoSigningKey, Value)
-> (CardanoSigningKey, [(AssetId, Quantity)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Value -> [(AssetId, Quantity)]
valueToList ((CardanoSigningKey, Value)
 -> (CardanoSigningKey, [(AssetId, Quantity)]))
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, [(AssetId, Quantity)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
UTxOType Payment
a
        bs :: [(CardanoSigningKey, [(AssetId, Quantity)])]
bs = (Value -> [(AssetId, Quantity)])
-> (CardanoSigningKey, Value)
-> (CardanoSigningKey, [(AssetId, Quantity)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Value -> [(AssetId, Quantity)]
valueToList ((CardanoSigningKey, Value)
 -> (CardanoSigningKey, [(AssetId, Quantity)]))
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, [(AssetId, Quantity)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
UTxOType Payment
b
        result :: [(CardanoSigningKey, [(AssetId, Quantity)])]
result = Set (CardanoSigningKey, [(AssetId, Quantity)])
-> [(CardanoSigningKey, [(AssetId, Quantity)])]
forall a. Set a -> [a]
Set.toList (Set (CardanoSigningKey, [(AssetId, Quantity)])
 -> [(CardanoSigningKey, [(AssetId, Quantity)])])
-> Set (CardanoSigningKey, [(AssetId, Quantity)])
-> [(CardanoSigningKey, [(AssetId, Quantity)])]
forall a b. (a -> b) -> a -> b
$ [(CardanoSigningKey, [(AssetId, Quantity)])]
-> Set (CardanoSigningKey, [(AssetId, Quantity)])
forall a. Ord a => [a] -> Set a
Set.fromList [(CardanoSigningKey, [(AssetId, Quantity)])]
as Set (CardanoSigningKey, [(AssetId, Quantity)])
-> Set (CardanoSigningKey, [(AssetId, Quantity)])
-> Set (CardanoSigningKey, [(AssetId, Quantity)])
forall a. Ord a => Set a -> Set a -> Set a
\\ [(CardanoSigningKey, [(AssetId, Quantity)])]
-> Set (CardanoSigningKey, [(AssetId, Quantity)])
forall a. Ord a => [a] -> Set a
Set.fromList [(CardanoSigningKey, [(AssetId, Quantity)])]
bs
     in ([(AssetId, Quantity)] -> Value)
-> (CardanoSigningKey, [(AssetId, Quantity)])
-> (CardanoSigningKey, Value)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [(AssetId, Quantity)] -> Value
valueFromList ((CardanoSigningKey, [(AssetId, Quantity)])
 -> (CardanoSigningKey, Value))
-> [(CardanoSigningKey, [(AssetId, Quantity)])]
-> [(CardanoSigningKey, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, [(AssetId, Quantity)])]
result

applyTx :: UTxOType Payment -> Payment -> UTxOType Payment
applyTx :: UTxOType Payment -> Payment -> UTxOType Payment
applyTx UTxOType Payment
utxo Payment{CardanoSigningKey
$sel:from:Payment :: Payment -> CardanoSigningKey
from :: CardanoSigningKey
from, CardanoSigningKey
$sel:to:Payment :: Payment -> CardanoSigningKey
to :: CardanoSigningKey
to, Value
$sel:value:Payment :: Payment -> Value
value :: Value
value} =
  (CardanoSigningKey
to, Value
value) (CardanoSigningKey, Value)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. a -> [a] -> [a]
: (CardanoSigningKey, Value)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. Eq a => a -> [a] -> [a]
List.delete (CardanoSigningKey
from, Value
value) [(CardanoSigningKey, Value)]
UTxOType Payment
utxo

genAdaValue :: Gen Value
genAdaValue :: Gen Value
genAdaValue = Coin -> Value
lovelaceToValue (Coin -> Value) -> (Integer -> Coin) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
forall a. Num a => Integer -> a
fromInteger (Integer -> Value) -> Gen Integer -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
minimumUTxOAda, Integer
10000000000)
 where
  -- NOTE: this should probably be retrieved from some authoritative source?
  minimumUTxOAda :: Integer
minimumUTxOAda = Integer
1000000

-- * Orphans
instance Arbitrary Value where
  arbitrary :: Gen Value
arbitrary = Gen Value
genAdaValue

instance ToCBOR Value where
  toCBOR :: Value -> Encoding
toCBOR = Text -> Value -> Encoding
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"

instance FromCBOR Value where
  fromCBOR :: forall s. Decoder s Value
fromCBOR = Text -> Decoder s Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"don't use"