[ADP-3487] Real NetworkEnv implementation

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

@@ -67,6 +67,7 @@ library
     , cardano-ledger-core
     , cardano-strict-containers
     , cardano-wallet
+    , cardano-wallet-launcher
     , cardano-wallet-network-layer
     , cardano-wallet-primitive
     , cardano-wallet-read           ==0.2024.8.27
@@ -78,6 +79,7 @@ library
     , digest
     , fingertree
     , io-classes
+    , int-cast
     , lens
     , MonadRandom
     , monoidal-containers
@@ -92,6 +94,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

@@ -4,6 +4,7 @@
 module Cardano.Wallet.Deposit.REST.Start
     ( loadDepositWalletFromDisk
     , newFakeBootEnv
+    , newBootEnv
     , mockFundTheWallet
     )
 where
@@ -16,6 +17,12 @@ import Cardano.Wallet.Deposit.IO
 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
@@ -130,3 +137,22 @@ newFakeBootEnv genesisFile = do
                 genesisData'
                 . mapBlock Read.EraValue
                 <$> newNetworkEnvMock
+
+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
+    print genesisFile
+    print eGenesisData
+    print $ Read.getNetworkId <$> eGenesisData
+    case eGenesisData of
+        Left e -> error $ show e
+        Right genesisData' ->
+            return $ WalletBootEnv
+                (show >$< stdoutTracer)
+                genesisData'
+                (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.getTimeInterpreter network
     pparams <-
         Network.currentPParams network
     Wallet.createPayment pparams timeTranslation a <$> readWalletState w

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

@@ -92,7 +92,7 @@ newNetworkEnvMock = do
             , currentPParams =
                 pure $ Read.EraValue Read.mockPParamsConway
             , getTimeInterpreter =
-                pure Time.mockTimeInterpreter
+                pure $ Time.toTimeTranslationPure Time.mockTimeInterpreter
             , slotToUTCTime = pure Time.unsafeUTCTimeOfSlot
-            , utcTimeToSlot = pure . Just . Time.unsafeSlotOfUTCTime
+--            , utcTimeToSlot = pure . Just . Time.unsafeSlotOfUTCTime
             }

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

@@ -0,0 +1,129 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- |
+-- Copyright: © 2024 Cardano Foundation
+-- License: Apache-2.0
+--
+-- Real implementation of a 'NetworkEnv'.
+module Cardano.Wallet.Deposit.IO.Network.NodeToClient
+    ( withNetwork
+
+    -- * Network Layer compatibility
+    , fromNetworkLayer
+    , NetworkLayer
+    , CardanoBlock
+    , StandardCrypto
+    ) where
+
+import Prelude
+
+import Cardano.Launcher.Node
+    ( CardanoNodeConn
+    )
+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.Network.Implementation.Ouroboros
+    ( tunedForMainnetPipeliningStrategy
+    )
+import Cardano.Wallet.Primitive.Ledger.Shelley
+    ( CardanoBlock
+    , NodeToClientVersionData
+    )
+import Cardano.Wallet.Primitive.Slotting
+    ( snapshot
+    )
+import Cardano.Wallet.Primitive.SyncProgress
+    ( SyncTolerance
+    )
+import Cardano.Wallet.Primitive.Types.NetworkParameters
+    ( NetworkParameters
+    )
+import Cardano.Wallet.Read
+    ( chainPointFromChainTip
+    )
+import Control.Monad.Trans.Except
+    ( runExceptT
+    , withExceptT
+    )
+import Control.Tracer
+    ( nullTracer
+    )
+import GHC.Stack
+    ( HasCallStack
+    )
+
+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
+import qualified Cardano.Wallet.Network.Implementation as NetworkLayer
+
+{-----------------------------------------------------------------------------
+    NodeToClient 'NetworkEnv'
+------------------------------------------------------------------------------}
+
+withNetwork
+    :: HasCallStack
+    => NetworkParameters
+    -- ^ Initial blockchain parameters
+    -> CardanoNodeConn
+    -- ^ Socket for communicating with the node
+    -> NodeToClientVersionData
+    -- ^ Codecs for the node's client
+    -> SyncTolerance
+    -> (NetworkEnv IO (Read.EraValue Read.Block) -> IO a)
+    -- ^ Callback function with the network layer
+    -> IO a
+withNetwork np conn vData syncTol act =
+    NetworkLayer.withNetworkLayer
+        nullTracer -- Using this for now
+        tunedForMainnetPipeliningStrategy
+        np
+        conn
+        vData
+        syncTol
+        (act .  fromNetworkLayer)
+
+-- | 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
+        , getTimeInterpreter = toTimeTranslation (NetworkLayer.timeInterpreter nl)
+        , slotToUTCTime = Time.slotToUTCTime <$> snapshot ti
+--        , utcTimeToSlot = pure . Just . Time.unsafeSlotOfUTCTime
+        }
+
+  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 (..)
@@ -61,14 +59,15 @@ data NetworkEnv m block = NetworkEnv
         :: m (Read.EraValue Read.PParams)
     -- ^ Current protocol paramters.
     , getTimeInterpreter
-        :: m Time.TimeInterpreter
+        :: 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)))
+
+--    -- ^ Try to convert a set of slots to their UTCTimes counterparts
+--    , utcTimeToSlot
+--        :: UTCTime
+--        -> m (Maybe Slot)
     }
 
 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
@@ -85,15 +94,29 @@ mockSlottingParameters = SlottingParameters
     , getSecurityParameter = Quantity 2_160
     }
 
+type LookupTimeFromSlot = Slot -> Maybe (WithOrigin UTCTime)
+
 {-----------------------------------------------------------------------------
     TimeInterpreter
 ------------------------------------------------------------------------------}
 
-toTimeTranslation :: TimeInterpreter -> Write.TimeTranslation
-toTimeTranslation = toTimeTranslationPure
-
-type LookupTimeFromSlot = Slot -> Maybe (WithOrigin UTCTime)
-
+-- TODO: Is this the start time of the slot?
+slotToUTCTime :: TimeInterpreter -> LookupTimeFromSlot
+slotToUTCTime _ti Origin = Just Origin --either (const Nothing) Just $ interpretQuery ti $ Primitive.slotToUTCTime minBound
+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
+
+--utcTimeToSlot :: TimeInterpreter -> UTCTime -> Maybe Slot
+--utcTimeToSlot ti t = either (const Nothing) Just . interpretQuery ti $ do
+--    ongoingSlotAt $ toRelativeTime startTime t
+--  where
+--    convertSlotNo :: Primitive.SlotNo -> SlotNo
+--    convertSlotNo (Primitive.SlotNo n) = SlotNo $ intCast n
+
+-- TODO: Rename to mainnetUTCTimeOfSlot
+-- TODO: Move to tests?
 unsafeUTCTimeOfSlot :: Slot -> Maybe (WithOrigin UTCTime)
 unsafeUTCTimeOfSlot Origin = Just Origin
 unsafeUTCTimeOfSlot (At (SlotNo n)) =