diff --git a/generated/openapi/schema.json b/generated/openapi/schema.json index 697c6db..077eb34 100644 --- a/generated/openapi/schema.json +++ b/generated/openapi/schema.json @@ -226,6 +226,38 @@ } } }, + "/query/address/{address}": { + "get": { + "description": "The user's receiving address for programmable tokens", + "parameters": [ + { + "in": "path", + "name": "address", + "required": true, + "schema": { + "description": "bech32-serialised cardano address", + "example": "addr1q9d42egme33z960rr8vlnt69lpmythdpm7ydk2e6k5nj5ghay9rg60vw49kejfah76sqeh4yshlsntgg007y0wgjlfwju6eksr", + "type": "string" + } + } + ], + "responses": { + "200": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/Address" + } + } + }, + "description": "" + }, + "404": { + "description": "`address` not found" + } + } + } + }, "/query/all-funds": { "get": { "description": "Total value of all programmable tokens", diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index 6455c53..2b23018 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -134,14 +134,8 @@ addressed to the payment credential -} paySmartTokensToDestination :: forall era env m. (MonadBuildTx era m, MonadReader env m, Env.HasDirectoryEnv env, MonadBlockchain era m, C.IsBabbageBasedEra era) => (C.AssetName, C.Quantity) -> C.PolicyId -> C.PaymentCredential -> m () paySmartTokensToDestination (an, q) issuedPolicyId destinationCred = Utils.inBabbage @era $ do - nid <- queryNetworkId - -- TODO: check if there is a better way to achieve: C.PaymentCredential -> C.StakeCredential - stakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred - directoryEnv <- asks Env.directoryEnv - let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv let value = fromList [(C.AssetId issuedPolicyId an, q)] - addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred) - + addr <- Env.programmableTokenReceivingAddress destinationCred payToAddress addr value issueSmartTokens :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m C.AssetId diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index f653e77..9517f2e 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -48,6 +48,7 @@ module Wst.Offchain.Env( -- ** Minting tokens programmableTokenMintingScript, programmableTokenAssetId, + programmableTokenReceivingAddress, -- * Runtime data RuntimeEnv(..), @@ -83,11 +84,12 @@ import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT) import Convex.BuildTx (BuildTxT) import Convex.BuildTx qualified as BuildTx -import Convex.Class (MonadBlockchain, MonadUtxoQuery (..), +import Convex.Class (MonadBlockchain (queryNetworkId), MonadUtxoQuery (..), queryProtocolParameters, utxosByPaymentCredential) import Convex.CoinSelection qualified as CoinSelection import Convex.PlutusLedger.V1 (transCredential, transPolicyId, - unTransCredential, unTransPolicyId) + unTransCredential, unTransPolicyId, + unTransStakeCredential) import Convex.Utils (mapError) import Convex.Utxos (BalanceChanges) import Convex.Utxos qualified as Utxos @@ -254,6 +256,16 @@ globalParams scripts = getGlobalParams :: (MonadReader e m, HasDirectoryEnv e) => m ProgrammableLogicGlobalParams getGlobalParams = asks (globalParams . directoryEnv) +{-| Compute the receiving address for a payment credential and network ID +-} +programmableTokenReceivingAddress :: forall era env m. (MonadReader env m, HasDirectoryEnv env, C.IsShelleyBasedEra era, MonadBlockchain era m) => C.PaymentCredential -> m (C.AddressInEra era) +programmableTokenReceivingAddress destinationCred = do + nid <- queryNetworkId + -- TODO: check if there is a better way to achieve: C.PaymentCredential -> C.StakeCredential + stakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred + progLogicBaseCred <- asks (programmableLogicBaseCredential . directoryEnv) + return $ C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred) + {-| Scripts related to managing the specific transfer logic -} diff --git a/src/lib/Wst/Server.hs b/src/lib/Wst/Server.hs index 35b3c39..10ca11d 100644 --- a/src/lib/Wst/Server.hs +++ b/src/lib/Wst/Server.hs @@ -69,6 +69,7 @@ queryApi = :<|> queryBlacklistedNodes (Proxy @C.ConwayEra) :<|> queryUserFunds @C.ConwayEra @env (Proxy @C.ConwayEra) :<|> queryAllFunds @C.ConwayEra @env (Proxy @C.ConwayEra) + :<|> computeUserAddress (Proxy @C.ConwayEra) txApi :: forall env. (Env.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra) txApi = @@ -77,6 +78,24 @@ txApi = :<|> addToBlacklistEndpoint :<|> seizeAssetsEndpoint +computeUserAddress :: forall era env m. + ( MonadReader env m + , Env.HasDirectoryEnv env + , C.IsShelleyBasedEra era + , MonadBlockchain era m + ) + => Proxy era + -> SerialiseAddress (C.Address C.ShelleyAddr) + -> m (C.Address C.ShelleyAddr) +computeUserAddress _ (SerialiseAddress addr) = do + let C.ShelleyAddress _ paymentCredential _stakeCredential = addr + Env.programmableTokenReceivingAddress @era (C.fromShelleyPaymentCredential paymentCredential) >>= \case + C.AddressInEra (C.ShelleyAddressInEra _) addr_ -> pure addr_ + + -- This is impossible as we construct the address with makeShelleyAddressInEra + -- But the compiler doesn't realise that. + C.AddressInEra C.ByronAddressInAnyEra _ -> error "Unexpected byron address" + queryBlacklistedNodes :: forall era env m. ( MonadUtxoQuery m , C.IsBabbageBasedEra era diff --git a/src/lib/Wst/Server/Types.hs b/src/lib/Wst/Server/Types.hs index c209bfc..fbb58ca 100644 --- a/src/lib/Wst/Server/Types.hs +++ b/src/lib/Wst/Server/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -70,6 +70,10 @@ instance C.HasTextEnvelope a => ToSchema (TextEnvelopeJSON a) where newtype SerialiseAddress a = SerialiseAddress{unSerialiseAddress :: a } +deriving newtype instance ToJSON (SerialiseAddress (C.Address C.ShelleyAddr)) +deriving newtype instance FromJSON (SerialiseAddress (C.Address C.ShelleyAddr)) +deriving newtype instance ToSchema (SerialiseAddress (C.Address C.ShelleyAddr)) + instance ToParamSchema (SerialiseAddress a) where toParamSchema _proxy = mempty @@ -94,6 +98,7 @@ type QueryAPI era = :<|> "blacklist" :> Description "The list of addresses that have been blacklisted" :> Capture "address" (SerialiseAddress (C.Address C.ShelleyAddr)) :> Get '[JSON] [C.Hash C.PaymentKey] :<|> "user-funds" :> Description "Total value locked in programmable token outputs addressed to the user" :> Capture "address" (SerialiseAddress (C.Address C.ShelleyAddr)) :> Get '[JSON] C.Value :<|> "all-funds" :> Description "Total value of all programmable tokens" :> Get '[JSON] C.Value + :<|> "address" :> Description "The user's receiving address for programmable tokens" :> Capture "address" (SerialiseAddress (C.Address C.ShelleyAddr)) :> Get '[JSON] (C.Address C.ShelleyAddr) {-| Arguments for the programmable-token endpoint. The asset name can be something like "USDW" for the regulated stablecoin. -} diff --git a/src/test/lib/Wst/Test/MockServer.hs b/src/test/lib/Wst/Test/MockServer.hs index 5e2f8ac..9685540 100644 --- a/src/test/lib/Wst/Test/MockServer.hs +++ b/src/test/lib/Wst/Test/MockServer.hs @@ -31,6 +31,7 @@ mockQueryApi = :<|> (\_ -> liftIO $ QC.generate $ Gen.listOf (hedgehog $ Gen.genVerificationKeyHash (C.proxyToAsType Proxy))) :<|> (\_ -> liftIO $ fmap (C.fromLedgerValue C.ShelleyBasedEraConway) $ QC.generate $ hedgehog $ Gen.genValue C.MaryEraOnwardsConway Gen.genAssetId Gen.genPositiveQuantity) :<|> liftIO (fmap (C.fromLedgerValue C.ShelleyBasedEraConway) $ QC.generate $ hedgehog $ Gen.genValue C.MaryEraOnwardsConway Gen.genAssetId Gen.genPositiveQuantity) + :<|> (\_ -> liftIO $ QC.generate Gen.genAddress) genTx :: MonadIO m => m (TextEnvelopeJSON (C.Tx C.ConwayEra)) genTx = liftIO $ fmap TextEnvelopeJSON $ QC.generate $ hedgehog $ Gen.genTx C.shelleyBasedEra