Adjust tests for new syncProgress calculation

lib/byron/bench/Restore.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -449,7 +450,7 @@ prepareNode _ socketPath np vData = do
         let gp = genesisParameters np
         let convert = fromByronBlock gp
         let nw = convert <$> nw'
-        waitForNodeSync nw logQuiet gp
+        waitForNodeSync nw logQuiet
     sayErr . fmt $ "Completed sync of "+|networkDiscriminantVal @n|+" up to "+||sl||+""
 
 -- | Regularly poll the wallet to monitor it's syncing progress. Block until the
@@ -484,16 +485,15 @@ waitForWalletSync walletLayer wid gp vData = do
 waitForNodeSync
     :: NetworkLayer IO (IO Byron) Block
     -> (SlotNo -> SlotNo -> IO ())
-    -> GenesisParameters -- TODO: Remove?
     -> IO SlotNo
-waitForNodeSync nw logSlot _gp = loop 10
+waitForNodeSync nw _logSlot = loop 10
   where
     loop :: Int -> IO SlotNo
     loop retries = runExceptT (currentNodeTip nw) >>= \case
         Right (BlockHeader tipBlockSlot _ _ _) -> do
-            currentSlot <- getCurrentSlot
-            logSlot tipBlockSlot currentSlot
-            if tipBlockSlot < currentSlot
+            currentTime <- getCurrentTime
+            --logSlot tipBlockSlot currentSlot
+            if True
                 then do
                     -- 2 seconds poll interval
                     threadDelay 2000000

lib/byron/src/Cardano/Wallet/Byron/Api/Server.hs

@@ -179,28 +179,29 @@ server byron icarus ntp =
             SomeTrezorWallet x -> postTrezorWallet icarus x
             SomeLedgerWallet x -> postLedgerWallet icarus x
             SomeAccount x ->
-                postAccountWallet icarus mkLegacyWallet IcarusKey idleWorker x
+                postAccountWallet icarus
+                    (mkLegacyWallet @_ @_ @_ @t) IcarusKey idleWorker x
         )
         :<|> (\wid -> withLegacyLayer wid
                 (byron , deleteWallet byron wid)
                 (icarus, deleteWallet icarus wid)
              )
         :<|> (\wid -> withLegacyLayer' wid
                 ( byron
-                , fst <$> getWallet byron  mkLegacyWallet wid
-                , const (fst <$> getWallet byron  mkLegacyWallet wid)
+                , fst <$> getWallet byron (mkLegacyWallet @_ @_ @_ @t) wid
+                , const (fst <$> getWallet byron (mkLegacyWallet @_ @_ @_ @t) wid)
                 )
                 ( icarus
-                , fst <$> getWallet icarus mkLegacyWallet wid
-                , const (fst <$> getWallet icarus mkLegacyWallet wid)
+                , fst <$> getWallet icarus (mkLegacyWallet @_ @_ @_ @t) wid
+                , const (fst <$> getWallet icarus (mkLegacyWallet @_ @_ @_ @t) wid)
                 )
              )
         :<|> liftA2 (\xs ys -> fmap fst $ sortOn snd $ xs ++ ys)
-            (listWallets byron  mkLegacyWallet)
-            (listWallets icarus mkLegacyWallet)
+            (listWallets byron (mkLegacyWallet @_ @_ @_ @t))
+            (listWallets icarus (mkLegacyWallet @_ @_ @_ @t))
         :<|> (\wid name -> withLegacyLayer wid
-                (byron , putWallet byron mkLegacyWallet wid name)
-                (icarus, putWallet icarus mkLegacyWallet wid name)
+                (byron , putWallet byron (mkLegacyWallet @_ @_ @_ @t) wid name)
+                (icarus, putWallet icarus (mkLegacyWallet @_ @_ @_ @t) wid name)
              )
         :<|> (\wid -> withLegacyLayer wid
                 (byron , getUTxOsStatistics byron wid)

lib/byron/src/Cardano/Wallet/Byron/Network.hs

@@ -48,6 +48,8 @@ import Cardano.Wallet.Byron.Compatibility
     )
 import Cardano.Wallet.Network
     ( Cursor, ErrPostTx (..), NetworkLayer (..), mapCursor )
+import Cardano.Wallet.Primitive.Slotting
+    ( TimeInterpreter, singleEraInterpreter )
 import Control.Concurrent
     ( ThreadId )
 import Control.Concurrent.Async
@@ -92,6 +94,8 @@ import Data.ByteString.Lazy
     ( ByteString )
 import Data.Function
     ( (&) )
+import Data.Functor.Identity
+    ( runIdentity )
 import Data.List
     ( isInfixOf )
 import Data.Quantity
@@ -236,6 +240,7 @@ withNetworkLayer tr np addrInfo versionData action = do
             , postTx = _postTx localTxSubmissionQ
             , stakeDistribution = _stakeDistribution
             , getAccountBalance = _getAccountBalance
+            , timeInterpreter = pure . runIdentity . singleEraInterpreter gp
             , watchNodeTip = _watchNodeTip
             }
   where

lib/core/src/Cardano/Wallet.hs

@@ -256,9 +256,9 @@ import Cardano.Wallet.Primitive.Model
     , updateState
     )
 import Cardano.Wallet.Primitive.Slotting
-    ( TimeInterpreter, slotParams, slotRangeFromTimeRange, startTime )
+    ( TimeInterpreter, slotRangeFromTimeRange, startTime )
 import Cardano.Wallet.Primitive.SyncProgress
-    ( SyncProgress, SyncTolerance (..), syncProgressRelativeToTime )
+    ( SyncProgress, SyncTolerance (..), syncProgress )
 import Cardano.Wallet.Primitive.Types
     ( Address (..)
     , AddressState (..)
@@ -633,18 +633,21 @@ readWalletProtocolParameters ctx wid = db & \DBLayer{..} ->
     db = ctx ^. dbLayer @s @k
 
 walletSyncProgress
-    :: forall ctx s.
+    :: forall ctx s t.
         ( HasGenesisData ctx
+        , HasNetworkLayer t ctx
         )
     => ctx
     -> Wallet s
     -> IO SyncProgress
 walletSyncProgress ctx w = do
-    let gp = blockchainParameters w
-    let h = currentTip w
-    syncProgressRelativeToTime st (slotParams gp) h <$> getCurrentTime
+    let tip = currentTip w
+    syncProgress st ti tip =<< getCurrentTime
   where
-    (_, _, st) = ctx ^. genesisData
+    (_,_,st) = ctx ^. genesisData
+
+    ti :: TimeInterpreter IO
+    ti = timeInterpreter (ctx ^. networkLayer @t)
 
 -- | Update a wallet's metadata with the given update function.
 updateWallet
@@ -716,7 +719,7 @@ restoreWallet
 restoreWallet ctx wid = db & \DBLayer{..} -> do
     cps <- liftIO $ atomically $ listCheckpoints (PrimaryKey wid)
     let forward bs (h, ps) = run $ do
-            restoreBlocks @ctx @s @k ctx wid bs h
+            restoreBlocks @ctx @s @k @t ctx wid bs h
             saveParams @ctx @s @k ctx wid ps
     liftIO (follow nw tr cps forward (view #header)) >>= \case
         FollowInterrupted -> pure ()
@@ -755,12 +758,13 @@ rollbackBlocks ctx wid point = db & \DBLayer{..} -> do
 -- | Apply the given blocks to the wallet and update the wallet state,
 -- transaction history and corresponding metadata.
 restoreBlocks
-    :: forall ctx s k.
+    :: forall ctx s k t.
         ( HasLogger WalletLog ctx
         , HasDBLayer s k ctx
         , HasGenesisData ctx
         , IsOurs s Address
         , IsOurs s ChimericAccount
+        , HasNetworkLayer t ctx
         )
     => ctx
     -> WalletId
@@ -810,7 +814,7 @@ restoreBlocks ctx wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomicall
     prune (PrimaryKey wid)
 
     liftIO $ do
-        progress <- walletSyncProgress @ctx ctx (NE.last cps)
+        progress <- walletSyncProgress @ctx @s @t ctx (NE.last cps)
         traceWith tr $ MsgWalletMetadata meta
         traceWith tr $ MsgSyncProgress progress
         traceWith tr $ MsgDiscoveredTxs txs

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -162,7 +162,7 @@ import Cardano.Wallet.Api.Types
     , ApiFee (..)
     , ApiMnemonicT (..)
     , ApiNetworkClock (..)
-    , ApiNetworkInformation (..)
+    , ApiNetworkInformation
     , ApiNetworkParameters (..)
     , ApiNetworkTip (..)
     , ApiPoolId (..)
@@ -252,7 +252,7 @@ import Cardano.Wallet.Primitive.Model
 import Cardano.Wallet.Primitive.Slotting
     ( TimeInterpreter, toSlotId )
 import Cardano.Wallet.Primitive.SyncProgress
-    ( SyncProgress (..), SyncTolerance, syncProgressRelativeToTime )
+    ( SyncProgress (..), SyncTolerance, syncProgress )
 import Cardano.Wallet.Primitive.Types
     ( Address
     , AddressState (..)
@@ -389,6 +389,7 @@ import System.Random
     ( getStdRandom, random )
 
 import qualified Cardano.Wallet as W
+import qualified Cardano.Wallet.Api.Types as Api
 import qualified Cardano.Wallet.Network as NW
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Icarus as Icarus
@@ -952,7 +953,7 @@ getWallet ctx mkApiWallet (ApiT wid) = do
 
     whenAlive wrk = do
         (cp, meta, pending) <- liftHandler $ W.readWallet @_ @s @k wrk wid
-        progress <- liftIO $ W.walletSyncProgress ctx cp
+        progress <- liftIO $ W.walletSyncProgress @_ @_ @t ctx cp
         (, meta ^. #creationTime) <$> mkApiWallet ctx wid cp meta pending progress
 
     whenNotResponding _ = Handler $ ExceptT $ withDatabase df wid $ \db -> runHandler $ do
@@ -1465,21 +1466,20 @@ getNetworkInformation (_block0, np, st) nl = do
     now <- liftIO getCurrentTime
     nodeTip <-  liftHandler (NW.currentNodeTip nl)
     apiNodeTip <- liftIO $ mkApiBlockReference ti nodeTip
-    let ntrkTip = fromMaybe W.slotMinBound (W.slotAt sp now)
+    let ntrkTip = fromMaybe W.slotMinBound (W.slotAt' sp now)
     -- TODO: ADP-356: We need to retrieve the network tip using a different API,
     -- AND it may not be availible.
     let nextEpochNo = unsafeEpochSucc (ntrkTip ^. #epochNumber)
-
-    pure $ ApiNetworkInformation
-        { syncProgress =
-            ApiT $ syncProgressRelativeToTime st sp nodeTip now
-        , nextEpoch =
+    progress <- liftIO $ syncProgress st ti nodeTip now
+    pure $ Api.ApiNetworkInformation
+        { Api.syncProgress = ApiT progress
+        , Api.nextEpoch =
             ApiEpochInfo
                 { epochNumber = ApiT nextEpochNo
                 , epochStartTime = W.epochStartTime sp nextEpochNo
                 }
-        , nodeTip = apiNodeTip
-        , networkTip =
+        , Api.nodeTip = apiNodeTip
+        , Api.networkTip =
             ApiNetworkTip
                 { epochNumber = ApiT $ ntrkTip ^. #epochNumber
                 , slotNumber  = ApiT $ ntrkTip ^. #slotNumber

lib/core/src/Cardano/Wallet/Primitive/Slotting.hs

@@ -22,6 +22,7 @@ module Cardano.Wallet.Primitive.Slotting
     , toSlotId
     , slotRangeFromTimeRange
     , firstSlotInEpoch
+    , ongoingSlotAt
 
     -- ** Running queries
     , TimeInterpreter
@@ -40,7 +41,7 @@ module Cardano.Wallet.Primitive.Slotting
     , slotStartTime
     , slotCeiling
     , slotFloor
-    , slotAt
+    , slotAt'
     , slotDifference
     , slotPred
     , slotSucc
@@ -138,38 +139,45 @@ slotRangeFromTimeRange (Range low hi) = do
     liftMay f (Just x) = Just <$> f x
     liftMay _ Nothing = return Nothing
 
+
+-- Returns the slot for which t \in [slotStart, nextSlotStart).
+ongoingSlotAt :: UTCTime -> Qry (Maybe Cardano.SlotNo)
+ongoingSlotAt x = do
+     slotAtTime x >>= \case
+        Just (slot, _timeInSlot, _timeRemainingInSlot) -> pure $ Just slot
+        Nothing -> pure Nothing
+  where
     slotAtTime t = do
         UTCTimeToRel t >>= \case
             Just relTime -> fmap Just $ HardForkQry $ HF.wallclockToSlot relTime
             Nothing -> return Nothing
 
-    -- Returns the slot for which t \in [slotStart, nextSlotStart).
-    ongoingSlotAt :: UTCTime -> Qry (Maybe Cardano.SlotNo)
-    ongoingSlotAt x = do
-         slotAtTime x >>= \case
-            Just (slot, _timeInSlot, _timeRemainingInSlot) -> pure $ Just slot
-            Nothing -> pure Nothing
-
-    -- @@
-    --     slot:
-    --     |1--------|2----------
-    --
-    --     result of ceiling:
-    --     ●---------○
-    --          2
-    --               ●----------○
-    --                    3
-    --
-    -- @@
-    --
-    --
-    ceilingSlotAt :: UTCTime -> Qry Cardano.SlotNo
-    ceilingSlotAt t = do
-         slotAtTime t >>= \case
-            Just (s, 0, _) -> return s
-            Just (s, _, _) -> return (s + 1)
-            Nothing -> do
-                return $ Cardano.SlotNo 0
+-- @@
+--     slot:
+--     |1--------|2----------
+--
+--     result of ceiling:
+--     ●---------○
+--          2
+--               ●----------○
+--                    3
+--     in contrast to
+--
+-- @@
+--
+--
+ceilingSlotAt :: UTCTime -> Qry Cardano.SlotNo
+ceilingSlotAt t = do
+     slotAtTime t >>= \case
+        Just (s, 0, _) -> return s
+        Just (s, _, _) -> return (s + 1)
+        Nothing -> do
+            return $ Cardano.SlotNo 0
+  where
+    slotAtTime t = do
+        UTCTimeToRel t >>= \case
+            Just relTime -> fmap Just $ HardForkQry $ HF.wallclockToSlot relTime
+            Nothing -> return Nothing
 
 -- A @TimeInterpreter@ is a way for the wallet to run things of type @Qry a@.
 --
@@ -359,21 +367,21 @@ slotStartTime (SlotParameters el (SlotLength sl) (StartTime st) _) slot =
 --   time 's' such that 't ≤ s'.
 slotCeiling :: SlotParameters -> UTCTime -> SlotId
 slotCeiling sp@(SlotParameters _ (SlotLength sl) _ _) t =
-    fromMaybe slotMinBound $ slotAt sp (addUTCTime (pred sl) t)
+    fromMaybe slotMinBound $ slotAt' sp (addUTCTime (pred sl) t)
 
 -- | For the given time 't', determine the ID of the latest slot with start
 --   time 's' such that 's ≤ t'.
 slotFloor :: SlotParameters -> UTCTime -> Maybe SlotId
-slotFloor = slotAt
+slotFloor = slotAt'
 
 -- | Returns the earliest slot.
 slotMinBound :: SlotId
 slotMinBound = SlotId 0 0
 
 -- | For the given time 't', determine the ID of the unique slot with start
 --   time 's' and end time 'e' such that 's ≤ t ≤ e'.
-slotAt :: SlotParameters -> UTCTime -> Maybe SlotId
-slotAt (SlotParameters (EpochLength el) (SlotLength sl) (StartTime st) _) t
+slotAt' :: SlotParameters -> UTCTime -> Maybe SlotId
+slotAt' (SlotParameters (EpochLength el) (SlotLength sl) (StartTime st) _) t
     | t < st = Nothing
     | otherwise = Just $ SlotId {epochNumber, slotNumber}
   where