diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.19.4 +### Changed +- Clarify and correct health check algorithm. + ## 0.19.3 ### Changed - Add address transactions to cache. 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: a1ecccb0f56324a96c0e1b9b728d04decb450aac987685698592e3618fc1140a +-- hash: 533fa2e36c8d6eecd9a95ddf073fc36b3ba6758e1afb7f8dce86192bba8eafd7 name: haskoin-store -version: 0.19.3 +version: 0.19.4 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network diff --git a/src/Network/Haskoin/Store/Data.hs b/src/Network/Haskoin/Store/Data.hs --- a/src/Network/Haskoin/Store/Data.hs +++ b/src/Network/Haskoin/Store/Data.hs @@ -22,24 +22,19 @@ import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M -import Data.Int import qualified Data.IntMap as I import Data.IntMap.Strict (IntMap) import Data.Maybe import Data.Serialize as S import Data.String.Conversions -import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as T.Lazy import Data.Word import Database.RocksDB (DB, ReadOptions) import GHC.Generics import Haskoin as H -import Network.Socket (SockAddr (SockAddrUnix)) +import Network.Socket (SockAddr) import Paths_haskoin_store as P import UnliftIO -import UnliftIO.Exception -import qualified Web.Scotty.Trans as Scotty encodeShort :: Serialize a => a -> ShortByteString encodeShort = B.Short.toShort . S.encode @@ -132,7 +127,10 @@ getUnspents :: ConduitT i Unspent m () -- | Serialize such that ordering is inverted. +putUnixTime :: Word64 -> Put putUnixTime w = putWord64be $ maxBound - w + +getUnixTime :: Get Word64 getUnixTime = (maxBound -) <$> getWord64be class JsonSerial a where diff --git a/src/Network/Haskoin/Store/Web.hs b/src/Network/Haskoin/Store/Web.hs --- a/src/Network/Haskoin/Store/Web.hs +++ b/src/Network/Haskoin/Store/Web.hs @@ -964,50 +964,64 @@ -> Timeouts -> m HealthCheck healthCheck net mgr ch tos = do - maybe_chain_best <- timeout (5 * 1000 * 1000) $ chainGetBest ch - maybe_block_best <- runMaybeT $ MaybeT . getBlock =<< MaybeT getBestBlock - peers <- timeout (5 * 1000 * 1000) $ managerGetPeers mgr - maybe_mempool_last <- fmap fst . listToMaybe <$> getMempool - now <- fromIntegral . systemSeconds <$> liftIO getSystemTime - let maybe_block_time_delta = - (now -) . fromIntegral . blockTimestamp . blockDataHeader <$> - maybe_block_best - maybe_tx_time_delta = - (now -) <$> maybe_mempool_last <|> maybe_block_time_delta - peers_ok = maybe False (not . Data.List.null) peers - block_timeout_ok = - getAllowMinDifficultyBlocks net || - blockTimeout tos == 0 || - maybe False (<= blockTimeout tos) maybe_block_time_delta - tx_timeout_ok = - getAllowMinDifficultyBlocks net || - txTimeout tos == 0 || - maybe False (<= txTimeout tos) maybe_tx_time_delta - status_ok = - isJust maybe_chain_best && - isJust maybe_block_best && - peers_ok && - block_timeout_ok && - tx_timeout_ok - synced = - isJust $ do - x <- maybe_chain_best - y <- maybe_block_best - guard $ nodeHeight x - blockDataHeight y <= 1 + cb <- chain_best + bb <- block_best + pc <- peer_count + tm <- get_current_time + ml <- get_mempool_last + let ck = block_ok cb + bk = block_ok bb + pk = peer_count_ok pc + bd = block_time_delta tm cb + td = tx_time_delta tm cb ml + lk = timeout_ok (blockTimeout tos) bd + tk = timeout_ok (txTimeout tos) td + ok = ck && bk && pk && lk && tk return HealthCheck - { healthBlockBest = - headerHash . blockDataHeader <$> maybe_block_best - , healthBlockHeight = blockDataHeight <$> maybe_block_best - , healthHeaderBest = headerHash . nodeHeader <$> maybe_chain_best - , healthHeaderHeight = nodeHeight <$> maybe_chain_best - , healthPeers = length <$> peers + { healthBlockBest = block_hash <$> bb + , healthBlockHeight = block_height <$> bb + , healthHeaderBest = node_hash <$> cb + , healthHeaderHeight = node_height <$> cb + , healthPeers = pc , healthNetwork = getNetworkName net - , healthOK = status_ok - , healthSynced = synced - , healthLastBlock = maybe_block_time_delta - , healthLastTx = maybe_tx_time_delta + , healthOK = ok + , healthSynced = in_sync bb cb + , healthLastBlock = bd + , healthLastTx = td } + where + block_hash = headerHash . blockDataHeader + block_height = blockDataHeight + node_hash = headerHash . nodeHeader + node_height = nodeHeight + get_mempool_last = listToMaybe <$> getMempool + get_current_time = fromIntegral . systemSeconds <$> liftIO getSystemTime + peer_count_ok pc = fromMaybe 0 pc > 0 + block_ok = isJust + node_timestamp = fromIntegral . blockTimestamp . nodeHeader + in_sync bb cb = fromMaybe False $ do + bh <- blockDataHeight <$> bb + nh <- nodeHeight <$> cb + return $ compute_delta bh nh <= 1 + block_time_delta tm cb = do + bt <- node_timestamp <$> cb + return $ compute_delta bt tm + tx_time_delta tm cb ml = do + tt <- fst <$> ml <|> node_timestamp <$> cb + return $ compute_delta tt tm + timeout_ok to td = fromMaybe False $ do + td' <- td + return $ + getAllowMinDifficultyBlocks net || + to == 0 || + td' <= to + peer_count = fmap length <$> timeout 500000 (managerGetPeers mgr) + block_best = runMaybeT $ do + h <- MaybeT getBestBlock + MaybeT $ getBlock h + chain_best = timeout 500000 $ chainGetBest ch + compute_delta a b = if b > a then b - a else 0 -- | Obtain information about connected peers from peer manager process. getPeersInformation :: MonadIO m => Manager -> m [PeerInformation]