Make slotting functions simpler

cardano-foundation · Dec 1, 2020 · 24c2c7b · 24c2c7b
1 parent 9899d9c
commit 24c2c7b
Show file tree

Hide file tree

Showing 15 changed files with 315 additions and 317 deletions.
diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -900,8 +900,8 @@ selectPoolProduction
     -> EpochNo
     -> SqlPersistT IO [PoolProduction]
 selectPoolProduction timeInterpreter epoch = do
-    e <- liftIO $ timeInterpreter $ firstSlotInEpoch epoch
-    eplus1 <- liftIO $ timeInterpreter $ firstSlotInEpoch (epoch + 1)
+    (e, eplus1) <- liftIO $ timeInterpreter
+        ((,) <$> firstSlotInEpoch epoch <*> firstSlotInEpoch (epoch + 1))
     fmap entityVal <$> selectList
         [ PoolProductionSlot >=. e
         , PoolProductionSlot <. eplus1 ]

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
@@ -287,9 +287,11 @@ import Cardano.Wallet.Primitive.Model
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException (..)
     , TimeInterpreter
+    , addRelTime
     , ceilingSlotAt
+    , currentRelativeTime
     , slotRangeFromTimeRange
-    , startTime
+    , slotToUTCTime
     )
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncProgress, SyncTolerance (..), syncProgress )
@@ -415,7 +417,7 @@ import Data.Set
 import Data.Text.Class
     ( ToText (..) )
 import Data.Time.Clock
-    ( NominalDiffTime, UTCTime, addUTCTime, getCurrentTime )
+    ( NominalDiffTime, UTCTime, getCurrentTime )
 import Data.Type.Equality
     ( (:~:) (..), testEquality )
 import Data.Vector.Shuffle
@@ -713,9 +715,9 @@ 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
+    (_, _, st) = ctx ^. genesisData
 
     ti :: TimeInterpreter IO
     ti = timeInterpreter (ctx ^. networkLayer @t)
@@ -1661,7 +1663,7 @@ getTxExpiry
     -- ^ Time to live (TTL) in seconds from now.
     -> IO (Either PastHorizonException SlotNo)
 getTxExpiry ti maybeTTL = do
-    expTime <- addUTCTime ttl <$> getCurrentTime
+    expTime <- addRelTime ttl <$> currentRelativeTime ti
     try $ ti $ ceilingSlotAt expTime
   where
     ttl = fromMaybe defaultTTL maybeTTL
@@ -1894,7 +1896,7 @@ mkTxMeta interpretTime blockHeader wState tx cs expiry =
                 }
             )
   where
-    slotStartTime' = interpretTime . startTime
+    slotStartTime' = interpretTime . slotToUTCTime
 
     ourCoins :: TxOut -> Maybe Natural
     ourCoins (TxOut addr (Coin val)) =

diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs
@@ -221,6 +221,7 @@ import Cardano.Wallet.Api.Types
     , WalletPutData (..)
     , WalletPutPassphraseData (..)
     , getApiMnemonicT
+    , toApiEpochInfo
     , toApiNetworkParameters
     , toApiUtxoStatistics
     )
@@ -280,12 +281,13 @@ import Cardano.Wallet.Primitive.Model
     ( Wallet, availableBalance, currentTip, getState, totalBalance )
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException
+    , RelativeTime
     , TimeInterpreter
     , currentEpoch
-    , endTimeOfEpoch
-    , firstSlotInEpoch
+    , currentRelativeTime
     , ongoingSlotAt
-    , startTime
+    , slotToUTCTime
+    , timeOfEpoch
     , toSlotId
     )
 import Cardano.Wallet.Primitive.SyncProgress
@@ -348,12 +350,8 @@ import Control.Monad.Catch
     ( handle, try )
 import Control.Monad.IO.Class
     ( MonadIO, liftIO )
-import Control.Monad.Trans.Class
-    ( lift )
 import Control.Monad.Trans.Except
     ( ExceptT (..), runExceptT, throwE, withExceptT )
-import Control.Monad.Trans.Maybe
-    ( MaybeT (..) )
 import Control.Tracer
     ( Tracer )
 import Data.Aeson
@@ -398,8 +396,6 @@ import Data.Text.Class
     ( FromText (..), ToText (..) )
 import Data.Time
     ( UTCTime )
-import Data.Time.Clock
-    ( getCurrentTime )
 import Data.Void
     ( Void )
 import Data.Word
@@ -458,7 +454,6 @@ 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
-import qualified Cardano.Wallet.Primitive.Slotting as S
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Cardano.Wallet.Primitive.Types.Tx as W
 import qualified Cardano.Wallet.Registry as Registry
@@ -720,7 +715,7 @@ mkShelleyWallet ctx wid cp meta pending progress = do
     ti :: TimeInterpreter IO
     ti = timeInterpreter (ctx ^. networkLayer @t)
 
-    -- This may fail
+    -- The epoch to utc time conversion may fail
     -- 1. In Byron when running Byron;Shelley
     -- 2. In Shelley when running Byron;Shelley;SomethingElse
     --
@@ -731,13 +726,9 @@ mkShelleyWallet ctx wid cp meta pending progress = do
     -- 2. We are currently only targeting Byron;Shelley.
     --
     -- so it shouldn't be a problem.
-    toApiEpochInfo ep = do
-        time <- ti (firstSlotInEpoch ep >>= startTime)
-        return $ ApiEpochInfo (ApiT ep) time
-
     toApiWalletDelegation W.WalletDelegation{active,next} = do
         apiNext <- forM next $ \W.WalletDelegationNext{status,changesAt} -> do
-            info <- toApiEpochInfo changesAt
+            info <- ti $ toApiEpochInfo changesAt
             return $ toApiWalletDelegationNext (Just info) status
 
         return $ ApiWalletDelegation
@@ -1752,19 +1743,15 @@ assignMigrationAddresses addrs selections =
 -------------------------------------------------------------------------------}
 
 data ErrCurrentEpoch
-    = ErrUnableToDetermineCurrentEpoch
+    = ErrUnableToDetermineCurrentEpoch  -- fixme: unused
     | ErrCurrentEpochPastHorizonException PastHorizonException
 
 getCurrentEpoch
     :: forall ctx s t k . (ctx ~ ApiLayer s t k)
     => ctx
     -> Handler W.EpochNo
-getCurrentEpoch ctx = do
-    res <- liftIO $ try $ currentEpoch ti
-    case res of
-        Right Nothing  -> liftE ErrUnableToDetermineCurrentEpoch
-        Right (Just x) -> pure x
-        Left e@(S.PastHorizon{}) -> liftE (ErrCurrentEpochPastHorizonException e)
+getCurrentEpoch ctx = liftIO (try $ currentEpoch ti) >>=
+    either (liftE . ErrCurrentEpochPastHorizonException) pure
   where
     ti :: TimeInterpreter IO
     ti = timeInterpreter (ctx ^. networkLayer @t)
@@ -1775,10 +1762,11 @@ getNetworkInformation
     -> NetworkLayer IO t Block
     -> Handler ApiNetworkInformation
 getNetworkInformation st nl = do
-    now <- liftIO getCurrentTime
-    nodeTip <-  liftHandler (NW.currentNodeTip nl)
+    now <- liftIO $ currentRelativeTime ti
+    nodeTip <- liftHandler (NW.currentNodeTip nl)
     apiNodeTip <- liftIO $ makeApiBlockReferenceFromHeader ti nodeTip
-    nowInfo <- liftIO $ runMaybeT $ networkTipInfo now
+    nowInfo <- handle (\(_ :: PastHorizonException) -> pure Nothing)
+        $ liftIO $ Just <$> networkTipInfo now
     progress <- handle (\(_ :: PastHorizonException) -> pure NotResponding)
         $ liftIO (syncProgress st ti nodeTip now)
     pure $ Api.ApiNetworkInformation
@@ -1793,22 +1781,16 @@ getNetworkInformation st nl = do
 
     -- (network tip, next epoch)
     -- May be unavailible if the node is still syncing.
-    networkTipInfo :: UTCTime -> MaybeT IO (ApiSlotReference, ApiEpochInfo)
-    networkTipInfo now = handle handlePastHorizonException $ do
-        networkTipSlot <- MaybeT (ti $ ongoingSlotAt now)
-        tip <- lift $ makeApiSlotReference ti networkTipSlot
+    networkTipInfo :: RelativeTime -> IO (ApiSlotReference, ApiEpochInfo)
+    networkTipInfo now = do
+        networkTipSlot <- ti $ ongoingSlotAt now
+        tip <- makeApiSlotReference ti networkTipSlot
         let curEpoch = tip ^. #slotId . #epochNumber . #getApiT
-        nextEpochStart <- lift $ ti $ endTimeOfEpoch curEpoch
+        (_, nextEpochStart) <- ti $ timeOfEpoch curEpoch
         let nextEpoch = ApiEpochInfo
                 (ApiT $ succ curEpoch)
                 nextEpochStart
         return (tip, nextEpoch)
-      where
-        handlePastHorizonException
-            :: PastHorizonException
-            -> MaybeT IO (ApiSlotReference, ApiEpochInfo)
-        handlePastHorizonException _ =
-            MaybeT (pure Nothing)
 
 getNetworkParameters
     :: (Block, NetworkParameters, SyncTolerance)
@@ -1821,9 +1803,7 @@ getNetworkParameters (_block0, genesisNp, _st) nl = do
             { protocolParameters = pp, slottingParameters = sp }
     case epochNoM of
         Just epochNo -> do
-            epochStartTime <-
-                liftIO $ timeInterpreter nl
-                (firstSlotInEpoch epochNo >>= startTime)
+            (epochStartTime, _) <- liftIO $ timeInterpreter nl $ timeOfEpoch epochNo
             pure $ apiNetworkParams
                 { hardforkAt = Just $
                     ApiEpochInfo (ApiT epochNo) epochStartTime }
@@ -2104,7 +2084,7 @@ makeApiBlockReference
     -> m ApiBlockReference
 makeApiBlockReference ti sl height = do
     slotId <- ti (toSlotId sl)
-    slotTime <- ti (startTime sl)
+    slotTime <- ti (slotToUTCTime sl)
     return $ ApiBlockReference
         { absoluteSlotNumber = ApiT sl
         , slotId = apiSlotId slotId
@@ -2121,14 +2101,13 @@ makeApiBlockReferenceFromHeader ti tip =
     makeApiBlockReference ti (tip ^. #slotNo) (natural $ tip ^. #blockHeight)
 
 makeApiSlotReference
-    :: Monad m
-    => TimeInterpreter m
+    :: TimeInterpreter m
     -> SlotNo
     -> m ApiSlotReference
 makeApiSlotReference ti sl =
-    ApiSlotReference (ApiT sl)
-        <$> fmap apiSlotId (ti $ toSlotId sl)
-        <*> ti (startTime sl)
+    ti (ApiSlotReference (ApiT sl)
+        <$> fmap apiSlotId (toSlotId sl)
+        <*> slotToUTCTime sl)
 
 getWalletTip
     :: Monad m

diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs
@@ -14,6 +14,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -52,6 +53,7 @@ module Cardano.Wallet.Api.Types
     , AnyAddressType (..)
     , ApiCertificate (..)
     , ApiEpochInfo (..)
+    , toApiEpochInfo
     , ApiSelectCoinsData (..)
     , ApiSelectCoinsPayments (..)
     , ApiSelectCoinsAction (..)
@@ -185,6 +187,8 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Random
     ( RndState )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( AddressPoolGap, SeqState, getAddressPoolGap )
+import Cardano.Wallet.Primitive.Slotting
+    ( Qry, timeOfEpoch )
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncProgress (..) )
 import Cardano.Wallet.Primitive.Types
@@ -226,7 +230,7 @@ import Codec.Binary.Bech32
     ( dataPartFromBytes, dataPartToBytes )
 import Codec.Binary.Bech32.TH
     ( humanReadablePart )
-import Codec.Binary.Encoding
+import "cardano-addresses" Codec.Binary.Encoding
     ( AbstractEncoding (..), detectEncoding, encode )
 import Control.Applicative
     ( optional, (<|>) )
@@ -452,6 +456,9 @@ data ApiEpochInfo = ApiEpochInfo
     } deriving (Eq, Generic, Show)
       deriving anyclass NFData
 
+toApiEpochInfo :: EpochNo -> Qry ApiEpochInfo
+toApiEpochInfo ep = ApiEpochInfo (ApiT ep) . fst <$> timeOfEpoch ep
+
 data ApiSelectCoinsData (n :: NetworkDiscriminant)
     = ApiSelectForPayment (ApiSelectCoinsPayments n)
     | ApiSelectForDelegation ApiSelectCoinsAction

diff --git a/lib/core/src/Cardano/Wallet/DB/Model.hs b/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 (..)
@@ -426,7 +426,7 @@ mReadTxHistory
 mReadTxHistory ti wid minWithdrawal order range mstatus db@(Database wallets txs) =
     (Right res, db)
   where
-    slotStartTime' = runIdentity . ti . startTime
+    slotStartTime' = runIdentity . ti . slotToUTCTime
     res = fromMaybe mempty $ do
         wal <- Map.lookup wid wallets
         (_, cp) <- Map.lookupMax (checkpoints wal)

diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs
@@ -106,7 +106,7 @@ import Cardano.Wallet.Primitive.AddressDerivation.Icarus
 import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( ShelleyKey )
 import Cardano.Wallet.Primitive.Slotting
-    ( TimeInterpreter, epochOf, firstSlotInEpoch, startTime )
+    ( TimeInterpreter, epochOf, firstSlotInEpoch, slotToUTCTime )
 import Control.Concurrent.MVar
     ( modifyMVar, modifyMVar_, newMVar, readMVar )
 import Control.Exception
@@ -1009,8 +1009,8 @@ readWalletDelegation
 readWalletDelegation ti wid epoch
     | epoch == 0 = pure $ W.WalletDelegation W.NotDelegating []
     | otherwise = do
-        eMinus1 <- liftIO $ ti $ firstSlotInEpoch (epoch - 1)
-        e <- liftIO $ ti $ firstSlotInEpoch epoch
+        (eMinus1, e) <- liftIO $ ti $
+            (,) <$> firstSlotInEpoch (epoch - 1) <*> firstSlotInEpoch epoch
         active <- maybe W.NotDelegating toWalletDelegationStatus
             <$> readDelegationCertificate wid
                 [ CertSlot <. eMinus1
@@ -1268,7 +1268,7 @@ txHistoryFromEntity
 txHistoryFromEntity ti tip metas ins outs ws =
     mapM mkItem metas
   where
-    startTime' = ti . startTime
+    startTime' = ti . slotToUTCTime
     mkItem m = mkTxWith (txMetaTxId m) (txMetaData m) (mkTxDerived m)
     mkTxWith txid meta derived = do
         t <- startTime' (derived ^. #slotNo)

diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
@@ -269,10 +269,9 @@ getSlottingParametersForTip nl = do
     -- This requires code changes in the shelley ledger.
     let getActiveSlotCoeff = pure (ActiveSlotCoefficient 1.0)
 
-    SlottingParameters
-        <$> timeInterpreter nl (querySlotLength tip)
-        <*> timeInterpreter nl (queryEpochLength tip)
-        <*> getActiveSlotCoeff
+    (slotLen, epLen) <- timeInterpreter nl
+        ((,) <$> querySlotLength tip <*> queryEpochLength tip)
+    SlottingParameters slotLen epLen <$> getActiveSlotCoeff
 
 {-------------------------------------------------------------------------------
                                 Chain Sync