haskoin-store 0.40.10 → 0.40.11
raw patch · 2 files changed
+68/−52 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- haskoin-store.cabal +1/−1
- src/Haskoin/Store/Cache.hs +67/−51
haskoin-store.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store-version: 0.40.10+version: 0.40.11 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-store#readme> category: Bitcoin, Finance, Network
src/Haskoin/Store/Cache.hs view
@@ -24,10 +24,10 @@ ) where import Control.DeepSeq (NFData)-import Control.Monad (forM, forM_, forever, unless, void,- when)+import Control.Monad (forM, forM_, forever, guard, unless,+ void, when) import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS,- logWarnS)+ logInfoS, logWarnS) import Control.Monad.Reader (ReaderT (..), ask, asks) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)@@ -468,7 +468,9 @@ $(logErrorS) "Cache" $ "Unexpected status acquiring lock: " <> cs s return Nothing- Left (Redis.Bulk Nothing) -> return Nothing+ Left (Redis.Bulk Nothing) -> do+ $(logDebugS) "Cache" "Lock already taken"+ return Nothing Left e -> do $(logErrorS) "Cache" "Error when trying to acquire lock"@@ -522,8 +524,12 @@ :: (MonadLoggerIO m, MonadUnliftIO m) => CacheX m a -> CacheX m a-withLockForever go = withLock go >>= \case- Nothing -> smallDelay >> go+withLockForever go =+ withLock go >>= \case+ Nothing -> do+ smallDelay+ $(logDebugS) "Cache" "Retrying lock aquisition without limits"+ withLockForever go Just x -> return x withLockRetry@@ -534,8 +540,13 @@ withLockRetry i f | i <= 0 = return Nothing | otherwise = withLock f >>= \case- Nothing -> smallDelay >> withLockRetry (i - 1) f- Just x -> return (Just x)+ Nothing -> do+ smallDelay+ $(logDebugS) "Cache" $+ "Retrying lock acquisition: " <>+ cs (show i) <> " tries remaining"+ withLockRetry (i - 1) f+ x -> return x pruneDB :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => CacheX m Integer@@ -639,47 +650,42 @@ newBlockC :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => CacheX m () newBlockC =- lift getBestBlock >>= \m ->- forM_ m $ \bb -> withLock $ f bb+ inSync >>= \s -> when s $+ lift getBestBlock >>= \case+ Nothing -> $(logDebugS) "Cache" "No best block"+ Just bb -> cacheGetHead >>= \case+ Nothing -> do+ $(logInfoS) "Cache" "Initializing best cache block"+ importBlockC bb+ Just cb+ | cb == bb -> $(logDebugS) "Cache" "Cache in sync"+ | otherwise -> sync bb cb where- f bb = cacheGetHead >>= go bb- go bb Nothing =- importBlockC bb- go bb (Just cb)- | cb == bb =- $(logDebugS) "Cache" "Cache in sync"- | otherwise =- sync bb cb sync bb cb = asks cacheChain >>= \ch ->- chainBlockMain bb ch >>= \case- False ->+ chainGetBlock cb ch >>= \case+ Nothing -> $(logErrorS) "Cache" $- "New head not in main chain: " <> blockHashToHex bb- True ->- chainGetBlock cb ch >>= \case- Nothing ->- $(logErrorS) "Cache" $- "Cache head block node not found: " <>- blockHashToHex cb- Just cn ->- chainBlockMain cb ch >>= \case- False -> do- $(logDebugS) "Cache" $- "Reverting cache head not in main chain: " <>- blockHashToHex cb- removeHeadC >> f bb- True ->- chainGetBlock bb ch >>= \case- Just nn -> next bb nn cn- Nothing -> do- $(logErrorS) "Cache" $- "Cache head node not found: "- <> blockHashToHex bb- throwIO $- LogicError $- "Cache head node not found: "- <> cs (blockHashToHex bb)+ "Cache head block node not found: " <>+ blockHashToHex cb+ Just cn ->+ chainBlockMain cb ch >>= \case+ False -> do+ $(logDebugS) "Cache" $+ "Reverting cache head not in main chain: " <>+ blockHashToHex cb+ removeHeadC cb >> newBlockC+ True ->+ chainGetBlock bb ch >>= \case+ Just nn -> next bb nn cn+ Nothing -> do+ $(logErrorS) "Cache" $+ "Cache head node not found: "+ <> blockHashToHex bb+ throwIO $+ LogicError $+ "Cache head node not found: "+ <> cs (blockHashToHex bb) next bb nn cn = asks cacheChain >>= \ch -> chainGetAncestor (nodeHeight cn + 1) nn ch >>= \case@@ -690,11 +696,12 @@ <> " for block: " <> blockHashToHex (headerHash (nodeHeader nn)) Just cn' ->- importBlockC (headerHash (nodeHeader cn')) >> f bb+ importBlockC (headerHash (nodeHeader cn')) >> newBlockC importBlockC :: (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) => BlockHash -> CacheX m () importBlockC bh =+ withLockForever $ lift (getBlock bh) >>= \case Just bd -> do let ths = blockDataTxs bd@@ -718,10 +725,12 @@ <> blockHashToHex bh removeHeadC :: (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m)- => CacheX m ()-removeHeadC =+ => BlockHash -> CacheX m ()+removeHeadC cb =+ withLockForever $ void . runMaybeT $ do bh <- MaybeT cacheGetHead+ guard (cb == bh) bd <- MaybeT (lift (getBlock bh)) lift $ do tds <- sortTxData . catMaybes <$>@@ -944,9 +953,16 @@ -> CacheX m a -> CacheX m (Maybe a) withCool key milliseconds run =- is_cool >>= \c -> if c- then run >>= \x -> cooldown >> return (Just x)- else return Nothing+ is_cool >>= \c ->+ if c+ then do+ $(logDebugS) "Cache" $ "Cooldown reached for key: " <> cs (show key)+ x <- run+ cooldown+ return (Just x)+ else do+ $(logDebugS) "Cache" $ "Cooldown NOT reached for key: " <> cs (show key)+ return Nothing where is_cool = isNothing <$> runRedis (Redis.get key) cooldown =