Merge pull request #397 from mlabs-haskell/euonymos/extended-keys

Support for extended keys in `runGYTxMonadIO`
geniusyield · Jan 16, 2025 · 21d7e55 · 21d7e55
2 parents b642648 + 4e2dbe2
commit 21d7e55
Show file tree

Hide file tree

Showing 7 changed files with 81 additions and 34 deletions.
diff --git a/flake.lock b/flake.lock
diff --git a/flake.nix b/flake.nix
@@ -37,6 +37,7 @@
                   cabal = {}  ;
                   hlint = {};
                   haskell-language-server = {};
+                  fourmolu = {};
                 };
                 # Non-Haskell shell tools go here
                 shell.buildInputs = with pkgs; [

diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs
@@ -409,8 +409,8 @@ instance GYTxUserQueryMonad GYTxMonadClb where
         Just (ref, _) -> return ref
 
 instance GYTxMonad GYTxMonadClb where
-  signTxBody = signTxBodyImpl . asks $ userPaymentSKey . clbEnvWallet
-  signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . userPaymentSKey . clbEnvWallet) <*> asks (userStakeSKey . clbEnvWallet)
+  signTxBody = signTxBodyImpl . asks $ AGYPaymentSigningKey . userPaymentSKey . clbEnvWallet
+  signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . AGYPaymentSigningKey . userPaymentSKey . clbEnvWallet) <*> asks (fmap AGYStakeSigningKey . userStakeSKey . clbEnvWallet)
   submitTx tx = do
     let txBody = getTxBody tx
     dumpBody txBody

diff --git a/src/GeniusYield/Test/Privnet/Ctx.hs b/src/GeniusYield/Test/Privnet/Ctx.hs
@@ -165,7 +165,15 @@ ctxRunGame :: Ctx -> GYTxGameMonadIO a -> IO a
 ctxRunGame ctx = runGYTxGameMonadIO (ctxNetworkId ctx) (ctxProviders ctx)
 
 ctxRun :: Ctx -> User -> GYTxMonadIO a -> IO a
-ctxRun ctx User' {..} = runGYTxMonadIO (ctxNetworkId ctx) (ctxProviders ctx) userPaymentSKey' userStakeSKey' [userAddr] userAddr Nothing
+ctxRun ctx User' {..} =
+  runGYTxMonadIO
+    (ctxNetworkId ctx)
+    (ctxProviders ctx)
+    (AGYPaymentSigningKey userPaymentSKey')
+    (AGYStakeSigningKey <$> userStakeSKey')
+    [userAddr]
+    userAddr
+    Nothing
 
 ctxRunQuery :: Ctx -> GYTxQueryMonadIO a -> IO a
 ctxRunQuery ctx = runGYTxQueryMonadIO (ctxNetworkId ctx) (ctxProviders ctx)

diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs
@@ -249,10 +249,14 @@ class GYTxBuilderMonad m => GYTxMonad m where
   -- by the identified transaction.
   awaitTxConfirmed' :: GYAwaitTxParameters -> GYTxId -> m ()
 
-signTxBodyImpl :: GYTxMonad m => m GYPaymentSigningKey -> GYTxBody -> m GYTx
+signTxBodyImpl :: GYTxMonad m => m GYSomePaymentSigningKey -> GYTxBody -> m GYTx
 signTxBodyImpl kM txBody = signGYTxBody txBody . (: []) <$> kM
 
-signTxBodyWithStakeImpl :: GYTxMonad m => m (GYPaymentSigningKey, Maybe GYStakeSigningKey) -> GYTxBody -> m GYTx
+signTxBodyWithStakeImpl ::
+  GYTxMonad m =>
+  m (GYSomePaymentSigningKey, Maybe GYSomeStakeSigningKey) ->
+  GYTxBody ->
+  m GYTx
 signTxBodyWithStakeImpl kM txBody = (\(pKey, sKey) -> signGYTxBody txBody $ GYSomeSigningKey pKey : maybeToList (GYSomeSigningKey <$> sKey)) <$> kM
 
 -- | Class of monads that can simulate a "game" between different users interacting with transactions.

diff --git a/src/GeniusYield/TxBuilder/IO.hs b/src/GeniusYield/TxBuilder/IO.hs
@@ -59,8 +59,8 @@ newtype GYTxMonadIO a = GYTxMonadIO (GYTxIOEnv -> GYTxBuilderMonadIO a)
 data GYTxIOEnv = GYTxIOEnv
   { envNid :: !GYNetworkId
   , envProviders :: !GYProviders
-  , envPaymentSKey :: !GYPaymentSigningKey
-  , envStakeSKey :: !(Maybe GYStakeSigningKey)
+  , envPaymentSKey :: !GYSomePaymentSigningKey
+  , envStakeSKey :: !(Maybe GYSomeStakeSigningKey)
   }
 
 -- INTERNAL USAGE ONLY
@@ -95,9 +95,9 @@ runGYTxMonadIO ::
   -- | Provider.
   GYProviders ->
   -- | Payment signing key of the wallet
-  GYPaymentSigningKey ->
+  GYSomePaymentSigningKey ->
   -- | Stake signing key of the wallet (optional)
-  Maybe GYStakeSigningKey ->
+  Maybe GYSomeStakeSigningKey ->
   -- | Addresses belonging to wallet.
   [GYAddress] ->
   -- | Change address.
@@ -176,8 +176,8 @@ instance GYTxGameMonad GYTxGameMonadIO where
       runGYTxMonadIO
         nid
         providers
-        userPaymentSKey
-        userStakeSKey
+        (AGYPaymentSigningKey userPaymentSKey)
+        (AGYStakeSigningKey <$> userStakeSKey)
         (NE.toList userAddresses)
         userChangeAddress
         (userCollateralDumb u)

diff --git a/src/GeniusYield/Types/Key.hs b/src/GeniusYield/Types/Key.hs
@@ -107,6 +107,9 @@ module GeniusYield.Types.Key (
   GYSomePaymentSigningKey (..),
   readSomePaymentSigningKey,
   somePaymentSigningKeyToSomeSigningKey,
+  GYSomeStakeSigningKey (..),
+  readSomeStakeSigningKey,
+  someStakeSigningKeyToSomeSigningKey,
 ) where
 
 import Cardano.Api qualified as Api
@@ -756,9 +759,24 @@ data GYSomeSigningKey = forall a. (ToShelleyWitnessSigningKey a, Show a) => GYSo
 instance ToShelleyWitnessSigningKey GYSomeSigningKey where
   toShelleyWitnessSigningKey (GYSomeSigningKey skey) = toShelleyWitnessSigningKey skey
 
-data GYSomePaymentSigningKey = AGYPaymentSigningKey !GYPaymentSigningKey | AGYExtendedPaymentSigningKey !GYExtendedPaymentSigningKey
+data GYSomePaymentSigningKey
+  = AGYPaymentSigningKey !GYPaymentSigningKey
+  | AGYExtendedPaymentSigningKey !GYExtendedPaymentSigningKey
   deriving stock (Eq, Show, Ord)
 
+instance ToShelleyWitnessSigningKey GYSomePaymentSigningKey where
+  toShelleyWitnessSigningKey (AGYPaymentSigningKey key) = toShelleyWitnessSigningKey key
+  toShelleyWitnessSigningKey (AGYExtendedPaymentSigningKey key) = toShelleyWitnessSigningKey key
+
+data GYSomeStakeSigningKey
+  = AGYStakeSigningKey !GYStakeSigningKey
+  | AGYExtendedStakeSigningKey !GYExtendedStakeSigningKey
+  deriving stock (Eq, Show, Ord)
+
+instance ToShelleyWitnessSigningKey GYSomeStakeSigningKey where
+  toShelleyWitnessSigningKey (AGYStakeSigningKey key) = toShelleyWitnessSigningKey key
+  toShelleyWitnessSigningKey (AGYExtendedStakeSigningKey key) = toShelleyWitnessSigningKey key
+
 readSomePaymentSigningKey :: FilePath -> IO GYSomePaymentSigningKey
 readSomePaymentSigningKey file = do
   e <-
@@ -771,6 +789,22 @@ readSomePaymentSigningKey file = do
     Left err -> throwIO $ userError $ show err
     Right skey -> return skey
 
+readSomeStakeSigningKey :: FilePath -> IO GYSomeStakeSigningKey
+readSomeStakeSigningKey file = do
+  e <-
+    Api.readFileTextEnvelopeAnyOf
+      [ Api.FromSomeType (Api.AsSigningKey Api.AsStakeKey) $ AGYStakeSigningKey . stakeSigningKeyFromApi
+      , Api.FromSomeType (Api.AsSigningKey Api.AsStakeExtendedKey) $ AGYExtendedStakeSigningKey . extendedStakeSigningKeyFromApi
+      ]
+      (Api.File file)
+  case e of
+    Left err -> throwIO $ userError $ show err
+    Right skey -> return skey
+
 somePaymentSigningKeyToSomeSigningKey :: GYSomePaymentSigningKey -> GYSomeSigningKey
 somePaymentSigningKeyToSomeSigningKey (AGYPaymentSigningKey key) = GYSomeSigningKey key
 somePaymentSigningKeyToSomeSigningKey (AGYExtendedPaymentSigningKey key) = GYSomeSigningKey key
+
+someStakeSigningKeyToSomeSigningKey :: GYSomeStakeSigningKey -> GYSomeSigningKey
+someStakeSigningKeyToSomeSigningKey (AGYStakeSigningKey key) = GYSomeSigningKey key
+someStakeSigningKeyToSomeSigningKey (AGYExtendedStakeSigningKey key) = GYSomeSigningKey key