Sync progress is easier with RelativeTime

lib/core/src/Cardano/Pool/DB/Model.hs

@@ -236,7 +236,7 @@ mReadPoolProduction
 mReadPoolProduction timeInterpreter epoch =
     updatePools . updateSlots epoch <$> get #pools
   where
-    epochOf' = runIdentity . timeInterpreter . epochOf
+    epochOf' = runIdentity . timeInterpreter . const . epochOf
     updatePools = Map.filter (not . L.null)
     updateSlots e = Map.map (filter (\x -> epochOf' (slotNo x) == e))
 
@@ -417,7 +417,7 @@ mReadCursor k = do
 mRollbackTo :: TimeInterpreter Identity -> SlotNo -> ModelOp ()
 mRollbackTo ti point = do
     modify #distributions
-        $ Map.mapMaybeWithKey $ discardBy $ runIdentity . ti . epochOf
+        $ Map.mapMaybeWithKey $ discardBy $ runIdentity . ti . const . epochOf
     modify #pools
         $ Map.filter (not . L.null) . fmap (filter ((<= point) . slotNo))
     modify #registrations

lib/core/src/Cardano/Wallet.hs

@@ -716,7 +716,7 @@ walletSyncProgress
     -> IO SyncProgress
 walletSyncProgress ctx w = do
     let tip = currentTip w
-    syncProgress st ti tip =<< getCurrentTime
+    syncProgress st ti tip =<< currentRelativeTime' ti
   where
     (_, _, st) = ctx ^. genesisData
 

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

@@ -284,7 +284,6 @@ import Cardano.Wallet.Primitive.Slotting
     , TimeInterpreter
     , currentEpoch
     , currentRelativeTime'
-    , fromRelativeTime
     , ongoingSlotAt
     , slotToUTCTime
     , timeOfEpoch
@@ -1767,13 +1766,12 @@ getNetworkInformation
     -> Handler ApiNetworkInformation
 getNetworkInformation st nl = do
     now <- liftIO $ currentRelativeTime' ti
-    utcNow <- liftIO $ ti (fromRelativeTime now)
     nodeTip <- liftHandler (NW.currentNodeTip nl)
     apiNodeTip <- liftIO $ makeApiBlockReferenceFromHeader ti nodeTip
     nowInfo <- handle (\(_ :: PastHorizonException) -> pure Nothing)
         $ liftIO $ fmap Just $ networkTipInfo now
     progress <- handle (\(_ :: PastHorizonException) -> pure NotResponding)
-        $ liftIO (syncProgress st ti nodeTip utcNow)
+        $ liftIO (syncProgress st ti nodeTip now)
     pure $ Api.ApiNetworkInformation
         { Api.syncProgress = ApiT progress
         , Api.nextEpoch = snd <$> nowInfo

lib/core/src/Cardano/Wallet/DB/Model.hs

@@ -69,7 +69,7 @@ import Prelude
 import Cardano.Wallet.Primitive.Model
     ( Wallet, currentTip, utxo )
 import Cardano.Wallet.Primitive.Slotting
-    ( TimeInterpreter, epochOf, startTime )
+    ( TimeInterpreter, epochOf, slotToUTCTime )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (blockHeight, slotNo)
     , DelegationCertificate (..)
@@ -337,7 +337,7 @@ mReadWalletMeta
 mReadWalletMeta interpretTime wid db@(Database wallets _) =
     (Right (mkMetadata =<< Map.lookup wid wallets), db)
   where
-    epochOf' = runIdentity . interpretTime . epochOf
+    epochOf' = runIdentity . interpretTime . const . epochOf
     mkMetadata :: WalletDatabase s xprv -> Maybe WalletMetadata
     mkMetadata WalletDatabase{checkpoints,certificates,metadata} = do
         (slot, _) <- Map.lookupMax checkpoints
@@ -417,17 +417,16 @@ mPutTxHistory wid txList db@Database{wallets,txs} =
 mReadTxHistory
     :: forall wid s xprv. Ord wid
     => TimeInterpreter Identity
-    -> StartTime
     -> wid
     -> Maybe (Quantity "lovelace" Natural)
     -> SortOrder
     -> Range SlotNo
     -> Maybe TxStatus
     -> ModelOp wid s xprv [TransactionInfo]
-mReadTxHistory ti startTime wid minWithdrawal order range mstatus db@(Database wallets txs) =
+mReadTxHistory ti wid minWithdrawal order range mstatus db@(Database wallets txs) =
     (Right res, db)
   where
-    slotStartTime' = runIdentity . ti (slotToUTCTime startTime)
+    slotStartTime' = runIdentity . ti . slotToUTCTime
     res = fromMaybe mempty $ do
         wal <- Map.lookup wid wallets
         (_, cp) <- Map.lookupMax (checkpoints wal)

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

@@ -18,6 +18,7 @@ module Cardano.Wallet.Primitive.Slotting
       currentEpoch
     , epochOf
     , slotToUTCTime
+    , slotToRelTime
     , toSlotId
     , slotRangeFromRelativeTimeRange
     , slotRangeFromTimeRange
@@ -135,10 +136,11 @@ toSlotId slot = do
     downCast = fromIntegral
 
 -- | Query the time at which a slot starts.
---
--- fixme: perhaps include slot length in result
 slotToUTCTime :: SlotNo -> StartTime -> HF.Qry UTCTime
-slotToUTCTime sl start = Cardano.fromRelativeTime (coerce start) . fst <$> HF.slotToWallclock sl
+slotToUTCTime sl start = Cardano.fromRelativeTime (coerce start) <$> slotToRelTime sl
+
+slotToRelTime :: SlotNo -> HF.Qry RelativeTime
+slotToRelTime = fmap fst . HF.slotToWallclock
 
 -- | Can be used to know when the next epoch starts.
 --

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

@@ -20,9 +20,9 @@ module Cardano.Wallet.Primitive.SyncProgress
 import Prelude
 
 import Cardano.Wallet.Primitive.Slotting
-    ( TimeInterpreter, getStartTime, slotToUTCTime )
+    ( TimeInterpreter, slotToRelTime )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader (..), StartTime (..) )
+    ( BlockHeader (..) )
 import Control.DeepSeq
     ( NFData (..) )
 import Data.Bifunctor
@@ -34,13 +34,15 @@ import Data.Ratio
 import Data.Text.Class
     ( FromText (..), TextDecodingError (..), ToText (..) )
 import Data.Time.Clock
-    ( NominalDiffTime, UTCTime, diffUTCTime )
+    ( NominalDiffTime )
 import Fmt
     ( Buildable, build )
 import GHC.Generics
     ( Generic )
 import GHC.Stack
     ( HasCallStack )
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types
+    ( RelativeTime (..), diffRelTime )
 
 data SyncProgress
     = Ready
@@ -120,20 +122,14 @@ syncProgress
         -- ^ Converts slots to actual time.
     -> BlockHeader
         -- ^ Local tip
-    -> UTCTime
+    -> RelativeTime
         -- ^ Current Time
     -> m SyncProgress
 syncProgress (SyncTolerance tolerance) ti tip now = do
-    tipTime <- ti $ slotToUTCTime $ slotNo tip
-    -- fixme: consider using RelativeTime for now -- makes the calculation simpler
-    StartTime genesisDate <- ti getStartTime
-    let timeRemaining = now `diffUTCTime` tipTime
-    let timeCovered = tipTime `diffUTCTime` genesisDate
-
-    -- Using (max 1) to avoid division by 0.
-    let progress = (convert timeCovered)
-            % max 1 (convert $ timeCovered + timeRemaining)
-    if timeRemaining < tolerance || timeRemaining < 0 || progress >= 1 then
+    timeCovered <- ti $ const $ slotToRelTime $ slotNo tip
+    let progress = convert timeCovered % convert now
+
+    if withinTolerance timeCovered now then
         return Ready
     else
         return
@@ -144,7 +140,9 @@ syncProgress (SyncTolerance tolerance) ti tip now = do
         . toRational
         $ progress
   where
-    convert :: NominalDiffTime -> Integer
-    convert = round
+    convert :: RelativeTime -> Int
+    convert = round . (* 1000) . getRelativeTime
+
+    withinTolerance a b = let dt = b `diffRelTime` a in dt < tolerance || dt < 0
 
     errMsg x = "syncProgress: " ++ show x ++ " is out of bounds"