Add server implementation, better handling of Environment

cabal.project

@@ -42,9 +42,10 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/j-mueller/sc-tools
-  tag: 956eb259e22d5a73fa5f67bc8aceec5df144d170
+  tag: e2759559324e172f12b11ab815323c48ed8922b0
   subdir:
     src/devnet
+    src/blockfrost
     src/coin-selection
     src/mockchain
     src/optics

nix/project.nix

@@ -2,7 +2,7 @@
 
 let
   sha256map = {
-    "https://github.com/j-mueller/sc-tools"."956eb259e22d5a73fa5f67bc8aceec5df144d170" = "sha256-5qc4MbB6GuQyjA+Y+tlqixf6UvhyDgEBgj23aKgpSAg=";
+    "https://github.com/j-mueller/sc-tools"."e2759559324e172f12b11ab815323c48ed8922b0" = "sha256-5qc4MbB6GuQyjA+Y+tlqixf6UvhyDgEBgj23aKgpSAg=";
     "https://github.com/colll78/plutarch-plutus"."b2379767c7f1c70acf28206bf922f128adc02f28" = "sha256-mhuW2CHxnc6FDWuMcjW/51PKuPOdYc4yxz+W5RmlQew=";
     "https://github.com/input-output-hk/catalyst-onchain-libs"."650a3435f8efbd4bf36e58768fac266ba5beede4" = "sha256-NUh+l97+eO27Ppd8Bx0yMl0E5EV+p7+7GuFun1B8gRc=";
   };

src/lib/SmartTokens/Types/ProtocolParams.hs

@@ -1,22 +1,29 @@
+{-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+{-# LANGUAGE InstanceSigs         #-}
 
 module SmartTokens.Types.ProtocolParams (
   ProgrammableLogicGlobalParams (..),
   PProgrammableLogicGlobalParams (..),
 ) where
 
-import Plutarch.Core.PlutusDataList
-    ( DerivePConstantViaDataList(..),
-      PlutusTypeDataList,
-      ProductIsData(..) )
+import Cardano.Api.Shelley qualified as C
+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))
+import Data.Aeson qualified as Aeson
+import Data.Bifunctor (Bifunctor (..))
 import Generics.SOP qualified as SOP
-import Plutarch.LedgerApi.V3 (PCurrencySymbol, PCredential)
-import Plutarch.Prelude
+import Plutarch.Core.PlutusDataList (DerivePConstantViaDataList (..),
+                                     PlutusTypeDataList, ProductIsData (..))
 import Plutarch.DataRepr (PDataFields)
-import PlutusTx qualified
-import PlutusLedgerApi.V3 (Credential, CurrencySymbol)
+import Plutarch.LedgerApi.V3 (PCredential, PCurrencySymbol)
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import Plutarch.Prelude (DerivePlutusType (..), Generic, PDataRecord, PEq,
+                         PIsData, PLabeledType ((:=)), PShow, PlutusType, S,
+                         Term)
+import PlutusLedgerApi.V3 (Credential, CurrencySymbol)
+import PlutusTx qualified
 
 -- TODO:
 -- Figure out why deriving PlutusType breaks when I uncomment this
@@ -48,4 +55,28 @@ instance DerivePlutusType PProgrammableLogicGlobalParams where
   type DPTStrat _ = PlutusTypeDataList
 
 instance PUnsafeLiftDecl PProgrammableLogicGlobalParams where
-  type PLifted PProgrammableLogicGlobalParams = ProgrammableLogicGlobalParams
+  type PLifted PProgrammableLogicGlobalParams = ProgrammableLogicGlobalParams
+
+-- We're using the Data representation of the PlutusLedgerApi types here
+-- Because it is somewhat human-readable (more so than the hex representation)
+
+plutusDataToJSON :: forall a. (PlutusTx.ToData a) => a -> Aeson.Value
+plutusDataToJSON = C.scriptDataToJson C.ScriptDataJsonNoSchema . C.unsafeHashableScriptData . C.fromPlutusData . PlutusTx.toData
+
+plutusDataFromJSON :: forall a. (PlutusTx.FromData a) => Aeson.Value -> Either String a
+plutusDataFromJSON val = do
+  k <- bimap show C.getScriptData $ C.scriptDataFromJson C.ScriptDataJsonNoSchema val
+  maybe (Left "fromData failed") Right (PlutusTx.fromData $ C.toPlutusData k)
+
+instance ToJSON ProgrammableLogicGlobalParams where
+  toJSON ProgrammableLogicGlobalParams{directoryNodeCS, progLogicCred} =
+    object
+      [ "directory_node_currency_symbol" .= plutusDataToJSON directoryNodeCS
+      , "programmable_logic_credential"  .= plutusDataToJSON progLogicCred
+      ]
+
+instance FromJSON ProgrammableLogicGlobalParams where
+  parseJSON = withObject "ProgrammableLogicGlobalParams" $ \obj ->
+    ProgrammableLogicGlobalParams
+      <$> (obj .: "directory_node_currency_symbol" >>= either fail pure . plutusDataFromJSON)
+      <*> (obj .: "programmable_logic_credential" >>= either fail pure . plutusDataFromJSON)

src/lib/Wst/App.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-| Application monad used by CLI and server
+-}
+module Wst.App (
+  WstApp(..),
+  runWstApp,
+  runWstAppServant
+) where
+
+import Blammo.Logging.Simple (MonadLogger, MonadLoggerIO, WithLogger (..))
+import Cardano.Api qualified as C
+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
+import Convex.Blockfrost (BlockfrostT (..), evalBlockfrostT)
+import Convex.Class (MonadBlockchain, MonadUtxoQuery)
+import Data.String (IsString (..))
+import Servant.Server (Handler (..))
+import Servant.Server qualified as S
+import Wst.AppError (AppError (BlockfrostErr))
+import Wst.Offchain.Env (RuntimeEnv (..))
+import Wst.Offchain.Env qualified as Env
+
+newtype WstApp env era a = WstApp { unWstApp :: ReaderT env (ExceptT (AppError era) (BlockfrostT IO)) a }
+  deriving newtype (Monad, Applicative, Functor, MonadIO, MonadReader env, MonadError (AppError era), MonadUtxoQuery, MonadBlockchain C.ConwayEra)
+  deriving
+    (MonadLogger, MonadLoggerIO)
+    via (WithLogger env (ExceptT (AppError era) (BlockfrostT IO)))
+
+runWstApp :: forall env era a. (Env.HasRuntimeEnv env) => env -> WstApp env era a -> IO (Either (AppError era) a)
+runWstApp env WstApp{unWstApp} = do
+  let RuntimeEnv{envBlockfrost} = Env.runtimeEnv env
+  evalBlockfrostT envBlockfrost (runExceptT (runReaderT unWstApp env)) >>= \case
+    Left e -> pure (Left $ BlockfrostErr e)
+    Right a -> pure  a
+
+{-| Interpret the 'WstApp' in a servant handler
+-}
+runWstAppServant :: forall env era a. (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) }
+    throwError err_
+  Right a -> pure a

src/lib/Wst/AppError.hs

@@ -0,0 +1,15 @@
+{-| Error type for endpoints and queries
+-}
+module Wst.AppError(
+  AppError(..)
+) where
+
+import Blockfrost.Client.Core (BlockfrostError)
+import Convex.CoinSelection qualified as CoinSelection
+
+data AppError era =
+  OperatorNoUTxOs -- ^ The operator does not have any UTxOs
+  | GlobalParamsNodeNotFound -- ^ The node with the global parameters was not found
+  | BalancingError (CoinSelection.BalanceTxError era)
+  | BlockfrostErr BlockfrostError
+  deriving stock (Show)

src/lib/Wst/Cli.hs

@@ -1,20 +1,18 @@
-{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Wst.Cli(runMain) where
 
-import Blammo.Logging.Simple (MonadLogger, MonadLoggerIO, WithLogger (..),
-                              logError, logInfo, runLoggerLoggingT)
-import Control.Monad.Except (ExceptT, MonadError, runExceptT)
+import Blammo.Logging.Simple (MonadLogger, logError, logInfo, runLoggerLoggingT)
 import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
 import Convex.Wallet.Operator (OperatorConfigSigning)
 import Convex.Wallet.Operator qualified as Operator
 import Data.String (IsString (..))
 import Options.Applicative (customExecParser, disambiguate, helper, idm, info,
                             prefs, showHelpOnEmpty, showHelpOnError)
-import Wst.Cli.Command (Command (..), parseCommand)
-import Wst.Cli.RuntimeEnv (RuntimeEnv)
-import Wst.Cli.RuntimeEnv qualified as RuntimeEnv
+import Wst.App (runWstApp)
+import Wst.Cli.Command (Command (..), ManageCommand (StartServer, Status),
+                        parseCommand)
+import Wst.Offchain.Env qualified as Env
+import Wst.Server qualified as Server
 
 runMain :: IO ()
 runMain = do
@@ -25,30 +23,23 @@ runMain = do
 
 runCommand :: Command -> IO ()
 runCommand com = do
-  env <- RuntimeEnv.loadEnv
-  result <- runWstApp env $ case com of
-    Deploy config -> deploy config
-    Manage _txIn _com ->
-      -- TODO:
-      -- * Implement status check (call the query endpoints and print out a summary of the results)
-      -- * Start the server
-      logInfo "Manage"
+  env <- Env.addRuntimeEnv <$> Env.loadRuntimeEnv <*> pure Env.empty
+  result <- case com of
+    Deploy config -> runWstApp env (deploy config)
+    Manage txIn com -> do
+      let env' = Env.addDirectoryEnvFor txIn env
+      runWstApp env' $ case com of
+        Status -> do
+          -- TODO: status check (call the query endpoints and print out a summary of the results)
+          logInfo "Manage"
+        StartServer -> do
+          logInfo "starting server"
+          liftIO (Server.runServer env')
+
   case result of
     Left err -> runLoggerLoggingT env $ logError (fromString $ show err)
     Right a -> pure a
 
-data AppError = AppError
-  deriving stock Show
-
-newtype WstApp a = WstApp { unWstApp :: ReaderT RuntimeEnv (ExceptT AppError IO) a }
-  deriving newtype (Monad, Applicative, Functor, MonadIO, MonadReader RuntimeEnv, MonadError AppError)
-  deriving
-    (MonadLogger, MonadLoggerIO)
-    via (WithLogger RuntimeEnv (ExceptT AppError IO))
-
-runWstApp :: RuntimeEnv -> WstApp a -> IO (Either AppError a)
-runWstApp env WstApp{unWstApp} = runExceptT (runReaderT unWstApp env)
-
 deploy :: (MonadLogger m, MonadIO m) => OperatorConfigSigning -> m ()
 deploy config = do
   logInfo "Loading operator files"

src/lib/Wst/Client.hs

@@ -4,51 +4,35 @@
 -}
 module Wst.Client (
   getHealthcheck,
-  postInitMerkleTree,
-  postUpdateMerkleTree,
-  postTransferToUser,
-  postTransferToIssuer,
-  getAddress,
-  getAllSanctionedAddresses
+
+  -- * Query routes
+  getGlobalParams,
+
+  -- * Build tx
+  postIssueProgrammableTokenTx,
 ) where
 
+import Cardano.Api qualified as C
 import Data.Data (Proxy (..))
 import Servant.API (NoContent, (:<|>) ((:<|>)))
 import Servant.Client (ClientEnv, client, runClientM)
 import Servant.Client.Core (ClientError)
-import Wst.Server.Types (API)
+import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams)
+import Wst.Offchain.Query (UTxODat)
+import Wst.Server.Types (API, APIInEra, IssueProgrammableTokenArgs (..),
+                         TextEnvelopeJSON)
 
 getHealthcheck :: ClientEnv -> IO (Either ClientError NoContent)
 getHealthcheck env = do
-  let healthcheck :<|> _ = client (Proxy @API)
+  let healthcheck :<|> _ = client (Proxy @APIInEra)
   runClientM healthcheck env
 
-postInitMerkleTree :: ClientEnv -> String -> IO (Either ClientError String)
-postInitMerkleTree env name = do
-  let _ :<|> initMerkleTree :<|> _ = client (Proxy @API)
-  runClientM (initMerkleTree name) env
-
-postUpdateMerkleTree :: ClientEnv -> String -> IO (Either ClientError String)
-postUpdateMerkleTree env name = do
-  let _ :<|> _ :<|> updateMerkleTree :<|> _ = client (Proxy @API)
-  runClientM (updateMerkleTree name) env
-
-postTransferToUser :: ClientEnv -> String -> IO (Either ClientError String)
-postTransferToUser env name = do
-  let _ :<|> _ :<|> _ :<|> transferToUser :<|> _ = client (Proxy @API)
-  runClientM (transferToUser name) env
-
-postTransferToIssuer :: ClientEnv -> String -> IO (Either ClientError String)
-postTransferToIssuer env name = do
-  let _ :<|> _ :<|> _ :<|> _ :<|> transferToIssuer :<|> _ = client (Proxy @API)
-  runClientM (transferToIssuer name) env
-
-getAddress :: ClientEnv -> String -> IO (Either ClientError String)
-getAddress env name = do
-  let _ :<|> _ :<|> _ :<|> _ :<|> address :<|> _ = client (Proxy @API)
-  runClientM (address name) env
+getGlobalParams :: forall era. C.IsShelleyBasedEra era => ClientEnv -> IO (Either ClientError (UTxODat era ProgrammableLogicGlobalParams))
+getGlobalParams env = do
+  let _ :<|> globalParams :<|> _ = client (Proxy @(API era))
+  runClientM globalParams env
 
-getAllSanctionedAddresses :: ClientEnv -> IO (Either ClientError String)
-getAllSanctionedAddresses env = do
-  let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> allSanctionedAddresses = client (Proxy @API)
-  runClientM allSanctionedAddresses 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))
+  runClientM (issueProgrammableTokenTx args) env

src/lib/Wst/Offchain/BuildTx/TransferLogic.hs

@@ -114,7 +114,7 @@ seizeStablecoins seizingTxo issuerTxo directoryList destinationCred = Utils.inBa
 
 addIssueWitness :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m ()
 addIssueWitness = Utils.inBabbage @era $ do
-  opPkh <- asks (C.verificationKeyHash . verificationKey . oPaymentKey . Env.bteOperator . Env.operatorEnv)
+  opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)
   mintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv)
   let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 mintingScript
   addRequiredSignature opPkh
@@ -153,7 +153,7 @@ addTransferWitness blacklistNodes clientCred = Utils.inBabbage @era $ do
 
 addSeizeWitness :: forall env era m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m ()
 addSeizeWitness = Utils.inBabbage @era $ do
-  opPkh <- asks (C.verificationKeyHash . verificationKey . oPaymentKey . Env.bteOperator . Env.operatorEnv)
+  opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)
   seizeScript <- asks (Env.tleIssuerScript . Env.transferLogicEnv)
   let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 seizeScript
   addRequiredSignature opPkh