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

@@ -1,6 +1,8 @@
 name: ci-linux
 on:
   push:
+    branches:
+      - main
   pull_request:
 
 concurrency:

.github/workflows/ci-linux.yaml

@@ -1,6 +1,8 @@
 name: ci-linux
 on:
   push:
+    branches:
+      - main
   pull_request:
 
 concurrency:

.github/workflows/ci-nix.yaml

@@ -4,6 +4,8 @@ name: "ci-nix"
 on:
   pull_request:
   push:
+    branches:
+      - main
 
 concurrency:
   group: "ci-nix-${{ github.ref }}"

.github/workflows/ci-oci.yaml

@@ -6,6 +6,8 @@ name: "ci-oci"
 on:
   pull_request:
   push:
+    branches:
+      - main
 
 concurrency:
   group: "ci-oci-${{ github.ref }}"

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

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
 

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

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.

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