{-# 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 hiding (CardanoSigningKey (..), getVerificationKey)
import Hydra.Prelude hiding (Any, label, toList)
import Test.Hydra.Prelude
import Text.Show qualified

import Data.List qualified as List
import Data.Set ((\\))
import Data.Set qualified as Set
import GHC.IsList (IsList (..))
import Hydra.Tx.Crypto (getVerificationKey)
import Hydra.Tx.IsTx (IsTx (..))
import Hydra.Tx.Secret (Secret, mkSecret)
import Test.Hydra.Tx.Gen (genKeyPair)
import Test.QuickCheck (choose)

-- | New type wrapper to add 'Ord' and 'Eq' instances to signing keys. The
-- inner 'SigningKey PaymentKey' is wrapped in 'Secret': the @signingKey@
-- field never exposes the raw key, mirroring the way Hydra signing keys
-- are handled. The accompanying 'ToJSON' / 'FromJSON' / 'ToCBOR' /
-- 'FromCBOR' bans are inherited from 'Secret'.
newtype CardanoSigningKey = CardanoSigningKey {CardanoSigningKey -> Secret (SigningKey PaymentKey)
signingKey :: Secret (SigningKey PaymentKey)}

instance Show CardanoSigningKey where
  show :: CardanoSigningKey -> String
show (CardanoSigningKey Secret (SigningKey PaymentKey)
sk) =
    String
"CardanoSigningKey " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Hash PaymentKey -> String
forall b a. (Show a, IsString b) => a -> b
show (VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk))

instance Eq CardanoSigningKey where
  CardanoSigningKey Secret (SigningKey PaymentKey)
ska == :: CardanoSigningKey -> CardanoSigningKey -> Bool
== CardanoSigningKey Secret (SigningKey PaymentKey)
skb =
    VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (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 (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
skb)

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

instance Arbitrary CardanoSigningKey where
  arbitrary :: Gen CardanoSigningKey
arbitrary = Secret (SigningKey PaymentKey) -> CardanoSigningKey
CardanoSigningKey (Secret (SigningKey PaymentKey) -> CardanoSigningKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey)
    -> Secret (SigningKey PaymentKey))
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> CardanoSigningKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret (SigningKey PaymentKey -> Secret (SigningKey PaymentKey))
-> ((VerificationKey PaymentKey, SigningKey PaymentKey)
    -> SigningKey PaymentKey)
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> Secret (SigningKey PaymentKey)
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

-- | 'CardanoSigningKey' wraps a 'Secret' internally, which makes any
-- JSON / CBOR access via the 'Secret' value a compile-time 'TypeError'.
-- 'IsTx Payment' below pulls in 'ToJSON' / 'FromJSON' / 'ToCBOR' /
-- 'FromCBOR' as superclasses of its transaction type, so we provide
-- placebo instances that error at runtime if accidentally called.
-- 'Payment' is purely a test-model type and is never serialised in
-- production.
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"

-- | 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 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 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
" }"

-- | 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
  txIdBytes :: TxIdType Payment -> ByteString
txIdBytes = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> (Int -> Text) -> Int -> 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, [Item Value])]
as = (Value -> [Item Value])
-> (CardanoSigningKey, Value) -> (CardanoSigningKey, [Item 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 Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList ((CardanoSigningKey, Value) -> (CardanoSigningKey, [Item Value]))
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, [Item Value])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
UTxOType Payment
a
        bs :: [(CardanoSigningKey, [Item Value])]
bs = (Value -> [Item Value])
-> (CardanoSigningKey, Value) -> (CardanoSigningKey, [Item 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 Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList ((CardanoSigningKey, Value) -> (CardanoSigningKey, [Item Value]))
-> [(CardanoSigningKey, Value)]
-> [(CardanoSigningKey, [Item Value])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, Value)]
UTxOType Payment
b
        result :: [(CardanoSigningKey, [Item Value])]
result = Set (CardanoSigningKey, [Item Value])
-> [(CardanoSigningKey, [Item Value])]
forall a. Set a -> [a]
Set.toList (Set (CardanoSigningKey, [Item Value])
 -> [(CardanoSigningKey, [Item Value])])
-> Set (CardanoSigningKey, [Item Value])
-> [(CardanoSigningKey, [Item Value])]
forall a b. (a -> b) -> a -> b
$ [(CardanoSigningKey, [Item Value])]
-> Set (CardanoSigningKey, [Item Value])
forall a. Ord a => [a] -> Set a
Set.fromList [(CardanoSigningKey, [Item Value])]
as Set (CardanoSigningKey, [Item Value])
-> Set (CardanoSigningKey, [Item Value])
-> Set (CardanoSigningKey, [Item Value])
forall a. Ord a => Set a -> Set a -> Set a
\\ [(CardanoSigningKey, [Item Value])]
-> Set (CardanoSigningKey, [Item Value])
forall a. Ord a => [a] -> Set a
Set.fromList [(CardanoSigningKey, [Item Value])]
bs
     in ([Item Value] -> Value)
-> (CardanoSigningKey, [Item Value]) -> (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 [Item Value] -> Value
forall l. IsList l => [Item l] -> l
fromList ((CardanoSigningKey, [Item Value]) -> (CardanoSigningKey, Value))
-> [(CardanoSigningKey, [Item Value])]
-> [(CardanoSigningKey, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CardanoSigningKey, [Item Value])]
result
  applyTxTo :: Payment -> UTxOType Payment -> UTxOType Payment
applyTxTo Payment
tx UTxOType Payment
utxo = UTxOType Payment -> Payment -> UTxOType Payment
applyTx UTxOType Payment
utxo Payment
tx
  filterUTxOByOutputs :: UTxOType Payment -> Set (TxOutType Payment) -> UTxOType Payment
filterUTxOByOutputs UTxOType Payment
utxo Set (TxOutType Payment)
outputs = ((CardanoSigningKey, Value) -> Bool)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxOutType Payment -> Set (TxOutType Payment) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (TxOutType Payment)
outputs) [(CardanoSigningKey, Value)]
UTxOType Payment
utxo
  removeOneOutputFromUTxO :: TxOutType Payment -> UTxOType Payment -> UTxOType Payment
removeOneOutputFromUTxO = (CardanoSigningKey, Value)
-> [(CardanoSigningKey, Value)] -> [(CardanoSigningKey, Value)]
TxOutType Payment -> UTxOType Payment -> UTxOType Payment
forall a. Eq a => a -> [a] -> [a]
List.delete
  utxoToElement :: TxOutType Payment -> ByteString
utxoToElement = 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

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 = Lovelace -> Value
lovelaceToValue (Lovelace -> Value) -> (Integer -> Lovelace) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lovelace
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

-- | Orphan 'Ord' instance for Cardano 'Value' using JSON encoding for comparison.
-- Needed to use '(CardanoSigningKey, Value)' as 'TxOutType Payment' in 'Set'.
instance Ord Value where
  compare :: Value -> Value -> Ordering
compare Value
x Value
y = Value -> Value -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
x) (Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
y)

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"