[ADP-3487] Real NetworkEnv implementation (#4856)

- [x] Add `Deposit.IO.Network.NodeToClient` module with
`fromNetworkLayer` function
- [x] Make `Cardano.Wallet.Application` use a real `NetworkEnv`,
translated with `fromNetworkLayer`

### Comments

<!-- Additional comments, links, or screenshots to attach, if any. -->

### Issue Number

ADP-3487

lib/customer-deposit-wallet/customer-deposit-wallet.cabal

@@ -78,6 +78,7 @@ library
     , digest
     , fingertree
     , io-classes
+    , int-cast
     , lens
     , MonadRandom
     , monoidal-containers
@@ -92,6 +93,7 @@ library
     Cardano.Wallet.Deposit.IO
     Cardano.Wallet.Deposit.IO.DB
     Cardano.Wallet.Deposit.IO.Network.Mock
+    Cardano.Wallet.Deposit.IO.Network.NodeToClient
     Cardano.Wallet.Deposit.IO.Network.Type
     Cardano.Wallet.Deposit.IO.Resource
     Cardano.Wallet.Deposit.IO.Resource.Event

lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs

@@ -3,7 +3,7 @@
 
 module Cardano.Wallet.Deposit.REST.Start
     ( loadDepositWalletFromDisk
-    , newFakeBootEnv
+    , newBootEnv
     , mockFundTheWallet
     )
 where
@@ -13,12 +13,14 @@ import Prelude
 import Cardano.Wallet.Deposit.IO
     ( WalletBootEnv (..)
     )
-import Cardano.Wallet.Deposit.IO.Network.Mock
-    ( newNetworkEnvMock
+import Cardano.Wallet.Deposit.IO.Network.NodeToClient
+    ( CardanoBlock
+    , NetworkLayer
+    , StandardCrypto
+    , fromNetworkLayer
     )
 import Cardano.Wallet.Deposit.IO.Network.Type
     ( NetworkEnv
-    , mapBlock
     , postTx
     )
 import Cardano.Wallet.Deposit.REST
@@ -114,8 +116,11 @@ mockFundTheWallet network resource = flip runWalletResourceM resource $ do
     Right () <- liftIO $ postTx network tx
     pure ()
 
-newFakeBootEnv :: Maybe FilePath -> IO (WalletBootEnv IO)
-newFakeBootEnv genesisFile = do
+newBootEnv
+    :: Maybe FilePath
+    -> NetworkLayer IO (CardanoBlock StandardCrypto)
+    -> IO (WalletBootEnv IO)
+newBootEnv genesisFile nl = do
     eGenesisData <- runExceptT $ case genesisFile of
         Nothing -> ExceptT $ pure $ Right Read.mockGenesisDataMainnet
         Just file -> fst <$> Byron.readGenesisData file
@@ -125,8 +130,7 @@ newFakeBootEnv genesisFile = do
     case eGenesisData of
         Left e -> error $ show e
         Right genesisData' ->
-            WalletBootEnv
+            return $ WalletBootEnv
                 (show >$< stdoutTracer)
                 genesisData'
-                . mapBlock Read.EraValue
-                <$> newNetworkEnvMock
+                (fromNetworkLayer nl)

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs

@@ -98,7 +98,6 @@ import Data.Time
 import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network
 import qualified Cardano.Wallet.Deposit.Pure as Wallet
 import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Cardano.Wallet.Deposit.Time as Time
 import qualified Cardano.Wallet.Deposit.Write as Write
 import qualified Control.Concurrent.Async as Async
 import qualified Data.DBVar as DBVar
@@ -326,8 +325,7 @@ createPayment
     -> WalletInstance
     -> IO (Either Wallet.ErrCreatePayment Write.Tx)
 createPayment a w = do
-    timeTranslation <-
-        Time.toTimeTranslation <$> Network.getTimeInterpreter network
+    timeTranslation <- Network.getTimeTranslation network
     pparams <-
         Network.currentPParams network
     Wallet.createPayment pparams timeTranslation a <$> readWalletState w

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs

@@ -91,8 +91,7 @@ newNetworkEnvMock = do
                 pure $ Right ()
             , currentPParams =
                 pure $ Read.EraValue Read.mockPParamsConway
-            , getTimeInterpreter =
-                pure Time.mockTimeInterpreter
+            , getTimeTranslation =
+                pure $ Time.toTimeTranslationPure Time.mockTimeInterpreter
             , slotToUTCTime = pure Time.unsafeUTCTimeOfSlot
-            , utcTimeToSlot = pure . Just . Time.unsafeSlotOfUTCTime
             }

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- |
+-- Copyright: © 2024 Cardano Foundation
+-- License: Apache-2.0
+--
+-- Real implementation of a 'NetworkEnv'.
+module Cardano.Wallet.Deposit.IO.Network.NodeToClient
+    ( fromNetworkLayer
+    , NetworkLayer
+    , CardanoBlock
+    , StandardCrypto
+    ) where
+
+import Prelude
+
+import Cardano.Ledger.Api
+    ( StandardCrypto
+    )
+import Cardano.Wallet.Deposit.IO.Network.Type
+    ( ErrPostTx (..)
+    , NetworkEnv (..)
+    , mapBlock
+    )
+import Cardano.Wallet.Deposit.Time
+    ( toTimeTranslation
+    )
+import Cardano.Wallet.Network
+    ( NetworkLayer
+    , mapChainFollower
+    )
+import Cardano.Wallet.Primitive.Ledger.Shelley
+    ( CardanoBlock
+    )
+import Cardano.Wallet.Primitive.Slotting
+    ( snapshot
+    )
+import Cardano.Wallet.Read
+    ( chainPointFromChainTip
+    )
+import Control.Monad.Trans.Except
+    ( runExceptT
+    , withExceptT
+    )
+import Control.Tracer
+    ( nullTracer
+    )
+
+import qualified Cardano.Read.Ledger.Block.Block as Read
+import qualified Cardano.Wallet.Deposit.Read as Read
+import qualified Cardano.Wallet.Deposit.Time as Time
+import qualified Cardano.Wallet.Network as NetworkLayer
+
+{-----------------------------------------------------------------------------
+    NodeToClient 'NetworkEnv'
+------------------------------------------------------------------------------}
+
+-- | Translate the old NetworkLayer to the new NetworkEnv interface
+fromNetworkLayer
+    :: NetworkLayer.NetworkLayer IO Read.ConsensusBlock
+    -> NetworkEnv IO (Read.EraValue Read.Block)
+fromNetworkLayer nl = mapBlock Read.fromConsensusBlock $
+    NetworkEnv
+        { chainSync = \_tr follower -> do
+            -- TODO: Connect tracer
+            let follower' = mapChainFollower id id chainPointFromChainTip id follower
+            NetworkLayer.chainSync nl nullTracer follower'
+            return $ error "impossible: chainSync returned"
+            -- TODO: We can change the error type of 'NetworkLayer.postTx' it
+            -- doesn't need the ErrPostTxEraUnsupported case
+        , postTx = runExceptT . withExceptT translateErrPostTx . NetworkLayer.postTx nl
+        , currentPParams =
+            NetworkLayer.currentPParams nl
+        , getTimeTranslation = toTimeTranslation (NetworkLayer.timeInterpreter nl)
+        , slotToUTCTime = Time.slotToUTCTime <$> snapshot ti
+        }
+
+  where
+    ti = NetworkLayer.timeInterpreter nl
+
+    translateErrPostTx :: NetworkLayer.ErrPostTx -> ErrPostTx
+    translateErrPostTx = \case
+        NetworkLayer.ErrPostTxValidationError errorText -> ErrPostTxValidationError errorText
+        NetworkLayer.ErrPostTxMempoolFull -> ErrPostTxMempoolFull
+        NetworkLayer.ErrPostTxEraUnsupported _era ->
+            error "translateErrPostTx: ErrPostTxEraUnsupported should be impossible"

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs

@@ -12,9 +12,7 @@ import Prelude
 
 import Cardano.Wallet.Deposit.Read
     ( Slot
-    )
-import Cardano.Wallet.Deposit.Time
-    ( LookupTimeFromSlot
+    , WithOrigin
     )
 import Cardano.Wallet.Network
     ( ChainFollower (..)
@@ -60,15 +58,12 @@ data NetworkEnv m block = NetworkEnv
     , currentPParams
         :: m (Read.EraValue Read.PParams)
     -- ^ Current protocol paramters.
-    , getTimeInterpreter
-        :: m Time.TimeInterpreter
+    , getTimeTranslation
+        :: m Time.TimeTranslation
         -- ^ Get the current 'TimeInterpreter' from the Cardano node.
     , slotToUTCTime
-        :: m LookupTimeFromSlot
-    -- ^ Try to convert a set of slots to their UTCTimes counterparts
-    , utcTimeToSlot
-        :: UTCTime
-        -> m (Maybe Slot)
+        :: m (Slot -> (Maybe (WithOrigin UTCTime)))
+
     }
 
 mapBlock

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs

@@ -53,6 +53,10 @@ module Cardano.Wallet.Deposit.Read
     , mockNextBlock
     , Read.mockRawHeaderHash
 
+    , Read.ChainTip (..)
+    , Read.getChainTip
+    , Read.prettyChainTip
+
     , Read.PParams (..)
     , Read.mockPParamsConway
 

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs

@@ -14,9 +14,12 @@ module Cardano.Wallet.Deposit.Time
     , PastHorizonException
     , mockTimeInterpreter
 
+    , slotToUTCTime
+
     -- * from Write
     , Write.TimeTranslation
     , toTimeTranslation
+    , toTimeTranslationPure
 
     -- * wishlist
     , LookupTimeFromSlot
@@ -32,10 +35,13 @@ import Prelude
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException
     , StartTime (..)
+    , hoistTimeInterpreter
+    , interpretQuery
     , mkSingleEraInterpreter
     )
 import Cardano.Wallet.Primitive.Slotting.TimeTranslation
-    ( toTimeTranslationPure
+    ( toTimeTranslation
+    , toTimeTranslationPure
     )
 import Cardano.Wallet.Primitive.Types.SlottingParameters
     ( ActiveSlotCoefficient (..)
@@ -51,6 +57,9 @@ import Cardano.Wallet.Read
 import Data.Functor.Identity
     ( Identity (..)
     )
+import Data.IntCast
+    ( intCastMaybe
+    )
 import Data.Quantity
     ( Quantity (..)
     )
@@ -69,10 +78,10 @@ import qualified Cardano.Write.Tx as Write
 {-----------------------------------------------------------------------------
     TimeInterpreter
 ------------------------------------------------------------------------------}
-type TimeInterpreter = Primitive.TimeInterpreter Identity
+type TimeInterpreter = Primitive.TimeInterpreter (Either PastHorizonException)
 
-mockTimeInterpreter :: TimeInterpreter
-mockTimeInterpreter =
+mockTimeInterpreter :: Primitive.TimeInterpreter Identity
+mockTimeInterpreter = hoistTimeInterpreter (pure . runIdentity) $
     mkSingleEraInterpreter
         (StartTime $ UTCTime (toEnum 0) 0)
         mockSlottingParameters
@@ -89,11 +98,20 @@ mockSlottingParameters = SlottingParameters
     TimeInterpreter
 ------------------------------------------------------------------------------}
 
-toTimeTranslation :: TimeInterpreter -> Write.TimeTranslation
-toTimeTranslation = toTimeTranslationPure
-
 type LookupTimeFromSlot = Slot -> Maybe (WithOrigin UTCTime)
 
+-- | Look up the UTCTime corresponding to the start of the provided `Slot`.
+--
+-- TODO: Check roundtrip properties once we need to implement the corresponding 'utcTimeToSlot'.
+slotToUTCTime :: TimeInterpreter -> LookupTimeFromSlot
+slotToUTCTime _ti Origin = Just Origin
+slotToUTCTime ti (At s) = either (const Nothing) (Just . At) . interpretQuery ti . Primitive.slotToUTCTime =<< convertSlotNo s
+  where
+    convertSlotNo :: SlotNo -> Maybe Primitive.SlotNo
+    convertSlotNo (SlotNo n) = Primitive.SlotNo <$> intCastMaybe n
+
+-- TODO: Rename to mainnetUTCTimeOfSlot
+-- TODO: Move to tests?
 unsafeUTCTimeOfSlot :: Slot -> Maybe (WithOrigin UTCTime)
 unsafeUTCTimeOfSlot Origin = Just Origin
 unsafeUTCTimeOfSlot (At (SlotNo n)) =

lib/exe/lib/Cardano/Wallet/Application.hs

@@ -106,7 +106,7 @@ import Cardano.Wallet.Deposit.REST
     )
 import Cardano.Wallet.Deposit.REST.Start
     ( loadDepositWalletFromDisk
-    , newFakeBootEnv
+    , newBootEnv
     )
 import Cardano.Wallet.Flavor
     ( CredFromOf
@@ -383,7 +383,7 @@ serveWallet
         eDepositUiSocket <- bindDepositUiSocket
         eDepositSocket <- bindDepositSocket
         eShelleySocket <- bindApiSocket
-        fakeBootEnv <- lift $ newFakeBootEnv depositByronGenesisFile
+        bootEnv <- lift $ newBootEnv depositByronGenesisFile netLayer
         callCC $ \exit -> do
             case eShelleyUiSocket of
                 Left err -> do
@@ -431,7 +431,7 @@ serveWallet
                                         >$< applicationTracer
                                     )
                                     databaseDir'
-                                    fakeBootEnv
+                                    bootEnv
                                     resource
                             ui <- Ui.withUILayer 1 resource
                             REST.onResourceChange
@@ -444,7 +444,7 @@ serveWallet
                             let uiService =
                                     startDepositUiServer
                                         ui
-                                        fakeBootEnv
+                                        bootEnv
                                         databaseDir'
                                         socket
                                         sNetwork
@@ -475,15 +475,15 @@ serveWallet
                                                     >$< applicationTracer
                                                 )
                                                 databaseDir'
-                                                fakeBootEnv
+                                                bootEnv
                                                 resource
                                         pure (databaseDir', resource)
                                     Just (databaseDir', w) ->
                                         pure (databaseDir', w)
                             let depositService =
                                     startDepositServer
                                         resource
-                                        fakeBootEnv
+                                        bootEnv
                                         databaseDir'
                                         socket
                             ContT $ \k ->
@@ -624,7 +624,7 @@ serveWallet
             -> IO ()
         startDepositServer
             resource
-            fakeBootEnv
+            bootEnv
             databaseDir'
             socket =
                 do
@@ -635,7 +635,7 @@ serveWallet
                                 $ Deposit.server
                                     (DepositApplicationLog >$< applicationTracer)
                                     databaseDir'
-                                    fakeBootEnv
+                                    bootEnv
                                     resource
                     start
                         serverSettings
@@ -657,7 +657,7 @@ serveWallet
             -> IO ()
         startDepositUiServer
             ui
-            fakeBootEnv
+            bootEnv
             databaseDir'
             socket
             _proxy
@@ -670,7 +670,7 @@ serveWallet
                             $ DepositUi.serveUI
                                 (DepositUIApplicationLog >$< applicationTracer)
                                 ui
-                                fakeBootEnv
+                                bootEnv
                                 databaseDir'
                                 (PageConfig "" "Deposit Cardano Wallet")
                                 _proxy