WIP: Strip out more QueryM. Move QueryM's wallet code into Internal.W…

…allet. KeyWallet now holds a networkId. Added wallet networkId check to Contract env creation

src/Contract/Wallet.purs

@@ -20,7 +20,7 @@ module Contract.Wallet
 import Prelude
 
 import Contract.Address (getWalletAddress, getWalletCollateral)
-import Contract.Monad (Contract, ContractEnv)
+import Contract.Monad (Contract)
 import Contract.Utxos (getWalletUtxos) as Contract.Utxos
 import Control.Monad.Reader (local)
 import Control.Monad.Reader.Class (asks)
@@ -49,12 +49,13 @@ import Ctl.Internal.Wallet
   , name
   , walletToWalletExtension
   ) as Wallet
-import Ctl.Internal.Wallet (Wallet(KeyWallet), mkKeyWallet)
+import Ctl.Internal.Wallet (Wallet(KeyWallet))
 import Ctl.Internal.Wallet.Cip30 (DataSignature)
 import Ctl.Internal.Wallet.Key (KeyWallet, privateKeysToKeyWallet) as Wallet
 import Ctl.Internal.Wallet.Key
   ( PrivatePaymentKey(PrivatePaymentKey)
   , PrivateStakeKey(PrivateStakeKey)
+  , privateKeysToKeyWallet
   )
 import Ctl.Internal.Wallet.KeyFile (formatPaymentKey, formatStakeKey)
 import Ctl.Internal.Wallet.Spec
@@ -69,12 +70,7 @@ import Ctl.Internal.Wallet.Spec
       , ConnectToEternl
       )
   )
-import Data.Lens (Lens, (.~))
-import Data.Lens.Common (simple)
-import Data.Lens.Iso.Newtype (_Newtype)
-import Data.Lens.Record (prop)
 import Data.Maybe (Maybe(Just))
-import Type.Proxy (Proxy(Proxy))
 
 getNetworkId :: Contract NetworkId
 getNetworkId = asks _.networkId
@@ -106,5 +102,7 @@ withKeyWallet wallet action = do
   local _ { wallet = Just $ KeyWallet wallet } action
 
 mkKeyWalletFromPrivateKeys
-  :: PrivatePaymentKey -> Maybe PrivateStakeKey -> Wallet
-mkKeyWalletFromPrivateKeys = mkKeyWallet
+  :: PrivatePaymentKey -> Maybe PrivateStakeKey -> Contract Wallet.KeyWallet
+mkKeyWalletFromPrivateKeys payment mbStake = do
+  networkId <- getNetworkId
+  pure $ privateKeysToKeyWallet networkId payment mbStake

src/Contract/Wallet/KeyFile.purs

@@ -6,8 +6,11 @@ module Contract.Wallet.KeyFile
 
 import Prelude
 
-import Ctl.Internal.Wallet (Wallet) as Wallet
-import Ctl.Internal.Wallet (mkKeyWallet)
+import Control.Monad.Reader.Class (asks)
+import Effect.Aff.Class (liftAff)
+import Ctl.Internal.Contract.Monad (Contract)
+import Ctl.Internal.Wallet.Key (KeyWallet) as Wallet
+import Ctl.Internal.Wallet.Key (privateKeysToKeyWallet)
 import Ctl.Internal.Wallet.KeyFile
   ( privatePaymentKeyFromFile
   , privatePaymentKeyFromTextEnvelope
@@ -18,7 +21,6 @@ import Ctl.Internal.Wallet.KeyFile
   )
 import Data.Maybe (Maybe)
 import Data.Traversable (traverse)
-import Effect.Aff (Aff)
 import Node.Path (FilePath)
 
 -- | Load `PrivateKey`s from `skey` files (the files should be in JSON format as
@@ -29,8 +31,9 @@ import Node.Path (FilePath)
 -- |
 -- | **NodeJS only**
 mkKeyWalletFromFiles
-  :: FilePath -> Maybe FilePath -> Aff Wallet.Wallet
+  :: FilePath -> Maybe FilePath -> Contract Wallet.KeyWallet
 mkKeyWalletFromFiles paymentKeyFile mbStakeKeyFile = do
-  mkKeyWallet
+  networkId <- asks _.networkId
+  liftAff $ privateKeysToKeyWallet networkId
     <$> privatePaymentKeyFromFile paymentKeyFile
     <*> traverse privateStakeKeyFromFile mbStakeKeyFile

src/Internal/Contract/Monad.purs

@@ -18,12 +18,12 @@ import Prelude
 
 import Data.Function (on)
 import Data.Foldable (maximumBy)
-import Ctl.Internal.Serialization.Address (Slot)
+import Ctl.Internal.Serialization.Address (NetworkId, Slot)
 import Effect.Aff (Aff, ParAff, attempt, error, finally, supervise)
 import Ctl.Internal.JsWebSocket (_wsClose, _wsFinalize)
 import Ctl.Internal.QueryM (Hooks, Logger, QueryEnv, QueryM, WebSocket, getProtocolParametersAff, getSystemStartAff, getEraSummariesAff, mkDatumCacheWebSocketAff, mkLogger, mkOgmiosWebSocketAff, mkWalletBySpec, underlyingWebSocket)
 import Record.Builder (build, merge)
-import Control.Parallel (parTraverse, parallel, sequential)
+import Control.Parallel (class Parallel, parTraverse, parallel, sequential)
 import Control.Monad.Error.Class
   ( class MonadError
   , class MonadThrow
@@ -46,9 +46,9 @@ import Ctl.Internal.Helpers (liftM, liftedM, logWithLevel)
 import Ctl.Internal.QueryM.Logging (setupLogs)
 import Ctl.Internal.QueryM.Ogmios (ProtocolParameters, SlotLength, SystemStart, RelativeTime) as Ogmios
 import Ctl.Internal.QueryM.ServerConfig (ServerConfig)
-import Ctl.Internal.Serialization.Address (NetworkId)
 import Ctl.Internal.Types.UsedTxOuts (UsedTxOuts, newUsedTxOuts)
 import Ctl.Internal.Wallet (Wallet)
+import Ctl.Internal.Wallet (getNetworkId) as Wallet
 import Ctl.Internal.Wallet.Spec (WalletSpec)
 import Data.Either (Either(Left, Right))
 import Data.Log.Level (LogLevel)
@@ -59,11 +59,10 @@ import Data.Traversable (for_, traverse)
 import Effect (Effect)
 import Effect.Aff.Class (liftAff)
 import Effect.Class (class MonadEffect, liftEffect)
-import Effect.Exception (Error, try)
+import Effect.Exception (Error, try, throw)
 import Effect.Ref (new) as Ref
 import MedeaPrelude (class MonadAff)
 import Undefined (undefined)
-import Control.Parallel (class Parallel, parallel, sequential)
 import Control.Alt (class Alt)
 import Control.Alternative (class Alternative)
 import Control.Plus (class Plus)
@@ -199,7 +198,7 @@ mkContractEnv params = do
     logger = mkLogger params.logLevel params.customLogger
 
     buildWallet :: Aff (Maybe Wallet)
-    buildWallet = traverse mkWalletBySpec params.walletSpec
+    buildWallet = traverse (mkWalletBySpec params.networkId) params.walletSpec
 
     constants =
       { ctlServerConfig: params.ctlServerConfig
@@ -216,6 +215,8 @@ buildBackend :: Logger -> QueryBackends QueryBackendParams -> Aff (QueryBackends
 buildBackend logger = parTraverse case _ of
   CtlBackendParams { ogmiosConfig, kupoConfig, odcConfig } -> do
     datumCacheWsRef <- liftEffect $ Ref.new Nothing
+    -- TODO Check the network in env matches up with the network of odc, ogmios and kupo
+    --      Need to pass in the networkid
     sequential ado
       odcWs <- parallel $ mkDatumCacheWebSocketAff datumCacheWsRef logger odcConfig
       ogmiosWs <- parallel $ mkOgmiosWebSocketAff datumCacheWsRef logger ogmiosConfig
@@ -238,7 +239,7 @@ getLedgerConstants :: Logger -> QueryBackend -> Aff
   , slotLength :: Ogmios.SlotLength
   , slotReference :: { slot :: Slot, time :: Ogmios.RelativeTime }
   }
-getLedgerConstants logger backend = case backend of
+getLedgerConstants logger = case _ of
   CtlBackend { ogmios: { ws } } -> do
     pparams <- getProtocolParametersAff ws logger
     systemStart <- getSystemStartAff ws logger
@@ -252,6 +253,20 @@ getLedgerConstants logger backend = case backend of
     pure { pparams, slotLength, systemStart, slotReference }
   BlockfrostBackend _ -> undefined
 
+-- | Ensure that `NetworkId` from wallet is the same as specified in the
+-- | `ContractEnv`.
+walletNetworkCheck :: NetworkId -> Wallet -> Aff Unit
+walletNetworkCheck envNetworkId wallet = do
+  networkId <- Wallet.getNetworkId wallet
+  unless (envNetworkId == networkId) do
+    liftEffect $ throw $
+      "The networkId that is specified is not equal to the one from wallet."
+        <> " The wallet is using "
+        <> show networkId
+        <> " while "
+        <> show envNetworkId
+        <> " is specified in the config."
+
 -- | Finalizes a `Contract` environment.
 -- | Closes the websockets in `ContractEnv`, effectively making it unusable.
 -- TODO Move to Aff?
@@ -286,8 +301,8 @@ withContractEnv params action = do
       | otherwise = params.customLogger
 
   contractEnv <- mkContractEnv params <#> _ { customLogger = customLogger }
+  for_ contractEnv.wallet $ walletNetworkCheck contractEnv.networkId
   eiRes <-
-    -- TODO: Adapt `networkIdCheck` from QueryM module
     attempt $ supervise (action contractEnv)
       `flip finally` liftEffect (stopContractEnv contractEnv)
   liftEffect $ case eiRes of

src/Internal/Contract/Sign.purs

@@ -14,7 +14,7 @@ import Ctl.Internal.Contract.Wallet
   ( callCip30Wallet
   , getWalletAddresses
   , getWalletUtxos
-  , withMWallet
+  , withWallet
   )
 import Ctl.Internal.Types.Transaction (TransactionInput)
 import Ctl.Internal.Wallet (Wallet(KeyWallet, Lode, Eternl, Flint, Gero, Nami))
@@ -40,7 +40,7 @@ signTransaction tx = do
     runHook =
       for_ hooks.beforeSign (void <<< liftEffect <<< try)
   runHook
-  withMWallet case _ of
+  withWallet case _ of
     Nami nami -> liftAff $ callCip30Wallet nami \nw -> flip nw.signTx tx
     Gero gero -> liftAff $ callCip30Wallet gero \nw -> flip nw.signTx tx
     Flint flint -> liftAff $ callCip30Wallet flint \nw -> flip nw.signTx tx

src/Internal/Contract/Wallet.purs

@@ -30,7 +30,7 @@ import Effect.Aff.Class (liftAff)
 import Effect.Class (liftEffect)
 import Effect.Exception (throw)
 import Ctl.Internal.Contract.QueryHandle (getQueryHandle)
-import Ctl.Internal.Helpers (liftM)
+import Ctl.Internal.Helpers (liftM, liftedM)
 import Ctl.Internal.Serialization.Address
   ( Address
   , NetworkId
@@ -51,53 +51,26 @@ import Ctl.Internal.Wallet
   , KeyWallet
   , Wallet(KeyWallet, Lode, Flint, Gero, Nami, Eternl)
   )
+import Ctl.Internal.Wallet (getChangeAddress, getRewardAddresses, getUnusedAddresses, getWalletAddresses, signData) as Aff
 import Ctl.Internal.Wallet.Cip30 (DataSignature)
 import Data.Array (catMaybes)
 import Effect.Exception (error, throw)
 import Data.Traversable (for_, traverse)
 
 getUnusedAddresses :: Contract (Array Address)
-getUnusedAddresses = fold <$> do
-  actionBasedOnWallet _.getUnusedAddresses
-    (\_ -> pure [])
+getUnusedAddresses = withWalletAff Aff.getUnusedAddresses
 
 getChangeAddress :: Contract (Maybe Address)
-getChangeAddress = do
-  networkId <- getNetworkId
-  actionBasedOnWallet _.getChangeAddress (\kw -> (unwrap kw).address networkId)
+getChangeAddress = withWalletAff Aff.getChangeAddress
 
 getRewardAddresses :: Contract (Array Address)
-getRewardAddresses = fold <$> do
-  networkId <- getNetworkId
-  actionBasedOnWallet _.getRewardAddresses
-    (\kw -> Array.singleton <$> (unwrap kw).address networkId)
+getRewardAddresses = withWalletAff Aff.getRewardAddresses
 
 getWalletAddresses :: Contract (Array Address)
-getWalletAddresses = fold <$> do
-  networkId <- getNetworkId
-  actionBasedOnWallet _.getWalletAddresses
-    (\kw -> Array.singleton <$> (unwrap kw).address networkId)
-
-actionBasedOnWallet
-  :: forall (a :: Type)
-   . (Cip30Wallet -> Cip30Connection -> Aff (Maybe a))
-  -> (KeyWallet -> Aff a)
-  -> Contract (Maybe a)
-actionBasedOnWallet walletAction keyWalletAction =
-  withMWalletAff case _ of
-    Eternl wallet -> callCip30Wallet wallet walletAction
-    Nami wallet -> callCip30Wallet wallet walletAction
-    Gero wallet -> callCip30Wallet wallet walletAction
-    Flint wallet -> callCip30Wallet wallet walletAction
-    Lode wallet -> callCip30Wallet wallet walletAction
-    KeyWallet kw -> pure <$> keyWalletAction kw
+getWalletAddresses = withWalletAff Aff.getWalletAddresses
 
 signData :: Address -> RawBytes -> Contract (Maybe DataSignature)
-signData address payload = do
-  networkId <- getNetworkId
-  actionBasedOnWallet
-    (\wallet conn -> wallet.signData conn address payload)
-    (\kw -> (unwrap kw).signData networkId payload)
+signData address payload = withWalletAff (Aff.signData address payload)
 
 getWallet :: Contract (Maybe Wallet)
 getWallet = asks (_.wallet)
@@ -131,14 +104,15 @@ ownStakePubKeysHashes = do
     wrap <<< wrap <$> stakeCredentialToKeyHash
       (baseAddressDelegationCred baseAddress)
 
-withMWalletAff
-  :: forall (a :: Type). (Wallet -> Aff (Maybe a)) -> Contract (Maybe a)
-withMWalletAff act = withMWallet (liftAff <<< act)
+withWalletAff
+  :: forall (a :: Type). (Wallet -> Aff a) -> Contract a
+withWalletAff act = withWallet (liftAff <<< act)
 
-withMWallet
-  :: forall (a :: Type). (Wallet -> Contract (Maybe a)) -> Contract (Maybe a)
-withMWallet act = asks _.wallet >>= maybe (pure Nothing)
-  act
+withWallet
+  :: forall (a :: Type). (Wallet -> Contract a) -> Contract a
+withWallet act = do
+  wallet <- liftedM (error "No wallet set") $ asks _.wallet
+  act wallet
 
 callCip30Wallet
   :: forall (a :: Type)
@@ -171,8 +145,7 @@ getWalletCollateral = do
       Lode wallet -> liftAff $ callCip30Wallet wallet _.getCollateral
       Eternl wallet -> liftAff $ callCip30Wallet wallet _.getCollateral
       KeyWallet kw -> do
-        networkId <- getNetworkId
-        addr <- liftAff $ (unwrap kw).address networkId
+        let addr = (unwrap kw).address
         utxos <- (liftAff $ queryHandle.utxosAt addr) <#> hush >>> fromMaybe Map.empty
           >>= filterLockedUtxos
         pparams <- asks $ _.ledgerConstants >>> _.pparams <#> unwrap

src/Internal/Plutip/UtxoDistribution.purs

@@ -10,6 +10,8 @@ module Ctl.Internal.Plutip.UtxoDistribution
 
 import Prelude
 
+import Ctl.Internal.Serialization.Address (NetworkId(MainnetId))
+import Contract.Wallet (mkKeyWalletFromPrivateKeys, withKeyWallet)
 import Contract.Address
   ( PaymentPubKeyHash
   , StakePubKeyHash
@@ -31,7 +33,6 @@ import Contract.Transaction
   )
 import Contract.TxConstraints as Constraints
 import Contract.Utxos (utxosAt)
-import Contract.Wallet (withKeyWallet)
 import Control.Alternative (guard)
 import Control.Monad.Reader (asks)
 import Control.Monad.State.Trans (StateT(StateT), runStateT)
@@ -85,15 +86,15 @@ instance UtxoDistribution InitialUTxOs KeyWallet where
   decodeWallets d p = decodeWalletsDefault d p
   decodeWallets' _ pks = Array.uncons pks <#>
     \{ head: PrivateKeyResponse key, tail } ->
-      (privateKeysToKeyWallet (PrivatePaymentKey key) Nothing) /\ tail
+      (privateKeysToKeyWallet MainnetId (PrivatePaymentKey key) Nothing) /\ tail
   keyWallets _ wallet = [ wallet ]
 
 instance UtxoDistribution InitialUTxOsWithStakeKey KeyWallet where
   encodeDistribution (InitialUTxOsWithStakeKey _ amounts) = [ amounts ]
   decodeWallets d p = decodeWalletsDefault d p
   decodeWallets' (InitialUTxOsWithStakeKey stake _) pks = Array.uncons pks <#>
     \{ head: PrivateKeyResponse key, tail } ->
-      privateKeysToKeyWallet (PrivatePaymentKey key) (Just stake) /\
+      privateKeysToKeyWallet MainnetId (PrivatePaymentKey key) (Just stake) /\
         tail
   keyWallets _ wallet = [ wallet ]
 
@@ -179,7 +180,7 @@ transferFundsFromEnterpriseToBase ourKey wallets = do
   -- Get all utxos and key hashes at all wallets containing a stake key
   walletsInfo <- foldM addStakeKeyWalletInfo mempty wallets
   unless (null walletsInfo) do
-    let ourWallet = privateKeysToKeyWallet ourKey Nothing
+    ourWallet <- mkKeyWalletFromPrivateKeys ourKey Nothing
     ourAddr <- liftedM "Could not get our address" $
       head <$> withKeyWallet ourWallet getWalletAddresses
     ourUtxos <- utxosAt ourAddr