put isCacheOptimised into CacheInternal

Author: Cmdv

cardano-db-sync/src/Cardano/DbSync/Cache.hs

@@ -74,37 +74,38 @@ import Ouroboros.Consensus.Cardano.Block (StandardCrypto)
 -- NOTE: Other tables are not cleaned up since they are not rollbacked.
 rollbackCache :: MonadIO m => CacheStatus -> DB.BlockId -> ReaderT SqlBackend m ()
 rollbackCache NoCache _ = pure ()
-rollbackCache (ActiveCache _ cache) blockId = do
+rollbackCache (ActiveCache cache) blockId = do
   liftIO $ do
     atomically $ writeTVar (cPrevBlock cache) Nothing
     atomically $ modifyTVar (cDatum cache) LRU.cleanup
     atomically $ modifyTVar (cTxIds cache) FIFO.cleanupCache
     void $ rollbackMapEpochInCache cache blockId
 
--- When syncing and we get within 2 minutes of the tip, we can optimise the caches
--- and set the flag to True on ActiveCache.
-optimiseCaches :: MonadIO m => CacheStatus -> ReaderT SqlBackend m CacheStatus
+-- | When syncing and we get within 2 minutes of the tip, we can optimise the caches
+-- and set the flag to True on ActiveCache.leaving the following caches as they are:
+-- cPools, cPrevBlock, Cstats, cEpoch
+optimiseCaches :: MonadIO m => CacheStatus -> ReaderT SqlBackend m ()
 optimiseCaches cache =
   case cache of
-    NoCache -> pure cache
-    ActiveCache True _ -> pure cache
-    ActiveCache False c -> do
-      liftIO $ do
-        -- empty caches not to be used anymore
-        atomically $ modifyTVar (cTxIds c) FIFO.cleanupCache
-        atomically $ writeTVar (cStake c) (StakeCache Map.empty (LRU.empty 0))
-        atomically $ modifyTVar (cDatum c) (LRU.optimise 0)
-        -- empty then limit the capacity of the cache
-        atomically $ writeTVar (cMultiAssets c) (LRU.empty 50000)
-        -- leaving the following caches as they are:
-        -- cPools, cPrevBlock, Cstats, cEpoch
-        pure $ ActiveCache True c
+    NoCache -> pure ()
+    ActiveCache c ->
+      withCacheOptimisationCheck c (pure ()) $
+        liftIO $ do
+          -- empty caches not to be used anymore
+          atomically $ modifyTVar (cTxIds c) FIFO.cleanupCache
+          atomically $ writeTVar (cStake c) (StakeCache Map.empty (LRU.empty 0))
+          atomically $ modifyTVar (cDatum c) (LRU.optimise 0)
+          -- empty then limit the capacity of the cache
+          atomically $ writeTVar (cMultiAssets c) (LRU.empty 50000)
+          -- set the flag to True
+          atomically $ writeTVar (cIsCacheOptimised c) True
+          pure ()
 
 getCacheStatistics :: CacheStatus -> IO CacheStatistics
 getCacheStatistics cs =
   case cs of
     NoCache -> pure initCacheStatistics
-    ActiveCache _ ci -> readTVarIO (cStats ci)
+    ActiveCache ci -> readTVarIO (cStats ci)
 
 queryOrInsertRewardAccount ::
   (MonadBaseControl IO m, MonadIO m) =>
@@ -170,34 +171,36 @@ queryStakeAddrWithCacheRetBs ::
 queryStakeAddrWithCacheRetBs _trce cache cacheUA ra@(Ledger.RewardAccount _ cred) = do
   let bs = Ledger.serialiseRewardAccount ra
   case cache of
-    NoCache -> mapLeft (,bs) <$> resolveStakeAddress bs
-    ActiveCache True _ -> mapLeft (,bs) <$> resolveStakeAddress bs
-    ActiveCache False ci -> do
-      stakeCache <- liftIO $ readTVarIO (cStake ci)
-      case queryStakeCache cred stakeCache of
-        Just (addrId, stakeCache') -> do
-          liftIO $ hitCreds (cStats ci)
-          case cacheUA of
-            EvictAndUpdateCache -> do
-              liftIO $ atomically $ writeTVar (cStake ci) $ deleteStakeCache cred stakeCache'
-              pure $ Right addrId
-            _other -> do
-              liftIO $ atomically $ writeTVar (cStake ci) stakeCache'
-              pure $ Right addrId
-        Nothing -> do
-          queryRes <- mapLeft (,bs) <$> resolveStakeAddress bs
-          liftIO $ missCreds (cStats ci)
-          case queryRes of
-            Left _ -> pure queryRes
-            Right stakeAddrsId -> do
-              let !stakeCache' = case cacheUA of
-                    UpdateCache -> stakeCache {scLruCache = LRU.insert cred stakeAddrsId (scLruCache stakeCache)}
-                    UpdateCacheStrong -> stakeCache {scStableCache = Map.insert cred stakeAddrsId (scStableCache stakeCache)}
-                    _ -> stakeCache
-              liftIO $
-                atomically $
-                  writeTVar (cStake ci) stakeCache'
-              pure $ Right stakeAddrsId
+    NoCache -> rsStkAdrrs bs
+    ActiveCache ci -> do
+      withCacheOptimisationCheck ci (rsStkAdrrs bs) $ do
+        stakeCache <- liftIO $ readTVarIO (cStake ci)
+        case queryStakeCache cred stakeCache of
+          Just (addrId, stakeCache') -> do
+            liftIO $ hitCreds (cStats ci)
+            case cacheUA of
+              EvictAndUpdateCache -> do
+                liftIO $ atomically $ writeTVar (cStake ci) $ deleteStakeCache cred stakeCache'
+                pure $ Right addrId
+              _other -> do
+                liftIO $ atomically $ writeTVar (cStake ci) stakeCache'
+                pure $ Right addrId
+          Nothing -> do
+            queryRes <- mapLeft (,bs) <$> resolveStakeAddress bs
+            liftIO $ missCreds (cStats ci)
+            case queryRes of
+              Left _ -> pure queryRes
+              Right stakeAddrsId -> do
+                let !stakeCache' = case cacheUA of
+                      UpdateCache -> stakeCache {scLruCache = LRU.insert cred stakeAddrsId (scLruCache stakeCache)}
+                      UpdateCacheStrong -> stakeCache {scStableCache = Map.insert cred stakeAddrsId (scStableCache stakeCache)}
+                      _otherwise -> stakeCache
+                liftIO $
+                  atomically $
+                    writeTVar (cStake ci) stakeCache'
+                pure $ Right stakeAddrsId
+  where
+    rsStkAdrrs bs = mapLeft (,bs) <$> resolveStakeAddress bs
 
 -- | True if it was found in LRU
 queryStakeCache :: StakeCred -> StakeCache -> Maybe (DB.StakeAddressId, StakeCache)
@@ -224,7 +227,7 @@ queryPoolKeyWithCache cache cacheUA hsh =
       case mPhId of
         Nothing -> pure $ Left (DB.DbLookupMessage "PoolKeyHash")
         Just phId -> pure $ Right phId
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       mp <- liftIO $ readTVarIO (cPools ci)
       case Map.lookup hsh mp of
         Just phId -> do
@@ -264,7 +267,7 @@ insertPoolKeyWithCache cache cacheUA pHash =
           { DB.poolHashHashRaw = Generic.unKeyHashRaw pHash
           , DB.poolHashView = Generic.unKeyHashView pHash
           }
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       mp <- liftIO $ readTVarIO (cPools ci)
       case Map.lookup pHash mp of
         Just phId -> do
@@ -327,23 +330,23 @@ queryMAWithCache ::
 queryMAWithCache cache policyId asset =
   case cache of
     NoCache -> queryDb
-    ActiveCache True _ -> queryDb
-    ActiveCache False ci -> do
-      mp <- liftIO $ readTVarIO (cMultiAssets ci)
-      case LRU.lookup (policyId, asset) mp of
-        Just (maId, mp') -> do
-          liftIO $ hitMAssets (cStats ci)
-          liftIO $ atomically $ writeTVar (cMultiAssets ci) mp'
-          pure $ Right maId
-        Nothing -> do
-          liftIO $ missMAssets (cStats ci)
-          -- miss. The lookup doesn't change the cache on a miss.
-          let !policyBs = Generic.unScriptHash $ policyID policyId
-          let !assetNameBs = Generic.unAssetName asset
-          maId <- maybe (Left (policyBs, assetNameBs)) Right <$> DB.queryMultiAssetId policyBs assetNameBs
-          whenRight maId $
-            liftIO . atomically . modifyTVar (cMultiAssets ci) . LRU.insert (policyId, asset)
-          pure maId
+    ActiveCache ci -> do
+      withCacheOptimisationCheck ci queryDb $ do
+        mp <- liftIO $ readTVarIO (cMultiAssets ci)
+        case LRU.lookup (policyId, asset) mp of
+          Just (maId, mp') -> do
+            liftIO $ hitMAssets (cStats ci)
+            liftIO $ atomically $ writeTVar (cMultiAssets ci) mp'
+            pure $ Right maId
+          Nothing -> do
+            liftIO $ missMAssets (cStats ci)
+            -- miss. The lookup doesn't change the cache on a miss.
+            let !policyBs = Generic.unScriptHash $ policyID policyId
+            let !assetNameBs = Generic.unAssetName asset
+            maId <- maybe (Left (policyBs, assetNameBs)) Right <$> DB.queryMultiAssetId policyBs assetNameBs
+            whenRight maId $
+              liftIO . atomically . modifyTVar (cMultiAssets ci) . LRU.insert (policyId, asset)
+            pure maId
   where
     queryDb = do
       let !policyBs = Generic.unScriptHash $ policyID policyId
@@ -359,7 +362,7 @@ queryPrevBlockWithCache ::
 queryPrevBlockWithCache msg cache hsh =
   case cache of
     NoCache -> liftLookupFail msg $ DB.queryBlockId hsh
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       mCachedPrev <- liftIO $ readTVarIO (cPrevBlock ci)
       case mCachedPrev of
         -- if the cached block matches the requested hash, we return its db id.
@@ -388,28 +391,28 @@ queryTxIdWithCache cache txIdLedger = do
   case cache of
     -- Direct database query if no cache.
     NoCache -> qTxHash
-    ActiveCache True _ -> qTxHash
-    ActiveCache False cacheInternal -> do
-      -- Read current cache state.
-      cacheTx <- liftIO $ readTVarIO (cTxIds cacheInternal)
-
-      case FIFO.lookup txIdLedger cacheTx of
-        -- Cache hit, return the transaction ID.
-        Just txId -> do
-          liftIO $ hitTxIds (cStats cacheInternal)
-          pure $ Right txId
-        -- Cache miss.
-        Nothing -> do
-          eTxId <- qTxHash
-          liftIO $ missTxIds (cStats cacheInternal)
-          case eTxId of
-            Right txId -> do
-              -- Update cache.
-              liftIO $ atomically $ modifyTVar (cTxIds cacheInternal) $ FIFO.insert txIdLedger txId
-              -- Return ID after updating cache.
-              pure $ Right txId
-            -- Return lookup failure.
-            Left _ -> pure $ Left $ DB.DbLookupTxHash txHash
+    ActiveCache ci ->
+      withCacheOptimisationCheck ci qTxHash $ do
+        -- Read current cache state.
+        cacheTx <- liftIO $ readTVarIO (cTxIds ci)
+
+        case FIFO.lookup txIdLedger cacheTx of
+          -- Cache hit, return the transaction ID.
+          Just txId -> do
+            liftIO $ hitTxIds (cStats ci)
+            pure $ Right txId
+          -- Cache miss.
+          Nothing -> do
+            eTxId <- qTxHash
+            liftIO $ missTxIds (cStats ci)
+            case eTxId of
+              Right txId -> do
+                -- Update cache.
+                liftIO $ atomically $ modifyTVar (cTxIds ci) $ FIFO.insert txIdLedger txId
+                -- Return ID after updating cache.
+                pure $ Right txId
+              -- Return lookup failure.
+              Left _ -> pure $ Left $ DB.DbLookupTxHash txHash
   where
     txHash = Generic.unTxHash txIdLedger
     qTxHash = DB.queryTxId txHash
@@ -420,7 +423,7 @@ tryUpdateCacheTx ::
   Ledger.TxId StandardCrypto ->
   DB.TxId ->
   m ()
-tryUpdateCacheTx (ActiveCache False ci) ledgerTxId txId =
+tryUpdateCacheTx (ActiveCache ci) ledgerTxId txId =
   liftIO $ atomically $ modifyTVar (cTxIds ci) $ FIFO.insert ledgerTxId txId
 tryUpdateCacheTx _ _ _ = pure ()
 
@@ -432,13 +435,13 @@ insertBlockAndCache ::
 insertBlockAndCache cache block =
   case cache of
     NoCache -> insBlck
-    ActiveCache True _ -> insBlck
-    ActiveCache False ci -> do
-      bid <- insBlck
-      liftIO $ do
-        missPrevBlock (cStats ci)
-        atomically $ writeTVar (cPrevBlock ci) $ Just (bid, DB.blockHash block)
-      pure bid
+    ActiveCache ci ->
+      withCacheOptimisationCheck ci insBlck $ do
+        bid <- insBlck
+        liftIO $ do
+          missPrevBlock (cStats ci)
+          atomically $ writeTVar (cPrevBlock ci) $ Just (bid, DB.blockHash block)
+        pure bid
   where
     insBlck = DB.insertBlock block
 
@@ -450,18 +453,18 @@ queryDatum ::
 queryDatum cache hsh = do
   case cache of
     NoCache -> queryDtm
-    ActiveCache True _ -> queryDtm
-    ActiveCache False ci -> do
-      mp <- liftIO $ readTVarIO (cDatum ci)
-      case LRU.lookup hsh mp of
-        Just (datumId, mp') -> do
-          liftIO $ hitDatum (cStats ci)
-          liftIO $ atomically $ writeTVar (cDatum ci) mp'
-          pure $ Just datumId
-        Nothing -> do
-          liftIO $ missDatum (cStats ci)
-          -- miss. The lookup doesn't change the cache on a miss.
-          queryDtm
+    ActiveCache ci -> do
+      withCacheOptimisationCheck ci queryDtm $ do
+        mp <- liftIO $ readTVarIO (cDatum ci)
+        case LRU.lookup hsh mp of
+          Just (datumId, mp') -> do
+            liftIO $ hitDatum (cStats ci)
+            liftIO $ atomically $ writeTVar (cDatum ci) mp'
+            pure $ Just datumId
+          Nothing -> do
+            liftIO $ missDatum (cStats ci)
+            -- miss. The lookup doesn't change the cache on a miss.
+            queryDtm
   where
     queryDtm = DB.queryDatum $ Generic.dataHashToBytes hsh
 
@@ -476,13 +479,25 @@ insertDatumAndCache cache hsh dt = do
   datumId <- DB.insertDatum dt
   case cache of
     NoCache -> pure datumId
-    ActiveCache True _ -> pure datumId
-    ActiveCache False ci -> do
-      liftIO $
-        atomically $
-          modifyTVar (cDatum ci) $
-            LRU.insert hsh datumId
-      pure datumId
+    ActiveCache ci ->
+      withCacheOptimisationCheck ci (pure datumId) $ do
+        liftIO $
+          atomically $
+            modifyTVar (cDatum ci) $
+              LRU.insert hsh datumId
+        pure datumId
+
+withCacheOptimisationCheck ::
+  MonadIO m =>
+  CacheInternal ->
+  m a -> -- Action to perform if cache is optimised
+  m a -> -- Action to perform if cache is not optimised
+  m a
+withCacheOptimisationCheck ci ifOptimised ifNotOptimised = do
+  isCachedOptimised <- liftIO $ readTVarIO (cIsCacheOptimised ci)
+  if isCachedOptimised
+    then ifOptimised
+    else ifNotOptimised
 
 -- Stakes
 hitCreds :: StrictTVar IO CacheStatistics -> IO ()

cardano-db-sync/src/Cardano/DbSync/Cache/Epoch.hs

@@ -29,15 +29,15 @@ readCacheEpoch :: MonadIO m => CacheStatus -> m (Maybe CacheEpoch)
 readCacheEpoch cache =
   case cache of
     NoCache -> pure Nothing
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       cacheEpoch <- liftIO $ readTVarIO (cEpoch ci)
       pure $ Just cacheEpoch
 
 readEpochBlockDiffFromCache :: MonadIO m => CacheStatus -> m (Maybe EpochBlockDiff)
 readEpochBlockDiffFromCache cache =
   case cache of
     NoCache -> pure Nothing
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       cE <- liftIO $ readTVarIO (cEpoch ci)
       case (ceMapEpoch cE, ceEpochBlockDiff cE) of
         (_, epochInternal) -> pure epochInternal
@@ -46,7 +46,7 @@ readLastMapEpochFromCache :: CacheStatus -> IO (Maybe DB.Epoch)
 readLastMapEpochFromCache cache =
   case cache of
     NoCache -> pure Nothing
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       cE <- readTVarIO (cEpoch ci)
       let mapEpoch = ceMapEpoch cE
       -- making sure db sync wasn't restarted on the last block in epoch
@@ -72,7 +72,7 @@ writeEpochBlockDiffToCache ::
 writeEpochBlockDiffToCache cache epCurrent =
   case cache of
     NoCache -> pure $ Left $ SNErrDefault "writeEpochBlockDiffToCache: Cache is NoCache"
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       cE <- liftIO $ readTVarIO (cEpoch ci)
       case (ceMapEpoch cE, ceEpochBlockDiff cE) of
         (epochLatest, _) -> writeToCache ci (CacheEpoch epochLatest (Just epCurrent))
@@ -94,7 +94,7 @@ writeToMapEpochCache syncEnv cache latestEpoch = do
           NoLedger nle -> getSecurityParameter $ nleProtocolInfo nle
   case cache of
     NoCache -> pure $ Left $ SNErrDefault "writeToMapEpochCache: Cache is NoCache"
-    ActiveCache _ ci -> do
+    ActiveCache ci -> do
       -- get EpochBlockDiff so we can use the BlockId we stored when inserting blocks
       epochInternalCE <- readEpochBlockDiffFromCache cache
       case epochInternalCE of