haskoin-store 0.18.7 → 0.18.8
raw patch · 6 files changed
+177/−69 lines, 6 filesdep ~haskoin-core
Dependency ranges changed: haskoin-core
Files
- CHANGELOG.md +5/−0
- app/Main.hs +27/−3
- haskoin-store.cabal +5/−5
- src/Haskoin/Store.hs +1/−0
- src/Network/Haskoin/Store/Data.hs +34/−13
- src/Network/Haskoin/Store/Web.hs +105/−48
CHANGELOG.md view
@@ -4,6 +4,11 @@ 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.18.8+### Added+- Transaction and block timeouts for health check.+- Raw blocks.+ ## 0.18.7 ### Fixed - Missing tranasctions on xpub listings.
app/Main.hs view
@@ -7,6 +7,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where+ import Conduit import Control.Arrow import Control.Exception ()@@ -55,6 +57,7 @@ , configDebug :: !Bool , configReqLog :: !Bool , configMaxLimits :: !MaxLimits+ , configTimeouts :: !Timeouts } defPort :: Int@@ -76,6 +79,9 @@ , maxLimitGap = 20 } +defTimeouts :: Timeouts+defTimeouts = Timeouts {blockTimeout = 7200, txTimeout = 600}+ config :: Parser Config config = do configDir <-@@ -120,8 +126,7 @@ value (maxLimitFull defMaxLimits) maxLimitOffset <- option auto $- metavar "INT" <> long "maxoffset" <>- help "Max offset (0 for no limit)" <>+ metavar "INT" <> long "maxoffset" <> help "Max offset (0 for no limit)" <> showDefault <> value (maxLimitOffset defMaxLimits) maxLimitDefault <-@@ -134,7 +139,24 @@ metavar "INT" <> long "gap" <> help "Extended public key gap" <> showDefault <> value (maxLimitGap defMaxLimits)- pure Config {configMaxLimits = MaxLimits {..}, ..}+ blockTimeout <-+ option auto $+ metavar "INT" <> long "blocktimeout" <>+ help "Unhealthy if no block for this many seconds" <>+ showDefault <>+ value (blockTimeout defTimeouts)+ txTimeout <-+ option auto $+ metavar "INT" <> long "txtimeout" <>+ help "Unhealthy if no new tx in this many seconds" <>+ showDefault <>+ value (txTimeout defTimeouts)+ pure+ Config+ { configMaxLimits = MaxLimits {..}+ , configTimeouts = Timeouts {..}+ , ..+ } networkReader :: String -> Either String Network networkReader s@@ -194,6 +216,7 @@ , configDebug = deb , configMaxLimits = limits , configReqLog = reqlog+ , configTimeouts = tos } = runStderrLoggingT . filterLogger l . flip finally clear $ do $(logInfoS) "Main" $@@ -251,6 +274,7 @@ , webStore = str , webMaxLimits = limits , webReqLog = reqlog+ , webTimeouts = tos } in runWeb wcfg where
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 484fc09cd43cad3fa46c71963e8d58bce072ca2aefb5f8c5fcabadb1b93c791b+-- hash: 88361eb08860af74fe1889c4b02d3ae0e4289cc2d4b2d8249e19e22d94ea2b05 name: haskoin-store-version: 0.18.7+version: 0.18.8 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@@ -54,7 +54,7 @@ , containers , data-default , hashable- , haskoin-core >=0.9.5+ , haskoin-core >=0.9.7 , haskoin-node , http-types , monad-logger@@ -94,7 +94,7 @@ , data-default , filepath , hashable- , haskoin-core >=0.9.5+ , haskoin-core >=0.9.7 , haskoin-node , haskoin-store , http-types@@ -138,7 +138,7 @@ , containers , data-default , hashable- , haskoin-core >=0.9.5+ , haskoin-core >=0.9.7 , haskoin-node , haskoin-store , hspec
src/Haskoin/Store.hs view
@@ -38,6 +38,7 @@ , LayeredDB(..) , WebConfig(..) , MaxLimits(..)+ , Timeouts(..) , Offset , Limit , newLayeredDB
src/Network/Haskoin/Store/Data.hs view
@@ -793,6 +793,14 @@ binSerial _ = put binDeserial _ = get +instance JsonSerial Block where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial Block where+ binSerial _ = put+ binDeserial _ = get+ -- | Information about a connected peer. data PeerInformation = PeerInformation { peerUserAgent :: !ByteString@@ -985,19 +993,23 @@ forM xs $ \(k, v) -> case k of Right a -> return (a, v)- Left _ -> mzero+ Left _ -> mzero return $ XPubSummary c z r u ext ch (M.fromList ys) -data HealthCheck = HealthCheck- { healthHeaderBest :: !(Maybe BlockHash)- , healthHeaderHeight :: !(Maybe BlockHeight)- , healthBlockBest :: !(Maybe BlockHash)- , healthBlockHeight :: !(Maybe BlockHeight)- , healthPeers :: !(Maybe Int)- , healthNetwork :: !String- , healthOK :: !Bool- , healthSynced :: !Bool- } deriving (Show, Eq, Generic, Serialize)+data HealthCheck =+ HealthCheck+ { healthHeaderBest :: !(Maybe BlockHash)+ , healthHeaderHeight :: !(Maybe BlockHeight)+ , healthBlockBest :: !(Maybe BlockHash)+ , healthBlockHeight :: !(Maybe BlockHeight)+ , healthPeers :: !(Maybe Int)+ , healthNetwork :: !String+ , healthOK :: !Bool+ , healthSynced :: !Bool+ , healthLastBlock :: !(Maybe Word64)+ , healthLastTx :: !(Maybe Word64)+ }+ deriving (Show, Eq, Generic, Serialize) healthCheckPairs :: A.KeyValue kv => HealthCheck -> [kv] healthCheckPairs h =@@ -1010,6 +1022,8 @@ , "ok" .= healthOK h , "synced" .= healthSynced h , "version" .= P.version+ , "lastblock" .= healthLastBlock h+ , "lasttx" .= healthLastTx h ] instance ToJSON HealthCheck where@@ -1029,6 +1043,8 @@ , healthNetwork = net , healthOK = ok , healthSynced = synced+ , healthLastBlock = lbk+ , healthLastTx = ltx } = do put hbest put hheight@@ -1038,8 +1054,13 @@ put net put ok put synced-- binDeserial _ = HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get+ put lbk+ put ltx+ binDeserial _ =+ HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*>+ get <*>+ get <*>+ get data Event = EventBlock BlockHash
src/Network/Haskoin/Store/Web.hs view
@@ -39,6 +39,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as T.Lazy import Data.Time.Clock+import Data.Time.Clock.System import Data.Vector (Vector, cons, (!)) import qualified Data.Vector as V import Data.Version@@ -122,6 +123,7 @@ , webStore :: !Store , webMaxLimits :: !MaxLimits , webReqLog :: !Bool+ , webTimeouts :: !Timeouts } data MaxLimits =@@ -134,6 +136,13 @@ } deriving (Eq, Show) +data Timeouts =+ Timeouts+ { txTimeout :: !Word64+ , blockTimeout :: !Word64+ }+ deriving (Eq, Show)+ instance Parsable BlockHash where parseParam = maybe (Left "could not decode block hash") Right . hexToBlockHash . cs@@ -211,43 +220,57 @@ -> WebT m () protoSerial net proto = S.raw . serialAny net proto -scottyBestBlock :: MonadLoggerIO m => Network -> WebT m ()-scottyBestBlock net = do+scottyBestBlock :: MonadUnliftIO m => Network -> Bool -> WebT m ()+scottyBestBlock net raw = do cors n <- parseNoTx proto <- setupBin- res <-+ bm <- runMaybeT $ do h <- MaybeT getBestBlock- b <- MaybeT $ getBlock h- return $ pruneTx n b- maybeSerial net proto res+ MaybeT $ getBlock h+ b <-+ case bm of+ Nothing -> raise ThingNotFound+ Just b -> return b+ if raw+ then rawBlock b >>= protoSerial net proto+ else protoSerial net proto (pruneTx n b) -scottyBlock :: MonadLoggerIO m => Network -> WebT m ()-scottyBlock net = do+scottyBlock :: MonadUnliftIO m => Network -> Bool -> WebT m ()+scottyBlock net raw = do cors block <- param "block" n <- parseNoTx proto <- setupBin- res <-- runMaybeT $ do- b <- MaybeT $ getBlock block- return $ pruneTx n b- maybeSerial net proto res+ b <-+ getBlock block >>= \case+ Nothing -> raise ThingNotFound+ Just b -> return b+ if raw+ then rawBlock b >>= protoSerial net proto+ else protoSerial net proto (pruneTx n b) -scottyBlockHeight :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()-scottyBlockHeight net = do+scottyBlockHeight ::+ (MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m ()+scottyBlockHeight net raw = do cors height <- param "height" n <- parseNoTx proto <- setupBin hs <- getBlocksAtHeight height db <- askDB- stream $ \io flush' -> do- runStream db . runConduit $- yieldMany hs .| concatMapMC getBlock .| mapC (pruneTx n) .|- streamAny net proto io- flush'+ if raw+ then stream $ \io flush' -> do+ runStream db . runConduit $+ yieldMany hs .| concatMapMC getBlock .| mapMC rawBlock .|+ streamAny net proto io+ flush'+ else stream $ \io flush' -> do+ runStream db . runConduit $+ yieldMany hs .| concatMapMC getBlock .| mapC (pruneTx n) .|+ streamAny net proto io+ flush' scottyBlockHeights :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m () scottyBlockHeights net = do@@ -379,6 +402,16 @@ streamAny net proto io flush' +rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block+rawBlock b = do+ let h = blockDataHeader b+ txs <-+ runConduit $+ yieldMany (blockDataTxs b) .| concatMapMC getTransaction .|+ mapC transactionData .|+ sinkList+ return Block {blockHeader = h, blockTxns = txs}+ scottyRawBlockTransactions :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m () scottyRawBlockTransactions net = do@@ -653,11 +686,18 @@ protoSerial net proto ps scottyHealth ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> Store -> WebT m ()-scottyHealth net st = do+ (MonadLoggerIO m, MonadUnliftIO m)+ => Network+ -> Store+ -> Timeouts+ -> WebT m ()+scottyHealth net st tos = do cors proto <- setupBin- h <- lift $ healthCheck net (storeManager st) (storeChain st)+ db <- askDB+ h <-+ liftIO . runStream db $+ healthCheck net (storeManager st) (storeChain st) tos when (not (healthOK h) || not (healthSynced h)) $ status status503 protoSerial net proto h @@ -669,6 +709,7 @@ , webPublisher = pub , webMaxLimits = limits , webReqLog = reqlog+ , webTimeouts = tos } = do req_logger <- if reqlog@@ -677,12 +718,15 @@ runner <- askRunInIO scottyT port (runner . withLayeredDB db) $ do case req_logger of- Just m -> middleware m+ Just m -> middleware m Nothing -> return () defaultHandler (defHandler net)- S.get "/block/best" $ scottyBestBlock net- S.get "/block/:block" $ scottyBlock net- S.get "/block/height/:height" $ scottyBlockHeight net+ S.get "/block/best" $ scottyBestBlock net False+ S.get "/block/best/raw" $ scottyBestBlock net True+ S.get "/block/:block" $ scottyBlock net False+ S.get "/block/:block/raw" $ scottyBlock net True+ S.get "/block/height/:height" $ scottyBlockHeight net False+ S.get "/block/height/:height/raw" $ scottyBlockHeight net True S.get "/block/heights" $ scottyBlockHeights net S.get "/block/latest" $ scottyBlockLatest net S.get "/blocks" $ scottyBlocks net@@ -713,7 +757,7 @@ S.get "/dbstats" scottyDbStats S.get "/events" $ scottyEvents net pub S.get "/peers" $ scottyPeers net st- S.get "/health" $ scottyHealth net st+ S.get "/health" $ scottyHealth net st tos notFound $ raise ThingNotFound getStart :: MonadUnliftIO m => WebT m (Maybe BlockRef)@@ -802,7 +846,7 @@ return $ case (t :: Text) of "segwit" -> deriveWitnessAddrs "compat" -> deriveCompatWitnessAddrs- _ -> deriveAddrs+ _ -> deriveAddrs | otherwise = return deriveAddrs parseNoTx :: (Monad m, ScottyError e) => ActionT e m Bool@@ -866,34 +910,47 @@ monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl healthCheck ::- (MonadUnliftIO m, StoreRead m)+ (MonadUnliftIO m, StoreRead m, StoreStream m) => Network -> Manager -> Chain+ -> Timeouts -> m HealthCheck-healthCheck net mgr ch = do- n <- timeout (5 * 1000 * 1000) $ chainGetBest ch- b <-- runMaybeT $ do- h <- MaybeT getBestBlock- MaybeT $ getBlock h- p <- timeout (5 * 1000 * 1000) $ managerGetPeers mgr- let k = isNothing n || isNothing b || maybe False (not . Data.List.null) p- s =+healthCheck net mgr ch tos = do+ maybe_chain_best <- timeout (5 * 1000 * 1000) $ chainGetBest ch+ maybe_block_best <- runMaybeT $ MaybeT . getBlock =<< MaybeT getBestBlock+ now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ peers <- timeout (5 * 1000 * 1000) $ managerGetPeers mgr+ maybe_mempool_last <- runConduit $ getMempool .| mapC fst .| headC+ let maybe_block_time_delta =+ (now -) . fromIntegral . blockTimestamp . blockDataHeader <$>+ maybe_block_best+ maybe_tx_time_delta =+ (now -) <$> maybe_mempool_last <|> maybe_block_time_delta+ status_ok =+ (isNothing maybe_chain_best ||+ isNothing maybe_block_best ||+ maybe False (not . Data.List.null) peers) &&+ maybe False (<= blockTimeout tos) maybe_block_time_delta &&+ maybe False (<= txTimeout tos) maybe_tx_time_delta+ synced = isJust $ do- x <- n- y <- b+ x <- maybe_chain_best+ y <- maybe_block_best guard $ nodeHeight x - blockDataHeight y <= 1 return HealthCheck- { healthBlockBest = headerHash . blockDataHeader <$> b- , healthBlockHeight = blockDataHeight <$> b- , healthHeaderBest = headerHash . nodeHeader <$> n- , healthHeaderHeight = nodeHeight <$> n- , healthPeers = length <$> p+ { 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 , healthNetwork = getNetworkName net- , healthOK = k- , healthSynced = s+ , healthOK = status_ok+ , healthSynced = synced+ , healthLastBlock = maybe_block_time_delta+ , healthLastTx = maybe_tx_time_delta } -- | Obtain information about connected peers from peer manager process.