{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE ViewPatterns       #-}
{-| Primitive wallet
-}
module Convex.Wallet(
  Wallet(..),
  paymentCredential,
  verificationKeyHash,
  shelleyPaymentCredential,
  address,
  addressInEra,
  privateKey,
  generateWallet,
  parse,
  signTx,
  addSignature,
  addSignatureExtended,
  -- * UTxOs and coin selection
  selectAdaInputsCovering,
  selectAnyInputsCovering,
  selectMixedInputsCovering
) where

import           Cardano.Api               (Address, AddressInEra,
                                            IsShelleyBasedEra, NetworkId,
                                            PaymentCredential,
                                            PaymentExtendedKey, PaymentKey,
                                            ShelleyAddr, SigningKey)
import qualified Cardano.Api               as C
import qualified Cardano.Ledger.Credential as Shelley
import           Cardano.Ledger.Crypto     (StandardCrypto)
import           Control.Lens              (_2, preview, view)
import qualified Convex.Lenses             as L
import           Convex.Utxos              (UtxoSet (..), onlyAda)
import           Data.Aeson                (FromJSON (..), ToJSON (..), object,
                                            withObject, (.:), (.=))
import           Data.Bifunctor            (Bifunctor (..))
import           Data.List                 (find)
import qualified Data.Map.Strict           as Map
import           Data.Maybe                (fromMaybe, mapMaybe)
import qualified Data.Set                  as Set
import           Data.Text                 (Text)
import qualified Data.Text                 as Text

newtype Wallet = Wallet { Wallet -> SigningKey PaymentKey
getWallet :: SigningKey PaymentKey }

instance ToJSON Wallet where
  toJSON :: Wallet -> Value
toJSON Wallet
k = [Pair] -> Value
object [Key
"private_key" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Wallet -> Text
privateKey Wallet
k]

instance FromJSON Wallet where
  parseJSON :: Value -> Parser Wallet
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Wallet" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Text
x <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"private_key"
    case Text -> Either Bech32DecodeError Wallet
parse Text
x of
      Right Wallet
pk -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Wallet
pk
      Left Bech32DecodeError
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"failed to parse 'private_key': " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Bech32DecodeError
err

instance Show Wallet where
  show :: Wallet -> String
show = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wallet -> Text
privateKey

{-| The wallet's payment credential (public key)
-}
paymentCredential :: Wallet -> PaymentCredential
paymentCredential :: Wallet -> PaymentCredential
paymentCredential = Hash PaymentKey -> PaymentCredential
C.PaymentCredentialByKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wallet -> Hash PaymentKey
verificationKeyHash

{-| Verification key hash of the wallet
-}
verificationKeyHash :: Wallet -> C.Hash C.PaymentKey
verificationKeyHash :: Wallet -> Hash PaymentKey
verificationKeyHash = forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
C.verificationKeyHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall keyrole.
Key keyrole =>
SigningKey keyrole -> VerificationKey keyrole
C.getVerificationKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wallet -> SigningKey PaymentKey
getWallet

shelleyPaymentCredential :: Wallet -> Shelley.PaymentCredential StandardCrypto
shelleyPaymentCredential :: Wallet -> PaymentCredential StandardCrypto
shelleyPaymentCredential =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"shelleyPaymentCredential: Expected ShelleyAddress in babbage era")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Prism' (AddressInEra BabbageEra) (Address ShelleyAddr)
L._AddressInEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso'
  (Address ShelleyAddr)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._Address forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
IsShelleyBasedEra era =>
NetworkId -> Wallet -> AddressInEra era
addressInEra NetworkId
C.Mainnet

{-| Sign the transaction body with the signing key and attach the signature
to the transaction
-}
addSignature :: IsShelleyBasedEra era => SigningKey PaymentKey -> C.Tx era -> C.Tx era
addSignature :: forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
addSignature (SigningKey PaymentKey -> ShelleyWitnessSigningKey
C.WitnessPaymentKey -> ShelleyWitnessSigningKey
key) Tx era
tx =
  let C.Tx TxBody era
body [KeyWitness era]
wits = Tx era
tx
      wit :: [KeyWitness era]
wit = (forall era.
IsShelleyBasedEra era =>
TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
C.makeShelleyKeyWitness TxBody era
body ShelleyWitnessSigningKey
key) forall a. a -> [a] -> [a]
: [KeyWitness era]
wits
      stx :: Tx era
stx = forall era. [KeyWitness era] -> TxBody era -> Tx era
C.makeSignedTransaction [KeyWitness era]
wit TxBody era
body
  in Tx era
stx

{-| Sign the transaction body with the extended signing key and attach the signature
to the transaction
-}
addSignatureExtended :: IsShelleyBasedEra era => SigningKey PaymentExtendedKey -> C.Tx era -> C.Tx era
addSignatureExtended :: forall era.
IsShelleyBasedEra era =>
SigningKey PaymentExtendedKey -> Tx era -> Tx era
addSignatureExtended (SigningKey PaymentExtendedKey -> ShelleyWitnessSigningKey
C.WitnessPaymentExtendedKey -> ShelleyWitnessSigningKey
key) Tx era
tx =
  let C.Tx TxBody era
body [KeyWitness era]
wits = Tx era
tx
      wit :: [KeyWitness era]
wit = (forall era.
IsShelleyBasedEra era =>
TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
C.makeShelleyKeyWitness TxBody era
body ShelleyWitnessSigningKey
key) forall a. a -> [a] -> [a]
: [KeyWitness era]
wits
      stx :: Tx era
stx = forall era. [KeyWitness era] -> TxBody era -> Tx era
C.makeSignedTransaction [KeyWitness era]
wit TxBody era
body
  in Tx era
stx

{-| Add the wallet's signature to the signatures of the transaction
-}
signTx :: IsShelleyBasedEra era => Wallet -> C.Tx era -> C.Tx era
signTx :: forall era. IsShelleyBasedEra era => Wallet -> Tx era -> Tx era
signTx Wallet{SigningKey PaymentKey
getWallet :: SigningKey PaymentKey
getWallet :: Wallet -> SigningKey PaymentKey
getWallet} = forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
addSignature SigningKey PaymentKey
getWallet

{-| The address of the wallet
-}
address :: NetworkId -> Wallet -> Address ShelleyAddr
address :: NetworkId -> Wallet -> Address ShelleyAddr
address NetworkId
networkId Wallet
wallet =
  NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
C.makeShelleyAddress NetworkId
networkId (Wallet -> PaymentCredential
paymentCredential Wallet
wallet) StakeAddressReference
C.NoStakeAddress

addressInEra :: IsShelleyBasedEra era => NetworkId -> Wallet -> AddressInEra era
addressInEra :: forall era.
IsShelleyBasedEra era =>
NetworkId -> Wallet -> AddressInEra era
addressInEra NetworkId
networkId Wallet
wallet =
  forall era.
IsShelleyBasedEra era =>
NetworkId
-> PaymentCredential -> StakeAddressReference -> AddressInEra era
C.makeShelleyAddressInEra NetworkId
networkId (Wallet -> PaymentCredential
paymentCredential Wallet
wallet) StakeAddressReference
C.NoStakeAddress

{-| The wallet's private key (serialised)
-}
privateKey :: Wallet -> Text
privateKey :: Wallet -> Text
privateKey Wallet{SigningKey PaymentKey
getWallet :: SigningKey PaymentKey
getWallet :: Wallet -> SigningKey PaymentKey
getWallet} = forall a. SerialiseAsBech32 a => a -> Text
C.serialiseToBech32 SigningKey PaymentKey
getWallet

generateWallet :: IO Wallet
generateWallet :: IO Wallet
generateWallet = SigningKey PaymentKey -> Wallet
Wallet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall keyrole.
Key keyrole =>
AsType keyrole -> IO (SigningKey keyrole)
C.generateSigningKey AsType PaymentKey
C.AsPaymentKey

parse :: Text -> Either C.Bech32DecodeError Wallet
parse :: Text -> Either Bech32DecodeError Wallet
parse = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SigningKey PaymentKey -> Wallet
Wallet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
SerialiseAsBech32 a =>
AsType a -> Text -> Either Bech32DecodeError a
C.deserialiseFromBech32 (forall a. AsType a -> AsType (SigningKey a)
C.AsSigningKey AsType PaymentKey
C.AsPaymentKey)

{-| Select Ada-only inputs that cover the given amount of lovelace
-}
selectAdaInputsCovering :: UtxoSet ctx a -> C.Lovelace -> Maybe (C.Lovelace, [C.TxIn])
selectAdaInputsCovering :: forall ctx a. UtxoSet ctx a -> Lovelace -> Maybe (Lovelace, [TxIn])
selectAdaInputsCovering UtxoSet ctx a
utxoSet Lovelace
target = forall ctx a. UtxoSet ctx a -> Lovelace -> Maybe (Lovelace, [TxIn])
selectAnyInputsCovering (forall ctx a. UtxoSet ctx a -> UtxoSet ctx a
onlyAda UtxoSet ctx a
utxoSet) Lovelace
target

{-| Select Ada-only inputs that cover the given amount of lovelace
-}
selectAnyInputsCovering :: UtxoSet ctx a -> C.Lovelace -> Maybe (C.Lovelace, [C.TxIn])
selectAnyInputsCovering :: forall ctx a. UtxoSet ctx a -> Lovelace -> Maybe (Lovelace, [TxIn])
selectAnyInputsCovering UtxoSet{Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: Map TxIn (TxOut ctx BabbageEra, a)
_utxos} (C.Lovelace Integer
target) =
  let append :: (Lovelace, [a]) -> (a, TxOut ctx BabbageEra) -> (Lovelace, [a])
append (C.Lovelace Integer
total_, [a]
txIns) (a
txIn, Value -> Lovelace
C.selectLovelace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue) -> C.Lovelace Integer
coin_) = (Integer -> Lovelace
C.Lovelace (Integer
total_ forall a. Num a => a -> a -> a
+ Integer
coin_), a
txIn forall a. a -> [a] -> [a]
: [a]
txIns) in
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(C.Lovelace Integer
c, [TxIn]
_) -> Integer
c forall a. Ord a => a -> a -> Bool
>= Integer
target)
  forall a b. (a -> b) -> a -> b
$ forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall {a} {ctx}.
(Lovelace, [a]) -> (a, TxOut ctx BabbageEra) -> (Lovelace, [a])
append (Integer -> Lovelace
C.Lovelace Integer
0, [])
  forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a, b) -> a
fst)
  forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map TxIn (TxOut ctx BabbageEra, a)
_utxos

{-| Select inputs that cover the given amount of non-Ada
assets.
-}
selectMixedInputsCovering :: UtxoSet ctx a -> [(C.PolicyId, C.AssetName, C.Quantity)] -> Maybe (C.Value, [C.TxIn])
selectMixedInputsCovering :: forall ctx a.
UtxoSet ctx a
-> [(PolicyId, AssetName, Quantity)] -> Maybe (Value, [TxIn])
selectMixedInputsCovering UtxoSet{Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos} [(PolicyId, AssetName, Quantity)]
xs =
  let append :: (a, [a]) -> (a, a) -> (a, [a])
append (a
vl, [a]
txIns) (a
vl', a
txIn) = (a
vl forall a. Semigroup a => a -> a -> a
<> a
vl', a
txIn forall a. a -> [a] -> [a]
: [a]
txIns)
      coversTarget :: (Value, b) -> Bool
coversTarget (Value
candidateVl, b
_txIns) =
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(PolicyId
policyId, AssetName
assetName, Quantity
quantity) -> Value -> AssetId -> Quantity
C.selectAsset Value
candidateVl (PolicyId -> AssetName -> AssetId
C.AssetId PolicyId
policyId AssetName
assetName) forall a. Ord a => a -> a -> Bool
>= Quantity
quantity) [(PolicyId, AssetName, Quantity)]
xs
      requiredAssets :: Set (PolicyId, AssetName)
requiredAssets = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(PolicyId
p, AssetName
a, Quantity
_) -> forall a. a -> Set a
Set.singleton (PolicyId
p, AssetName
a)) [(PolicyId, AssetName, Quantity)]
xs
      nonAdaAssets :: AssetId -> Set (PolicyId, AssetName)
nonAdaAssets = \case
        AssetId
C.AdaAssetId  -> forall a. Set a
Set.empty
        C.AssetId PolicyId
p AssetName
n -> forall a. a -> Set a
Set.singleton (PolicyId
p, AssetName
n)
      relevantValue :: (b, TxOut ctx BabbageEra) -> Maybe (Value, b)
relevantValue (b
txIn, forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue) -> Value
txOutValue) =
        let providedAssets :: Set (PolicyId, AssetName)
providedAssets = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (AssetId -> Set (PolicyId, AssetName)
nonAdaAssets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (Value -> [(AssetId, Quantity)]
C.valueToList Value
txOutValue)
        in if forall a. Set a -> Bool
Set.null (forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set (PolicyId, AssetName)
requiredAssets Set (PolicyId, AssetName)
providedAssets)
          then forall a. Maybe a
Nothing
          else forall a. a -> Maybe a
Just (Value
txOutValue, b
txIn)
  in
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find forall {b}. (Value, b) -> Bool
coversTarget
    forall a b. (a -> b) -> a -> b
$ forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall {a} {a}. Semigroup a => (a, [a]) -> (a, a) -> (a, [a])
append (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b} {ctx}. (b, TxOut ctx BabbageEra) -> Maybe (Value, b)
relevantValue
    forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a, b) -> a
fst)
    forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map TxIn (TxOut ctx BabbageEra, a)
_utxos