Add freeze and seize endpoints

src/lib/Wst/Client.hs

@@ -10,7 +10,9 @@ module Wst.Client (
 
   -- * Build tx
   postIssueProgrammableTokenTx,
-  postTransferProgrammableTokenTx
+  postTransferProgrammableTokenTx,
+  postAddToBlacklistTx,
+  postSeizeFundsTx
 ) where
 
 import Cardano.Api qualified as C
@@ -20,7 +22,8 @@ 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 (..),
+import Wst.Server.Types (API, APIInEra, AddToBlacklistArgs,
+                         IssueProgrammableTokenArgs (..), SeizeAssetsArgs,
                          TextEnvelopeJSON, TransferProgrammableTokenArgs (..))
 
 getHealthcheck :: ClientEnv -> IO (Either ClientError NoContent)
@@ -40,5 +43,15 @@ postIssueProgrammableTokenTx env args = do
 
 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))
+  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

src/lib/Wst/Server.hs

@@ -22,8 +22,9 @@ import Wst.Offchain.BuildTx.ProgrammableLogic (alwaysSucceedsArgs,
 import Wst.Offchain.Endpoints.Deployment qualified as Endpoints
 import Wst.Offchain.Env qualified as Env
 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 (..), TextEnvelopeJSON (..),
                          TransferProgrammableTokenArgs (..))
 
 runServer :: (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env) => env -> IO ()
@@ -48,6 +49,8 @@ txApi :: forall env. (Env.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEr
 txApi =
   issueProgrammableTokenEndpoint @C.ConwayEra @env
   :<|> transferProgrammableTokenEndpoint @C.ConwayEra @env
+  :<|> addToBlacklistEndpoint
+  :<|> seizeAssetsEndpoint
 
 issueProgrammableTokenEndpoint :: forall era env m.
   ( MonadReader env m
@@ -59,8 +62,8 @@ 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
@@ -72,6 +75,11 @@ 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
@@ -85,7 +93,43 @@ transferProgrammableTokenEndpoint :: forall era env m.
 transferProgrammableTokenEndpoint TransferProgrammableTokenArgs{ttaSender, ttaRecipient, ttaAssetName, ttaQuantity, ttaIssuer} = do
   operatorEnv <- Env.loadOperatorEnvFromAddress ttaSender
   dirEnv <- asks Env.directoryEnv
-  let transferLogic = Env.mkTransferLogicEnv ttaIssuer
+  let transferLogic = Env.mkTransferLogicEnv (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
+  let transferLogic = Env.mkTransferLogicEnv (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
+  let transferLogic = Env.mkTransferLogicEnv (paymentKeyHashFromAddress saIssuer)
+  Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do
+    TextEnvelopeJSON <$> Endpoints.seizeCredentialAssetsTx badCred

src/lib/Wst/Server/Types.hs

@@ -13,6 +13,8 @@ module Wst.Server.Types (
   BuildTxAPI,
   IssueProgrammableTokenArgs(..),
   TransferProgrammableTokenArgs(..),
+  AddToBlacklistArgs(..),
+  SeizeAssetsArgs(..),
   TextEnvelopeJSON(..),
 ) where
 
@@ -48,7 +50,7 @@ type QueryAPI era =
 -}
 data IssueProgrammableTokenArgs =
   IssueProgrammableTokenArgs
-    { itaOperatorAddress :: C.Address C.ShelleyAddr
+    { itaIssuer    :: C.Address C.ShelleyAddr
     , itaAssetName :: AssetName
     , itaQuantity  :: Quantity
     }
@@ -59,15 +61,33 @@ data TransferProgrammableTokenArgs =
   TransferProgrammableTokenArgs
     { ttaSender    :: C.Address C.ShelleyAddr
     , ttaRecipient :: C.Address C.ShelleyAddr
-    , ttaIssuer    :: C.Hash C.PaymentKey
+    , 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 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))
     )