diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -45,53 +45,55 @@ #endif data Config = Config - { configDir :: !FilePath - , configHost :: !String - , configPort :: !Int - , configNetwork :: !Network - , configDiscover :: !Bool - , configPeers :: ![(String, Maybe Int)] - , configVersion :: !Bool - , configDebug :: !Bool - , configReqLog :: !Bool - , configMaxPending :: !Int - , configWebLimits :: !WebLimits - , configWebTimeouts :: !WebTimeouts - , configRedis :: !Bool - , configRedisURL :: !String - , configRedisMin :: !Int - , configRedisMax :: !Integer - , configWipeMempool :: !Bool - , configNoMempool :: !Bool - , configPeerTimeout :: !Int - , configPeerMaxLife :: !Int - , configMaxPeers :: !Int - , configMaxDiff :: !Int + { configDir :: !FilePath + , configHost :: !String + , configPort :: !Int + , configNetwork :: !Network + , configDiscover :: !Bool + , configPeers :: ![(String, Maybe Int)] + , configVersion :: !Bool + , configDebug :: !Bool + , configReqLog :: !Bool + , configMaxPending :: !Int + , configWebLimits :: !WebLimits + , configWebTimeouts :: !WebTimeouts + , configRedis :: !Bool + , configRedisURL :: !String + , configRedisMin :: !Int + , configRedisMax :: !Integer + , configWipeMempool :: !Bool + , configNoMempool :: !Bool + , configPeerTimeout :: !Int + , configPeerMaxLife :: !Int + , configMaxPeers :: !Int + , configMaxDiff :: !Int + , configCacheRefresh :: !Int } instance Default Config where - def = Config { configDir = defDirectory - , configHost = defHost - , configPort = defPort - , configNetwork = defNetwork - , configDiscover = defDiscover - , configPeers = defPeers - , configVersion = False - , configDebug = defDebug - , configReqLog = defReqLog - , configMaxPending = defMaxPending - , configWebLimits = defWebLimits - , configWebTimeouts = defWebTimeouts - , configRedis = defRedis - , configRedisURL = defRedisURL - , configRedisMin = defRedisMin - , configRedisMax = defRedisMax - , configWipeMempool = defWipeMempool - , configNoMempool = defNoMempool - , configPeerTimeout = defPeerTimeout - , configPeerMaxLife = defPeerMaxLife - , configMaxPeers = defMaxPeers - , configMaxDiff = defMaxDiff + def = Config { configDir = defDirectory + , configHost = defHost + , configPort = defPort + , configNetwork = defNetwork + , configDiscover = defDiscover + , configPeers = defPeers + , configVersion = False + , configDebug = defDebug + , configReqLog = defReqLog + , configMaxPending = defMaxPending + , configWebLimits = defWebLimits + , configWebTimeouts = defWebTimeouts + , configRedis = defRedis + , configRedisURL = defRedisURL + , configRedisMin = defRedisMin + , configRedisMax = defRedisMax + , configWipeMempool = defWipeMempool + , configNoMempool = defNoMempool + , configPeerTimeout = defPeerTimeout + , configPeerMaxLife = defPeerMaxLife + , configMaxPeers = defMaxPeers + , configMaxDiff = defMaxDiff + , configCacheRefresh = defCacheRefresh } defEnv :: MonadIO m => String -> a -> (String -> Maybe a) -> m a @@ -99,6 +101,11 @@ ms <- lookupEnv e return $ fromMaybe d $ p =<< ms +defCacheRefresh :: Int +defCacheRefresh = unsafePerformIO $ + defEnv "CACHE_REFRESH" 750 readMaybe +{-# NOINLINE defCacheRefresh #-} + defMaxPending :: Int defMaxPending = unsafePerformIO $ defEnv "MAX_PENDING_TXS" 100 readMaybe @@ -401,6 +408,13 @@ <> help "Maximum number of keys in Redis xpub cache" <> showDefault <> value (configRedisMax def) + configCacheRefresh <- + option auto $ + metavar "MILLISECONDS" + <> long "cache-refresh" + <> help "Refresh cache this frequently" + <> showDefault + <> value (configCacheRefresh def) configNoMempool <- flag (configNoMempool def) True $ long "no-mempool" @@ -485,6 +499,7 @@ , configMaxPeers = maxpeers , configMaxDiff = maxdiff , configNoMempool = nomem + , configCacheRefresh = crefresh } = runStderrLoggingT . filterLogger l $ do $(logInfoS) "Main" $ @@ -511,6 +526,7 @@ , storeConfPeerTimeout = fromIntegral peertimeout , storeConfPeerMaxLife = fromIntegral peerlife , storeConfConnect = withConnection + , storeConfCacheRefresh = crefresh } withStore scfg $ \st -> runWeb diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: a9cd74aee3b5a5b336b40bb4d2e3a0f823359573cc439ade5a2b32175bfb665b +-- hash: 6706ddf8dce4c42481f5013333abf722c72156f93f2e540ce10c8c8086eb9d13 name: haskoin-store -version: 0.37.4 +version: 0.37.5 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -53,7 +53,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 - , haskoin-store-data ==0.37.4 + , haskoin-store-data ==0.37.5 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32 @@ -96,7 +96,7 @@ , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 , haskoin-store - , haskoin-store-data ==0.37.4 + , haskoin-store-data ==0.37.5 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1 @@ -135,8 +135,8 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 - , haskoin-store ==0.37.4 - , haskoin-store-data ==0.37.4 + , haskoin-store ==0.37.5 + , haskoin-store-data ==0.37.5 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -87,10 +87,11 @@ throwIO (RedisError e) data CacheConfig = CacheConfig - { cacheConn :: !Connection - , cacheMin :: !Int - , cacheMax :: !Integer - , cacheChain :: !Chain + { cacheConn :: !Connection + , cacheMin :: !Int + , cacheMax :: !Integer + , cacheChain :: !Chain + , cacheRefresh :: !Int } type CacheT = ReaderT (Maybe CacheConfig) @@ -912,10 +913,9 @@ Nothing -> return True Just bs -> do let t = read (cs bs) + cooldown <- toInteger . (* 500) <$> asks cacheRefresh now <- microseconds return (cooldown <= now - t) - where - cooldown = 250000 startCooldown :: (MonadUnliftIO m, MonadLoggerIO m) => CacheX m () startCooldown = do diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -46,10 +46,8 @@ publishSTM, receive, withProcess, withPublisher, withSubscription) -import System.Random (randomRIO) import UnliftIO (MonadIO, MonadUnliftIO, STM, - atomically, liftIO, link, - withAsync) + atomically, link, withAsync) import UnliftIO.Concurrent (threadDelay) -- | Store mailboxes. @@ -67,36 +65,38 @@ -- | Configuration for a 'Store'. data StoreConfig = StoreConfig - { storeConfMaxPeers :: !Int + { storeConfMaxPeers :: !Int -- ^ max peers to connect to - , storeConfInitPeers :: ![HostPort] + , storeConfInitPeers :: ![HostPort] -- ^ static set of peers to connect to - , storeConfDiscover :: !Bool + , storeConfDiscover :: !Bool -- ^ discover new peers - , storeConfDB :: !FilePath + , storeConfDB :: !FilePath -- ^ RocksDB database path - , storeConfNetwork :: !Network + , storeConfNetwork :: !Network -- ^ network constants - , storeConfCache :: !(Maybe String) + , storeConfCache :: !(Maybe String) -- ^ Redis cache configuration - , storeConfInitialGap :: !Word32 + , storeConfInitialGap :: !Word32 -- ^ gap on extended public key with no transactions - , storeConfGap :: !Word32 + , storeConfGap :: !Word32 -- ^ gap for extended public keys - , storeConfCacheMin :: !Int + , storeConfCacheMin :: !Int -- ^ cache xpubs with more than this many used addresses - , storeConfMaxKeys :: !Integer + , storeConfMaxKeys :: !Integer -- ^ maximum number of keys in Redis cache - , storeConfNoMempool :: !Bool + , storeConfNoMempool :: !Bool -- ^ do not index new mempool transactions - , storeConfWipeMempool :: !Bool + , storeConfWipeMempool :: !Bool -- ^ wipe mempool when starting - , storeConfPeerTimeout :: !NominalDiffTime + , storeConfPeerTimeout :: !NominalDiffTime -- ^ disconnect peer if message not received for this many seconds - , storeConfPeerMaxLife :: !NominalDiffTime + , storeConfPeerMaxLife :: !NominalDiffTime -- ^ disconnect peer if it has been connected this long - , storeConfConnect :: !(SockAddr -> WithConnection) + , storeConfConnect :: !(SockAddr -> WithConnection) -- ^ connect to peers using the function 'withConnection' + , storeConfCacheRefresh :: !Int + -- ^ refresh the cache this often (milliseconds) } withStore :: (MonadLoggerIO m, MonadUnliftIO m) @@ -181,9 +181,10 @@ connectRedis redisurl >>= \conn -> withSubscription pub $ \evts -> withProcess (f conn) $ \p -> - cacheWriterProcesses evts (getProcessMailbox p) $ + cacheWriterProcesses crefresh evts (getProcessMailbox p) $ action (Just (c conn)) where + crefresh = storeConfCacheRefresh cfg f conn cwinbox = runReaderT (cacheWriter (c conn) cwinbox) db c conn = @@ -192,22 +193,23 @@ , cacheMin = storeConfCacheMin cfg , cacheChain = chain , cacheMax = storeConfMaxKeys cfg + , cacheRefresh = storeConfCacheRefresh cfg } cacheWriterProcesses :: MonadUnliftIO m - => Inbox StoreEvent + => Int + -> Inbox StoreEvent -> CacheWriter -> m a -> m a -cacheWriterProcesses evts cwm action = +cacheWriterProcesses crefresh evts cwm action = withAsync events $ \a1 -> withAsync ping $ \a2 -> link a1 >> link a2 >> action where events = cacheWriterEvents evts cwm ping = forever $ do - time <- liftIO $ randomRIO (600000, 1200000) - threadDelay time + threadDelay (crefresh * 1000) cachePing cwm cacheWriterEvents :: MonadIO m => Inbox StoreEvent -> CacheWriter -> m () diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -92,6 +92,7 @@ , storeConfPeerTimeout = 60 , storeConfPeerMaxLife = 48 * 3600 , storeConfConnect = dummyPeerConnect net ad + , storeConfCacheRefresh = 750 } withStore cfg $ \Store {..} -> withSubscription storePublisher $ \sub ->