WIP

lib/core/src/Cardano/Wallet.hs

@@ -80,6 +80,8 @@ module Cardano.Wallet
     , readRewardAccount
     , someRewardAccount
     , queryRewardBalance
+    , guardSoftIndex
+    , guardHardIndex
     , ErrWalletAlreadyExists (..)
     , ErrNoSuchWallet (..)
     , ErrListUTxOStatistics (..)

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -110,6 +110,7 @@ module Cardano.Wallet.Api.Server
 
 import Prelude
 
+import Cardano.Address.Script (KeyHash, Script(RequireSignatureOf))
 import Cardano.Address.Derivation
     ( XPrv, XPub, xpubPublicKey, xpubToBytes )
 import Cardano.Address.Script
@@ -268,6 +269,8 @@ import Cardano.Wallet.Primitive.AddressDerivation
     ( DelegationAddress (..)
     , Depth (..)
     , DerivationIndex (..)
+    , hashVerificationKey
+    , deriveVerificationKey
     , DerivationType (..)
     , HardDerivation (..)
     , Index (..)
@@ -276,7 +279,7 @@ import Cardano.Wallet.Primitive.AddressDerivation
     , Passphrase (..)
     , PaymentAddress (..)
     , RewardAccount (..)
-    , Role
+    , Role(MultisigScript)
     , SoftDerivation (..)
     , WalletKey (..)
     , deriveRewardAccount
@@ -290,6 +293,7 @@ import Cardano.Wallet.Primitive.AddressDerivation.Icarus
     ( IcarusKey )
 import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( ShelleyKey )
+import Cardano.Wallet.Primitive.AddressDiscovery.Script (keyHashFromAccXPubIx)
 import Cardano.Wallet.Primitive.AddressDiscovery
     ( CompareDiscovery
     , GenChange (ArgGenChange)
@@ -372,8 +376,9 @@ import Cardano.Wallet.Primitive.Types.TokenBundle
     ( Flat (..), TokenBundle (..) )
 import Cardano.Wallet.Primitive.Types.TokenMap
     ( AssetId (..) )
+import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
 import Cardano.Wallet.Primitive.Types.TokenPolicy
-    ( TokenName (..), TokenPolicyId (..), nullTokenName )
+    ( TokenName (..), TokenPolicyId (..), nullTokenName, tokenPolicyIdFromScript )
 import Cardano.Wallet.Primitive.Types.Tx
     ( TransactionInfo (TransactionInfo)
     , Tx (..)
@@ -391,6 +396,7 @@ import Cardano.Wallet.Registry
     , defaultWorkerAfter
     , workerResource
     )
+import Cardano.Wallet.Primitive.Types.TokenQuantity (TokenQuantity(TokenQuantity))
 import Cardano.Wallet.TokenMetadata
     ( TokenMetadataClient, fillMetadata )
 import Cardano.Wallet.Transaction
@@ -421,6 +427,7 @@ import Control.Tracer
     ( Tracer, contramap )
 import Data.Aeson
     ( (.=) )
+import Data.String (fromString)
 import Data.ByteString
     ( ByteString )
 import Data.Coerce
@@ -467,7 +474,6 @@ import Fmt
     ( blockListF, indentF, pretty )
 import GHC.Stack
     ( HasCallStack )
-import Cardano.Wallet.Api.Types (AddressForgeAmount(AddressForgeAmount))
 import Network.HTTP.Media.RenderHeader
     ( renderHeader )
 import Network.HTTP.Types.Header
@@ -520,6 +526,7 @@ import UnliftIO.Concurrent
 import UnliftIO.Exception
     ( IOException, bracket, throwIO, tryAnyDeep, tryJust )
 
+import qualified Cardano.Api.Typed as Cardano
 import qualified Cardano.Wallet as W
 import qualified Cardano.Wallet.Api.Types as Api
 import qualified Cardano.Wallet.Network as NW
@@ -3314,14 +3321,17 @@ instance HasSeverityAnnotation WalletEngineLog where
 forgeToken
     :: forall ctx s k n.
         ( ctx ~ ApiLayer s k
+        , s ~ SeqState n k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+        , WalletKey k
         , GenChange s
         , HardDerivation k
+        , SoftDerivation k
         , HasNetworkLayer ctx
         , IsOwned s k
         , Typeable n
         , Typeable s
-        , WalletKey k
+        , PaymentAddress n k
         )
     => ctx
     -> ArgGenChange s
@@ -3330,25 +3340,55 @@ forgeToken
     -> Handler (ApiTransaction n)
 forgeToken ctx genChange (ApiT wid) body = do
     let pwd = coerce $ body ^. #passphrase . #getApiT
-    let forgePayments = fmap (\(AddressForgeAmount (ApiT addr, _) amt) -> AddressForgeAmount addr amt) $ body ^. #forgePayments
-    -- let outs = (\(AddressForgeAmount addr (Quantity amt) -> TxOut addr (fromFlatList (Coin 0) [()])) <$> forgePayments
-    let outs = undefined
-    let forgeAssetName = (\(UnsafeTokenName name) -> AssetName name) $ body ^. #assetName . #getApiT
+    let assetName = body ^. #assetName . #getApiT
+    let assetQty = (\(Quantity nat) -> TokenQuantity nat) $ body ^. #mintAmount
+    let derivationIndex = fromMaybe (DerivationIndex 0) $ fmap getApiT $ body ^. #monetaryPolicyPath
     let md = body ^? #metadata . traverse . #getApiT
     let mTTL = body ^? #timeToLive . traverse . #getQuantity
 
     (wdrl, mkRwdAcct) <-
         mkRewardAccountBuilder @_ @s @_ @n ctx wid Nothing
 
     ttl <- liftIO $ W.getTxExpiry ti mTTL
-    let txCtx = defaultTransactionCtx
-            { txWithdrawal = wdrl
-            , txMetadata = md
-            , txTimeToLive = ttl
-            , txForgeAmount = Just (forgeAssetName, forgePayments)
-            }
 
     (sel, tx, txMeta, txTime) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+        -- In the HD-wallet, monetary policies are associated with
+        -- address indices under the account type "3" (MultiSigScript).
+        -- Each address index stores the key associated with a single
+        -- monetary policy.
+        --
+        -- e.g. m/1852(purpose)​/​1815(coin_type)/0(account)​/3/0 -> monetary policy 1
+        --      m/1852(purpose)​/​1815(coin_type)/0(account)​/3/1 -> monetary policy 2
+
+        -- Get the public key of the monetary policy
+        addrXPub <- liftHandler $ W.derivePublicKey @_ @s @k @n wrk wid MultisigScript derivationIndex
+
+        -- Use that public key to generate a monetary policy
+        let
+          keyHash :: KeyHash
+          keyHash = hashVerificationKey @k (liftRawKey . getRawKey $ addrXPub)
+
+          script :: Script KeyHash
+          script = RequireSignatureOf keyHash
+
+          policyId :: TokenPolicyId
+          policyId = tokenPolicyIdFromScript script
+
+          assetId :: AssetId
+          assetId = AssetId policyId assetName
+
+        -- Transfer the minted assets to the payment address
+        -- associated with the monetary policy
+        let txout = TxOut (paymentAddress @n @k addrXPub) (TokenBundle.TokenBundle (Coin 0) (TokenMap.singleton assetId assetQty))
+        let outs = pure txout
+
+        let txCtx = defaultTransactionCtx
+                { txWithdrawal = wdrl
+                , txMetadata = md
+                , txTimeToLive = ttl
+                , txMintBurnAmount = Just $ (assetId, assetQty) :| []
+                }
+
         w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
         sel <- liftHandler
             $ W.selectAssets @_ @s @k wrk w txCtx outs (const Prelude.id)

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -128,7 +128,6 @@ module Cardano.Wallet.Api.Types
     , ApiVerificationKey (..)
     , ApiAccountKey (..)
     , ApiPostAccountKeyData (..)
-    , AddressForgeAmount(..)
     , ForgeTokenData(..)
 
     -- * API Types (Byron)
@@ -189,10 +188,6 @@ module Cardano.Wallet.Api.Types
     , HealthStatusSMASH (..)
     , HealthCheckSMASH (..)
     , ApiHealthCheck (..)
-
-    , ForgeAmount (..)
-    , mintAmount
-    , burnAmount
     ) where
 
 import Prelude
@@ -2779,66 +2774,15 @@ instance ToJSON (ApiT SmashServer) where
 -------------------------------------------------------------------------------}
 
 data ForgeTokenData (n :: NetworkDiscriminant) = ForgeTokenData
-    { forgePayments :: !(NonEmpty (AddressForgeAmount (ApiT Address, Proxy n)))
-    , assetName :: !(ApiT W.TokenName)
+    { assetName :: !(ApiT W.TokenName)
+    , mintAmount :: !(Quantity "assets" Natural)
+    , monetaryPolicyIndex :: !(Maybe (ApiT DerivationIndex))
     , passphrase :: !(ApiT (Passphrase "lenient"))
     , metadata :: !(Maybe (ApiT TxMetadata))
     , timeToLive :: !(Maybe (Quantity "second" NominalDiffTime))
     } deriving (Eq, Generic, Show)
 
-data AddressForgeAmount addr = AddressForgeAmount
-  { address :: !addr
-  , amt :: !(Quantity "token-unit" Natural)
-  } deriving stock (Eq, Generic, Show)
-
-newtype ForgeAmount = ForgeAmount
-    { unForgeAmount
-        :: These (ApiT W.TokenMap) (ApiT W.TokenMap)
-    }
-    deriving stock (Eq, Generic)
-    deriving (Show) via Quiet ForgeAmount
-    deriving anyclass NFData
-
-data ForgeRequest
-  = Mint !Cardano.Quantity
-  | Burn !Cardano.Quantity
-
--- next:
--- mint: find first address in wallet and just sent tokens to that
--- burn: say we want to send x tokens to an addr, use coin selection algorithm to find inputs, but then modify outputs to be mempty, instead burning inputs
-
-mintAmount :: ForgeAmount -> W.TokenMap
-mintAmount (ForgeAmount (This _burn))              = mempty
-mintAmount (ForgeAmount (That (ApiT mint)))        = mint
-mintAmount (ForgeAmount (These _burn (ApiT mint))) = mint
-
-burnAmount :: ForgeAmount -> W.TokenMap
-burnAmount (ForgeAmount (This (ApiT burn)))        = burn
-burnAmount (ForgeAmount (That _mint))              = mempty
-burnAmount (ForgeAmount (These (ApiT burn) _mint)) = burn
-
-instance Monoid ForgeAmount where
-  mempty = ForgeAmount $ These mempty mempty
-
-instance Semigroup ForgeAmount where
-  (ForgeAmount x) <> (ForgeAmount y) = ForgeAmount $ x <> y
-
-instance FromJSON ForgeAmount where
-    parseJSON = genericParseJSON defaultRecordTypeOptions
-instance ToJSON ForgeAmount where
-    toJSON = genericToJSON defaultRecordTypeOptions
-
 instance DecodeAddress n => FromJSON (ForgeTokenData n) where
     parseJSON = genericParseJSON defaultRecordTypeOptions
 instance EncodeAddress n => ToJSON (ForgeTokenData n) where
     toJSON = genericToJSON defaultRecordTypeOptions
-
-instance FromJSON a => FromJSON (AddressForgeAmount a) where
-    parseJSON = withObject "AddressForgeAmount " $ \v ->
-        prependFailure "parsing AddressForgeAmount failed, " $
-        AddressForgeAmount
-            <$> v .: "address"
-            <*> v .:? "forge" .!= (Quantity 0)
-
-instance ToJSON a => ToJSON (AddressForgeAmount a) where
-    toJSON = genericToJSON defaultRecordTypeOptions

lib/core/src/Cardano/Wallet/Primitive/Types/TokenPolicy.hs

@@ -12,6 +12,7 @@ module Cardano.Wallet.Primitive.Types.TokenPolicy
     (
       -- * Token Policies
       TokenPolicyId (..)
+    , tokenPolicyIdFromScript
 
       -- * Token Names
     , TokenName (..)
@@ -38,6 +39,7 @@ module Cardano.Wallet.Primitive.Types.TokenPolicy
 
 import Prelude
 
+import Cardano.Address.Script (KeyHash, Script, unScriptHash, toScriptHash)
 import Cardano.Wallet.Primitive.Types.Hash
     ( Hash (..) )
 import Codec.Binary.Bech32.TH
@@ -112,6 +114,9 @@ instance ToText TokenPolicyId where
 instance FromText TokenPolicyId where
     fromText = fmap UnsafeTokenPolicyId . fromText
 
+tokenPolicyIdFromScript :: Script KeyHash -> TokenPolicyId
+tokenPolicyIdFromScript = UnsafeTokenPolicyId . Hash . unScriptHash . toScriptHash
+
 -- | Token names, defined by the monetary policy script.
 newtype TokenName =
     -- | Construct a 'TokenName' without any validation.

lib/core/src/Cardano/Wallet/Transaction.hs

@@ -39,6 +39,8 @@ import Prelude
 
 import Cardano.Address.Derivation
     ( XPrv )
+import Numeric.Natural
+    ( Natural )
 import Cardano.Api.Typed
     ( AnyCardanoEra, AssetName )
 import Cardano.Wallet.Primitive.AddressDerivation
@@ -69,13 +71,13 @@ import Cardano.Wallet.Primitive.Types.UTxOIndex
     ( UTxOIndex )
 import Data.ByteString
     ( ByteString )
+import Data.Quantity (Quantity)
 import Data.List.NonEmpty
     ( NonEmpty )
 import Data.Text
     ( Text )
 import GHC.Generics
     ( Generic )
-import Cardano.Wallet.Api.Types (AddressForgeAmount)
 
 data TransactionLayer k = TransactionLayer
     { mkTransaction
@@ -153,8 +155,8 @@ data TransactionCtx = TransactionCtx
     -- ^ Transaction expiry (TTL) slot.
     , txDelegationAction :: Maybe DelegationAction
     -- ^ An additional delegation to take.
-    , txForgeAmount :: Maybe (AssetName, NonEmpty (AddressForgeAmount Address))
-    -- ^ Amount to mint/burn, if this is a forging transaction.
+    , txMintBurnAmount :: Maybe (NonEmpty (AssetId, TokenQuantity))
+    -- ^ Amount to mint/burn.
     } deriving (Show, Eq)
 
 data Withdrawal
@@ -177,7 +179,7 @@ defaultTransactionCtx = TransactionCtx
     , txMetadata = Nothing
     , txTimeToLive = maxBound
     , txDelegationAction = Nothing
-    , txForgeAmount = Nothing
+    , txMintBurnAmount = Nothing
     }
 
 -- | Whether the user is attempting any particular delegation action.