Merge #1901

1901: Use SlotNo and TimeInterpreter r=Anviking a=Anviking

# Issue Number

ADP-356 #1868 #1869 


# Overview

- [x] Add TimeInterpreter, necessary queries, and a way to run them
Add tests comparing them with old implementation

- [x] Fundamentally change wallet to use SlotNo instead of SlotId
    - Patch together cardano-wallet-jormungandr to still work, despite the
binary using SlotId.

- [x] Remove redundant byron code

- [x] Sync progress calculation compares times now instead of slots

- [x] Rename the `slot` tables to `slot_no` to force automatic migration, preventing catastrophic re-interpretation of old data

# Comments

- Depends on #1890 

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

<!-- 
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Once created, link this PR to its corresponding ticket
 ✓ Assign the PR to a corresponding milestone
 ✓ Acknowledge any changes required to the Wiki
-->


Co-authored-by: Johannes Lund <johannes.lund@iohk.io>

lib/byron/bench/Cardano/Wallet/Primitive/AddressDiscovery/Any/TH.hs

@@ -37,6 +37,6 @@ share
     [persistLowerCase|
 AnyAddressState
     anyAddressStateWalletId        W.WalletId  sql=wallet_id
-    anyAddressStateCheckpointSlot  W.SlotId    sql=slot
+    anyAddressStateCheckpointSlot  W.SlotNo    sql=slot
     anyAddressStateProportion      Double      sql=proportion
 |]

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 #-}
@@ -97,9 +98,9 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Random
 import Cardano.Wallet.Primitive.Model
     ( currentTip, totalUTxO )
 import Cardano.Wallet.Primitive.Slotting
-    ( slotAt, slotParams )
+    ( TimeInterpreter )
 import Cardano.Wallet.Primitive.SyncProgress
-    ( SyncProgress (..), mkSyncTolerance, syncProgressRelativeToTime )
+    ( SyncProgress (..), mkSyncTolerance, syncProgress )
 import Cardano.Wallet.Primitive.Types
     ( Address
     , Block (..)
@@ -108,7 +109,7 @@ import Cardano.Wallet.Primitive.Types
     , Coin (..)
     , GenesisParameters (..)
     , NetworkParameters (..)
-    , SlotId (..)
+    , SlotNo (..)
     , WalletId (..)
     , WalletName (..)
     , computeUtxoStatistics
@@ -132,8 +133,6 @@ import Control.Tracer
     ( Tracer (..), traceWith )
 import Criterion.Measurement
     ( getTime, initializeTime, secs )
-import Data.Maybe
-    ( fromMaybe )
 import Data.Proxy
     ( Proxy (..) )
 import Data.Quantity
@@ -369,7 +368,7 @@ bench_restoration _proxy tracer socketPath np vData progressLogFile (wid, wname,
         let gp = genesisParameters np
         let convert = fromByronBlock gp
         let nw = convert <$> nw'
-        withBenchDBLayer @s @k tracer $ \db -> do
+        withBenchDBLayer @s @k tracer (timeInterpreter nw) $ \db -> do
             BlockHeader sl _ _ _ <- unsafeRunExceptT $ currentNodeTip nw
             sayErr . fmt $ networkText ||+ " tip is at " +|| sl ||+ ""
 
@@ -413,11 +412,12 @@ withBenchDBLayer
         , PersistPrivateKey (k 'RootK)
         )
     => Trace IO Text
+    -> TimeInterpreter IO
     -> (DBLayer IO s k -> IO a)
     -> IO a
-withBenchDBLayer tr action =
+withBenchDBLayer tr ti action =
     withSystemTempFile "bench.db" $ \dbFile _ -> do
-        let before = newDBLayer (trMessageText tr) migrationDefaultValues (Just dbFile)
+        let before = newDBLayer (trMessageText tr) migrationDefaultValues (Just dbFile) ti
         let after = destroyDBLayer . fst
         bracket before after $ \(ctx, db) -> do
             migrateDB ctx
@@ -433,7 +433,7 @@ withBenchDBLayer tr action =
     migrateDB ctx = unsafeRunQuery ctx (void $ runMigrationSilent migrateAll)
 
 
-logChunk :: SlotId -> IO ()
+logChunk :: SlotNo -> IO ()
 logChunk slot = sayErr . fmt $ "Processing "+||slot||+""
 
 prepareNode
@@ -449,7 +449,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
@@ -463,12 +463,12 @@ waitForWalletSync
     -> IO ()
 waitForWalletSync walletLayer wid gp vData = do
     (w, _, _) <- unsafeRunExceptT $ W.readWallet walletLayer wid
-    let tol = mkSyncTolerance 3600
-    prog <- syncProgressRelativeToTime
-                tol
-                (slotParams gp)
+    let tolerance = mkSyncTolerance 3600
+    prog <- syncProgress
+                tolerance
+                (timeInterpreter nl)
                 (currentTip w)
-                <$> getCurrentTime
+                =<< getCurrentTime
     case prog of
         Ready -> return ()
         NotResponding -> do
@@ -478,41 +478,37 @@ waitForWalletSync walletLayer wid gp vData = do
             sayErr . fmt $ "[INFO] restoring: "+|p|+""
             threadDelay 1000000
             waitForWalletSync walletLayer wid gp vData
+  where
+    WalletLayer _ _ nl _ _ = walletLayer
 
 -- | Poll the network tip until it reaches the slot corresponding to the current
 -- time.
 waitForNodeSync
     :: NetworkLayer IO (IO Byron) Block
-    -> (SlotId -> SlotId -> IO ())
-    -> GenesisParameters
-    -> IO SlotId
-waitForNodeSync nw logSlot gp = loop 10
+    -> (SlotNo -> SlotNo -> IO ())
+    -> IO SlotNo
+waitForNodeSync nw _logSlot = loop 10
   where
-    loop :: Int -> IO SlotId
+    loop :: Int -> IO SlotNo
     loop retries = runExceptT (currentNodeTip nw) >>= \case
-        Right (BlockHeader tipBlockSlot _ _ _) -> do
-            currentSlot <- getCurrentSlot
-            logSlot tipBlockSlot currentSlot
-            if tipBlockSlot < currentSlot
-                then do
+        Right nodeTip -> do
+            let tolerance = mkSyncTolerance 60
+            prog <- syncProgress
+                        tolerance
+                        (timeInterpreter nw)
+                        nodeTip
+                        =<< getCurrentTime
+            if prog == Ready
+                then pure (slotNo nodeTip)
+                else do
                     -- 2 seconds poll interval
                     threadDelay 2000000
                     loop retries
-                else
-                    pure tipBlockSlot
         Left e | retries > 0 -> do
                      sayErr "Fetching tip failed, retrying shortly..."
                      threadDelay 15000000
                      loop (retries - 1)
                | otherwise -> throwIO e
 
-    getCurrentSlot :: IO SlotId
-    getCurrentSlot = do
-        let sp = slotParams gp
-        fromMaybe (error errMsg) . slotAt sp <$> getCurrentTime
-      where
-        errMsg = "getCurrentSlot: is the current time earlier than the\
-                 \start time of the blockchain"
-
-logQuiet :: SlotId -> SlotId -> IO ()
+logQuiet :: SlotNo -> SlotNo -> IO ()
 logQuiet _ _ = pure ()

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

@@ -283,6 +283,7 @@ serveWallet
                     minimumUTxOvalue (protocolParameters np)
                 }
             )
+            (timeInterpreter nl)
             databaseDir
         Server.newApiLayer walletEngineTracer params nl' tl db
             Server.idleWorker

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

@@ -180,28 +180,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/Compatibility.hs

@@ -222,8 +222,8 @@ emptyGenesis gp = W.Block
     { transactions = []
     , delegations  = []
     , header = W.BlockHeader
-        { slotId =
-            W.SlotId 0 0
+        { slotNo =
+            W.SlotNo 0
         , blockHeight =
             Quantity 0
         , headerHash =
@@ -299,12 +299,11 @@ hashOfNoParent = W.Hash . BS.pack $ replicate 0 32
 
 toPoint
     :: W.Hash "Genesis"
-    -> W.EpochLength
     -> W.BlockHeader
     -> Point ByronBlock
-toPoint genesisH epLength (W.BlockHeader sid _ h _)
+toPoint genesisH (W.BlockHeader sl _ h _)
   | h == (coerce genesisH) = O.GenesisPoint
-  | otherwise = O.Point $ Point.block (toSlotInEpoch epLength sid) (toByronHash h)
+  | otherwise = O.Point $ Point.block sl (toByronHash h)
 
 toSlotInEpoch :: W.EpochLength -> W.SlotId -> SlotNo
 toSlotInEpoch epLength =
@@ -334,18 +333,19 @@ fromByronBlock gp byronBlk = case byronBlockRaw byronBlk of
   ABOBBoundary _ ->
     mkBlock []
   where
-    W.GenesisParameters genesisHash _ _ epLength _ _ = gp
+    W.GenesisParameters { getGenesisBlockHash } = gp
     mkBlock :: [W.Tx] -> W.Block
     mkBlock txs = W.Block
         { header = W.BlockHeader
-            { slotId =
-                fromSlotNo epLength $ blockSlot byronBlk
+            { slotNo =
+                blockSlot byronBlk
             , blockHeight =
                 fromBlockNo $ blockNo byronBlk
             , headerHash =
                 fromByronHash $ blockHash byronBlk
             , parentHeaderHash =
-                fromChainHash genesisHash $ headerPrevHash (byronCodecConfig gp) (getHeader byronBlk)
+                fromChainHash getGenesisBlockHash
+                    $ headerPrevHash (byronCodecConfig gp) (getHeader byronBlk)
             }
         , transactions = txs
         , delegations  = []
@@ -397,16 +397,16 @@ fromBlockNo :: BlockNo -> Quantity "block" Word32
 fromBlockNo (BlockNo h) =
     Quantity (fromIntegral h)
 
-fromTip :: W.Hash "Genesis" -> W.EpochLength -> Tip ByronBlock -> W.BlockHeader
-fromTip genesisHash epLength tip = case getPoint (getTipPoint tip) of
+fromTip :: W.Hash "Genesis" -> Tip ByronBlock -> W.BlockHeader
+fromTip genesisHash tip = case getPoint (getTipPoint tip) of
     Origin -> W.BlockHeader
-        { slotId = W.SlotId 0 0
+        { slotNo = W.SlotNo 0
         , blockHeight = Quantity 0
         , headerHash = coerce genesisHash
         , parentHeaderHash = hashOfNoParent
         }
     At blk -> W.BlockHeader
-        { slotId = fromSlotNo epLength $ Point.blockPointSlot blk
+        { slotNo = Point.blockPointSlot blk
         , blockHeight = fromBlockNo $ getLegacyTipBlockNo tip
         , headerHash = fromByronHash $ Point.blockPointHash blk
         -- TODO

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

@@ -41,14 +41,15 @@ import Cardano.Wallet.Byron.Compatibility
     ( Byron
     , byronCodecConfig
     , fromChainHash
-    , fromSlotNo
     , fromTip
     , protocolParametersFromUpdateState
     , toGenTx
     , toPoint
     )
 import Cardano.Wallet.Network
     ( Cursor, ErrPostTx (..), NetworkLayer (..), mapCursor )
+import Cardano.Wallet.Primitive.Slotting
+    ( singleEraInterpreter )
 import Control.Concurrent
     ( ThreadId )
 import Control.Concurrent.Async
@@ -93,6 +94,8 @@ import Data.ByteString.Lazy
     ( ByteString )
 import Data.Function
     ( (&) )
+import Data.Functor.Identity
+    ( runIdentity )
 import Data.List
     ( isInfixOf )
 import Data.Quantity
@@ -232,17 +235,17 @@ withNetworkLayer tr np addrInfo versionData action = do
             , nextBlocks = _nextBlocks
             , initCursor = _initCursor
             , destroyCursor = _destroyCursor
-            , cursorSlotId = _cursorSlotId
+            , cursorSlotNo = _cursorSlotNo
             , getProtocolParameters = atomically $ readTVar protocolParamsVar
             , postTx = _postTx localTxSubmissionQ
             , stakeDistribution = _stakeDistribution
             , getAccountBalance = _getAccountBalance
+            , timeInterpreter = pure . runIdentity . singleEraInterpreter gp
             , watchNodeTip = _watchNodeTip
             }
   where
     gp@W.GenesisParameters
         { getGenesisBlockHash
-        , getEpochLength
         } = W.genesisParameters np
 
     _initCursor headers = do
@@ -252,7 +255,7 @@ withNetworkLayer tr np addrInfo versionData action = do
         thread <- async (connectClient tr handlers client versionData addrInfo)
         link thread
         let points = reverse $ genesisPoint :
-                (toPoint getGenesisBlockHash getEpochLength <$> headers)
+                (toPoint getGenesisBlockHash <$> headers)
         let findIt = chainSyncQ `send` CmdFindIntersection points
         traceWith tr $ MsgFindIntersection headers
         res <- findIt
@@ -277,14 +280,14 @@ withNetworkLayer tr np addrInfo versionData action = do
         let toCursor point = Cursor thread point chainSyncQ
         liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks
 
-    _cursorSlotId (Cursor _ point _) = do
-        fromSlotNo getEpochLength $ fromWithOrigin (SlotNo 0) $ pointSlot point
+    _cursorSlotNo (Cursor _ point _) = do
+        fromWithOrigin (SlotNo 0) $ pointSlot point
 
     _getAccountBalance _ =
         pure (Quantity 0)
 
     _currentNodeTip nodeTipVar =
-        fromTip getGenesisBlockHash getEpochLength <$> atomically (readTVar nodeTipVar)
+        fromTip getGenesisBlockHash <$> atomically (readTVar nodeTipVar)
 
     _postTx localTxSubmissionQ tx = do
         liftIO $ traceWith tr $ MsgPostSealedTx tx
@@ -330,8 +333,7 @@ mkWalletClient gp chainSyncQ = do
     pure $ nodeToClientProtocols (const $ pure $ NodeToClientProtocols
         { localChainSyncProtocol =
             let
-                fromTip' =
-                    fromTip getGenesisBlockHash getEpochLength
+                fromTip' = fromTip getGenesisBlockHash
                 codec = cChainSyncCodec codecs
             in
             InitiatorProtocolOnly $ MuxPeerRaw
@@ -348,8 +350,7 @@ mkWalletClient gp chainSyncQ = do
         NodeToClientV_2
   where
     W.GenesisParameters
-        { getEpochLength
-        , getGenesisBlockHash
+        { getGenesisBlockHash
         } = gp
 
     codecs :: MonadST m => ClientCodecs ByronBlock m
@@ -402,7 +403,7 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onProtocolParamsUpdate = do
 
     onTipUpdate' <- debounce $ \tip -> do
         traceWith tr $
-            MsgNodeTip $ fromTip getGenesisBlockHash getEpochLength tip
+            MsgNodeTip $ fromTip getGenesisBlockHash tip
         onTipUpdate tip
         queryLocalState (getTipPoint tip)
 
@@ -440,7 +441,6 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onProtocolParamsUpdate = do
   where
     gp@W.GenesisParameters
         { getGenesisBlockHash
-        , getEpochLength
         } = W.genesisParameters np
 
     codecs :: MonadST m => DefaultCodecs ByronBlock m