From f048c4956c9a24fdc8417fe7630856b6b96e929f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Thu, 2 Jan 2025 18:34:04 +0000 Subject: [PATCH] Add routes to server (#32) * Add transfer programmable token route * Add freeze and seize endpoints * Add query for blacklist * Fix workflow triggers * Add query for user funds and total funds * Fix build * Update compiled scripts --- .github/workflows/ci-compiled-scripts.yaml | 2 + .github/workflows/ci-linux.yaml | 2 + .github/workflows/ci-nix.yaml | 2 + .github/workflows/ci-oci.yaml | 2 + src/lib/Wst/Client.hs | 27 +++- .../Wst/Offchain/BuildTx/ProgrammableLogic.hs | 28 +++- src/lib/Wst/Offchain/BuildTx/TransferLogic.hs | 5 +- src/lib/Wst/Offchain/Endpoints/Deployment.hs | 9 +- src/lib/Wst/Offchain/Env.hs | 13 +- src/lib/Wst/Server.hs | 152 ++++++++++++++++-- src/lib/Wst/Server/Types.hs | 62 ++++++- src/test/Wst/Test/UnitTest.hs | 10 +- 12 files changed, 269 insertions(+), 45 deletions(-) diff --git a/.github/workflows/ci-compiled-scripts.yaml b/.github/workflows/ci-compiled-scripts.yaml index 01c782b..77270ee 100644 --- a/.github/workflows/ci-compiled-scripts.yaml +++ b/.github/workflows/ci-compiled-scripts.yaml @@ -1,6 +1,8 @@ name: ci-linux on: push: + branches: + - main pull_request: concurrency: diff --git a/.github/workflows/ci-linux.yaml b/.github/workflows/ci-linux.yaml index 01c782b..77270ee 100644 --- a/.github/workflows/ci-linux.yaml +++ b/.github/workflows/ci-linux.yaml @@ -1,6 +1,8 @@ name: ci-linux on: push: + branches: + - main pull_request: concurrency: diff --git a/.github/workflows/ci-nix.yaml b/.github/workflows/ci-nix.yaml index 7faf425..0a63ed6 100644 --- a/.github/workflows/ci-nix.yaml +++ b/.github/workflows/ci-nix.yaml @@ -4,6 +4,8 @@ name: "ci-nix" on: pull_request: push: + branches: + - main concurrency: group: "ci-nix-${{ github.ref }}" diff --git a/.github/workflows/ci-oci.yaml b/.github/workflows/ci-oci.yaml index 7e1169a..f8805bb 100644 --- a/.github/workflows/ci-oci.yaml +++ b/.github/workflows/ci-oci.yaml @@ -6,6 +6,8 @@ name: "ci-oci" on: pull_request: push: + branches: + - main concurrency: group: "ci-oci-${{ github.ref }}" diff --git a/src/lib/Wst/Client.hs b/src/lib/Wst/Client.hs index 6ff262c..2d1ca45 100644 --- a/src/lib/Wst/Client.hs +++ b/src/lib/Wst/Client.hs @@ -10,6 +10,9 @@ module Wst.Client ( -- * Build tx postIssueProgrammableTokenTx, + postTransferProgrammableTokenTx, + postAddToBlacklistTx, + postSeizeFundsTx ) where import Cardano.Api qualified as C @@ -19,8 +22,9 @@ import Servant.Client (ClientEnv, client, runClientM) import Servant.Client.Core (ClientError) import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) import Wst.Offchain.Query (UTxODat) -import Wst.Server.Types (API, APIInEra, IssueProgrammableTokenArgs (..), - TextEnvelopeJSON) +import Wst.Server.Types (API, APIInEra, AddToBlacklistArgs, + IssueProgrammableTokenArgs (..), SeizeAssetsArgs, + TextEnvelopeJSON, TransferProgrammableTokenArgs (..)) getHealthcheck :: ClientEnv -> IO (Either ClientError NoContent) getHealthcheck env = do @@ -29,10 +33,25 @@ getHealthcheck env = do getGlobalParams :: forall era. C.IsShelleyBasedEra era => ClientEnv -> IO (Either ClientError (UTxODat era ProgrammableLogicGlobalParams)) getGlobalParams env = do - let _ :<|> globalParams :<|> _ = client (Proxy @(API era)) + let _ :<|> (globalParams :<|> _) :<|> _ = client (Proxy @(API era)) runClientM globalParams env postIssueProgrammableTokenTx :: forall era. C.IsShelleyBasedEra era => ClientEnv -> IssueProgrammableTokenArgs -> IO (Either ClientError (TextEnvelopeJSON (C.Tx era))) postIssueProgrammableTokenTx env args = do - let _ :<|> _ :<|> issueProgrammableTokenTx = client (Proxy @(API era)) + let _ :<|> _ :<|> (issueProgrammableTokenTx :<|> _) = client (Proxy @(API era)) runClientM (issueProgrammableTokenTx args) env + +postTransferProgrammableTokenTx :: forall era. C.IsShelleyBasedEra era => ClientEnv -> TransferProgrammableTokenArgs -> IO (Either ClientError (TextEnvelopeJSON (C.Tx era))) +postTransferProgrammableTokenTx env args = do + let _ :<|> _ :<|> (_ :<|> transferProgrammableTokenTx :<|> _) = client (Proxy @(API era)) + runClientM (transferProgrammableTokenTx args) env + +postAddToBlacklistTx :: forall era. C.IsShelleyBasedEra era => ClientEnv -> AddToBlacklistArgs -> IO (Either ClientError (TextEnvelopeJSON (C.Tx era))) +postAddToBlacklistTx env args = do + let _ :<|> _ :<|> (_ :<|> _ :<|> addToBlacklistTx :<|> _) = client (Proxy @(API era)) + runClientM (addToBlacklistTx args) env + +postSeizeFundsTx :: forall era. C.IsShelleyBasedEra era => ClientEnv -> SeizeAssetsArgs -> IO (Either ClientError (TextEnvelopeJSON (C.Tx era))) +postSeizeFundsTx env args = do + let _ :<|> _ :<|> (_ :<|> _ :<|> _ :<|> seizeFunds) = client (Proxy @(API era)) + runClientM (seizeFunds args) env diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs index f440aab..0eae8de 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -10,6 +10,8 @@ module Wst.Offchain.BuildTx.ProgrammableLogic IssueNewTokenArgs (..), alwaysSucceedsArgs, fromTransferEnv, + programmableTokenMintingScript, + programmableTokenAssetId, issueProgrammableToken, transferProgrammableToken, seizeProgrammableToken, @@ -29,6 +31,7 @@ import Convex.Class (MonadBlockchain (queryNetworkId)) import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential, unTransPolicyId) import Convex.Utils qualified as Utils +import Data.Either (fromRight) import Data.Foldable (find, maximumBy, traverse_) import Data.Function (on) import Data.List (partition) @@ -74,19 +77,30 @@ fromTransferEnv TransferLogicEnv{tleMintingScript, tleTransferScript, tleIssuerS , intaIssuerLogic = tleIssuerScript } +{-| The minting script for a programmable token that uses the global parameters +-} +programmableTokenMintingScript :: ProgrammableLogicGlobalParams -> IssueNewTokenArgs -> C.PlutusScript C.PlutusScriptV3 +programmableTokenMintingScript ProgrammableLogicGlobalParams {progLogicCred, directoryNodeCS} IssueNewTokenArgs{intaMintingLogic} = + let progLogicScriptCredential = fromRight (error "could not parse protocol params") $ unTransCredential progLogicCred + directoryNodeSymbol = fromRight (error "could not parse protocol params") $ unTransPolicyId directoryNodeCS + in programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol + +{-| 'C.AssetId' of the programmable tokens +-} +programmableTokenAssetId :: ProgrammableLogicGlobalParams -> IssueNewTokenArgs -> C.AssetName -> C.AssetId +programmableTokenAssetId params inta = + C.AssetId + (C.scriptPolicyId $ C.PlutusScript C.plutusScriptVersion $ programmableTokenMintingScript params inta) + + {- Issue a programmable token and register it in the directory set if necessary. The caller should ensure that the specific minting logic stake script witness is included in the final transaction. - If the programmable token is not in the directory, then it is registered - If the programmable token is in the directory, then it is minted -} issueProgrammableToken :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> m C.PolicyId -issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, intaTransferLogic, intaIssuerLogic} directoryList = Utils.inBabbage @era $ do - let ProgrammableLogicGlobalParams {directoryNodeCS, progLogicCred} = uDatum paramsTxOut - - progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred - directoryNodeSymbol <- either (const $ error "could not parse protocol params") pure $ unTransPolicyId directoryNodeCS - - let mintingScript = programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol +issueProgrammableToken paramsTxOut (an, q) inta@IssueNewTokenArgs{intaTransferLogic, intaIssuerLogic} directoryList = Utils.inBabbage @era $ do + let mintingScript = programmableTokenMintingScript (uDatum paramsTxOut) inta issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript issuedSymbol = transPolicyId issuedPolicyId diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index 8e6a122..bf080f8 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -166,9 +166,10 @@ issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBab paySmartTokensToDestination (an, q) issuedPolicyId destinationCred pure $ C.AssetId issuedPolicyId an -transferSmartTokens :: forall env era a 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, MonadError (AppError era) m) => UTxODat era ProgrammableLogicGlobalParams -> C.PaymentCredential -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m () -transferSmartTokens paramsTxIn userCred blacklistNodes directoryList spendingUserOutputs (assetId, q) destinationCred = Utils.inBabbage @era $ do +transferSmartTokens :: forall env era a 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, MonadError (AppError era) m) => UTxODat era ProgrammableLogicGlobalParams -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m () +transferSmartTokens paramsTxIn blacklistNodes directoryList spendingUserOutputs (assetId, q) destinationCred = Utils.inBabbage @era $ do nid <- queryNetworkId + userCred <- Env.operatorPaymentCredential progLogicBaseCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) -- Find sufficient inputs to cover the transfer diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index 45c7f07..58c7c91 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -140,18 +140,17 @@ transferSmartTokensTx :: forall era env m. , C.HasScriptLanguageInEra C.PlutusScriptV3 era , MonadUtxoQuery m ) - => C.PaymentCredential -- ^ Source/User credential - -> C.AssetId -- ^ AssetId to transfer + => C.AssetId -- ^ AssetId to transfer -> Quantity -- ^ Amount of tokens to be minted -> C.PaymentCredential -- ^ Destination credential -> m (C.Tx era) -transferSmartTokensTx srcCred assetId quantity destCred = do +transferSmartTokensTx assetId quantity destCred = do directory <- Query.registryNodes @era blacklist <- Query.blacklistNodes @era - userOutputsAtProgrammable <- Query.userProgrammableOutputs srcCred + userOutputsAtProgrammable <- Env.operatorPaymentCredential >>= Query.userProgrammableOutputs paramsTxIn <- Query.globalParamsNode @era (tx, _) <- Env.balanceTxEnv_ $ do - BuildTx.transferSmartTokens paramsTxIn srcCred blacklist directory userOutputsAtProgrammable (assetId, quantity) destCred + BuildTx.transferSmartTokens paramsTxIn blacklist directory userOutputsAtProgrammable (assetId, quantity) destCred pure (Convex.CoinSelection.signBalancedTxBody [] tx) blacklistCredentialTx :: forall era env m. diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs index 204eea2..2555a6e 100644 --- a/src/lib/Wst/Offchain/Env.hs +++ b/src/lib/Wst/Offchain/Env.hs @@ -28,7 +28,7 @@ module Wst.Offchain.Env( directoryNodePolicyId, protocolParamsPolicyId, globalParams, - + getGlobalParams, -- * Transfer logic environment TransferLogicEnv(..), @@ -222,6 +222,9 @@ globalParams scripts = , progLogicCred = transCredential (programmableLogicBaseCredential scripts) -- its the script hash of the programmable base spending script } +getGlobalParams :: (MonadReader e m, HasDirectoryEnv e) => m ProgrammableLogicGlobalParams +getGlobalParams = asks (globalParams . directoryEnv) + {-| Scripts related to managing the specific transfer logic -} @@ -261,8 +264,8 @@ blacklistNodePolicyId = scriptPolicyIdV3 . tleBlacklistMintingScript data RuntimeEnv = RuntimeEnv - { envLogger :: Logger - , envBlockfrost :: Blockfrost.Project + { envLogger :: Logger + , envBlockfrost :: Blockfrost.Project } makeLensesFor @@ -292,7 +295,7 @@ data CombinedEnv operatorF directoryF transferF runtimeF era = { ceOperator :: operatorF (OperatorEnv era) , ceDirectory :: directoryF DirectoryEnv , ceTransfer :: transferF TransferLogicEnv - , ceRuntime :: runtimeF RuntimeEnv + , ceRuntime :: runtimeF RuntimeEnv } makeLensesFor @@ -354,7 +357,7 @@ addTransferEnv :: TransferLogicEnv -> CombinedEnv o d t r era -> CombinedEnv o d addTransferEnv de env = env{ceTransfer = Identity de } -withTransfer :: MonadReader (CombinedEnv o Identity t r era) m => TransferLogicEnv -> ReaderT (CombinedEnv o Identity Identity r era) m a -> m a +withTransfer :: MonadReader (CombinedEnv o d t r era) m => TransferLogicEnv -> ReaderT (CombinedEnv o d Identity r era) m a -> m a withTransfer dir action = do asks (addTransferEnv dir) >>= runReaderT action diff --git a/src/lib/Wst/Server.hs b/src/lib/Wst/Server.hs index 1612da0..11c6b3c 100644 --- a/src/lib/Wst/Server.hs +++ b/src/lib/Wst/Server.hs @@ -5,24 +5,33 @@ -} module Wst.Server(runServer) where -import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Control.Lens qualified as L import Control.Monad.Except (MonadError) import Control.Monad.Reader (MonadReader, asks) +import Convex.CardanoApi.Lenses qualified as L import Convex.Class (MonadBlockchain, MonadUtxoQuery) import Data.Data (Proxy (..)) import Network.Wai.Handler.Warp qualified as Warp +import PlutusTx.Prelude qualified as P import Servant (Server, ServerT) import Servant.API (NoContent (..), (:<|>) (..)) import Servant.Server (hoistServer, serve) +import SmartTokens.Types.PTokenDirectory (blnKey) import Wst.App (WstApp, runWstAppServant) import Wst.AppError (AppError) -import Wst.Offchain.BuildTx.ProgrammableLogic (alwaysSucceedsArgs) +import Wst.Offchain.BuildTx.ProgrammableLogic (alwaysSucceedsArgs, + fromTransferEnv, + programmableTokenAssetId) import Wst.Offchain.Endpoints.Deployment qualified as Endpoints -import Wst.Offchain.Env qualified as C import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Query (UTxODat (uDatum)) import Wst.Offchain.Query qualified as Query -import Wst.Server.Types (APIInEra, BuildTxAPI, IssueProgrammableTokenArgs (..), - QueryAPI, TextEnvelopeJSON (..)) +import Wst.Server.Types (APIInEra, AddToBlacklistArgs (..), BuildTxAPI, + IssueProgrammableTokenArgs (..), QueryAPI, + SeizeAssetsArgs (..), SerialiseAddress (..), + TextEnvelopeJSON (..), + TransferProgrammableTokenArgs (..)) runServer :: (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env) => env -> IO () runServer env = do @@ -30,21 +39,74 @@ runServer env = do port = 8081 Warp.run port app -server :: forall env. (Env.HasRuntimeEnv env, C.HasDirectoryEnv env) => env -> Server APIInEra +server :: forall env. (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env) => env -> Server APIInEra server env = hoistServer (Proxy @APIInEra) (runWstAppServant env) $ healthcheck - :<|> queryApi @env @C.ConwayEra + :<|> queryApi @env :<|> txApi @env healthcheck :: Applicative m => m NoContent healthcheck = pure NoContent -queryApi :: forall env era. C.IsBabbageBasedEra era => ServerT (QueryAPI era) (WstApp env era) -queryApi = Query.globalParamsNode +queryApi :: forall env. (Env.HasDirectoryEnv env) => ServerT (QueryAPI C.ConwayEra) (WstApp env C.ConwayEra) +queryApi = + Query.globalParamsNode + :<|> queryBlacklistedNodes (Proxy @C.ConwayEra) + :<|> queryUserFunds @C.ConwayEra @env (Proxy @C.ConwayEra) + :<|> queryAllFunds @C.ConwayEra @env (Proxy @C.ConwayEra) -txApi :: forall env. (C.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra) +txApi :: forall env. (Env.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra) txApi = issueProgrammableTokenEndpoint @C.ConwayEra @env + :<|> transferProgrammableTokenEndpoint @C.ConwayEra @env + :<|> addToBlacklistEndpoint + :<|> seizeAssetsEndpoint + +queryBlacklistedNodes :: forall era env m. + ( MonadUtxoQuery m + , C.IsBabbageBasedEra era + , MonadReader env m + , Env.HasDirectoryEnv env + ) + => Proxy era + -> SerialiseAddress (C.Address C.ShelleyAddr) + -> m [C.Hash C.PaymentKey] +queryBlacklistedNodes _ (SerialiseAddress addr) = do + programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) + let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress addr) + getHash = + either (error "deserialiseFromRawBytes failed") id + . C.deserialiseFromRawBytes (C.proxyToAsType $ Proxy @(C.Hash C.PaymentKey)) + . P.fromBuiltin + . blnKey + . uDatum + Env.withEnv $ Env.withTransfer transferLogic (fmap (fmap getHash) (Query.blacklistNodes @era)) + +txOutValue :: C.IsMaryBasedEra era => C.TxOut C.CtxUTxO era -> C.Value +txOutValue = L.view (L._TxOut . L._2 . L._TxOutValue) + +queryUserFunds :: forall era env m. + ( MonadUtxoQuery m + , C.IsBabbageBasedEra era + , MonadReader env m + , Env.HasDirectoryEnv env + , MonadBlockchain era m + ) + => Proxy era + -> SerialiseAddress (C.Address C.ShelleyAddr) + -> m C.Value +queryUserFunds _ (SerialiseAddress addr) = + foldMap (txOutValue . Query.uOut) <$> Query.userProgrammableOutputs @era @env (paymentCredentialFromAddress addr) + +queryAllFunds :: forall era env m. + ( MonadUtxoQuery m + , C.IsBabbageBasedEra era + , MonadReader env m + , Env.HasDirectoryEnv env + ) + => Proxy era + -> m C.Value +queryAllFunds _ = foldMap (txOutValue . Query.uOut) <$> Query.programmableLogicOutputs @era @env issueProgrammableTokenEndpoint :: forall era env m. ( MonadReader env m @@ -56,11 +118,77 @@ issueProgrammableTokenEndpoint :: forall era env m. , MonadUtxoQuery m ) => IssueProgrammableTokenArgs -> m (TextEnvelopeJSON (C.Tx era)) -issueProgrammableTokenEndpoint IssueProgrammableTokenArgs{itaAssetName, itaQuantity, itaOperatorAddress} = do - operatorEnv <- Env.loadOperatorEnvFromAddress itaOperatorAddress +issueProgrammableTokenEndpoint IssueProgrammableTokenArgs{itaAssetName, itaQuantity, itaIssuer} = do + operatorEnv <- Env.loadOperatorEnvFromAddress itaIssuer dirEnv <- asks Env.directoryEnv -- FIXME: Replace alwaysSucceedsArgs with blacklist monetary policy as soon as it is finished let tokenArgs = alwaysSucceedsArgs Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ do TextEnvelopeJSON <$> Endpoints.issueProgrammableTokenTx tokenArgs itaAssetName itaQuantity + +paymentCredentialFromAddress :: C.Address C.ShelleyAddr -> C.PaymentCredential +paymentCredentialFromAddress = \case + C.ShelleyAddress _ cred _ -> C.fromShelleyPaymentCredential cred + +paymentKeyHashFromAddress :: C.Address C.ShelleyAddr -> C.Hash C.PaymentKey +paymentKeyHashFromAddress = \case + C.ShelleyAddress _ (C.fromShelleyPaymentCredential -> C.PaymentCredentialByKey cred) _ -> cred + _ -> error "Expected PaymentCredentialByKey" + +transferProgrammableTokenEndpoint :: forall era env m. + ( MonadReader env m + , Env.HasDirectoryEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => TransferProgrammableTokenArgs -> m (TextEnvelopeJSON (C.Tx era)) +transferProgrammableTokenEndpoint TransferProgrammableTokenArgs{ttaSender, ttaRecipient, ttaAssetName, ttaQuantity, ttaIssuer} = do + operatorEnv <- Env.loadOperatorEnvFromAddress ttaSender + dirEnv <- asks Env.directoryEnv + programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) + let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress ttaIssuer) + assetId <- programmableTokenAssetId <$> Env.getGlobalParams <*> pure (fromTransferEnv transferLogic) <*> pure ttaAssetName + Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do + TextEnvelopeJSON <$> Endpoints.transferSmartTokensTx assetId ttaQuantity (paymentCredentialFromAddress ttaRecipient) + +addToBlacklistEndpoint :: forall era env m. + ( MonadReader env m + , Env.HasDirectoryEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => AddToBlacklistArgs -> m (TextEnvelopeJSON (C.Tx era)) +addToBlacklistEndpoint AddToBlacklistArgs{atbIssuer, atbBlacklistAddress} = do + let badCred = paymentCredentialFromAddress atbBlacklistAddress + operatorEnv <- Env.loadOperatorEnvFromAddress atbIssuer + dirEnv <- asks Env.directoryEnv + programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) + let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress atbIssuer) + Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do + TextEnvelopeJSON <$> Endpoints.blacklistCredentialTx badCred + +seizeAssetsEndpoint :: forall era env m. + ( MonadReader env m + , Env.HasDirectoryEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => SeizeAssetsArgs -> m (TextEnvelopeJSON (C.Tx era)) +seizeAssetsEndpoint SeizeAssetsArgs{saIssuer, saTarget} = do + let badCred = paymentCredentialFromAddress saTarget + operatorEnv <- Env.loadOperatorEnvFromAddress saIssuer + dirEnv <- asks Env.directoryEnv + programmableBaseLogicCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) + let transferLogic = Env.mkTransferLogicEnv programmableBaseLogicCred (paymentKeyHashFromAddress saIssuer) + Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do + TextEnvelopeJSON <$> Endpoints.seizeCredentialAssetsTx badCred diff --git a/src/lib/Wst/Server/Types.hs b/src/lib/Wst/Server/Types.hs index 3aa2e5b..c8f5f5c 100644 --- a/src/lib/Wst/Server/Types.hs +++ b/src/lib/Wst/Server/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -11,8 +12,16 @@ module Wst.Server.Types ( APIInEra, QueryAPI, BuildTxAPI, + + -- * Build tx arguments IssueProgrammableTokenArgs(..), + TransferProgrammableTokenArgs(..), + AddToBlacklistArgs(..), + SeizeAssetsArgs(..), + + -- * Newtypes TextEnvelopeJSON(..), + SerialiseAddress(..) ) where import Cardano.Api (AssetName, Quantity) @@ -20,8 +29,9 @@ import Cardano.Api qualified as C import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) -import Servant.API (Description, Get, JSON, NoContent, Post, ReqBody, type (:>), - (:<|>) (..)) +import Servant (FromHttpApiData (..), ToHttpApiData (toUrlPiece)) +import Servant.API (Capture, Description, Get, JSON, NoContent, Post, ReqBody, + type (:>), (:<|>) (..)) import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) import Wst.Offchain.Query (UTxODat (..)) @@ -35,6 +45,15 @@ instance C.HasTextEnvelope a => ToJSON (TextEnvelopeJSON a) where instance C.HasTextEnvelope a => FromJSON (TextEnvelopeJSON a) where parseJSON val = parseJSON val >>= either (fail . show) (pure . TextEnvelopeJSON) . C.deserialiseFromTextEnvelope (C.proxyToAsType Proxy) +newtype SerialiseAddress a = SerialiseAddress{unSerialiseAddress :: a } + +instance C.SerialiseAddress a => FromHttpApiData (SerialiseAddress a) where + parseUrlPiece = + maybe (Left "Failed to deserialise address") (Right . SerialiseAddress) . C.deserialiseAddress (C.proxyToAsType Proxy) + +instance C.SerialiseAddress a => ToHttpApiData (SerialiseAddress a) where + toUrlPiece = C.serialiseAddress . unSerialiseAddress + type API era = "healthcheck" :> Description "Is the server alive?" :> Get '[JSON] NoContent :<|> "query" :> QueryAPI era @@ -42,17 +61,52 @@ type API era = type QueryAPI era = "global-params" :> Description "The UTxO with the global parameters" :> Get '[JSON] (UTxODat era ProgrammableLogicGlobalParams) + :<|> "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 {-| Arguments for the programmable-token endpoint. The asset name can be something like "USDW" for the regulated stablecoin. -} data IssueProgrammableTokenArgs = IssueProgrammableTokenArgs - { itaOperatorAddress :: C.Address C.ShelleyAddr + { itaIssuer :: C.Address C.ShelleyAddr , itaAssetName :: AssetName , itaQuantity :: Quantity } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) +data TransferProgrammableTokenArgs = + TransferProgrammableTokenArgs + { ttaSender :: C.Address C.ShelleyAddr + , ttaRecipient :: C.Address C.ShelleyAddr + , ttaIssuer :: C.Address C.ShelleyAddr + , ttaAssetName :: AssetName + , ttaQuantity :: Quantity + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data AddToBlacklistArgs = + AddToBlacklistArgs + { atbIssuer :: C.Address C.ShelleyAddr + , atbBlacklistAddress :: C.Address C.ShelleyAddr + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data SeizeAssetsArgs = + SeizeAssetsArgs + { saIssuer :: C.Address C.ShelleyAddr + , saTarget :: C.Address C.ShelleyAddr + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + type BuildTxAPI era = - "programmable-token" :> "issue" :> Description "Create some programamble tokens" :> ReqBody '[JSON] IssueProgrammableTokenArgs :> Post '[JSON] (TextEnvelopeJSON (C.Tx era)) + "programmable-token" :> + ( "issue" :> Description "Create some programmable tokens" :> ReqBody '[JSON] IssueProgrammableTokenArgs :> Post '[JSON] (TextEnvelopeJSON (C.Tx era)) + :<|> "transfer" :> Description "Transfer programmable tokens from one address to another" :> ReqBody '[JSON] TransferProgrammableTokenArgs :> Post '[JSON] (TextEnvelopeJSON (C.Tx era)) + :<|> "blacklist" :> Description "Add a credential to the blacklist" :> ReqBody '[JSON] AddToBlacklistArgs :> Post '[JSON] (TextEnvelopeJSON (C.Tx era)) + :<|> "seize" :> Description "Seize a user's funds" :> ReqBody '[JSON] SeizeAssetsArgs :> Post '[JSON] (TextEnvelopeJSON (C.Tx era)) + ) diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs index c06c72e..73a5f2c 100644 --- a/src/test/Wst/Test/UnitTest.hs +++ b/src/test/Wst/Test/UnitTest.hs @@ -6,7 +6,6 @@ module Wst.Test.UnitTest( import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C import Cardano.Ledger.Api qualified as Ledger -import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Plutus.ExUnits qualified as Ledger import Cardano.Ledger.Shelley.TxCert qualified as TxCert import Control.Exception (try) @@ -154,7 +153,7 @@ transferSmartTokens = failOnError $ Env.withEnv $ do asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) - Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey opPkh) aid 80 (C.PaymentCredentialByKey userPkh) + Endpoints.transferSmartTokensTx aid 80 (C.PaymentCredentialByKey userPkh) >>= void . sendTx . signTxOperator admin Query.programmableLogicOutputs @C.ConwayEra @@ -200,7 +199,7 @@ blacklistTransfer = failOnError $ Env.withEnv $ do opPkh <- asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) - Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey opPkh) aid 50 (C.PaymentCredentialByKey userPkh) + Endpoints.transferSmartTokensTx aid 50 (C.PaymentCredentialByKey userPkh) >>= void . sendTx . signTxOperator admin pure opPkh @@ -213,7 +212,7 @@ blacklistTransfer = failOnError $ Env.withEnv $ do >>= void . sendTx . signTxOperator admin asWallet Wallet.w2 $ Env.withDirectoryFor txIn $ Env.withTransferFor progLogicCred opPkh $ do - Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey userPkh) aid 30 (C.PaymentCredentialByKey opPkh) + Endpoints.transferSmartTokensTx aid 30 (C.PaymentCredentialByKey opPkh) >>= void . sendTx . signTxOperator (user Wallet.w2) seizeUserOutput :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () @@ -229,8 +228,7 @@ seizeUserOutput = failOnError $ Env.withEnv $ do >>= void . sendTx . signTxOperator admin asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do - opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) - Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey opPkh) aid 50 (C.PaymentCredentialByKey userPkh) + Endpoints.transferSmartTokensTx aid 50 (C.PaymentCredentialByKey userPkh) >>= void . sendTx . signTxOperator admin Query.programmableLogicOutputs @C.ConwayEra >>= void . expectN 2 "programmable logic outputs"