Add vkey-witness and submit endpoints

src/lib/Wst/App.hs

@@ -36,7 +36,7 @@ runWstApp env WstApp{unWstApp} = do
 
 {-| Interpret the 'WstApp' in a servant handler
 -}
-runWstAppServant :: forall env era a. (Env.HasRuntimeEnv env) => env -> WstApp env era a -> Handler a
+runWstAppServant :: forall env era a. (C.IsAlonzoBasedEra era, Env.HasRuntimeEnv env) => env -> WstApp env era a -> Handler a
 runWstAppServant env action = liftIO (runWstApp env action) >>= \case
   Left err -> do
     let err_ = S.err500 { S.errBody = fromString (show err) }

src/lib/Wst/AppError.hs

@@ -5,6 +5,7 @@ module Wst.AppError(
 ) where
 
 import Blockfrost.Client.Core (BlockfrostError)
+import Convex.Class (ValidationError)
 import Convex.CoinSelection qualified as CoinSelection
 import PlutusLedgerApi.Data.V3 (Credential)
 
@@ -14,4 +15,5 @@ data AppError era =
   | BalancingError (CoinSelection.BalanceTxError era)
   | BlockfrostErr BlockfrostError
   | TransferBlacklistedCredential Credential -- ^ Attempting to transfer funds from a blacklisted address
+  | SubmitError (ValidationError era)
   deriving stock (Show)

src/lib/Wst/Client.hs

@@ -38,20 +38,21 @@ getGlobalParams env = do
 
 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))
+  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))
+  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))
+  let _ :<|> _ :<|> ((_ :<|> _ :<|> _ :<|> seizeFunds) :<|> _) = client (Proxy @(API era))
   runClientM (seizeFunds args) env
+

src/lib/Wst/Offchain/Query.hs

@@ -61,7 +61,7 @@ data UTxODat era a =
 
 -- | Aeson options for the UTxODat type. Used to derive JSON instances and ToSchema
 utxoDatOptions :: JSON.Options
-utxoDatOptions = JSON.customJsonOptions 2
+utxoDatOptions = JSON.customJsonOptions 1
 
 instance (C.IsCardanoEra era, ToJSON a) => ToJSON (UTxODat era a) where
   toJSON = JSON.genericToJSON utxoDatOptions

src/lib/Wst/Server.hs

@@ -12,12 +12,13 @@ module Wst.Server(
 
 import Cardano.Api.Shelley qualified as C
 import Control.Lens qualified as L
+import Control.Monad.Error.Class (MonadError (throwError))
 import Control.Monad.Except (MonadError)
 import Control.Monad.Reader (MonadReader, asks)
 import Convex.CardanoApi.Lenses qualified as L
-import Convex.Class (MonadBlockchain, MonadUtxoQuery)
-import Convex.CoinSelection qualified
+import Convex.Class (MonadBlockchain (sendTx), MonadUtxoQuery)
 import Data.Data (Proxy (..))
+import Data.List (nub)
 import Network.Wai.Handler.Warp qualified as Warp
 import Network.Wai.Middleware.Cors
 import PlutusTx.Prelude qualified as P
@@ -27,12 +28,13 @@ import Servant.Server (hoistServer, serve)
 import Servant.Server.StaticFiles (serveDirectoryWebApp)
 import SmartTokens.Types.PTokenDirectory (blnKey)
 import Wst.App (WstApp, runWstAppServant)
-import Wst.AppError (AppError)
+import Wst.AppError (AppError (..))
 import Wst.Offchain.Endpoints.Deployment qualified as Endpoints
 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, AddToBlacklistArgs (..), BuildTxAPI,
+import Wst.Server.Types (APIInEra, AddToBlacklistArgs (..),
+                         AddVKeyWitnessArgs (..), BuildTxAPI,
                          IssueProgrammableTokenArgs (..), QueryAPI,
                          SeizeAssetsArgs (..), SerialiseAddress (..),
                          TextEnvelopeJSON (..),
@@ -85,10 +87,14 @@ queryApi =
 
 txApi :: forall env. (Env.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra)
 txApi =
-  issueProgrammableTokenEndpoint @C.ConwayEra @env
+  (issueProgrammableTokenEndpoint @C.ConwayEra @env
   :<|> transferProgrammableTokenEndpoint @C.ConwayEra @env
   :<|> addToBlacklistEndpoint
   :<|> seizeAssetsEndpoint
+  )
+  :<|> pure . addWitnessEndpoint
+  :<|> submitTxEndpoint
+
 
 computeUserAddress :: forall era env m.
   ( MonadReader env m
@@ -234,3 +240,18 @@ seizeAssetsEndpoint SeizeAssetsArgs{saIssuer, saTarget} = do
   transferLogic <- Env.transferLogicForDirectory (paymentKeyHashFromAddress saIssuer)
   Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ Env.withTransfer transferLogic $ do
     TextEnvelopeJSON <$> Endpoints.seizeCredentialAssetsTx badCred
+
+addWitnessEndpoint :: forall era. AddVKeyWitnessArgs era -> TextEnvelopeJSON (C.Tx era)
+addWitnessEndpoint AddVKeyWitnessArgs{avwTx, avwVKeyWitness} =
+  let C.Tx txBody txWits = unTextEnvelopeJSON avwTx
+      vkey = unTextEnvelopeJSON avwVKeyWitness
+      x = C.makeSignedTransaction (nub $ vkey : txWits) txBody
+  in TextEnvelopeJSON x
+
+submitTxEndpoint :: forall era m.
+  ( MonadBlockchain era m
+  , MonadError (AppError era) m
+  )
+  =>  TextEnvelopeJSON (C.Tx era) -> m C.TxId
+submitTxEndpoint (TextEnvelopeJSON tx) = do
+  either (throwError . SubmitError) pure =<< sendTx tx

src/lib/Wst/Server/Types.hs

@@ -19,6 +19,7 @@ module Wst.Server.Types (
   TransferProgrammableTokenArgs(..),
   AddToBlacklistArgs(..),
   SeizeAssetsArgs(..),
+  AddVKeyWitnessArgs(..),
 
   -- * Newtypes
   TextEnvelopeJSON(..),
@@ -180,10 +181,31 @@ instance FromJSON SeizeAssetsArgs where
 instance ToSchema SeizeAssetsArgs where
   declareNamedSchema = Schema.genericDeclareNamedSchema (SchemaOptions.fromAesonOptions jsonOptions2)
 
+data AddVKeyWitnessArgs era =
+  AddVKeyWitnessArgs
+    { avwTx :: TextEnvelopeJSON (C.Tx era)
+    , avwVKeyWitness :: TextEnvelopeJSON (C.KeyWitness era)
+    }
+    deriving stock (Generic)
+
+instance C.IsShelleyBasedEra era => ToJSON (AddVKeyWitnessArgs era) where
+  toJSON = JSON.genericToJSON jsonOptions3
+  toEncoding = JSON.genericToEncoding jsonOptions3
+
+instance C.IsShelleyBasedEra era => FromJSON (AddVKeyWitnessArgs era) where
+  parseJSON = JSON.genericParseJSON jsonOptions3
+
+instance C.IsShelleyBasedEra era => ToSchema (AddVKeyWitnessArgs era) where
+  declareNamedSchema = Schema.genericDeclareNamedSchema (SchemaOptions.fromAesonOptions jsonOptions2)
+
 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))
     )
+  :<|>
+  "add-vkey-witness" :> Description "Add a VKey witness to a transaction" :> ReqBody '[JSON] (AddVKeyWitnessArgs era) :> Post '[JSON] (TextEnvelopeJSON (C.Tx era))
+  :<|>
+  "submit" :> Description "Submit a transaction to the blockchain" :> ReqBody '[JSON] (TextEnvelopeJSON (C.Tx era)) :> Post '[JSON] C.TxId