As patterns in offchain code (#94)

Author: j-mueller

cabal.project

@@ -15,8 +15,8 @@ repository cardano-haskell-packages
     d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee
 
 index-state:
-  , hackage.haskell.org 2025-02-14T16:51:26Z
-  , cardano-haskell-packages 2025-02-14T16:51:26Z
+  , hackage.haskell.org 2025-04-15T08:13:08Z
+  , cardano-haskell-packages 2025-04-11T16:42:25Z
 
 constraints:
   plutus-core == 1.40.0.0,
@@ -42,8 +42,8 @@ packages:
 source-repository-package
   type: git
   location: https://github.com/j-mueller/sc-tools
-  tag: f7d5883efe416afc5ba5e5461ad4115ee9245a9b
-  --sha256: sha256-bbRmnKWzw6JBaNUY1Lprvg3ryZ3pXxJpUHuOlJKM6Rs=
+  tag: 100452e6b64200cdffcb2582be07c47e1efebb6b
+  --sha256: sha256-65swdL2zk1mbqdjten6SIX/2v8tADOX4AhzyE0ocpwY=
   subdir:
     src/devnet
     src/coin-selection

flake.lock

@@ -17,7 +17,7 @@ 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.AppError (AppError (..), ProgrammableTokensError (..))
 import Wst.Offchain.Env (RuntimeEnv (..))
 import Wst.Offchain.Env qualified as Env
 
@@ -31,7 +31,7 @@ runWstApp :: forall env era a. (Env.HasRuntimeEnv env) => env -> WstApp env era
 runWstApp env WstApp{unWstApp} = do
   let RuntimeEnv{envBlockfrost} = Env.runtimeEnv env
   evalBlockfrostT envBlockfrost (runExceptT (runReaderT unWstApp env)) >>= \case
-    Left e -> pure (Left $ BlockfrostErr e)
+    Left e -> pure (Left $ ProgTokensError $ BlockfrostErr e)
     Right a -> pure  a
 
 {-| Interpret the 'WstApp' in a servant handler

src/regulated-stablecoin/lib/Wst/App.hs

@@ -1,22 +1,60 @@
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TemplateHaskell        #-}
 {-| Error type for endpoints and queries
 -}
 module Wst.AppError(
-  AppError(..)
+  -- * Programmable token errors
+  ProgrammableTokensError(..),
+  AsProgrammableTokensError(..),
+
+  -- * WST App error
+  AppError(..),
+  AsAppError(..)
 ) where
 
 import Blockfrost.Client.Core (BlockfrostError)
-import Convex.Class (ValidationError)
+import Control.Lens (makeClassyPrisms)
+import Convex.Class (AsValidationError (..), ValidationError)
+import Convex.CoinSelection (AsBalanceTxError (..), AsCoinSelectionError (..))
 import Convex.CoinSelection qualified as CoinSelection
 import PlutusLedgerApi.V3 (Credential)
 
-data AppError era =
+data ProgrammableTokensError =
   OperatorNoUTxOs -- ^ The operator does not have any UTxOs
   | GlobalParamsNodeNotFound -- ^ The node with the global parameters was not found
-  | BalancingError (CoinSelection.BalanceTxError era)
   | BlockfrostErr BlockfrostError
+  -- TODO: The following errors are specific to the regulated stablecoin
+  -- They should be separated out
   | NoTokensToSeize -- ^ No tokens to seize
   | DuplicateBlacklistNode -- ^ Attempting to add a duplicate blacklist node
   | BlacklistNodeNotFound -- ^ Attempting to remove a blacklist node that does not exist
   | TransferBlacklistedCredential Credential -- ^ Attempting to transfer funds from a blacklisted address
+  deriving stock (Show)
+
+makeClassyPrisms ''ProgrammableTokensError
+
+data AppError era =
+  BalancingError (CoinSelection.BalanceTxError era)
   | SubmitError (ValidationError era)
+  | ProgTokensError ProgrammableTokensError
   deriving stock (Show)
+
+makeClassyPrisms ''AppError
+
+instance AsBalanceTxError (AppError era) era where
+  _BalanceTxError = _BalancingError
+
+instance AsValidationError (AppError era) era where
+  _ValidationError = _SubmitError
+
+instance AsProgrammableTokensError (AppError era) where
+  _ProgrammableTokensError = _ProgTokensError
+
+instance AsCoinSelectionError (AppError era) where
+  _CoinSelectionError = _BalancingError . _CoinSelectionError
+
+instance CoinSelection.AsBalancingError (AppError era) era where
+  __BalancingError = _BalanceTxError . CoinSelection.__BalancingError
+
+-- CoinSelection.AsCoinSelectionError err, CoinSelection.AsBalancingError err era

src/regulated-stablecoin/lib/Wst/AppError.hs

@@ -14,21 +14,21 @@ module Wst.Offchain.BuildTx.Failing(
 import Cardano.Api.Experimental (IsEra)
 import Cardano.Api.Shelley qualified as C
 import Control.Lens (set)
-import Control.Monad.Except (MonadError, throwError)
+import Control.Monad.Error.Lens (throwing, throwing_)
+import Control.Monad.Except (MonadError)
 import Control.Monad.Reader (MonadReader, asks)
 import Convex.BuildTx (BuildTxT)
 import Convex.BuildTx qualified as BuildTx
 import Convex.CardanoApi.Lenses qualified as L
 import Convex.Class (MonadBlockchain, queryProtocolParameters)
 import Convex.CoinSelection qualified as CoinSelection
 import Convex.PlutusLedger.V1 (transCredential)
-import Convex.Utils (mapError)
 import Convex.Utxos (BalanceChanges)
 import Convex.Utxos qualified as Utxos
 import Convex.Wallet.Operator (returnOutputFor)
 import Data.Aeson (FromJSON, ToJSON)
 import GHC.Generics (Generic)
-import Wst.AppError (AppError (..))
+import Wst.AppError (AsProgrammableTokensError (..))
 import Wst.Offchain.BuildTx.TransferLogic (FindProofResult (..))
 import Wst.Offchain.Env (HasOperatorEnv (..), OperatorEnv (..))
 import Wst.Offchain.Query (UTxODat (..))
@@ -43,7 +43,7 @@ data BlacklistedTransferPolicy
 
 {-| Balance a transaction using the operator's funds and return output
 -}
-balanceTxEnvFailing :: forall era env m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BlacklistedTransferPolicy -> BuildTxT era m (FindProofResult era) -> m (C.BalancedTxBody era, BalanceChanges)
+balanceTxEnvFailing :: forall era env err m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError err m, C.IsBabbageBasedEra era, AsProgrammableTokensError err, CoinSelection.AsCoinSelectionError err, CoinSelection.AsBalancingError err era) => BlacklistedTransferPolicy -> BuildTxT era m (FindProofResult era) -> m (C.BalancedTxBody era, BalanceChanges)
 balanceTxEnvFailing policy btx = do
   OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv
   params <- queryProtocolParameters
@@ -54,14 +54,14 @@ balanceTxEnvFailing policy btx = do
   output <- returnOutputFor credential
   (balBody, balChanges) <- case r of
     CredentialNotBlacklisted{} -> do
-      mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange)
+      CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange
     CredentialBlacklisted UTxODat{}
       | policy == SubmitFailingTx -> do
         -- deliberately set the script validity flag to false
         -- this means we will be losing the collateral!
         let builder' = txBuilder <> BuildTx.liftTxBodyEndo (set L.txScriptValidity (C.TxScriptValidity C.alonzoBasedEra C.ScriptInvalid))
-        mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) builder' CoinSelection.TrailingChange)
+        CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) builder' CoinSelection.TrailingChange
       | otherwise -> do
-        throwError (TransferBlacklistedCredential (transCredential credential))
-    NoBlacklistNodes -> throwError BlacklistNodeNotFound
+        throwing _TransferBlacklistedCredential (transCredential credential)
+    NoBlacklistNodes -> throwing_ _BlacklistNodeNotFound
   pure (balBody, balChanges)