{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Consensus.HardFork.History.Caching ( RunWithCachedSummary (..) , runWithCachedSummary ) where import Data.Kind (Type) import Ouroboros.Consensus.HardFork.History.Qry import Ouroboros.Consensus.HardFork.History.Summary import Ouroboros.Consensus.Util.IOLike {------------------------------------------------------------------------------- Caching the summary -------------------------------------------------------------------------------} -- | Stateful abstraction to execute queries data RunWithCachedSummary (xs :: [Type]) m = RunWithCachedSummary { -- | Run the specified query -- -- If the query fails with a 'PastHorizonException', it will update its -- internal state (compute a new summary) and try again. If that /still/ -- fails, the 'PastHorizonException' is returned. -- forall (xs :: [*]) (m :: * -> *). RunWithCachedSummary xs m -> forall a. Qry a -> STM m (Either PastHorizonException a) cachedRunQuery :: forall a. Qry a -> STM m (Either PastHorizonException a) } -- | Construct 'RunWithCachedSummary' given action that computes the summary -- -- Most use cases will probably construct this action from an action that reads -- the ledger state and then computes the summary from that. runWithCachedSummary :: forall m xs. MonadSTM m => STM m (Summary xs) -> m (RunWithCachedSummary xs m) runWithCachedSummary :: forall (m :: * -> *) (xs :: [*]). MonadSTM m => STM m (Summary xs) -> m (RunWithCachedSummary xs m) runWithCachedSummary STM m (Summary xs) getLatestSummary = do Summary xs initSummary <- STM m (Summary xs) -> m (Summary xs) forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically STM m (Summary xs) getLatestSummary StrictTVar m (Summary xs) var <- Summary xs -> m (StrictTVar m (Summary xs)) forall (m :: * -> *) a. (HasCallStack, MonadSTM m, NoThunks a) => a -> m (StrictTVar m a) newTVarIO Summary xs initSummary RunWithCachedSummary xs m -> m (RunWithCachedSummary xs m) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return (RunWithCachedSummary xs m -> m (RunWithCachedSummary xs m)) -> RunWithCachedSummary xs m -> m (RunWithCachedSummary xs m) forall a b. (a -> b) -> a -> b $ RunWithCachedSummary { cachedRunQuery :: forall a. Qry a -> STM m (Either PastHorizonException a) cachedRunQuery = StrictTVar m (Summary xs) -> Qry a -> STM m (Either PastHorizonException a) forall a. StrictTVar m (Summary xs) -> Qry a -> STM m (Either PastHorizonException a) go StrictTVar m (Summary xs) var } where go :: StrictTVar m (Summary xs) -> Qry a -> STM m (Either PastHorizonException a) go :: forall a. StrictTVar m (Summary xs) -> Qry a -> STM m (Either PastHorizonException a) go StrictTVar m (Summary xs) var Qry a q = do Summary xs summary <- StrictTVar m (Summary xs) -> STM m (Summary xs) forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a readTVar StrictTVar m (Summary xs) var case Qry a -> Summary xs -> Either PastHorizonException a forall a (xs :: [*]). HasCallStack => Qry a -> Summary xs -> Either PastHorizonException a runQuery Qry a q Summary xs summary of Right a a -> Either PastHorizonException a -> STM m (Either PastHorizonException a) forall a. a -> STM m a forall (m :: * -> *) a. Monad m => a -> m a return (a -> Either PastHorizonException a forall a b. b -> Either a b Right a a) Left PastHorizon{} -> do Summary xs summary' <- STM m (Summary xs) getLatestSummary StrictTVar m (Summary xs) -> Summary xs -> STM m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () writeTVar StrictTVar m (Summary xs) var Summary xs summary' Either PastHorizonException a -> STM m (Either PastHorizonException a) forall a. a -> STM m a forall (m :: * -> *) a. Monad m => a -> m a return (Either PastHorizonException a -> STM m (Either PastHorizonException a)) -> Either PastHorizonException a -> STM m (Either PastHorizonException a) forall a b. (a -> b) -> a -> b $ Qry a -> Summary xs -> Either PastHorizonException a forall a (xs :: [*]). HasCallStack => Qry a -> Summary xs -> Either PastHorizonException a runQuery Qry a q Summary xs summary'