API: Compute programmable token address (#43)

generated/openapi/schema.json

@@ -226,6 +226,38 @@
                 }
             }
         },
+        "/query/address/{address}": {
+            "get": {
+                "description": "The user's receiving address for programmable tokens",
+                "parameters": [
+                    {
+                        "in": "path",
+                        "name": "address",
+                        "required": true,
+                        "schema": {
+                            "description": "bech32-serialised cardano address",
+                            "example": "addr1q9d42egme33z960rr8vlnt69lpmythdpm7ydk2e6k5nj5ghay9rg60vw49kejfah76sqeh4yshlsntgg007y0wgjlfwju6eksr",
+                            "type": "string"
+                        }
+                    }
+                ],
+                "responses": {
+                    "200": {
+                        "content": {
+                            "application/json;charset=utf-8": {
+                                "schema": {
+                                    "$ref": "#/components/schemas/Address"
+                                }
+                            }
+                        },
+                        "description": ""
+                    },
+                    "404": {
+                        "description": "`address` not found"
+                    }
+                }
+            }
+        },
         "/query/all-funds": {
             "get": {
                 "description": "Total value of all programmable tokens",

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

@@ -134,14 +134,8 @@ addressed to the payment credential
 -}
 paySmartTokensToDestination :: forall era env m. (MonadBuildTx era m, MonadReader env m, Env.HasDirectoryEnv env, MonadBlockchain era m, C.IsBabbageBasedEra era) => (C.AssetName, C.Quantity) -> C.PolicyId -> C.PaymentCredential -> m ()
 paySmartTokensToDestination (an, q) issuedPolicyId destinationCred = Utils.inBabbage @era $ do
-  nid <- queryNetworkId
-  -- TODO: check if there is a better way to achieve: C.PaymentCredential -> C.StakeCredential
-  stakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred
-  directoryEnv <- asks Env.directoryEnv
-  let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv
   let value = fromList [(C.AssetId issuedPolicyId an, q)]
-      addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred)
-
+  addr <- Env.programmableTokenReceivingAddress destinationCred
   payToAddress addr value
 
 issueSmartTokens :: forall era env 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) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m C.AssetId

src/lib/Wst/Offchain/Env.hs

@@ -48,6 +48,7 @@ module Wst.Offchain.Env(
   -- ** Minting tokens
   programmableTokenMintingScript,
   programmableTokenAssetId,
+  programmableTokenReceivingAddress,
 
   -- * Runtime data
   RuntimeEnv(..),
@@ -83,11 +84,12 @@ import Control.Monad.Except (MonadError, throwError)
 import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)
 import Convex.BuildTx (BuildTxT)
 import Convex.BuildTx qualified as BuildTx
-import Convex.Class (MonadBlockchain, MonadUtxoQuery (..),
+import Convex.Class (MonadBlockchain (queryNetworkId), MonadUtxoQuery (..),
                      queryProtocolParameters, utxosByPaymentCredential)
 import Convex.CoinSelection qualified as CoinSelection
 import Convex.PlutusLedger.V1 (transCredential, transPolicyId,
-                               unTransCredential, unTransPolicyId)
+                               unTransCredential, unTransPolicyId,
+                               unTransStakeCredential)
 import Convex.Utils (mapError)
 import Convex.Utxos (BalanceChanges)
 import Convex.Utxos qualified as Utxos
@@ -254,6 +256,16 @@ globalParams scripts =
 getGlobalParams :: (MonadReader e m, HasDirectoryEnv e) => m ProgrammableLogicGlobalParams
 getGlobalParams = asks (globalParams . directoryEnv)
 
+{-| Compute the receiving address for a payment credential and network ID
+-}
+programmableTokenReceivingAddress :: forall era env m. (MonadReader env m, HasDirectoryEnv env, C.IsShelleyBasedEra era, MonadBlockchain era m) => C.PaymentCredential -> m (C.AddressInEra era)
+programmableTokenReceivingAddress destinationCred = do
+  nid <- queryNetworkId
+  -- TODO: check if there is a better way to achieve: C.PaymentCredential -> C.StakeCredential
+  stakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred
+  progLogicBaseCred <- asks (programmableLogicBaseCredential . directoryEnv)
+  return $ C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred)
+
 {-| Scripts related to managing the specific transfer logic
 -}
 

src/lib/Wst/Server.hs

@@ -69,6 +69,7 @@ queryApi =
   :<|> queryBlacklistedNodes (Proxy @C.ConwayEra)
   :<|> queryUserFunds @C.ConwayEra @env (Proxy @C.ConwayEra)
   :<|> queryAllFunds @C.ConwayEra @env (Proxy @C.ConwayEra)
+  :<|> computeUserAddress (Proxy @C.ConwayEra)
 
 txApi :: forall env. (Env.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra)
 txApi =
@@ -77,6 +78,24 @@ txApi =
   :<|> addToBlacklistEndpoint
   :<|> seizeAssetsEndpoint
 
+computeUserAddress :: forall era env m.
+  ( MonadReader env m
+  , Env.HasDirectoryEnv env
+  , C.IsShelleyBasedEra era
+  , MonadBlockchain era m
+  )
+  => Proxy era
+  -> SerialiseAddress (C.Address C.ShelleyAddr)
+  -> m (C.Address C.ShelleyAddr)
+computeUserAddress _ (SerialiseAddress addr) = do
+  let C.ShelleyAddress _ paymentCredential _stakeCredential  = addr
+  Env.programmableTokenReceivingAddress @era (C.fromShelleyPaymentCredential paymentCredential) >>= \case
+    C.AddressInEra (C.ShelleyAddressInEra _) addr_ -> pure addr_
+
+    -- This is impossible as we construct the address with makeShelleyAddressInEra
+    -- But the compiler doesn't realise that.
+    C.AddressInEra C.ByronAddressInAnyEra _ -> error "Unexpected byron address"
+
 queryBlacklistedNodes :: forall era env m.
   ( MonadUtxoQuery m
   , C.IsBabbageBasedEra era

src/lib/Wst/Server/Types.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE OverloadedLists    #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE TypeOperators      #-}
@@ -70,6 +70,10 @@ instance C.HasTextEnvelope a => ToSchema (TextEnvelopeJSON a) where
 
 newtype SerialiseAddress a = SerialiseAddress{unSerialiseAddress :: a }
 
+deriving newtype instance ToJSON (SerialiseAddress (C.Address C.ShelleyAddr))
+deriving newtype instance FromJSON (SerialiseAddress (C.Address C.ShelleyAddr))
+deriving newtype instance ToSchema (SerialiseAddress (C.Address C.ShelleyAddr))
+
 instance ToParamSchema (SerialiseAddress a) where
   toParamSchema _proxy =
     mempty
@@ -94,6 +98,7 @@ type QueryAPI era =
   :<|> "blacklist" :> Description "The list of addresses that have been blacklisted" :> Capture "address" (SerialiseAddress (C.Address C.ShelleyAddr)) :>  Get '[JSON] [C.Hash C.PaymentKey]
   :<|> "user-funds" :> Description "Total value locked in programmable token outputs addressed to the user" :> Capture "address" (SerialiseAddress (C.Address C.ShelleyAddr)) :> Get '[JSON] C.Value
   :<|> "all-funds" :> Description "Total value of all programmable tokens" :> Get '[JSON] C.Value
+  :<|> "address" :> Description "The user's receiving address for programmable tokens" :> Capture "address" (SerialiseAddress (C.Address C.ShelleyAddr)) :> Get '[JSON] (C.Address C.ShelleyAddr)
 
 {-| Arguments for the programmable-token endpoint. The asset name can be something like "USDW" for the regulated stablecoin.
 -}

src/test/lib/Wst/Test/MockServer.hs

@@ -31,6 +31,7 @@ mockQueryApi =
   :<|> (\_ -> liftIO $ QC.generate $ Gen.listOf (hedgehog $ Gen.genVerificationKeyHash (C.proxyToAsType Proxy)))
   :<|> (\_ -> liftIO $ fmap (C.fromLedgerValue C.ShelleyBasedEraConway) $ QC.generate $ hedgehog $ Gen.genValue C.MaryEraOnwardsConway Gen.genAssetId Gen.genPositiveQuantity)
   :<|> liftIO (fmap (C.fromLedgerValue C.ShelleyBasedEraConway) $ QC.generate $ hedgehog $ Gen.genValue C.MaryEraOnwardsConway Gen.genAssetId Gen.genPositiveQuantity)
+  :<|> (\_ -> liftIO $ QC.generate Gen.genAddress)
 
 genTx :: MonadIO m => m (TextEnvelopeJSON (C.Tx C.ConwayEra))
 genTx = liftIO $ fmap TextEnvelopeJSON $ QC.generate $ hedgehog $ Gen.genTx C.shelleyBasedEra