haskoin-store 0.33.1 → 0.34.0
raw patch · 2 files changed
+64/−82 lines, 2 filesdep ~haskoin-storedep ~haskoin-store-data
Dependency ranges changed: haskoin-store, haskoin-store-data
Files
- haskoin-store.cabal +6/−6
- src/Haskoin/Store/Web.hs +58/−76
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 02339d71f3339f1a7cc7ec5cca22592c9b8b68752549137c4649db2a8d347281+-- hash: 4d387f3124649772fe3bf688cdd281364146d3f1f944ff4e02e433cd147379f1 name: haskoin-store-version: 0.33.1+version: 0.34.0 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@@ -53,7 +53,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1- , haskoin-store-data ==0.33.1+ , haskoin-store-data ==0.34.0 , 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.33.1+ , haskoin-store-data ==0.34.0 , 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.33.1- , haskoin-store-data ==0.33.1+ , haskoin-store ==0.34.0+ , haskoin-store-data ==0.34.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store/Web.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Haskoin.Store.Web@@ -16,7 +17,7 @@ import Conduit () import Control.Applicative ((<|>))-import Control.Monad (forever, when, (<=<))+import Control.Monad (forever, unless, when, (<=<)) import Control.Monad.Logger (MonadLoggerIO, logInfoS) import Control.Monad.Reader (ReaderT, asks, local, runReaderT)@@ -33,7 +34,7 @@ import Data.Default (Default (..)) import Data.Function ((&)) import Data.List (nub)-import Data.Maybe (catMaybes, fromMaybe, isJust,+import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Proxy (Proxy (..)) import Data.Serialize as Serialize@@ -874,83 +875,64 @@ tos <- lift $ asks webWebTimeouts ver <- lift $ asks webVersion h <- lift $ healthCheck net mgr chn tos ver- when (not (healthOK h) || not (healthSynced h)) $ S.status status503+ unless (isOK h) $ S.status status503 return h -healthCheck ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)- => Network- -> PeerManager- -> Chain- -> WebTimeouts- -> String- -> m HealthCheck+blockHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)+ => Chain -> m BlockHealth+blockHealthCheck ch = do+ let blockHealthMaxDiff = 2+ blockHealthHeaders <-+ H.nodeHeight <$> chainGetBest ch+ blockHealthBlocks <-+ maybe 0 blockDataHeight <$>+ runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock)+ return BlockHealth {..}++lastBlockHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)+ => Chain -> WebTimeouts -> m TimeHealth+lastBlockHealthCheck ch tos = do+ n <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ t <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch+ let timeHealthAge = n - t+ timeHealthMax = fromIntegral $ blockTimeout tos+ return TimeHealth {..}++lastTxHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)+ => Chain -> WebTimeouts -> m TimeHealth+lastTxHealthCheck ch tos = do+ n <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ t <- listToMaybe <$> getMempool >>= \case+ Just t ->+ return $ fromIntegral $ memRefTime $ txRefBlock t+ Nothing ->+ fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch+ let timeHealthAge = n - t+ timeHealthMax = fromIntegral $ txTimeout tos+ return TimeHealth {..}++peerHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)+ => PeerManager -> m CountHealth+peerHealthCheck mgr = do+ let countHealthMin = 1+ countHealthNum <- length <$> getPeers mgr+ return CountHealth {..}++healthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m)+ => Network+ -> PeerManager+ -> Chain+ -> WebTimeouts+ -> String+ -> m HealthCheck healthCheck net mgr ch tos ver = do- chain_best <- get_chain_best- block_best <- get_block_store_best- peer_count <- get_peer_count- time <- get_current_time- mempool_last <- get_mempool_last- let chain_ok = is_block_ok chain_best- block_ok = is_block_ok block_best- peer_count_ok = is_peer_count_ok peer_count- block_time_delta = get_block_time_delta time chain_best- tx_time_delta = get_tx_time_delta time block_time_delta mempool_last- block_timeout_ok = is_timeout_ok (blockTimeout tos) block_time_delta- tx_timeout_ok = is_timeout_ok (txTimeout tos) tx_time_delta- in_sync = is_in_sync block_best chain_best- ok = chain_ok &&- block_ok &&- peer_count_ok &&- block_timeout_ok &&- (tx_timeout_ok || not in_sync)- return- HealthCheck- { healthBlockBest = block_data_hash <$> block_best- , healthBlockHeight = block_data_height <$> block_best- , healthHeaderBest = node_hash <$> chain_best- , healthHeaderHeight = node_height <$> chain_best- , healthPeers = peer_count- , healthNetwork = getNetworkName net- , healthOK = ok- , healthSynced = in_sync- , healthLastBlock = block_time_delta- , healthLastTx = tx_time_delta- , healthVersion = ver- }- where- block_data_hash = H.headerHash . blockDataHeader- block_data_height = blockDataHeight- node_hash = H.headerHash . H.nodeHeader- node_height = H.nodeHeight- get_mempool_last = listToMaybe <$> getMempool- get_current_time = fromIntegral . systemSeconds <$> liftIO getSystemTime- is_peer_count_ok pc = fromMaybe 0 pc > 0- is_block_ok = isJust- node_timestamp = fromIntegral . H.blockTimestamp . H.nodeHeader- is_in_sync bb cb = fromMaybe False $ do- bh <- blockDataHeight <$> bb- nh <- H.nodeHeight <$> cb- return $ compute_delta bh nh <= 1- get_block_time_delta tm cb = do- bt <- node_timestamp <$> cb- return $ compute_delta bt tm- get_tx_time_delta tm bd ml = do- bd' <- bd- tt <- memRefTime . txRefBlock <$> ml <|> bd- return $ min (compute_delta tt tm) bd'- is_timeout_ok to td = fromMaybe False $ do- td' <- td- return $- getAllowMinDifficultyBlocks net ||- to == 0 ||- td' <= to- get_peer_count = fmap length <$> timeout 10000000 (getPeers mgr)- get_block_store_best = runMaybeT $ do- h <- MaybeT getBestBlock- MaybeT $ getBlock h- get_chain_best = timeout 10000000 $ chainGetBest ch- compute_delta a b = if b > a then b - a else 0+ healthBlocks <- blockHealthCheck ch+ healthLastBlock <- lastBlockHealthCheck ch tos+ healthLastTx <- lastTxHealthCheck ch tos+ healthPeers <- peerHealthCheck mgr+ let healthNetwork = getNetworkName net+ healthVersion = ver+ return HealthCheck {..} scottyDbStats :: MonadLoggerIO m => WebT m () scottyDbStats = do