haskoin-store 0.64.7 → 0.64.8
raw patch · 15 files changed
+8126/−8023 lines, 15 filesdep ~haskoin-store-dataPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: haskoin-store-data
API changes (from Hackage documentation)
Files
- CHANGELOG.md +9/−0
- haskoin-store.cabal +4/−4
- src/Haskoin/Store.hs +4/−3
- src/Haskoin/Store/BlockStore.hs +1220/−1219
- src/Haskoin/Store/Cache.hs +1492/−1489
- src/Haskoin/Store/Common.hs +225/−223
- src/Haskoin/Store/Database/Reader.hs +295/−298
- src/Haskoin/Store/Database/Types.hs +298/−287
- src/Haskoin/Store/Database/Writer.hs +201/−201
- src/Haskoin/Store/Logic.hs +757/−756
- src/Haskoin/Store/Manager.hs +217/−216
- src/Haskoin/Store/Stats.hs +100/−110
- src/Haskoin/Store/Web.hs +3134/−3047
- test/Haskoin/Store/CacheSpec.hs +15/−15
- test/Haskoin/StoreSpec.hs +155/−155
CHANGELOG.md view
@@ -4,6 +4,15 @@ 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.64.8+### Changed+- Use better Fourmolu format.+- Be more precise when counting retrieved items.++### Fixed+- Avoid transactions duplicated in xpub data.+- Refactor some functions to make them more robust.+ ## 0.64.7 ### Fixed - Optimisations for various Blockchain endpoints.
haskoin-store.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store-version: 0.64.7+version: 0.64.8 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@@ -60,7 +60,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.21.1 , haskoin-node >=0.17.0- , haskoin-store-data ==0.64.7+ , haskoin-store-data ==0.64.8 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1@@ -116,7 +116,7 @@ , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store- , haskoin-store-data ==0.64.7+ , haskoin-store-data ==0.64.8 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1@@ -177,7 +177,7 @@ , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store- , haskoin-store-data ==0.64.7+ , haskoin-store-data ==0.64.8 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store.hs view
@@ -1,5 +1,5 @@-module Haskoin.Store (- Store (..),+module Haskoin.Store+ ( Store (..), StoreConfig (..), StoreEvent (..), withStore,@@ -32,7 +32,8 @@ -- * Other Data PubExcept (..),-) where+ )+where import Haskoin.Store.BlockStore import Haskoin.Store.Cache
src/Haskoin/Store/BlockStore.hs view
@@ -7,1225 +7,1226 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.BlockStore (- -- * Block Store- BlockStore,- BlockStoreConfig (..),- withBlockStore,- blockStorePeerConnect,- blockStorePeerConnectSTM,- blockStorePeerDisconnect,- blockStorePeerDisconnectSTM,- blockStoreHead,- blockStoreHeadSTM,- blockStoreBlock,- blockStoreBlockSTM,- blockStoreNotFound,- blockStoreNotFoundSTM,- blockStoreTx,- blockStoreTxSTM,- blockStoreTxHash,- blockStoreTxHashSTM,- blockStorePendingTxs,- blockStorePendingTxsSTM,-) where--import Control.Monad (- forM,- forM_,- forever,- mzero,- unless,- void,- when,- )-import Control.Monad.Except (- ExceptT (..),- MonadError,- catchError,- runExceptT,- )-import Control.Monad.Logger (- MonadLoggerIO,- logDebugS,- logErrorS,- logInfoS,- logWarnS,- )-import Control.Monad.Reader (- MonadReader,- ReaderT (..),- ask,- asks,- )-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (runMaybeT)-import qualified Data.ByteString as B-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import Data.List (delete)-import Data.Maybe (- catMaybes,- fromJust,- isJust,- mapMaybe,- )-import Data.Serialize (encode)-import Data.String (fromString)-import Data.String.Conversions (cs)-import Data.Text (Text)-import Data.Time.Clock (- NominalDiffTime,- UTCTime,- diffUTCTime,- getCurrentTime,- )-import Data.Time.Clock.POSIX (- posixSecondsToUTCTime,- utcTimeToPOSIXSeconds,- )-import Data.Time.Format (- defaultTimeLocale,- formatTime,- iso8601DateFormat,- )-import Haskoin (- Block (..),- BlockHash (..),- BlockHeader (..),- BlockHeight,- BlockNode (..),- GetData (..),- InvType (..),- InvVector (..),- Message (..),- Network (..),- OutPoint (..),- Tx (..),- TxHash (..),- TxIn (..),- blockHashToHex,- headerHash,- txHash,- txHashToHex,- )-import Haskoin.Node (- Chain,- OnlinePeer (..),- Peer,- PeerException (..),- PeerManager,- chainBlockMain,- chainGetAncestor,- chainGetBest,- chainGetBlock,- chainGetParents,- getPeers,- killPeer,- peerText,- sendMessage,- setBusy,- setFree,- )-import Haskoin.Store.Common-import Haskoin.Store.Data-import Haskoin.Store.Database.Reader-import Haskoin.Store.Database.Writer-import Haskoin.Store.Logic (- ImportException (Orphan),- deleteUnconfirmedTx,- importBlock,- initBest,- newMempoolTx,- revertBlock,- )-import Haskoin.Store.Stats-import NQE (- Listen,- Mailbox,- Publisher,- inboxToMailbox,- newInbox,- publish,- query,- receive,- send,- sendSTM,- )-import qualified System.Metrics as Metrics-import qualified System.Metrics.Gauge as Metrics (Gauge)-import qualified System.Metrics.Gauge as Metrics.Gauge-import System.Random (randomRIO)-import UnliftIO (- Exception,- MonadIO,- MonadUnliftIO,- STM,- TVar,- async,- atomically,- liftIO,- link,- modifyTVar,- newTVarIO,- readTVar,- readTVarIO,- throwIO,- withAsync,- writeTVar,- )-import UnliftIO.Concurrent (threadDelay)--data BlockStoreMessage- = BlockNewBest !BlockNode- | BlockPeerConnect !Peer- | BlockPeerDisconnect !Peer- | BlockReceived !Peer !Block- | BlockNotFound !Peer ![BlockHash]- | TxRefReceived !Peer !Tx- | TxRefAvailable !Peer ![TxHash]- | BlockPing !(Listen ())--data BlockException- = BlockNotInChain !BlockHash- | Uninitialized- | CorruptDatabase- | AncestorNotInChain !BlockHeight !BlockHash- | MempoolImportFailed- deriving (Show, Eq, Ord, Exception)--data Syncing = Syncing- { syncingPeer :: !Peer- , syncingTime :: !UTCTime- , syncingBlocks :: ![BlockHash]- }--data PendingTx = PendingTx- { pendingTxTime :: !UTCTime- , pendingTx :: !Tx- , pendingDeps :: !(HashSet TxHash)- }- deriving (Show, Eq, Ord)---- | Block store process state.-data BlockStore = BlockStore- { myMailbox :: !(Mailbox BlockStoreMessage)- , myConfig :: !BlockStoreConfig- , myPeer :: !(TVar (Maybe Syncing))- , myTxs :: !(TVar (HashMap TxHash PendingTx))- , requested :: !(TVar (HashSet TxHash))- , myMetrics :: !(Maybe StoreMetrics)- }--data StoreMetrics = StoreMetrics- { storeHeight :: !Metrics.Gauge- , headersHeight :: !Metrics.Gauge- , storePendingTxs :: !Metrics.Gauge- , storePeersConnected :: !Metrics.Gauge- , storeMempoolSize :: !Metrics.Gauge- }--newStoreMetrics :: MonadIO m => Metrics.Store -> m StoreMetrics-newStoreMetrics s = liftIO $ do- storeHeight <- g "blockchain.height"- headersHeight <- g "blockchain.headers"- storePendingTxs <- g "mempool.pending_txs"- storePeersConnected <- g "network.peers_connected"- storeMempoolSize <- g "mempool.size"- return StoreMetrics{..}- where- g x = Metrics.createGauge ("store." <> x) s--setStoreHeight :: MonadIO m => BlockT m ()-setStoreHeight =- asks myMetrics >>= \case- Nothing -> return ()- Just m ->- getBestBlock >>= \case- Nothing -> setit m 0- Just bb ->- getBlock bb >>= \case- Nothing -> setit m 0- Just b -> setit m (blockDataHeight b)- where- setit m i = liftIO $ storeHeight m `Metrics.Gauge.set` fromIntegral i--setHeadersHeight :: MonadIO m => BlockT m ()-setHeadersHeight =- asks myMetrics >>= \case- Nothing -> return ()- Just m -> do- h <- fmap nodeHeight $ chainGetBest =<< asks (blockConfChain . myConfig)- liftIO $ headersHeight m `Metrics.Gauge.set` fromIntegral h--setPendingTxs :: MonadIO m => BlockT m ()-setPendingTxs =- asks myMetrics >>= \case- Nothing -> return ()- Just m -> do- s <- asks myTxs >>= \t -> atomically (HashMap.size <$> readTVar t)- liftIO $ storePendingTxs m `Metrics.Gauge.set` fromIntegral s--setPeersConnected :: MonadIO m => BlockT m ()-setPeersConnected =- asks myMetrics >>= \case- Nothing -> return ()- Just m -> do- ps <- fmap length $ getPeers =<< asks (blockConfManager . myConfig)- liftIO $ storePeersConnected m `Metrics.Gauge.set` fromIntegral ps--setMempoolSize :: MonadIO m => BlockT m ()-setMempoolSize =- asks myMetrics >>= \case- Nothing -> return ()- Just m -> do- s <- length <$> getMempool- liftIO $ storeMempoolSize m `Metrics.Gauge.set` fromIntegral s---- | Configuration for a block store.-data BlockStoreConfig = BlockStoreConfig- { -- | peer manager from running node- blockConfManager :: !PeerManager- , -- | chain from a running node- blockConfChain :: !Chain- , -- | listener for store events- blockConfListener :: !(Publisher StoreEvent)- , -- | RocksDB database handle- blockConfDB :: !DatabaseReader- , -- | network constants- blockConfNet :: !Network- , -- | do not index new mempool transactions- blockConfNoMempool :: !Bool- , -- | wipe mempool at start- blockConfWipeMempool :: !Bool- , -- | sync mempool from peers- blockConfSyncMempool :: !Bool- , -- | disconnect syncing peer if inactive for this long- blockConfPeerTimeout :: !NominalDiffTime- , blockConfStats :: !(Maybe Metrics.Store)- }--type BlockT m = ReaderT BlockStore m--runImport ::- MonadLoggerIO m =>- WriterT (ExceptT ImportException m) a ->- BlockT m (Either ImportException a)-runImport f =- ReaderT $ \r -> runExceptT $ runWriter (blockConfDB (myConfig r)) f--runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a-runRocksDB f =- ReaderT $ runReaderT f . blockConfDB . myConfig--instance MonadIO m => StoreReadBase (BlockT m) where- getNetwork =- runRocksDB getNetwork- getBestBlock =- runRocksDB getBestBlock- getBlocksAtHeight =- runRocksDB . getBlocksAtHeight- getBlock =- runRocksDB . getBlock- getTxData =- runRocksDB . getTxData- getSpender =- runRocksDB . getSpender- getUnspent =- runRocksDB . getUnspent- getBalance =- runRocksDB . getBalance- getMempool =- runRocksDB getMempool--instance MonadUnliftIO m => StoreReadExtra (BlockT m) where- getMaxGap =- runRocksDB getMaxGap- getInitialGap =- runRocksDB getInitialGap- getAddressesTxs as =- runRocksDB . getAddressesTxs as- getAddressesUnspents as =- runRocksDB . getAddressesUnspents as- getAddressUnspents a =- runRocksDB . getAddressUnspents a- getAddressTxs a =- runRocksDB . getAddressTxs a- getNumTxData =- runRocksDB . getNumTxData- getBalances =- runRocksDB . getBalances- xPubBals =- runRocksDB . xPubBals- xPubUnspents x l =- runRocksDB . xPubUnspents x l- xPubTxs x l =- runRocksDB . xPubTxs x l- xPubTxCount x =- runRocksDB . xPubTxCount x---- | Run block store process.-withBlockStore ::- (MonadUnliftIO m, MonadLoggerIO m) =>- BlockStoreConfig ->- (BlockStore -> m a) ->- m a-withBlockStore cfg action = do- pb <- newTVarIO Nothing- ts <- newTVarIO HashMap.empty- rq <- newTVarIO HashSet.empty- inbox <- newInbox- metrics <- mapM newStoreMetrics (blockConfStats cfg)- let r =- BlockStore- { myMailbox = inboxToMailbox inbox- , myConfig = cfg- , myPeer = pb- , myTxs = ts- , requested = rq- , myMetrics = metrics- }- withAsync (runReaderT (go inbox) r) $ \a -> do- link a- action r- where- go inbox = do- ini- wipe- run inbox- del txs = do- $(logInfoS) "BlockStore" $- "Deleting " <> cs (show (length txs)) <> " transactions"- forM_ txs $ \(_, th) -> deleteUnconfirmedTx False th- wipe_it txs = do- let (txs1, txs2) = splitAt 1000 txs- unless (null txs1) $- runImport (del txs1) >>= \case- Left e -> do- $(logErrorS) "BlockStore" $- "Could not wipe mempool: " <> cs (show e)- throwIO e- Right () -> wipe_it txs2- wipe- | blockConfWipeMempool cfg =- getMempool >>= wipe_it- | otherwise =- return ()- ini =- runImport initBest >>= \case- Left e -> do- $(logErrorS) "BlockStore" $- "Could not initialize: " <> cs (show e)- throwIO e- Right () -> return ()- run inbox =- withAsync (pingMe (inboxToMailbox inbox)) $- const $- forever $- receive inbox- >>= ReaderT . runReaderT . processBlockStoreMessage--isInSync :: MonadLoggerIO m => BlockT m Bool-isInSync =- getBestBlock >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "Block database uninitialized"- throwIO Uninitialized- Just bb -> do- cb <- asks (blockConfChain . myConfig) >>= chainGetBest- if headerHash (nodeHeader cb) == bb- then clearSyncingState >> return True- else return False--guardMempool :: Monad m => BlockT m () -> BlockT m ()-guardMempool f = do- n <- asks (blockConfNoMempool . myConfig)- unless n f--syncMempool :: Monad m => BlockT m () -> BlockT m ()-syncMempool f = do- s <- asks (blockConfSyncMempool . myConfig)- when s f--mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()-mempool p = guardMempool $- syncMempool $- void $- async $ do- isInSync >>= \s -> when s $ do- $(logDebugS) "BlockStore" $- "Requesting mempool from peer: " <> peerText p- MMempool `sendMessage` p--processBlock ::- (MonadUnliftIO m, MonadLoggerIO m) =>- Peer ->- Block ->- BlockT m ()-processBlock peer block = void . runMaybeT $ do- checkPeer peer >>= \case- True -> return ()- False -> do- $(logErrorS) "BlockStore" $- "Non-syncing peer " <> peerText peer- <> " sent me a block: "- <> blockHashToHex blockhash- PeerMisbehaving "Sent unexpected block" `killPeer` peer- mzero- node <-- getBlockNode blockhash >>= \case- Just b -> return b- Nothing -> do- $(logErrorS) "BlockStore" $- "Peer " <> peerText peer- <> " sent unknown block: "- <> blockHashToHex blockhash- PeerMisbehaving "Sent unknown block" `killPeer` peer- mzero- $(logDebugS) "BlockStore" $- "Processing block: " <> blockText node Nothing- <> " from peer: "- <> peerText peer- lift . notify (Just block) $- runImport (importBlock block node) >>= \case- Left e -> failure e- Right () -> success node- where- header = blockHeader block- blockhash = headerHash header- hexhash = blockHashToHex blockhash- success node = do- $(logInfoS) "BlockStore" $- "Best block: " <> blockText node (Just block)- removeSyncingBlock $ headerHash $ nodeHeader node- touchPeer- isInSync >>= \case- False -> syncMe- True -> do- updateOrphans- mempool peer- failure e = do- $(logErrorS) "BlockStore" $- "Error importing block " <> hexhash- <> " from peer: "- <> peerText peer- <> ": "- <> cs (show e)- killPeer (PeerMisbehaving (show e)) peer--setSyncingBlocks ::- (MonadReader BlockStore m, MonadIO m) =>- [BlockHash] ->- m ()-setSyncingBlocks hs =- asks myPeer >>= \box ->- atomically $- modifyTVar box $ \case- Nothing -> Nothing- Just x -> Just x{syncingBlocks = hs}--getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash]-getSyncingBlocks =- asks myPeer >>= readTVarIO >>= \case- Nothing -> return []- Just x -> return $ syncingBlocks x--addSyncingBlocks ::- (MonadReader BlockStore m, MonadIO m) =>- [BlockHash] ->- m ()-addSyncingBlocks hs =- asks myPeer >>= \box ->- atomically $- modifyTVar box $ \case- Nothing -> Nothing- Just x -> Just x{syncingBlocks = syncingBlocks x <> hs}--removeSyncingBlock ::- (MonadReader BlockStore m, MonadIO m) =>- BlockHash ->- m ()-removeSyncingBlock h = do- box <- asks myPeer- atomically $- modifyTVar box $ \case- Nothing -> Nothing- Just x -> Just x{syncingBlocks = delete h (syncingBlocks x)}--checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool-checkPeer p =- fmap syncingPeer <$> getSyncingState >>= \case- Nothing -> return False- Just p' -> return $ p == p'--getBlockNode ::- (MonadLoggerIO m, MonadReader BlockStore m) =>- BlockHash ->- m (Maybe BlockNode)-getBlockNode blockhash =- chainGetBlock blockhash =<< asks (blockConfChain . myConfig)--processNoBlocks ::- MonadLoggerIO m =>- Peer ->- [BlockHash] ->- BlockT m ()-processNoBlocks p hs = do- forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) ->- $(logErrorS) "BlockStore" $- "Block "- <> cs (show i)- <> "/"- <> cs (show (length hs))- <> " "- <> blockHashToHex h- <> " not found by peer: "- <> peerText p- killPeer (PeerMisbehaving "Did not find requested block(s)") p--processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m ()-processTx p tx = guardMempool $ do- t <- liftIO getCurrentTime- $(logDebugS) "BlockManager" $- "Received tx " <> txHashToHex (txHash tx)- <> " by peer: "- <> peerText p- addPendingTx $ PendingTx t tx HashSet.empty--pruneOrphans :: MonadIO m => BlockT m ()-pruneOrphans = guardMempool $ do- ts <- asks myTxs- now <- liftIO getCurrentTime- atomically . modifyTVar ts . HashMap.filter $ \p ->- now `diffUTCTime` pendingTxTime p > 600--addPendingTx :: MonadIO m => PendingTx -> BlockT m ()-addPendingTx p = do- ts <- asks myTxs- rq <- asks requested- atomically $ do- modifyTVar ts $ HashMap.insert th p- modifyTVar rq $ HashSet.delete th- HashMap.size <$> readTVar ts- setPendingTxs- where- th = txHash (pendingTx p)--addRequestedTx :: MonadIO m => TxHash -> BlockT m ()-addRequestedTx th = do- qbox <- asks requested- atomically $ modifyTVar qbox $ HashSet.insert th- liftIO $- void $- async $ do- threadDelay 20000000- atomically $ modifyTVar qbox $ HashSet.delete th--isPending :: MonadIO m => TxHash -> BlockT m Bool-isPending th = do- tbox <- asks myTxs- qbox <- asks requested- atomically $ do- ts <- readTVar tbox- rs <- readTVar qbox- return $- th `HashMap.member` ts- || th `HashSet.member` rs--pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx]-pendingTxs i = do- selected <-- asks myTxs >>= \box -> atomically $ do- pending <- readTVar box- let (selected, rest) = select pending- writeTVar box rest- return (selected)- setPendingTxs- return selected- where- select pend =- let eligible = HashMap.filter (null . pendingDeps) pend- orphans = HashMap.difference pend eligible- selected = take i $ sortit eligible- remaining = HashMap.filter (`notElem` selected) eligible- in (selected, remaining <> orphans)- sortit m =- let sorted = sortTxs $ map pendingTx $ HashMap.elems m- txids = map (txHash . snd) sorted- in mapMaybe (`HashMap.lookup` m) txids--fulfillOrphans :: MonadIO m => BlockStore -> TxHash -> m ()-fulfillOrphans block_read th =- atomically $ modifyTVar box (HashMap.map fulfill)- where- box = myTxs block_read- fulfill p = p{pendingDeps = HashSet.delete th (pendingDeps p)}--updateOrphans ::- ( StoreReadBase m- , MonadLoggerIO m- , MonadReader BlockStore m- ) =>- m ()-updateOrphans = do- box <- asks myTxs- pending <- readTVarIO box- let orphans = HashMap.filter (not . null . pendingDeps) pending- updated <- forM orphans $ \p -> do- let tx = pendingTx p- exists (txHash tx) >>= \case- True -> return Nothing- False -> Just <$> fill_deps p- let pruned = HashMap.map fromJust $ HashMap.filter isJust updated- atomically $ writeTVar box pruned- where- exists th =- getTxData th >>= \case- Nothing -> return False- Just TxData{txDataDeleted = True} -> return False- Just TxData{txDataDeleted = False} -> return True- prev_utxos tx = catMaybes <$> mapM (getUnspent . prevOutput) (txIn tx)- fulfill p unspent =- let unspent_hash = outPointHash (unspentPoint unspent)- new_deps = HashSet.delete unspent_hash (pendingDeps p)- in p{pendingDeps = new_deps}- fill_deps p = do- let tx = pendingTx p- unspents <- prev_utxos tx- return $ foldl fulfill p unspents--newOrphanTx ::- MonadLoggerIO m =>- BlockStore ->- UTCTime ->- Tx ->- WriterT m ()-newOrphanTx block_read time tx = do- $(logDebugS) "BlockStore" $- "Import tx "- <> txHashToHex (txHash tx)- <> ": Orphan"- let box = myTxs block_read- unspents <- catMaybes <$> mapM getUnspent prevs- let unspent_set = HashSet.fromList (map unspentPoint unspents)- missing_set = HashSet.difference prev_set unspent_set- missing_txs = HashSet.map outPointHash missing_set- atomically . modifyTVar box $- HashMap.insert- (txHash tx)- PendingTx- { pendingTxTime = time- , pendingTx = tx- , pendingDeps = missing_txs- }- where- prev_set = HashSet.fromList prevs- prevs = map prevOutput (txIn tx)--importMempoolTx ::- (MonadLoggerIO m, MonadError ImportException m) =>- BlockStore ->- UTCTime ->- Tx ->- WriterT m Bool-importMempoolTx block_read time tx =- catchError new_mempool_tx handle_error- where- tx_hash = txHash tx- handle_error Orphan = do- newOrphanTx block_read time tx- return False- handle_error _ = return False- seconds = floor (utcTimeToPOSIXSeconds time)- new_mempool_tx =- newMempoolTx tx seconds >>= \case- True -> do- $(logInfoS) "BlockStore" $- "Import tx " <> txHashToHex (txHash tx)- <> ": OK"- fulfillOrphans block_read tx_hash- return True- False -> do- $(logDebugS) "BlockStore" $- "Import tx " <> txHashToHex (txHash tx)- <> ": Already imported"- return False--notify :: MonadIO m => Maybe Block -> BlockT m a -> BlockT m a-notify block go = do- old <- HashSet.union e . HashSet.fromList . map snd <$> getMempool- x <- go- new <- HashSet.fromList . map snd <$> getMempool- l <- asks (blockConfListener . myConfig)- forM_ (old `HashSet.difference` new) $ \h ->- publish (StoreMempoolDelete h) l- forM_ (new `HashSet.difference` old) $ \h ->- publish (StoreMempoolNew h) l- case block of- Just b -> publish (StoreBestBlock (headerHash (blockHeader b))) l- Nothing -> return ()- return x- where- e = case block of- Just b -> HashSet.fromList (map txHash (blockTxns b))- Nothing -> HashSet.empty--processMempool :: MonadLoggerIO m => BlockT m ()-processMempool = guardMempool . notify Nothing $ do- txs <- pendingTxs 2000- block_read <- ask- unless (null txs) (import_txs block_read txs)- where- run_import block_read p =- let t = pendingTx p- h = txHash t- in importMempoolTx block_read (pendingTxTime p) (pendingTx p)- import_txs block_read txs =- let r = mapM (run_import block_read) txs- in runImport r >>= \case- Left e -> report_error e- Right _ -> return ()- report_error e = do- $(logErrorS) "BlockImport" $- "Error processing mempool: " <> cs (show e)- throwIO e--processTxs ::- MonadLoggerIO m =>- Peer ->- [TxHash] ->- BlockT m ()-processTxs p hs = guardMempool $ do- s <- isInSync- when s $ do- $(logDebugS) "BlockStore" $- "Received inventory with "- <> cs (show (length hs))- <> " transactions from peer: "- <> peerText p- xs <- catMaybes <$> zip_counter process_tx- unless (null xs) $ go xs- where- len = length hs- zip_counter = forM (zip [(1 :: Int) ..] hs) . uncurry- process_tx i h =- isPending h >>= \case- True -> do- $(logDebugS) "BlockStore" $- "Tx " <> cs (show i) <> "/" <> cs (show len)- <> " "- <> txHashToHex h- <> ": "- <> "Pending"- return Nothing- False ->- getActiveTxData h >>= \case- Just _ -> do- $(logDebugS) "BlockStore" $- "Tx " <> cs (show i) <> "/" <> cs (show len)- <> " "- <> txHashToHex h- <> ": "- <> "Already Imported"- return Nothing- Nothing -> do- $(logDebugS) "BlockStore" $- "Tx " <> cs (show i) <> "/" <> cs (show len)- <> " "- <> txHashToHex h- <> ": "- <> "Requesting"- return (Just h)- go xs = do- mapM_ addRequestedTx xs- net <- asks (blockConfNet . myConfig)- let inv = if getSegWit net then InvWitnessTx else InvTx- vec = map (InvVector inv . getTxHash) xs- msg = MGetData (GetData vec)- msg `sendMessage` p--touchPeer ::- ( MonadIO m- , MonadReader BlockStore m- ) =>- m ()-touchPeer =- getSyncingState >>= \case- Nothing -> return ()- Just _ -> do- box <- asks myPeer- now <- liftIO getCurrentTime- atomically $- modifyTVar box $- fmap $ \x -> x{syncingTime = now}--checkTime :: MonadLoggerIO m => BlockT m ()-checkTime =- asks myPeer >>= readTVarIO >>= \case- Nothing -> return ()- Just- Syncing- { syncingTime = t- , syncingPeer = p- } -> do- now <- liftIO getCurrentTime- peer_time_out <- asks (blockConfPeerTimeout . myConfig)- when (now `diffUTCTime` t > peer_time_out) $ do- $(logErrorS) "BlockStore" $- "Syncing peer timeout: " <> peerText p- killPeer PeerTimeout p--revertToMainChain :: MonadLoggerIO m => BlockT m ()-revertToMainChain = do- h <- headerHash . nodeHeader <$> getBest- ch <- asks (blockConfChain . myConfig)- chainBlockMain h ch >>= \x -> unless x $ do- $(logWarnS) "BlockStore" $- "Reverting best block: "- <> blockHashToHex h- runImport (revertBlock h) >>= \case- Left e -> do- $(logErrorS) "BlockStore" $- "Could not revert block "- <> blockHashToHex h- <> ": "- <> cs (show e)- throwIO e- Right () -> setSyncingBlocks []- revertToMainChain--getBest :: MonadLoggerIO m => BlockT m BlockNode-getBest = do- bb <-- getBestBlock >>= \case- Just b -> return b- Nothing -> do- $(logErrorS) "BlockStore" "No best block set"- throwIO Uninitialized- ch <- asks (blockConfChain . myConfig)- chainGetBlock bb ch >>= \case- Just x -> return x- Nothing -> do- $(logErrorS) "BlockStore" $- "Header not found for best block: "- <> blockHashToHex bb- throwIO (BlockNotInChain bb)--getSyncBest :: MonadLoggerIO m => BlockT m BlockNode-getSyncBest = do- bb <-- getSyncingBlocks >>= \case- [] ->- getBestBlock >>= \case- Just b -> return b- Nothing -> do- $(logErrorS) "BlockStore" "No best block set"- throwIO Uninitialized- hs -> return $ last hs- ch <- asks (blockConfChain . myConfig)- chainGetBlock bb ch >>= \case- Just x -> return x- Nothing -> do- $(logErrorS) "BlockStore" $- "Header not found for block: "- <> blockHashToHex bb- throwIO (BlockNotInChain bb)--shouldSync :: MonadLoggerIO m => BlockT m (Maybe Peer)-shouldSync =- isInSync >>= \case- True -> return Nothing- False ->- getSyncingState >>= \case- Nothing -> return Nothing- Just Syncing{syncingPeer = p, syncingBlocks = bs}- | 100 > length bs -> return (Just p)- | otherwise -> return Nothing--syncMe :: MonadLoggerIO m => BlockT m ()-syncMe = do- revertToMainChain- shouldSync >>= \case- Nothing -> return ()- Just p -> do- bb <- getSyncBest- bh <- getbh- when (bb /= bh) $ do- bns <- sel bb bh- iv <- getiv bns- $(logDebugS) "BlockStore" $- "Requesting "- <> fromString (show (length iv))- <> " blocks from peer: "- <> peerText p- addSyncingBlocks $ map (headerHash . nodeHeader) bns- MGetData (GetData iv) `sendMessage` p- where- getiv bns = do- w <- getSegWit <$> asks (blockConfNet . myConfig)- let i = if w then InvWitnessBlock else InvBlock- f = InvVector i . getBlockHash . headerHash . nodeHeader- return $ map f bns- getbh =- chainGetBest =<< asks (blockConfChain . myConfig)- sel bb bh = do- let sh = geth bb bh- t <- top sh bh- ch <- asks (blockConfChain . myConfig)- ps <- chainGetParents (nodeHeight bb + 1) t ch- return $- if 500 > length ps- then ps <> [bh]- else ps- geth bb bh =- min- (nodeHeight bb + 501)- (nodeHeight bh)- top sh bh =- if sh == nodeHeight bh- then return bh- else findAncestor sh bh--findAncestor ::- (MonadLoggerIO m, MonadReader BlockStore m) =>- BlockHeight ->- BlockNode ->- m BlockNode-findAncestor height target = do- ch <- asks (blockConfChain . myConfig)- chainGetAncestor height target ch >>= \case- Just ancestor -> return ancestor- Nothing -> do- let h = headerHash $ nodeHeader target- $(logErrorS) "BlockStore" $- "Could not find header for ancestor of block "- <> blockHashToHex h- <> " at height "- <> cs (show (nodeHeight target))- throwIO $ AncestorNotInChain height h--finishPeer ::- (MonadLoggerIO m, MonadReader BlockStore m) =>- Peer ->- m ()-finishPeer p = do- box <- asks myPeer- readTVarIO box >>= \case- Just Syncing{syncingPeer = p'} | p == p' -> reset_it box- _ -> return ()- where- reset_it box = do- atomically $ writeTVar box Nothing- $(logDebugS) "BlockStore" $ "Releasing peer: " <> peerText p- setFree p--trySetPeer :: MonadLoggerIO m => Peer -> BlockT m Bool-trySetPeer p =- getSyncingState >>= \case- Just _ -> return False- Nothing -> set_it- where- set_it =- setBusy p >>= \case- False -> return False- True -> do- $(logDebugS) "BlockStore" $- "Locked peer: " <> peerText p- box <- asks myPeer- now <- liftIO getCurrentTime- atomically . writeTVar box $- Just- Syncing- { syncingPeer = p- , syncingTime = now- , syncingBlocks = []- }- return True--trySyncing :: MonadLoggerIO m => BlockT m ()-trySyncing =- isInSync >>= \case- True -> return ()- False ->- getSyncingState >>= \case- Just _ -> return ()- Nothing -> online_peer- where- recurse [] = return ()- recurse (p : ps) =- trySetPeer p >>= \case- False -> recurse ps- True -> syncMe- online_peer = do- ops <- getPeers =<< asks (blockConfManager . myConfig)- let ps = map onlinePeerMailbox ops- recurse ps--trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()-trySyncingPeer p =- isInSync >>= \case- True -> mempool p- False ->- trySetPeer p >>= \case- False -> return ()- True -> syncMe--getSyncingState ::- (MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing)-getSyncingState =- readTVarIO =<< asks myPeer--clearSyncingState ::- (MonadLoggerIO m, MonadReader BlockStore m) => m ()-clearSyncingState =- asks myPeer >>= readTVarIO >>= \case- Nothing -> return ()- Just Syncing{syncingPeer = p} -> finishPeer p--processBlockStoreMessage ::- (MonadUnliftIO m, MonadLoggerIO m) =>- BlockStoreMessage ->- BlockT m ()-processBlockStoreMessage (BlockNewBest _) =- trySyncing-processBlockStoreMessage (BlockPeerConnect p) =- trySyncingPeer p-processBlockStoreMessage (BlockPeerDisconnect p) =- finishPeer p-processBlockStoreMessage (BlockReceived p b) =- processBlock p b-processBlockStoreMessage (BlockNotFound p bs) =- processNoBlocks p bs-processBlockStoreMessage (TxRefReceived p tx) =- processTx p tx-processBlockStoreMessage (TxRefAvailable p ts) =- processTxs p ts-processBlockStoreMessage (BlockPing r) = do- setStoreHeight- setHeadersHeight- setPendingTxs- setPeersConnected- setMempoolSize- trySyncing- processMempool- pruneOrphans- checkTime- atomically (r ())--pingMe :: MonadLoggerIO m => Mailbox BlockStoreMessage -> m ()-pingMe mbox =- forever $ do- BlockPing `query` mbox- delay <-- liftIO $- randomRIO- ( 100 * 1000- , 1000 * 1000- )- threadDelay delay--blockStorePeerConnect :: MonadIO m => Peer -> BlockStore -> m ()-blockStorePeerConnect peer store =- BlockPeerConnect peer `send` myMailbox store--blockStorePeerDisconnect ::- MonadIO m => Peer -> BlockStore -> m ()-blockStorePeerDisconnect peer store =- BlockPeerDisconnect peer `send` myMailbox store--blockStoreHead ::- MonadIO m => BlockNode -> BlockStore -> m ()-blockStoreHead node store =- BlockNewBest node `send` myMailbox store--blockStoreBlock ::- MonadIO m => Peer -> Block -> BlockStore -> m ()-blockStoreBlock peer block store =- BlockReceived peer block `send` myMailbox store--blockStoreNotFound ::- MonadIO m => Peer -> [BlockHash] -> BlockStore -> m ()-blockStoreNotFound peer blocks store =- BlockNotFound peer blocks `send` myMailbox store--blockStoreTx ::- MonadIO m => Peer -> Tx -> BlockStore -> m ()-blockStoreTx peer tx store =- TxRefReceived peer tx `send` myMailbox store--blockStoreTxHash ::- MonadIO m => Peer -> [TxHash] -> BlockStore -> m ()-blockStoreTxHash peer txhashes store =- TxRefAvailable peer txhashes `send` myMailbox store--blockStorePeerConnectSTM ::- Peer -> BlockStore -> STM ()-blockStorePeerConnectSTM peer store =- BlockPeerConnect peer `sendSTM` myMailbox store--blockStorePeerDisconnectSTM ::- Peer -> BlockStore -> STM ()-blockStorePeerDisconnectSTM peer store =- BlockPeerDisconnect peer `sendSTM` myMailbox store--blockStoreHeadSTM ::- BlockNode -> BlockStore -> STM ()-blockStoreHeadSTM node store =- BlockNewBest node `sendSTM` myMailbox store--blockStoreBlockSTM ::- Peer -> Block -> BlockStore -> STM ()-blockStoreBlockSTM peer block store =- BlockReceived peer block `sendSTM` myMailbox store--blockStoreNotFoundSTM ::- Peer -> [BlockHash] -> BlockStore -> STM ()-blockStoreNotFoundSTM peer blocks store =- BlockNotFound peer blocks `sendSTM` myMailbox store--blockStoreTxSTM ::- Peer -> Tx -> BlockStore -> STM ()-blockStoreTxSTM peer tx store =- TxRefReceived peer tx `sendSTM` myMailbox store--blockStoreTxHashSTM ::- Peer -> [TxHash] -> BlockStore -> STM ()-blockStoreTxHashSTM peer txhashes store =- TxRefAvailable peer txhashes `sendSTM` myMailbox store--blockStorePendingTxs ::- MonadIO m => BlockStore -> m Int-blockStorePendingTxs =- atomically . blockStorePendingTxsSTM--blockStorePendingTxsSTM ::- BlockStore -> STM Int-blockStorePendingTxsSTM BlockStore{..} = do- x <- HashMap.keysSet <$> readTVar myTxs- y <- readTVar requested- return $ HashSet.size $ x `HashSet.union` y--blockText :: BlockNode -> Maybe Block -> Text-blockText bn mblock = case mblock of- Nothing ->- height <> sep <> time <> sep <> hash- Just block ->- height <> sep <> time <> sep <> hash <> sep <> size block- where- height = cs $ show (nodeHeight bn)- systime =- posixSecondsToUTCTime $- fromIntegral $- blockTimestamp $- nodeHeader bn- time =- cs $- formatTime- defaultTimeLocale- (iso8601DateFormat (Just "%H:%M"))- systime+module Haskoin.Store.BlockStore+ ( -- * Block Store+ BlockStore,+ BlockStoreConfig (..),+ withBlockStore,+ blockStorePeerConnect,+ blockStorePeerConnectSTM,+ blockStorePeerDisconnect,+ blockStorePeerDisconnectSTM,+ blockStoreHead,+ blockStoreHeadSTM,+ blockStoreBlock,+ blockStoreBlockSTM,+ blockStoreNotFound,+ blockStoreNotFoundSTM,+ blockStoreTx,+ blockStoreTxSTM,+ blockStoreTxHash,+ blockStoreTxHashSTM,+ blockStorePendingTxs,+ blockStorePendingTxsSTM,+ )+where++import Control.Monad+ ( forM,+ forM_,+ forever,+ mzero,+ unless,+ void,+ when,+ )+import Control.Monad.Except+ ( ExceptT (..),+ MonadError,+ catchError,+ runExceptT,+ )+import Control.Monad.Logger+ ( MonadLoggerIO,+ logDebugS,+ logErrorS,+ logInfoS,+ logWarnS,+ )+import Control.Monad.Reader+ ( MonadReader,+ ReaderT (..),+ ask,+ asks,+ )+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (runMaybeT)+import qualified Data.ByteString as B+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.List (delete)+import Data.Maybe+ ( catMaybes,+ fromJust,+ isJust,+ mapMaybe,+ )+import Data.Serialize (encode)+import Data.String (fromString)+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Time.Clock+ ( NominalDiffTime,+ UTCTime,+ diffUTCTime,+ getCurrentTime,+ )+import Data.Time.Clock.POSIX+ ( posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds,+ )+import Data.Time.Format+ ( defaultTimeLocale,+ formatTime,+ iso8601DateFormat,+ )+import Haskoin+ ( Block (..),+ BlockHash (..),+ BlockHeader (..),+ BlockHeight,+ BlockNode (..),+ GetData (..),+ InvType (..),+ InvVector (..),+ Message (..),+ Network (..),+ OutPoint (..),+ Tx (..),+ TxHash (..),+ TxIn (..),+ blockHashToHex,+ headerHash,+ txHash,+ txHashToHex,+ )+import Haskoin.Node+ ( Chain,+ OnlinePeer (..),+ Peer,+ PeerException (..),+ PeerManager,+ chainBlockMain,+ chainGetAncestor,+ chainGetBest,+ chainGetBlock,+ chainGetParents,+ getPeers,+ killPeer,+ peerText,+ sendMessage,+ setBusy,+ setFree,+ )+import Haskoin.Store.Common+import Haskoin.Store.Data+import Haskoin.Store.Database.Reader+import Haskoin.Store.Database.Writer+import Haskoin.Store.Logic+ ( ImportException (Orphan),+ deleteUnconfirmedTx,+ importBlock,+ initBest,+ newMempoolTx,+ revertBlock,+ )+import Haskoin.Store.Stats+import NQE+ ( Listen,+ Mailbox,+ Publisher,+ inboxToMailbox,+ newInbox,+ publish,+ query,+ receive,+ send,+ sendSTM,+ )+import qualified System.Metrics as Metrics+import qualified System.Metrics.Gauge as Metrics (Gauge)+import qualified System.Metrics.Gauge as Metrics.Gauge+import System.Random (randomRIO)+import UnliftIO+ ( Exception,+ MonadIO,+ MonadUnliftIO,+ STM,+ TVar,+ async,+ atomically,+ liftIO,+ link,+ modifyTVar,+ newTVarIO,+ readTVar,+ readTVarIO,+ throwIO,+ withAsync,+ writeTVar,+ )+import UnliftIO.Concurrent (threadDelay)++data BlockStoreMessage+ = BlockNewBest !BlockNode+ | BlockPeerConnect !Peer+ | BlockPeerDisconnect !Peer+ | BlockReceived !Peer !Block+ | BlockNotFound !Peer ![BlockHash]+ | TxRefReceived !Peer !Tx+ | TxRefAvailable !Peer ![TxHash]+ | BlockPing !(Listen ())++data BlockException+ = BlockNotInChain !BlockHash+ | Uninitialized+ | CorruptDatabase+ | AncestorNotInChain !BlockHeight !BlockHash+ | MempoolImportFailed+ deriving (Show, Eq, Ord, Exception)++data Syncing = Syncing+ { syncingPeer :: !Peer,+ syncingTime :: !UTCTime,+ syncingBlocks :: ![BlockHash]+ }++data PendingTx = PendingTx+ { pendingTxTime :: !UTCTime,+ pendingTx :: !Tx,+ pendingDeps :: !(HashSet TxHash)+ }+ deriving (Show, Eq, Ord)++-- | Block store process state.+data BlockStore = BlockStore+ { myMailbox :: !(Mailbox BlockStoreMessage),+ myConfig :: !BlockStoreConfig,+ myPeer :: !(TVar (Maybe Syncing)),+ myTxs :: !(TVar (HashMap TxHash PendingTx)),+ requested :: !(TVar (HashSet TxHash)),+ myMetrics :: !(Maybe StoreMetrics)+ }++data StoreMetrics = StoreMetrics+ { storeHeight :: !Metrics.Gauge,+ headersHeight :: !Metrics.Gauge,+ storePendingTxs :: !Metrics.Gauge,+ storePeersConnected :: !Metrics.Gauge,+ storeMempoolSize :: !Metrics.Gauge+ }++newStoreMetrics :: MonadIO m => Metrics.Store -> m StoreMetrics+newStoreMetrics s = liftIO $ do+ storeHeight <- g "blockchain.height"+ headersHeight <- g "blockchain.headers"+ storePendingTxs <- g "mempool.pending_txs"+ storePeersConnected <- g "network.peers_connected"+ storeMempoolSize <- g "mempool.size"+ return StoreMetrics {..}+ where+ g x = Metrics.createGauge ("store." <> x) s++setStoreHeight :: MonadIO m => BlockT m ()+setStoreHeight =+ asks myMetrics >>= \case+ Nothing -> return ()+ Just m ->+ getBestBlock >>= \case+ Nothing -> setit m 0+ Just bb ->+ getBlock bb >>= \case+ Nothing -> setit m 0+ Just b -> setit m (blockDataHeight b)+ where+ setit m i = liftIO $ storeHeight m `Metrics.Gauge.set` fromIntegral i++setHeadersHeight :: MonadIO m => BlockT m ()+setHeadersHeight =+ asks myMetrics >>= \case+ Nothing -> return ()+ Just m -> do+ h <- fmap nodeHeight $ chainGetBest =<< asks (blockConfChain . myConfig)+ liftIO $ headersHeight m `Metrics.Gauge.set` fromIntegral h++setPendingTxs :: MonadIO m => BlockT m ()+setPendingTxs =+ asks myMetrics >>= \case+ Nothing -> return ()+ Just m -> do+ s <- asks myTxs >>= \t -> atomically (HashMap.size <$> readTVar t)+ liftIO $ storePendingTxs m `Metrics.Gauge.set` fromIntegral s++setPeersConnected :: MonadIO m => BlockT m ()+setPeersConnected =+ asks myMetrics >>= \case+ Nothing -> return ()+ Just m -> do+ ps <- fmap length $ getPeers =<< asks (blockConfManager . myConfig)+ liftIO $ storePeersConnected m `Metrics.Gauge.set` fromIntegral ps++setMempoolSize :: MonadIO m => BlockT m ()+setMempoolSize =+ asks myMetrics >>= \case+ Nothing -> return ()+ Just m -> do+ s <- length <$> getMempool+ liftIO $ storeMempoolSize m `Metrics.Gauge.set` fromIntegral s++-- | Configuration for a block store.+data BlockStoreConfig = BlockStoreConfig+ { -- | peer manager from running node+ blockConfManager :: !PeerManager,+ -- | chain from a running node+ blockConfChain :: !Chain,+ -- | listener for store events+ blockConfListener :: !(Publisher StoreEvent),+ -- | RocksDB database handle+ blockConfDB :: !DatabaseReader,+ -- | network constants+ blockConfNet :: !Network,+ -- | do not index new mempool transactions+ blockConfNoMempool :: !Bool,+ -- | wipe mempool at start+ blockConfWipeMempool :: !Bool,+ -- | sync mempool from peers+ blockConfSyncMempool :: !Bool,+ -- | disconnect syncing peer if inactive for this long+ blockConfPeerTimeout :: !NominalDiffTime,+ blockConfStats :: !(Maybe Metrics.Store)+ }++type BlockT m = ReaderT BlockStore m++runImport ::+ MonadLoggerIO m =>+ WriterT (ExceptT ImportException m) a ->+ BlockT m (Either ImportException a)+runImport f =+ ReaderT $ \r -> runExceptT $ runWriter (blockConfDB (myConfig r)) f++runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a+runRocksDB f =+ ReaderT $ runReaderT f . blockConfDB . myConfig++instance MonadIO m => StoreReadBase (BlockT m) where+ getNetwork =+ runRocksDB getNetwork+ getBestBlock =+ runRocksDB getBestBlock+ getBlocksAtHeight =+ runRocksDB . getBlocksAtHeight+ getBlock =+ runRocksDB . getBlock+ getTxData =+ runRocksDB . getTxData+ getSpender =+ runRocksDB . getSpender+ getUnspent =+ runRocksDB . getUnspent+ getBalance =+ runRocksDB . getBalance+ getMempool =+ runRocksDB getMempool++instance MonadUnliftIO m => StoreReadExtra (BlockT m) where+ getMaxGap =+ runRocksDB getMaxGap+ getInitialGap =+ runRocksDB getInitialGap+ getAddressesTxs as =+ runRocksDB . getAddressesTxs as+ getAddressesUnspents as =+ runRocksDB . getAddressesUnspents as+ getAddressUnspents a =+ runRocksDB . getAddressUnspents a+ getAddressTxs a =+ runRocksDB . getAddressTxs a+ getNumTxData =+ runRocksDB . getNumTxData+ getBalances =+ runRocksDB . getBalances+ xPubBals =+ runRocksDB . xPubBals+ xPubUnspents x l =+ runRocksDB . xPubUnspents x l+ xPubTxs x l =+ runRocksDB . xPubTxs x l+ xPubTxCount x =+ runRocksDB . xPubTxCount x++-- | Run block store process.+withBlockStore ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ BlockStoreConfig ->+ (BlockStore -> m a) ->+ m a+withBlockStore cfg action = do+ pb <- newTVarIO Nothing+ ts <- newTVarIO HashMap.empty+ rq <- newTVarIO HashSet.empty+ inbox <- newInbox+ metrics <- mapM newStoreMetrics (blockConfStats cfg)+ let r =+ BlockStore+ { myMailbox = inboxToMailbox inbox,+ myConfig = cfg,+ myPeer = pb,+ myTxs = ts,+ requested = rq,+ myMetrics = metrics+ }+ withAsync (runReaderT (go inbox) r) $ \a -> do+ link a+ action r+ where+ go inbox = do+ ini+ wipe+ run inbox+ del txs = do+ $(logInfoS) "BlockStore" $+ "Deleting " <> cs (show (length txs)) <> " transactions"+ forM_ txs $ \(_, th) -> deleteUnconfirmedTx False th+ wipe_it txs = do+ let (txs1, txs2) = splitAt 1000 txs+ unless (null txs1) $+ runImport (del txs1) >>= \case+ Left e -> do+ $(logErrorS) "BlockStore" $+ "Could not wipe mempool: " <> cs (show e)+ throwIO e+ Right () -> wipe_it txs2+ wipe+ | blockConfWipeMempool cfg =+ getMempool >>= wipe_it+ | otherwise =+ return ()+ ini =+ runImport initBest >>= \case+ Left e -> do+ $(logErrorS) "BlockStore" $+ "Could not initialize: " <> cs (show e)+ throwIO e+ Right () -> return ()+ run inbox =+ withAsync (pingMe (inboxToMailbox inbox)) $+ const $+ forever $+ receive inbox+ >>= ReaderT . runReaderT . processBlockStoreMessage++isInSync :: MonadLoggerIO m => BlockT m Bool+isInSync =+ getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Block database uninitialized"+ throwIO Uninitialized+ Just bb -> do+ cb <- asks (blockConfChain . myConfig) >>= chainGetBest+ if headerHash (nodeHeader cb) == bb+ then clearSyncingState >> return True+ else return False++guardMempool :: Monad m => BlockT m () -> BlockT m ()+guardMempool f = do+ n <- asks (blockConfNoMempool . myConfig)+ unless n f++syncMempool :: Monad m => BlockT m () -> BlockT m ()+syncMempool f = do+ s <- asks (blockConfSyncMempool . myConfig)+ when s f++mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()+mempool p = guardMempool $+ syncMempool $+ void $+ async $ do+ isInSync >>= \s -> when s $ do+ $(logDebugS) "BlockStore" $+ "Requesting mempool from peer: " <> peerText p+ MMempool `sendMessage` p++processBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ Peer ->+ Block ->+ BlockT m ()+processBlock peer block = void . runMaybeT $ do+ checkPeer peer >>= \case+ True -> return ()+ False -> do+ $(logErrorS) "BlockStore" $+ "Non-syncing peer " <> peerText peer+ <> " sent me a block: "+ <> blockHashToHex blockhash+ PeerMisbehaving "Sent unexpected block" `killPeer` peer+ mzero+ node <-+ getBlockNode blockhash >>= \case+ Just b -> return b+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Peer " <> peerText peer+ <> " sent unknown block: "+ <> blockHashToHex blockhash+ PeerMisbehaving "Sent unknown block" `killPeer` peer+ mzero+ $(logDebugS) "BlockStore" $+ "Processing block: " <> blockText node Nothing+ <> " from peer: "+ <> peerText peer+ lift . notify (Just block) $+ runImport (importBlock block node) >>= \case+ Left e -> failure e+ Right () -> success node+ where+ header = blockHeader block+ blockhash = headerHash header+ hexhash = blockHashToHex blockhash+ success node = do+ $(logInfoS) "BlockStore" $+ "Best block: " <> blockText node (Just block)+ removeSyncingBlock $ headerHash $ nodeHeader node+ touchPeer+ isInSync >>= \case+ False -> syncMe+ True -> do+ updateOrphans+ mempool peer+ failure e = do+ $(logErrorS) "BlockStore" $+ "Error importing block " <> hexhash+ <> " from peer: "+ <> peerText peer+ <> ": "+ <> cs (show e)+ killPeer (PeerMisbehaving (show e)) peer++setSyncingBlocks ::+ (MonadReader BlockStore m, MonadIO m) =>+ [BlockHash] ->+ m ()+setSyncingBlocks hs =+ asks myPeer >>= \box ->+ atomically $+ modifyTVar box $ \case+ Nothing -> Nothing+ Just x -> Just x {syncingBlocks = hs}++getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash]+getSyncingBlocks =+ asks myPeer >>= readTVarIO >>= \case+ Nothing -> return []+ Just x -> return $ syncingBlocks x++addSyncingBlocks ::+ (MonadReader BlockStore m, MonadIO m) =>+ [BlockHash] ->+ m ()+addSyncingBlocks hs =+ asks myPeer >>= \box ->+ atomically $+ modifyTVar box $ \case+ Nothing -> Nothing+ Just x -> Just x {syncingBlocks = syncingBlocks x <> hs}++removeSyncingBlock ::+ (MonadReader BlockStore m, MonadIO m) =>+ BlockHash ->+ m ()+removeSyncingBlock h = do+ box <- asks myPeer+ atomically $+ modifyTVar box $ \case+ Nothing -> Nothing+ Just x -> Just x {syncingBlocks = delete h (syncingBlocks x)}++checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool+checkPeer p =+ fmap syncingPeer <$> getSyncingState >>= \case+ Nothing -> return False+ Just p' -> return $ p == p'++getBlockNode ::+ (MonadLoggerIO m, MonadReader BlockStore m) =>+ BlockHash ->+ m (Maybe BlockNode)+getBlockNode blockhash =+ chainGetBlock blockhash =<< asks (blockConfChain . myConfig)++processNoBlocks ::+ MonadLoggerIO m =>+ Peer ->+ [BlockHash] ->+ BlockT m ()+processNoBlocks p hs = do+ forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) ->+ $(logErrorS) "BlockStore" $+ "Block "+ <> cs (show i)+ <> "/"+ <> cs (show (length hs))+ <> " "+ <> blockHashToHex h+ <> " not found by peer: "+ <> peerText p+ killPeer (PeerMisbehaving "Did not find requested block(s)") p++processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m ()+processTx p tx = guardMempool $ do+ t <- liftIO getCurrentTime+ $(logDebugS) "BlockManager" $+ "Received tx " <> txHashToHex (txHash tx)+ <> " by peer: "+ <> peerText p+ addPendingTx $ PendingTx t tx HashSet.empty++pruneOrphans :: MonadIO m => BlockT m ()+pruneOrphans = guardMempool $ do+ ts <- asks myTxs+ now <- liftIO getCurrentTime+ atomically . modifyTVar ts . HashMap.filter $ \p ->+ now `diffUTCTime` pendingTxTime p > 600++addPendingTx :: MonadIO m => PendingTx -> BlockT m ()+addPendingTx p = do+ ts <- asks myTxs+ rq <- asks requested+ atomically $ do+ modifyTVar ts $ HashMap.insert th p+ modifyTVar rq $ HashSet.delete th+ HashMap.size <$> readTVar ts+ setPendingTxs+ where+ th = txHash (pendingTx p)++addRequestedTx :: MonadIO m => TxHash -> BlockT m ()+addRequestedTx th = do+ qbox <- asks requested+ atomically $ modifyTVar qbox $ HashSet.insert th+ liftIO $+ void $+ async $ do+ threadDelay 20000000+ atomically $ modifyTVar qbox $ HashSet.delete th++isPending :: MonadIO m => TxHash -> BlockT m Bool+isPending th = do+ tbox <- asks myTxs+ qbox <- asks requested+ atomically $ do+ ts <- readTVar tbox+ rs <- readTVar qbox+ return $+ th `HashMap.member` ts+ || th `HashSet.member` rs++pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx]+pendingTxs i = do+ selected <-+ asks myTxs >>= \box -> atomically $ do+ pending <- readTVar box+ let (selected, rest) = select pending+ writeTVar box rest+ return (selected)+ setPendingTxs+ return selected+ where+ select pend =+ let eligible = HashMap.filter (null . pendingDeps) pend+ orphans = HashMap.difference pend eligible+ selected = take i $ sortit eligible+ remaining = HashMap.filter (`notElem` selected) eligible+ in (selected, remaining <> orphans)+ sortit m =+ let sorted = sortTxs $ map pendingTx $ HashMap.elems m+ txids = map (txHash . snd) sorted+ in mapMaybe (`HashMap.lookup` m) txids++fulfillOrphans :: MonadIO m => BlockStore -> TxHash -> m ()+fulfillOrphans block_read th =+ atomically $ modifyTVar box (HashMap.map fulfill)+ where+ box = myTxs block_read+ fulfill p = p {pendingDeps = HashSet.delete th (pendingDeps p)}++updateOrphans ::+ ( StoreReadBase m,+ MonadLoggerIO m,+ MonadReader BlockStore m+ ) =>+ m ()+updateOrphans = do+ box <- asks myTxs+ pending <- readTVarIO box+ let orphans = HashMap.filter (not . null . pendingDeps) pending+ updated <- forM orphans $ \p -> do+ let tx = pendingTx p+ exists (txHash tx) >>= \case+ True -> return Nothing+ False -> Just <$> fill_deps p+ let pruned = HashMap.map fromJust $ HashMap.filter isJust updated+ atomically $ writeTVar box pruned+ where+ exists th =+ getTxData th >>= \case+ Nothing -> return False+ Just TxData {txDataDeleted = True} -> return False+ Just TxData {txDataDeleted = False} -> return True+ prev_utxos tx = catMaybes <$> mapM (getUnspent . prevOutput) (txIn tx)+ fulfill p unspent =+ let unspent_hash = outPointHash (unspentPoint unspent)+ new_deps = HashSet.delete unspent_hash (pendingDeps p)+ in p {pendingDeps = new_deps}+ fill_deps p = do+ let tx = pendingTx p+ unspents <- prev_utxos tx+ return $ foldl fulfill p unspents++newOrphanTx ::+ MonadLoggerIO m =>+ BlockStore ->+ UTCTime ->+ Tx ->+ WriterT m ()+newOrphanTx block_read time tx = do+ $(logDebugS) "BlockStore" $+ "Import tx "+ <> txHashToHex (txHash tx)+ <> ": Orphan"+ let box = myTxs block_read+ unspents <- catMaybes <$> mapM getUnspent prevs+ let unspent_set = HashSet.fromList (map unspentPoint unspents)+ missing_set = HashSet.difference prev_set unspent_set+ missing_txs = HashSet.map outPointHash missing_set+ atomically . modifyTVar box $+ HashMap.insert+ (txHash tx)+ PendingTx+ { pendingTxTime = time,+ pendingTx = tx,+ pendingDeps = missing_txs+ }+ where+ prev_set = HashSet.fromList prevs+ prevs = map prevOutput (txIn tx)++importMempoolTx ::+ (MonadLoggerIO m, MonadError ImportException m) =>+ BlockStore ->+ UTCTime ->+ Tx ->+ WriterT m Bool+importMempoolTx block_read time tx =+ catchError new_mempool_tx handle_error+ where+ tx_hash = txHash tx+ handle_error Orphan = do+ newOrphanTx block_read time tx+ return False+ handle_error _ = return False+ seconds = floor (utcTimeToPOSIXSeconds time)+ new_mempool_tx =+ newMempoolTx tx seconds >>= \case+ True -> do+ $(logInfoS) "BlockStore" $+ "Import tx " <> txHashToHex (txHash tx)+ <> ": OK"+ fulfillOrphans block_read tx_hash+ return True+ False -> do+ $(logDebugS) "BlockStore" $+ "Import tx " <> txHashToHex (txHash tx)+ <> ": Already imported"+ return False++notify :: MonadIO m => Maybe Block -> BlockT m a -> BlockT m a+notify block go = do+ old <- HashSet.union e . HashSet.fromList . map snd <$> getMempool+ x <- go+ new <- HashSet.fromList . map snd <$> getMempool+ l <- asks (blockConfListener . myConfig)+ forM_ (old `HashSet.difference` new) $ \h ->+ publish (StoreMempoolDelete h) l+ forM_ (new `HashSet.difference` old) $ \h ->+ publish (StoreMempoolNew h) l+ case block of+ Just b -> publish (StoreBestBlock (headerHash (blockHeader b))) l+ Nothing -> return ()+ return x+ where+ e = case block of+ Just b -> HashSet.fromList (map txHash (blockTxns b))+ Nothing -> HashSet.empty++processMempool :: MonadLoggerIO m => BlockT m ()+processMempool = guardMempool . notify Nothing $ do+ txs <- pendingTxs 2000+ block_read <- ask+ unless (null txs) (import_txs block_read txs)+ where+ run_import block_read p =+ let t = pendingTx p+ h = txHash t+ in importMempoolTx block_read (pendingTxTime p) (pendingTx p)+ import_txs block_read txs =+ let r = mapM (run_import block_read) txs+ in runImport r >>= \case+ Left e -> report_error e+ Right _ -> return ()+ report_error e = do+ $(logErrorS) "BlockImport" $+ "Error processing mempool: " <> cs (show e)+ throwIO e++processTxs ::+ MonadLoggerIO m =>+ Peer ->+ [TxHash] ->+ BlockT m ()+processTxs p hs = guardMempool $ do+ s <- isInSync+ when s $ do+ $(logDebugS) "BlockStore" $+ "Received inventory with "+ <> cs (show (length hs))+ <> " transactions from peer: "+ <> peerText p+ xs <- catMaybes <$> zip_counter process_tx+ unless (null xs) $ go xs+ where+ len = length hs+ zip_counter = forM (zip [(1 :: Int) ..] hs) . uncurry+ process_tx i h =+ isPending h >>= \case+ True -> do+ $(logDebugS) "BlockStore" $+ "Tx " <> cs (show i) <> "/" <> cs (show len)+ <> " "+ <> txHashToHex h+ <> ": "+ <> "Pending"+ return Nothing+ False ->+ getActiveTxData h >>= \case+ Just _ -> do+ $(logDebugS) "BlockStore" $+ "Tx " <> cs (show i) <> "/" <> cs (show len)+ <> " "+ <> txHashToHex h+ <> ": "+ <> "Already Imported"+ return Nothing+ Nothing -> do+ $(logDebugS) "BlockStore" $+ "Tx " <> cs (show i) <> "/" <> cs (show len)+ <> " "+ <> txHashToHex h+ <> ": "+ <> "Requesting"+ return (Just h)+ go xs = do+ mapM_ addRequestedTx xs+ net <- asks (blockConfNet . myConfig)+ let inv = if getSegWit net then InvWitnessTx else InvTx+ vec = map (InvVector inv . getTxHash) xs+ msg = MGetData (GetData vec)+ msg `sendMessage` p++touchPeer ::+ ( MonadIO m,+ MonadReader BlockStore m+ ) =>+ m ()+touchPeer =+ getSyncingState >>= \case+ Nothing -> return ()+ Just _ -> do+ box <- asks myPeer+ now <- liftIO getCurrentTime+ atomically $+ modifyTVar box $+ fmap $ \x -> x {syncingTime = now}++checkTime :: MonadLoggerIO m => BlockT m ()+checkTime =+ asks myPeer >>= readTVarIO >>= \case+ Nothing -> return ()+ Just+ Syncing+ { syncingTime = t,+ syncingPeer = p+ } -> do+ now <- liftIO getCurrentTime+ peer_time_out <- asks (blockConfPeerTimeout . myConfig)+ when (now `diffUTCTime` t > peer_time_out) $ do+ $(logErrorS) "BlockStore" $+ "Syncing peer timeout: " <> peerText p+ killPeer PeerTimeout p++revertToMainChain :: MonadLoggerIO m => BlockT m ()+revertToMainChain = do+ h <- headerHash . nodeHeader <$> getBest+ ch <- asks (blockConfChain . myConfig)+ chainBlockMain h ch >>= \x -> unless x $ do+ $(logWarnS) "BlockStore" $+ "Reverting best block: "+ <> blockHashToHex h+ runImport (revertBlock h) >>= \case+ Left e -> do+ $(logErrorS) "BlockStore" $+ "Could not revert block "+ <> blockHashToHex h+ <> ": "+ <> cs (show e)+ throwIO e+ Right () -> setSyncingBlocks []+ revertToMainChain++getBest :: MonadLoggerIO m => BlockT m BlockNode+getBest = do+ bb <-+ getBestBlock >>= \case+ Just b -> return b+ Nothing -> do+ $(logErrorS) "BlockStore" "No best block set"+ throwIO Uninitialized+ ch <- asks (blockConfChain . myConfig)+ chainGetBlock bb ch >>= \case+ Just x -> return x+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Header not found for best block: "+ <> blockHashToHex bb+ throwIO (BlockNotInChain bb)++getSyncBest :: MonadLoggerIO m => BlockT m BlockNode+getSyncBest = do+ bb <-+ getSyncingBlocks >>= \case+ [] ->+ getBestBlock >>= \case+ Just b -> return b+ Nothing -> do+ $(logErrorS) "BlockStore" "No best block set"+ throwIO Uninitialized+ hs -> return $ last hs+ ch <- asks (blockConfChain . myConfig)+ chainGetBlock bb ch >>= \case+ Just x -> return x+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Header not found for block: "+ <> blockHashToHex bb+ throwIO (BlockNotInChain bb)++shouldSync :: MonadLoggerIO m => BlockT m (Maybe Peer)+shouldSync =+ isInSync >>= \case+ True -> return Nothing+ False ->+ getSyncingState >>= \case+ Nothing -> return Nothing+ Just Syncing {syncingPeer = p, syncingBlocks = bs}+ | 100 > length bs -> return (Just p)+ | otherwise -> return Nothing++syncMe :: MonadLoggerIO m => BlockT m ()+syncMe = do+ revertToMainChain+ shouldSync >>= \case+ Nothing -> return ()+ Just p -> do+ bb <- getSyncBest+ bh <- getbh+ when (bb /= bh) $ do+ bns <- sel bb bh+ iv <- getiv bns+ $(logDebugS) "BlockStore" $+ "Requesting "+ <> fromString (show (length iv))+ <> " blocks from peer: "+ <> peerText p+ addSyncingBlocks $ map (headerHash . nodeHeader) bns+ MGetData (GetData iv) `sendMessage` p+ where+ getiv bns = do+ w <- getSegWit <$> asks (blockConfNet . myConfig)+ let i = if w then InvWitnessBlock else InvBlock+ f = InvVector i . getBlockHash . headerHash . nodeHeader+ return $ map f bns+ getbh =+ chainGetBest =<< asks (blockConfChain . myConfig)+ sel bb bh = do+ let sh = geth bb bh+ t <- top sh bh+ ch <- asks (blockConfChain . myConfig)+ ps <- chainGetParents (nodeHeight bb + 1) t ch+ return $+ if 500 > length ps+ then ps <> [bh]+ else ps+ geth bb bh =+ min+ (nodeHeight bb + 501)+ (nodeHeight bh)+ top sh bh =+ if sh == nodeHeight bh+ then return bh+ else findAncestor sh bh++findAncestor ::+ (MonadLoggerIO m, MonadReader BlockStore m) =>+ BlockHeight ->+ BlockNode ->+ m BlockNode+findAncestor height target = do+ ch <- asks (blockConfChain . myConfig)+ chainGetAncestor height target ch >>= \case+ Just ancestor -> return ancestor+ Nothing -> do+ let h = headerHash $ nodeHeader target+ $(logErrorS) "BlockStore" $+ "Could not find header for ancestor of block "+ <> blockHashToHex h+ <> " at height "+ <> cs (show (nodeHeight target))+ throwIO $ AncestorNotInChain height h++finishPeer ::+ (MonadLoggerIO m, MonadReader BlockStore m) =>+ Peer ->+ m ()+finishPeer p = do+ box <- asks myPeer+ readTVarIO box >>= \case+ Just Syncing {syncingPeer = p'} | p == p' -> reset_it box+ _ -> return ()+ where+ reset_it box = do+ atomically $ writeTVar box Nothing+ $(logDebugS) "BlockStore" $ "Releasing peer: " <> peerText p+ setFree p++trySetPeer :: MonadLoggerIO m => Peer -> BlockT m Bool+trySetPeer p =+ getSyncingState >>= \case+ Just _ -> return False+ Nothing -> set_it+ where+ set_it =+ setBusy p >>= \case+ False -> return False+ True -> do+ $(logDebugS) "BlockStore" $+ "Locked peer: " <> peerText p+ box <- asks myPeer+ now <- liftIO getCurrentTime+ atomically . writeTVar box $+ Just+ Syncing+ { syncingPeer = p,+ syncingTime = now,+ syncingBlocks = []+ }+ return True++trySyncing :: MonadLoggerIO m => BlockT m ()+trySyncing =+ isInSync >>= \case+ True -> return ()+ False ->+ getSyncingState >>= \case+ Just _ -> return ()+ Nothing -> online_peer+ where+ recurse [] = return ()+ recurse (p : ps) =+ trySetPeer p >>= \case+ False -> recurse ps+ True -> syncMe+ online_peer = do+ ops <- getPeers =<< asks (blockConfManager . myConfig)+ let ps = map onlinePeerMailbox ops+ recurse ps++trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()+trySyncingPeer p =+ isInSync >>= \case+ True -> mempool p+ False ->+ trySetPeer p >>= \case+ False -> return ()+ True -> syncMe++getSyncingState ::+ (MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing)+getSyncingState =+ readTVarIO =<< asks myPeer++clearSyncingState ::+ (MonadLoggerIO m, MonadReader BlockStore m) => m ()+clearSyncingState =+ asks myPeer >>= readTVarIO >>= \case+ Nothing -> return ()+ Just Syncing {syncingPeer = p} -> finishPeer p++processBlockStoreMessage ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ BlockStoreMessage ->+ BlockT m ()+processBlockStoreMessage (BlockNewBest _) =+ trySyncing+processBlockStoreMessage (BlockPeerConnect p) =+ trySyncingPeer p+processBlockStoreMessage (BlockPeerDisconnect p) =+ finishPeer p+processBlockStoreMessage (BlockReceived p b) =+ processBlock p b+processBlockStoreMessage (BlockNotFound p bs) =+ processNoBlocks p bs+processBlockStoreMessage (TxRefReceived p tx) =+ processTx p tx+processBlockStoreMessage (TxRefAvailable p ts) =+ processTxs p ts+processBlockStoreMessage (BlockPing r) = do+ setStoreHeight+ setHeadersHeight+ setPendingTxs+ setPeersConnected+ setMempoolSize+ trySyncing+ processMempool+ pruneOrphans+ checkTime+ atomically (r ())++pingMe :: MonadLoggerIO m => Mailbox BlockStoreMessage -> m ()+pingMe mbox =+ forever $ do+ BlockPing `query` mbox+ delay <-+ liftIO $+ randomRIO+ ( 100 * 1000,+ 1000 * 1000+ )+ threadDelay delay++blockStorePeerConnect :: MonadIO m => Peer -> BlockStore -> m ()+blockStorePeerConnect peer store =+ BlockPeerConnect peer `send` myMailbox store++blockStorePeerDisconnect ::+ MonadIO m => Peer -> BlockStore -> m ()+blockStorePeerDisconnect peer store =+ BlockPeerDisconnect peer `send` myMailbox store++blockStoreHead ::+ MonadIO m => BlockNode -> BlockStore -> m ()+blockStoreHead node store =+ BlockNewBest node `send` myMailbox store++blockStoreBlock ::+ MonadIO m => Peer -> Block -> BlockStore -> m ()+blockStoreBlock peer block store =+ BlockReceived peer block `send` myMailbox store++blockStoreNotFound ::+ MonadIO m => Peer -> [BlockHash] -> BlockStore -> m ()+blockStoreNotFound peer blocks store =+ BlockNotFound peer blocks `send` myMailbox store++blockStoreTx ::+ MonadIO m => Peer -> Tx -> BlockStore -> m ()+blockStoreTx peer tx store =+ TxRefReceived peer tx `send` myMailbox store++blockStoreTxHash ::+ MonadIO m => Peer -> [TxHash] -> BlockStore -> m ()+blockStoreTxHash peer txhashes store =+ TxRefAvailable peer txhashes `send` myMailbox store++blockStorePeerConnectSTM ::+ Peer -> BlockStore -> STM ()+blockStorePeerConnectSTM peer store =+ BlockPeerConnect peer `sendSTM` myMailbox store++blockStorePeerDisconnectSTM ::+ Peer -> BlockStore -> STM ()+blockStorePeerDisconnectSTM peer store =+ BlockPeerDisconnect peer `sendSTM` myMailbox store++blockStoreHeadSTM ::+ BlockNode -> BlockStore -> STM ()+blockStoreHeadSTM node store =+ BlockNewBest node `sendSTM` myMailbox store++blockStoreBlockSTM ::+ Peer -> Block -> BlockStore -> STM ()+blockStoreBlockSTM peer block store =+ BlockReceived peer block `sendSTM` myMailbox store++blockStoreNotFoundSTM ::+ Peer -> [BlockHash] -> BlockStore -> STM ()+blockStoreNotFoundSTM peer blocks store =+ BlockNotFound peer blocks `sendSTM` myMailbox store++blockStoreTxSTM ::+ Peer -> Tx -> BlockStore -> STM ()+blockStoreTxSTM peer tx store =+ TxRefReceived peer tx `sendSTM` myMailbox store++blockStoreTxHashSTM ::+ Peer -> [TxHash] -> BlockStore -> STM ()+blockStoreTxHashSTM peer txhashes store =+ TxRefAvailable peer txhashes `sendSTM` myMailbox store++blockStorePendingTxs ::+ MonadIO m => BlockStore -> m Int+blockStorePendingTxs =+ atomically . blockStorePendingTxsSTM++blockStorePendingTxsSTM ::+ BlockStore -> STM Int+blockStorePendingTxsSTM BlockStore {..} = do+ x <- HashMap.keysSet <$> readTVar myTxs+ y <- readTVar requested+ return $ HashSet.size $ x `HashSet.union` y++blockText :: BlockNode -> Maybe Block -> Text+blockText bn mblock = case mblock of+ Nothing ->+ height <> sep <> time <> sep <> hash+ Just block ->+ height <> sep <> time <> sep <> hash <> sep <> size block+ where+ height = cs $ show (nodeHeight bn)+ systime =+ posixSecondsToUTCTime $+ fromIntegral $+ blockTimestamp $+ nodeHeader bn+ time =+ cs $+ formatTime+ defaultTimeLocale+ (iso8601DateFormat (Just "%H:%M"))+ systime hash = blockHashToHex (headerHash (nodeHeader bn)) sep = " | " size = (<> " bytes") . cs . show . B.length . encode
src/Haskoin/Store/Cache.hs view
@@ -11,1495 +11,1498 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.Cache (- CacheConfig (..),- CacheMetrics,- CacheT,- CacheError (..),- newCacheMetrics,- withCache,- connectRedis,- blockRefScore,- scoreBlockRef,- CacheWriter,- CacheWriterInbox,- cacheNewBlock,- cacheNewTx,- cacheWriter,- cacheDelXPubs,- isInCache,-) where--import Control.DeepSeq (NFData)-import Control.Monad (forM, forM_, forever, guard, unless, void, when, (>=>))-import Control.Monad.Logger (- MonadLoggerIO,- logDebugS,- logErrorS,- logInfoS,- logWarnS,- )-import Control.Monad.Reader (ReaderT (..), ask, asks)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Bits (complement, shift, (.&.), (.|.))-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.Default (def)-import Data.Either (fromRight, isRight, rights)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import qualified Data.IntMap.Strict as I-import Data.List (sort)-import qualified Data.Map.Strict as Map-import Data.Maybe (- catMaybes,- fromMaybe,- isJust,- isNothing,- mapMaybe,- )-import Data.Serialize (Serialize, decode, encode)-import Data.String.Conversions (cs)-import Data.Text (Text)-import Data.Time.Clock (NominalDiffTime, diffUTCTime)-import Data.Time.Clock.System (- getSystemTime,- systemSeconds,- systemToUTCTime,- )-import Data.Word (Word32, Word64)-import Database.Redis (- Connection,- Redis,- RedisCtx,- Reply,- checkedConnect,- defaultConnectInfo,- hgetall,- parseConnectInfo,- zadd,- zrangeWithscores,- zrangebyscoreWithscoresLimit,- zrem,- )-import qualified Database.Redis as Redis-import GHC.Generics (Generic)-import Haskoin (- Address,- BlockHash,- BlockHeader (..),- BlockNode (..),- DerivPathI (..),- KeyIndex,- OutPoint (..),- Tx (..),- TxHash,- TxIn (..),- TxOut (..),- XPubKey,- blockHashToHex,- derivePubPath,- eitherToMaybe,- headerHash,- pathToList,- scriptToAddressBS,- txHash,- txHashToHex,- xPubAddr,- xPubCompatWitnessAddr,- xPubExport,- xPubWitnessAddr,- )-import Haskoin.Node (- Chain,- chainBlockMain,- chainGetAncestor,- chainGetBest,- chainGetBlock,- )-import Haskoin.Store.Common-import Haskoin.Store.Data-import Haskoin.Store.Stats-import NQE (- Inbox,- Listen,- Mailbox,- inboxToMailbox,- query,- receive,- send,- )-import qualified System.Metrics as Metrics-import qualified System.Metrics.Counter as Metrics (Counter)-import qualified System.Metrics.Counter as Metrics.Counter-import qualified System.Metrics.Distribution as Metrics (Distribution)-import qualified System.Metrics.Distribution as Metrics.Distribution-import qualified System.Metrics.Gauge as Metrics (Gauge)-import qualified System.Metrics.Gauge as Metrics.Gauge-import System.Random (randomIO, randomRIO)-import UnliftIO (- Exception,- MonadIO,- MonadUnliftIO,- TQueue,- TVar,- async,- atomically,- bracket,- liftIO,- link,- modifyTVar,- newTVarIO,- readTQueue,- readTVar,- throwIO,- wait,- withAsync,- writeTQueue,- writeTVar,- )-import UnliftIO.Concurrent (threadDelay)--runRedis :: MonadLoggerIO m => Redis (Either Reply a) -> CacheX m a-runRedis action =- asks cacheConn >>= \conn ->- liftIO (Redis.runRedis conn action) >>= \case- Right x -> return x- Left e -> do- $(logErrorS) "Cache" $ "Got error from Redis: " <> cs (show e)- throwIO (RedisError e)--data CacheConfig = CacheConfig- { cacheConn :: !Connection- , cacheMin :: !Int- , cacheMax :: !Integer- , cacheChain :: !Chain- , cacheRetryDelay :: !Int -- microseconds- , cacheMetrics :: !(Maybe CacheMetrics)- }--data CacheMetrics = CacheMetrics- { cacheHits :: !Metrics.Counter- , cacheMisses :: !Metrics.Counter- , cacheLockAcquired :: !Metrics.Counter- , cacheLockReleased :: !Metrics.Counter- , cacheLockFailed :: !Metrics.Counter- , cacheXPubBals :: !Metrics.Counter- , cacheXPubUnspents :: !Metrics.Counter- , cacheXPubTxs :: !Metrics.Counter- , cacheXPubTxCount :: !Metrics.Counter- , cacheIndexTime :: !StatDist- }--newCacheMetrics :: MonadIO m => Metrics.Store -> m CacheMetrics-newCacheMetrics s = liftIO $ do- cacheHits <- c "cache.hits"- cacheMisses <- c "cache.misses"- cacheLockAcquired <- c "cache.lock_acquired"- cacheLockReleased <- c "cache.lock_released"- cacheLockFailed <- c "cache.lock_failed"- cacheIndexTime <- d "cache.index"- cacheXPubBals <- c "cache.xpub_balances_cached"- cacheXPubUnspents <- c "cache.xpub_unspents_cached"- cacheXPubTxs <- c "cache.xpub_txs_cached"- cacheXPubTxCount <- c "cache.xpub_tx_count_cached"- return CacheMetrics{..}- where- c x = Metrics.createCounter x s- d x = createStatDist x s--withMetrics ::- MonadUnliftIO m =>- (CacheMetrics -> StatDist) ->- CacheX m a ->- CacheX m a-withMetrics df go =- asks cacheMetrics >>= \case- Nothing -> go- Just m ->- bracket- (systemToUTCTime <$> liftIO getSystemTime)- (end m)- (const go)- where- end metrics t1 = do- t2 <- systemToUTCTime <$> liftIO getSystemTime- let diff = round $ diffUTCTime t2 t1 * 1000- df metrics `addStatTime` diff- addStatQuery (df metrics)--incrementCounter ::- MonadIO m =>- (CacheMetrics -> Metrics.Counter) ->- Int ->- CacheX m ()-incrementCounter f i =- asks cacheMetrics >>= \case- Just s -> liftIO $ Metrics.Counter.add (f s) (fromIntegral i)- Nothing -> return ()--type CacheT = ReaderT (Maybe CacheConfig)-type CacheX = ReaderT CacheConfig--data CacheError- = RedisError Reply- | RedisTxError !String- | LogicError !String- deriving (Show, Eq, Generic, NFData, Exception)--connectRedis :: MonadIO m => String -> m Connection-connectRedis redisurl = do- conninfo <-- if null redisurl- then return defaultConnectInfo- else case parseConnectInfo redisurl of- Left e -> error e- Right r -> return r- liftIO (checkedConnect conninfo)--instance- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- StoreReadBase (CacheT m)- where- getNetwork = lift getNetwork- getBestBlock = lift getBestBlock- getBlocksAtHeight = lift . getBlocksAtHeight- getBlock = lift . getBlock- getTxData = lift . getTxData- getSpender = lift . getSpender- getBalance = lift . getBalance- getUnspent = lift . getUnspent- getMempool = lift getMempool--instance- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- StoreReadExtra (CacheT m)- where- getBalances = lift . getBalances- getAddressesTxs addrs = lift . getAddressesTxs addrs- getAddressTxs addr = lift . getAddressTxs addr- getAddressUnspents addr = lift . getAddressUnspents addr- getAddressesUnspents addrs = lift . getAddressesUnspents addrs- getMaxGap = lift getMaxGap- getInitialGap = lift getInitialGap- getNumTxData = lift . getNumTxData- xPubBals xpub =- ask >>= \case- Nothing ->- lift $- xPubBals xpub- Just cfg ->- lift $- runReaderT (getXPubBalances xpub) cfg- xPubUnspents xpub xbals limits =- ask >>= \case- Nothing ->- lift $- xPubUnspents xpub xbals limits- Just cfg ->- lift $- runReaderT (getXPubUnspents xpub xbals limits) cfg- xPubTxs xpub xbals limits =- ask >>= \case- Nothing ->- lift $- xPubTxs xpub xbals limits- Just cfg ->- lift $- runReaderT (getXPubTxs xpub xbals limits) cfg- xPubTxCount xpub xbals =- ask >>= \case- Nothing ->- lift $- xPubTxCount xpub xbals- Just cfg ->- lift $- runReaderT (getXPubTxCount xpub xbals) cfg--withCache :: StoreReadBase m => Maybe CacheConfig -> CacheT m a -> m a-withCache s f = runReaderT f s--balancesPfx :: ByteString-balancesPfx = "b"--txSetPfx :: ByteString-txSetPfx = "t"--utxoPfx :: ByteString-utxoPfx = "u"--idxPfx :: ByteString-idxPfx = "i"--getXPubTxs ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- XPubSpec ->- [XPubBal] ->- Limits ->- CacheX m [TxRef]-getXPubTxs xpub xbals limits = go False- where- go m =- isXPubCached xpub >>= \case- True -> do- txs <- cacheGetXPubTxs xpub limits- incrementCounter cacheXPubTxs (length txs)- return txs- False ->- case m of- True -> lift $ xPubTxs xpub xbals limits- False -> do- newXPubC xpub xbals- go True--getXPubTxCount ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- XPubSpec ->- [XPubBal] ->- CacheX m Word32-getXPubTxCount xpub xbals =- go False- where- go t =- isXPubCached xpub >>= \case- True -> do- incrementCounter cacheXPubTxCount 1- cacheGetXPubTxCount xpub- False ->- if t- then lift $ xPubTxCount xpub xbals- else do- newXPubC xpub xbals- go True--getXPubUnspents ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- XPubSpec ->- [XPubBal] ->- Limits ->- CacheX m [XPubUnspent]-getXPubUnspents xpub xbals limits =- go False- where- xm =- let f x = (balanceAddress (xPubBal x), x)- g = (> 0) . balanceUnspentCount . xPubBal- in HashMap.fromList $ map f $ filter g xbals- go m =- isXPubCached xpub >>= \case- True -> do- process- False -> case m of- True -> do- us <- lift $ xPubUnspents xpub xbals limits- return us- False -> do- newXPubC xpub xbals- go True- process = do- ops <- map snd <$> cacheGetXPubUnspents xpub limits- uns <- catMaybes <$> lift (mapM getUnspent ops)- let f u =- either- (const Nothing)- (\a -> Just (a, u))- (scriptToAddressBS (unspentScript u))- g a = HashMap.lookup a xm- h u x =- XPubUnspent- { xPubUnspent = u- , xPubUnspentPath = xPubBalPath x- }- us = mapMaybe f uns- i a u = h u <$> g a- incrementCounter cacheXPubUnspents (length us)- return $ mapMaybe (uncurry i) us--getXPubBalances ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- XPubSpec ->- CacheX m [XPubBal]-getXPubBalances xpub =- isXPubCached xpub >>= \case- True -> do- xbals <- cacheGetXPubBalances xpub- incrementCounter cacheXPubBals (length xbals)- return xbals- False -> do- bals <- lift $ xPubBals xpub- newXPubC xpub bals- return bals--isInCache :: MonadLoggerIO m => XPubSpec -> CacheT m Bool-isInCache xpub =- ask >>= \case- Nothing -> return False- Just cfg -> runReaderT (isXPubCached xpub) cfg--isXPubCached :: MonadLoggerIO m => XPubSpec -> CacheX m Bool-isXPubCached xpub = do- cached <- runRedis (redisIsXPubCached xpub)- if cached- then incrementCounter cacheHits 1- else incrementCounter cacheMisses 1- return cached--redisIsXPubCached :: RedisCtx m f => XPubSpec -> m (f Bool)-redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub)--cacheGetXPubBalances :: MonadLoggerIO m => XPubSpec -> CacheX m [XPubBal]-cacheGetXPubBalances xpub = do- bals <- runRedis $ redisGetXPubBalances xpub- touchKeys [xpub]- return bals--cacheGetXPubTxCount ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- XPubSpec ->- CacheX m Word32-cacheGetXPubTxCount xpub = do- count <- fromInteger <$> runRedis (redisGetXPubTxCount xpub)- touchKeys [xpub]- return count--redisGetXPubTxCount :: RedisCtx m f => XPubSpec -> m (f Integer)-redisGetXPubTxCount xpub = Redis.zcard (txSetPfx <> encode xpub)--cacheGetXPubTxs ::- (StoreReadBase m, MonadLoggerIO m) =>- XPubSpec ->- Limits ->- CacheX m [TxRef]-cacheGetXPubTxs xpub limits =- case start limits of- Nothing ->- go1 Nothing- Just (AtTx th) ->- lift (getTxData th) >>= \case- Just TxData{txDataBlock = b@BlockRef{}} ->- go1 $ Just (blockRefScore b)- _ ->- go2 th- Just (AtBlock h) ->- go1 (Just (blockRefScore (BlockRef h maxBound)))- where- go1 score = do- xs <-- runRedis $- getFromSortedSet- (txSetPfx <> encode xpub)- score- (offset limits)- (limit limits)- touchKeys [xpub]- return $ map (uncurry f) xs- go2 hash = do- xs <-- runRedis $- getFromSortedSet- (txSetPfx <> encode xpub)- Nothing- 0- 0- touchKeys [xpub]- let xs' =- if any ((== hash) . fst) xs- then dropWhile ((/= hash) . fst) xs- else []- return $- map (uncurry f) $- l $- drop (fromIntegral (offset limits)) xs'- l =- if limit limits > 0- then take (fromIntegral (limit limits))- else id- f t s = TxRef{txRefHash = t, txRefBlock = scoreBlockRef s}--cacheGetXPubUnspents ::- (StoreReadBase m, MonadLoggerIO m) =>- XPubSpec ->- Limits ->- CacheX m [(BlockRef, OutPoint)]-cacheGetXPubUnspents xpub limits =- case start limits of- Nothing ->- go1 Nothing- Just (AtTx th) ->- lift (getTxData th) >>= \case- Just TxData{txDataBlock = b@BlockRef{}} ->- go1 (Just (blockRefScore b))- _ ->- go2 th- Just (AtBlock h) ->- go1 (Just (blockRefScore (BlockRef h maxBound)))- where- go1 score = do- xs <-- runRedis $- getFromSortedSet- (utxoPfx <> encode xpub)- score- (offset limits)- (limit limits)- touchKeys [xpub]- return $ map (uncurry f) xs- go2 hash = do- xs <-- runRedis $- getFromSortedSet- (utxoPfx <> encode xpub)- Nothing- 0- 0- touchKeys [xpub]- let xs' =- if any ((== hash) . outPointHash . fst) xs- then dropWhile ((/= hash) . outPointHash . fst) xs- else []- return $- map (uncurry f) $- l $- drop (fromIntegral (offset limits)) xs'- l =- if limit limits > 0- then take (fromIntegral (limit limits))- else id- f o s = (scoreBlockRef s, o)--redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal])-redisGetXPubBalances xpub =- fmap (sort . map (uncurry f)) <$> getAllFromMap (balancesPfx <> encode xpub)- where- f p b = XPubBal{xPubBalPath = p, xPubBal = b}--blockRefScore :: BlockRef -> Double-blockRefScore BlockRef{blockRefHeight = h, blockRefPos = p} =- fromIntegral (0x001fffffffffffff - (h' .|. p'))- where- h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64- p' = (fromIntegral p .&. 0x03ffffff) :: Word64-blockRefScore MemRef{memRefTime = t} = negate t'- where- t' = fromIntegral (t .&. 0x001fffffffffffff)--scoreBlockRef :: Double -> BlockRef-scoreBlockRef s- | s < 0 = MemRef{memRefTime = n}- | otherwise = BlockRef{blockRefHeight = h, blockRefPos = p}- where- n = truncate (abs s) :: Word64- m = 0x001fffffffffffff - n- h = fromIntegral (m `shift` (-26))- p = fromIntegral (m .&. 0x03ffffff)--getFromSortedSet ::- (Applicative f, RedisCtx m f, Serialize a) =>- ByteString ->- Maybe Double ->- Word32 ->- Word32 ->- m (f [(a, Double)])-getFromSortedSet key Nothing off 0 = do- xs <- zrangeWithscores key (fromIntegral off) (-1)- return $ do- ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs- return (rights ys)-getFromSortedSet key Nothing off count = do- xs <-- zrangeWithscores- key- (fromIntegral off)- (fromIntegral off + fromIntegral count - 1)- return $ do- ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs- return (rights ys)-getFromSortedSet key (Just score) off 0 = do- xs <-- zrangebyscoreWithscoresLimit- key- score- (1 / 0)- (fromIntegral off)- (-1)- return $ do- ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs- return (rights ys)-getFromSortedSet key (Just score) off count = do- xs <-- zrangebyscoreWithscoresLimit- key- score- (1 / 0)- (fromIntegral off)- (fromIntegral count)- return $ do- ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs- return (rights ys)--getAllFromMap ::- (Functor f, RedisCtx m f, Serialize k, Serialize v) =>- ByteString ->- m (f [(k, v)])-getAllFromMap n = do- fxs <- hgetall n- return $ do- xs <- fxs- return- [ (k, v)- | (k', v') <- xs- , let Right k = decode k'- , let Right v = decode v'- ]--data CacheWriterMessage- = CacheNewBlock- | CacheNewTx TxHash--type CacheWriterInbox = Inbox CacheWriterMessage-type CacheWriter = Mailbox CacheWriterMessage--data AddressXPub = AddressXPub- { addressXPubSpec :: !XPubSpec- , addressXPubPath :: ![KeyIndex]- }- deriving (Show, Eq, Generic, NFData, Serialize)--mempoolSetKey :: ByteString-mempoolSetKey = "mempool"--addrPfx :: ByteString-addrPfx = "a"--bestBlockKey :: ByteString-bestBlockKey = "head"--maxKey :: ByteString-maxKey = "max"--xPubAddrFunction :: DeriveType -> XPubKey -> Address-xPubAddrFunction DeriveNormal = xPubAddr-xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr-xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr--cacheWriter ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- CacheConfig ->- CacheWriterInbox ->- m ()-cacheWriter cfg inbox =- runReaderT go cfg- where- go = do- newBlockC- syncMempoolC- forever $ do- x <- receive inbox- cacheWriterReact x--lockIt :: MonadLoggerIO m => CacheX m (Maybe Word32)-lockIt = do- rnd <- liftIO randomIO- go rnd >>= \case- Right Redis.Ok -> do- $(logDebugS) "Cache" $- "Acquired lock with value " <> cs (show rnd)- incrementCounter cacheLockAcquired 1- return (Just rnd)- Right Redis.Pong -> do- $(logErrorS)- "Cache"- "Unexpected pong when acquiring lock"- incrementCounter cacheLockFailed 1- return Nothing- Right (Redis.Status s) -> do- $(logErrorS) "Cache" $- "Unexpected status acquiring lock: " <> cs s- incrementCounter cacheLockFailed 1- return Nothing- Left (Redis.Bulk Nothing) -> do- $(logDebugS) "Cache" "Lock already taken"- incrementCounter cacheLockFailed 1- return Nothing- Left e -> do- $(logErrorS)- "Cache"- "Error when trying to acquire lock"- incrementCounter cacheLockFailed 1- throwIO (RedisError e)- where- go rnd = do- conn <- asks cacheConn- liftIO . Redis.runRedis conn $ do- let opts =- Redis.SetOpts- { Redis.setSeconds = Just 300- , Redis.setMilliseconds = Nothing- , Redis.setCondition = Just Redis.Nx- }- Redis.setOpts "lock" (cs (show rnd)) opts--unlockIt :: MonadLoggerIO m => Maybe Word32 -> CacheX m ()-unlockIt Nothing = return ()-unlockIt (Just i) =- runRedis (Redis.get "lock") >>= \case- Nothing ->- $(logErrorS) "Cache" $- "Not releasing lock with value " <> cs (show i)- <> ": not locked"- Just bs ->- if read (cs bs) == i- then do- void $ runRedis (Redis.del ["lock"])- $(logDebugS) "Cache" $- "Released lock with value "- <> cs (show i)- incrementCounter cacheLockReleased 1- else- $(logErrorS) "Cache" $- "Could not release lock: value is not "- <> cs (show i)--withLock ::- (MonadLoggerIO m, MonadUnliftIO m) =>- CacheX m a ->- CacheX m (Maybe a)-withLock f =- bracket lockIt unlockIt $ \case- Just _ -> Just <$> f- Nothing -> return Nothing--smallDelay :: MonadUnliftIO m => CacheX m ()-smallDelay = do- delay <- asks cacheRetryDelay- let delayMin = delay `div` 2- let delayMax = delay * 3 `div` 2- threadDelay =<< liftIO (randomRIO (delayMin, delayMax))--withLockForever ::- (MonadLoggerIO m, MonadUnliftIO m) =>- CacheX m a ->- CacheX m a-withLockForever go =- withLock go >>= \case- Nothing -> do- smallDelay- $(logDebugS) "Cache" "Retrying lock aquisition without limits"- withLockForever go- Just x -> return x--withLockRetry ::- (MonadLoggerIO m, MonadUnliftIO m) =>- Int ->- CacheX m a ->- CacheX m (Maybe a)-withLockRetry i f- | i <= 0 = return Nothing- | otherwise =- withLock f >>= \case- 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-pruneDB = do- x <- asks cacheMax- s <- runRedis Redis.dbsize- if s > x then flush (s - x) else return 0- where- flush n =- case n `div` 64 of- 0 -> return 0- x -> fmap (fromMaybe 0) $- withLock $ do- ks <-- fmap (map fst) . runRedis $- getFromSortedSet maxKey Nothing 0 (fromIntegral x)- $(logDebugS) "Cache" $- "Pruning " <> cs (show (length ks)) <> " old xpubs"- delXPubKeys ks--touchKeys :: MonadLoggerIO m => [XPubSpec] -> CacheX m ()-touchKeys xpubs = do- now <- systemSeconds <$> liftIO getSystemTime- runRedis $ redisTouchKeys now xpubs--redisTouchKeys :: (Monad f, RedisCtx m f, Real a) => a -> [XPubSpec] -> m (f ())-redisTouchKeys _ [] = return $ return ()-redisTouchKeys now xpubs =- void <$> Redis.zadd maxKey (map ((realToFrac now,) . encode) xpubs)--cacheWriterReact ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- CacheWriterMessage ->- CacheX m ()-cacheWriterReact CacheNewBlock =- doSync-cacheWriterReact (CacheNewTx txid) =- withLock go >>= \case- Just () -> return ()- Nothing -> smallDelay >> cacheWriterReact (CacheNewTx txid)- where- hex = txHashToHex txid- go =- $(logDebugS) "Cache" ("Locking to import tx: " <> hex)- >> cacheIsInMempool txid >>= \case- True ->- $(logDebugS) "Cache" $ "Already imported tx: " <> hex- False ->- lift (getTxData txid) >>= mapM_ \tx -> do- $(logDebugS) "Cache" $ "Importing mempool tx: " <> hex- importMultiTxC [tx]--doSync ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- CacheX m ()-doSync = newBlockC >> void pruneDB--lenNotNull :: [XPubBal] -> Int-lenNotNull = length . filter (not . nullBalance . xPubBal)--newXPubC ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- XPubSpec ->- [XPubBal] ->- CacheX m ()-newXPubC xpub xbals =- should_index >>= \i -> when i $- bracket set_index unset_index $ \j -> when j $- withMetrics cacheIndexTime $ do- xpubtxt <- xpubText xpub- $(logDebugS) "Cache" $- "Caching " <> xpubtxt <> ": "- <> cs (show (length xbals))- <> " addresses / "- <> cs (show (lenNotNull xbals))- <> " used"- utxo <- lift $ xPubUnspents xpub xbals def- $(logDebugS) "Cache" $- "Caching " <> xpubtxt <> ": " <> cs (show (length utxo))- <> " utxos"- xtxs <- lift $ xPubTxs xpub xbals def- $(logDebugS) "Cache" $- "Caching " <> xpubtxt <> ": " <> cs (show (length xtxs))- <> " txs"- now <- systemSeconds <$> liftIO getSystemTime- runRedis $ do- b <- redisTouchKeys now [xpub]- c <- redisAddXPubBalances xpub xbals- d <- redisAddXPubUnspents xpub (map op utxo)- e <- redisAddXPubTxs xpub xtxs- return $ b >> c >> d >> e >> return ()- $(logDebugS) "Cache" $ "Cached " <> xpubtxt- where- op XPubUnspent{xPubUnspent = u} = (unspentPoint u, unspentBlock u)- should_index =- asks cacheMin >>= \x ->- if x <= lenNotNull xbals then inSync else return False- key = idxPfx <> encode xpub- opts =- Redis.SetOpts- { Redis.setSeconds = Just 600- , Redis.setMilliseconds = Nothing- , Redis.setCondition = Just Redis.Nx- }- red = Redis.setOpts key "1" opts- unset_index y = when y . void . runRedis $ Redis.del [key]- set_index =- asks cacheConn >>= \conn ->- liftIO (Redis.runRedis conn red) >>= return . isRight--inSync ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- CacheX m Bool-inSync =- lift getBestBlock >>= \case- Nothing -> return False- Just bb ->- asks cacheChain >>= \ch ->- chainGetBest ch >>= \cb ->- return $ headerHash (nodeHeader cb) == bb--newBlockC ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- CacheX m ()-newBlockC =- inSync >>= \s ->- when s $- asks cacheChain >>= \ch ->- chainGetBest ch >>= \bn ->- cacheGetHead >>= \case- Nothing ->- $(logInfoS) "Cache" "Initializing best cache block"- >> withLock (do_import bn) >>= \case- Nothing -> smallDelay >> newBlockC- Just () -> return ()- Just hb ->- if hb == headerHash (nodeHeader bn)- then $(logDebugS) "Cache" "Cache in sync"- else- withLock (sync ch hb bn) >>= \case- Nothing -> smallDelay >> newBlockC- Just () -> return ()- where- sync ch hb bn =- chainGetBlock hb ch >>= \case- Nothing -> do- $(logErrorS) "Cache" $- "Cache head block node not found: "- <> blockHashToHex hb- throwIO $- LogicError $- "Cache head block node not found: "- <> cs (blockHashToHex hb)- Just hn ->- chainBlockMain hb ch >>= \m ->- if m- then next ch bn hn- else do- $(logDebugS) "Cache" $- "Reverting cache head not in main chain: "- <> blockHashToHex hb- removeHeadC hb- cacheGetHead >>= \case- Nothing -> do_import bn- Just hb' -> sync ch hb' bn- next ch bn hn =- if- | prevBlock (nodeHeader bn) == headerHash (nodeHeader hn) ->- do_import bn- | nodeHeight bn > nodeHeight hn ->- chainGetAncestor (nodeHeight hn + 1) bn ch >>= \case- Nothing -> do- $(logErrorS) "Cache" $- "Ancestor not found at height "- <> cs (show (nodeHeight hn + 1))- <> " for block: "- <> blockHashToHex (headerHash (nodeHeader bn))- throwIO $- LogicError $- "Ancestor not found at height "- <> show (nodeHeight hn + 1)- <> " for block: "- <> cs (blockHashToHex (headerHash (nodeHeader bn)))- Just hn' -> do- do_import hn'- next ch bn hn'- | otherwise ->- $(logInfoS) "Cache" "Cache best block higher than this node's"- do_import = importBlockC . headerHash . nodeHeader--importBlockC ::- (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) =>- BlockHash ->- CacheX m ()-importBlockC bh =- lift (getBlock bh) >>= \case- Just bd -> do- let ths = blockDataTxs bd- tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths- $(logDebugS) "Cache" $- "Importing " <> cs (show (length tds))- <> " transactions from block "- <> blockHashToHex bh- importMultiTxC tds- $(logDebugS) "Cache" $- "Done importing " <> cs (show (length tds))- <> " transactions from block "- <> blockHashToHex bh- cacheSetHead bh- Nothing -> do- $(logErrorS) "Cache" $- "Could not get block: "- <> blockHashToHex bh- throwIO . LogicError . cs $- "Could not get block: "- <> blockHashToHex bh--removeHeadC ::- (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) =>- BlockHash ->- CacheX m ()-removeHeadC cb =- void . runMaybeT $ do- bh <- MaybeT cacheGetHead- guard (cb == bh)- bd <- MaybeT (lift (getBlock bh))- lift $ do- tds <-- sortTxData . catMaybes- <$> mapM (lift . getTxData) (blockDataTxs bd)- $(logDebugS) "Cache" $ "Reverting head: " <> blockHashToHex bh- importMultiTxC tds- $(logWarnS) "Cache" $- "Reverted block head "- <> blockHashToHex bh- <> " to parent "- <> blockHashToHex (prevBlock (blockDataHeader bd))- cacheSetHead (prevBlock (blockDataHeader bd))--importMultiTxC ::- (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) =>- [TxData] ->- CacheX m ()-importMultiTxC txs = do- $(logDebugS) "Cache" $ "Processing " <> cs (show (length txs)) <> " txs"- $(logDebugS) "Cache" $- "Getting address information for "- <> cs (show (length alladdrs))- <> " addresses"- addrmap <- getaddrmap- let addrs = HashMap.keys addrmap- $(logDebugS) "Cache" $- "Getting balances for "- <> cs (show (HashMap.size addrmap))- <> " addresses"- balmap <- getbalances addrs- $(logDebugS) "Cache" $- "Getting unspent data for "- <> cs (show (length allops))- <> " outputs"- unspentmap <- getunspents- gap <- lift getMaxGap- now <- systemSeconds <$> liftIO getSystemTime- let xpubs = allxpubsls addrmap- forM_ (zip [(1 :: Int) ..] xpubs) $ \(i, xpub) -> do- xpubtxt <- xpubText xpub- $(logDebugS) "Cache" $- "Affected xpub "- <> cs (show i)- <> "/"- <> cs (show (length xpubs))- <> ": "- <> xpubtxt- addrs' <- do- $(logDebugS) "Cache" $- "Getting xpub balances for "- <> cs (show (length xpubs))- <> " xpubs"- xmap <- getxbals xpubs- let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap- $(logDebugS) "Cache" "Starting Redis import pipeline"- runRedis $ do- x <- redisImportMultiTx addrmap' unspentmap txs- y <- redisUpdateBalances addrmap' balmap- z <- redisTouchKeys now (HashMap.keys xmap)- return $ x >> y >> z >> return ()- $(logDebugS) "Cache" "Completed Redis pipeline"- return $ getNewAddrs gap xmap (HashMap.elems addrmap')- cacheAddAddresses addrs'- where- alladdrsls = HashSet.toList alladdrs- faddrmap xmap = HashMap.filter (\a -> addressXPubSpec a `elem` xmap)- getaddrmap =- HashMap.fromList . catMaybes . zipWith (\a -> fmap (a,)) alladdrsls- <$> cacheGetAddrsInfo alladdrsls- getunspents =- HashMap.fromList . catMaybes . zipWith (\p -> fmap (p,)) allops- <$> lift (mapM getUnspent allops)- getbalances addrs =- HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs- getxbals xpubs = do- bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do- bs <- redisGetXPubBalances xpub- return $ (,) xpub <$> bs- return $ HashMap.filter (not . null) (HashMap.fromList bals)- allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs- alladdrs =- HashSet.fromList . map fst $- concatMap txInputs txs <> concatMap txOutputs txs- allxpubsls addrmap = HashSet.toList (allxpubs addrmap)- allxpubs addrmap =- HashSet.fromList . map addressXPubSpec $ HashMap.elems addrmap--redisImportMultiTx ::- (Monad f, RedisCtx m f) =>- HashMap Address AddressXPub ->- HashMap OutPoint Unspent ->- [TxData] ->- m (f ())-redisImportMultiTx addrmap unspentmap txs = do- xs <- mapM importtxentries txs- return $ sequence_ xs- where- uns p i =- case HashMap.lookup p unspentmap of- Just u ->- redisAddXPubUnspents (addressXPubSpec i) [(p, unspentBlock u)]- Nothing -> redisRemXPubUnspents (addressXPubSpec i) [p]- addtx tx a p =- case HashMap.lookup a addrmap of- Just i -> do- let tr =- TxRef- { txRefHash = txHash (txData tx)- , txRefBlock = txDataBlock tx- }- x <- redisAddXPubTxs (addressXPubSpec i) [tr]- y <- uns p i- return $ x >> y >> return ()- Nothing -> return (pure ())- remtx tx a p =- case HashMap.lookup a addrmap of- Just i -> do- x <- redisRemXPubTxs (addressXPubSpec i) [txHash (txData tx)]- y <- uns p i- return $ x >> y >> return ()- Nothing -> return (pure ())- importtxentries tx =- if txDataDeleted tx- then do- x <- mapM (uncurry (remtx tx)) (txaddrops tx)- y <- redisRemFromMempool [txHash (txData tx)]- return $ sequence_ x >> void y- else do- a <- sequence <$> mapM (uncurry (addtx tx)) (txaddrops tx)- b <-- case txDataBlock tx of- b@MemRef{} ->- let tr =- TxRef- { txRefHash = txHash (txData tx)- , txRefBlock = b- }- in redisAddToMempool [tr]- _ -> redisRemFromMempool [txHash (txData tx)]- return $ a >> b >> return ()- txaddrops td = txInputs td <> txOutputs td--redisUpdateBalances ::- (Monad f, RedisCtx m f) =>- HashMap Address AddressXPub ->- HashMap Address Balance ->- m (f ())-redisUpdateBalances addrmap balmap =- fmap (fmap mconcat . sequence) . forM (HashMap.keys addrmap) $ \a ->- case (HashMap.lookup a addrmap, HashMap.lookup a balmap) of- (Just ainfo, Just bal) ->- redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal]- _ -> return (pure ())- where- xpubbal ainfo bal =- XPubBal{xPubBalPath = addressXPubPath ainfo, xPubBal = bal}--cacheAddAddresses ::- (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) =>- [(Address, AddressXPub)] ->- CacheX m ()-cacheAddAddresses [] = $(logDebugS) "Cache" "No further addresses to add"-cacheAddAddresses addrs = do- $(logDebugS) "Cache" $- "Adding " <> cs (show (length addrs)) <> " new generated addresses"- $(logDebugS) "Cache" "Getting balances"- balmap <- HashMap.fromListWith (<>) <$> mapM (uncurry getbal) addrs- $(logDebugS) "Cache" "Getting unspent outputs"- utxomap <- HashMap.fromListWith (<>) <$> mapM (uncurry getutxo) addrs- $(logDebugS) "Cache" "Getting transactions"- txmap <- HashMap.fromListWith (<>) <$> mapM (uncurry gettxmap) addrs- $(logDebugS) "Cache" "Running Redis pipeline"- runRedis $ do- a <- forM (HashMap.toList balmap) (uncurry redisAddXPubBalances)- b <- forM (HashMap.toList utxomap) (uncurry redisAddXPubUnspents)- c <- forM (HashMap.toList txmap) (uncurry redisAddXPubTxs)- return $ sequence_ a >> sequence_ b >> sequence_ c- $(logDebugS) "Cache" "Completed Redis pipeline"- let xpubs =- HashSet.toList- . HashSet.fromList- . map addressXPubSpec- $ Map.elems amap- $(logDebugS) "Cache" "Getting xpub balances"- xmap <- getbals xpubs- gap <- lift getMaxGap- let notnulls = getnotnull balmap- addrs' = getNewAddrs gap xmap notnulls- cacheAddAddresses addrs'- where- getbals xpubs = runRedis $ do- bs <- sequence <$> forM xpubs redisGetXPubBalances- return $- HashMap.filter (not . null) . HashMap.fromList . zip xpubs <$> bs- amap = Map.fromList addrs- getnotnull =- let f xpub =- map $ \bal ->- AddressXPub- { addressXPubSpec = xpub- , addressXPubPath = xPubBalPath bal- }- g = filter (not . nullBalance . xPubBal)- in concatMap (uncurry f) . HashMap.toList . HashMap.map g- getbal a i =- let f b =- ( addressXPubSpec i- , [XPubBal{xPubBal = b, xPubBalPath = addressXPubPath i}]- )- in f <$> lift (getDefaultBalance a)- getutxo a i =- let f us =- ( addressXPubSpec i- , map (\u -> (unspentPoint u, unspentBlock u)) us- )- in f <$> lift (getAddressUnspents a def)- gettxmap a i =- let f ts = (addressXPubSpec i, ts)- in f <$> lift (getAddressTxs a def)--getNewAddrs ::- KeyIndex ->- HashMap XPubSpec [XPubBal] ->- [AddressXPub] ->- [(Address, AddressXPub)]-getNewAddrs gap xpubs =- concatMap $ \a ->- case HashMap.lookup (addressXPubSpec a) xpubs of- Nothing -> []- Just bals -> addrsToAdd gap bals a--syncMempoolC ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>- CacheX m ()-syncMempoolC = void . withLockForever $ do- nodepool <- HashSet.fromList . map snd <$> lift getMempool- cachepool <- HashSet.fromList . map snd <$> cacheGetMempool- getem (HashSet.difference nodepool cachepool)- getem (HashSet.difference cachepool nodepool)- where- getem tset = do- let tids = HashSet.toList tset- txs <- catMaybes <$> mapM (lift . getTxData) tids- unless (null txs) $ do- $(logDebugS) "Cache" $- "Importing mempool transactions: " <> cs (show (length txs))- importMultiTxC txs--cacheGetMempool :: MonadLoggerIO m => CacheX m [(UnixTime, TxHash)]-cacheGetMempool = runRedis redisGetMempool--cacheIsInMempool :: MonadLoggerIO m => TxHash -> CacheX m Bool-cacheIsInMempool = runRedis . redisIsInMempool--cacheGetHead :: MonadLoggerIO m => CacheX m (Maybe BlockHash)-cacheGetHead = runRedis redisGetHead--cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockHash -> CacheX m ()-cacheSetHead bh = do- $(logDebugS) "Cache" $ "Cache head set to: " <> blockHashToHex bh- void $ runRedis (redisSetHead bh)--cacheGetAddrsInfo ::- MonadLoggerIO m => [Address] -> CacheX m [Maybe AddressXPub]-cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as)--redisAddToMempool :: (Applicative f, RedisCtx m f) => [TxRef] -> m (f Integer)-redisAddToMempool [] = return (pure 0)-redisAddToMempool btxs =- zadd mempoolSetKey $- map- (\btx -> (blockRefScore (txRefBlock btx), encode (txRefHash btx)))- btxs--redisIsInMempool :: (Applicative f, RedisCtx m f) => TxHash -> m (f Bool)-redisIsInMempool txid =- fmap isJust <$> Redis.zrank mempoolSetKey (encode txid)--redisRemFromMempool ::- (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer)-redisRemFromMempool [] = return (pure 0)-redisRemFromMempool xs = zrem mempoolSetKey $ map encode xs--redisSetAddrInfo ::- (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ())-redisSetAddrInfo a i = void <$> Redis.set (addrPfx <> encode a) (encode i)--cacheDelXPubs ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- [XPubSpec] ->- CacheT m Integer-cacheDelXPubs xpubs = ReaderT $ \case- Just cache -> runReaderT (delXPubKeys xpubs) cache- Nothing -> return 0--delXPubKeys ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- [XPubSpec] ->- CacheX m Integer-delXPubKeys [] = return 0-delXPubKeys xpubs = do- forM_ xpubs $ \x -> do- xtxt <- xpubText x- $(logDebugS) "Cache" $ "Deleting xpub: " <> xtxt- xbals <-- runRedis . fmap sequence . forM xpubs $ \xpub -> do- bs <- redisGetXPubBalances xpub- return $ (xpub,) <$> bs- runRedis $ fmap sum . sequence <$> forM xbals (uncurry redisDelXPubKeys)--redisDelXPubKeys ::- (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f Integer)-redisDelXPubKeys xpub bals = go (map (balanceAddress . xPubBal) bals)- where- go addrs = do- addrcount <-- case addrs of- [] -> return (pure 0)- _ -> Redis.del (map ((addrPfx <>) . encode) addrs)- txsetcount <- Redis.del [txSetPfx <> encode xpub]- utxocount <- Redis.del [utxoPfx <> encode xpub]- balcount <- Redis.del [balancesPfx <> encode xpub]- x <- Redis.zrem maxKey [encode xpub]- return $ do- _ <- x- addrs' <- addrcount- txset' <- txsetcount- utxo' <- utxocount- bal' <- balcount- return $ addrs' + txset' + utxo' + bal'--redisAddXPubTxs ::- (Applicative f, RedisCtx m f) => XPubSpec -> [TxRef] -> m (f Integer)-redisAddXPubTxs _ [] = return (pure 0)-redisAddXPubTxs xpub btxs =- zadd (txSetPfx <> encode xpub) $- map (\t -> (blockRefScore (txRefBlock t), encode (txRefHash t))) btxs--redisRemXPubTxs ::- (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer)-redisRemXPubTxs _ [] = return (pure 0)-redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs)--redisAddXPubUnspents ::- (Applicative f, RedisCtx m f) =>- XPubSpec ->- [(OutPoint, BlockRef)] ->- m (f Integer)-redisAddXPubUnspents _ [] =- return (pure 0)-redisAddXPubUnspents xpub utxo =- zadd (utxoPfx <> encode xpub) $- map (\(p, r) -> (blockRefScore r, encode p)) utxo--redisRemXPubUnspents ::- (Applicative f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f Integer)-redisRemXPubUnspents _ [] =- return (pure 0)-redisRemXPubUnspents xpub ops =- zrem (utxoPfx <> encode xpub) (map encode ops)--redisAddXPubBalances ::- (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ())-redisAddXPubBalances _ [] = return (pure ())-redisAddXPubBalances xpub bals = do- xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries- ys <- forM bals $ \b ->- redisSetAddrInfo- (balanceAddress (xPubBal b))- AddressXPub- { addressXPubSpec = xpub- , addressXPubPath = xPubBalPath b- }- return $ sequence_ xs >> sequence_ ys- where- entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals--redisSetHead :: RedisCtx m f => BlockHash -> m (f Redis.Status)-redisSetHead bh = Redis.set bestBlockKey (encode bh)--redisGetAddrsInfo ::- (Monad f, RedisCtx m f) => [Address] -> m (f [Maybe AddressXPub])-redisGetAddrsInfo [] = return (pure [])-redisGetAddrsInfo as = do- is <- mapM (\a -> Redis.get (addrPfx <> encode a)) as- return $ do- is' <- sequence is- return $ map (eitherToMaybe . decode =<<) is'--addrsToAdd :: KeyIndex -> [XPubBal] -> AddressXPub -> [(Address, AddressXPub)]-addrsToAdd gap xbals addrinfo- | null fbals = []- | otherwise = zipWith f addrs list- where- f a p = (a, AddressXPub{addressXPubSpec = xpub, addressXPubPath = p})- dchain = head (addressXPubPath addrinfo)- fbals = filter ((== dchain) . head . xPubBalPath) xbals- maxidx = maximum (map (head . tail . xPubBalPath) fbals)- xpub = addressXPubSpec addrinfo- aidx = (head . tail) (addressXPubPath addrinfo)- ixs =- if gap > maxidx - aidx- then [maxidx + 1 .. aidx + gap]- else []- paths = map (Deriv :/ dchain :/) ixs- keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths- list = map pathToList paths- xpubf = xPubAddrFunction (xPubDeriveType xpub)- addrs = map xpubf keys--sortTxData :: [TxData] -> [TxData]-sortTxData tds =- let txm = Map.fromList (map (\d -> (txHash (txData d), d)) tds)- ths = map (txHash . snd) (sortTxs (map txData tds))- in mapMaybe (`Map.lookup` txm) ths--txInputs :: TxData -> [(Address, OutPoint)]-txInputs td =- let is = txIn (txData td)- ps = I.toAscList (txDataPrevs td)- as = map (scriptToAddressBS . prevScript . snd) ps- f (Right a) i = Just (a, prevOutput i)- f (Left _) _ = Nothing- in catMaybes (zipWith f as is)--txOutputs :: TxData -> [(Address, OutPoint)]-txOutputs td =- let ps =- zipWith- ( \i _ ->- OutPoint- { outPointHash = txHash (txData td)- , outPointIndex = i- }- )- [0 ..]- (txOut (txData td))- as = map (scriptToAddressBS . scriptOutput) (txOut (txData td))- f (Right a) p = Just (a, p)- f (Left _) _ = Nothing- in catMaybes (zipWith f as ps)--redisGetHead :: (Functor f, RedisCtx m f) => m (f (Maybe BlockHash))-redisGetHead = do- x <- Redis.get bestBlockKey- return $ (eitherToMaybe . decode =<<) <$> x--redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [(UnixTime, TxHash)])-redisGetMempool = do- xs <- getFromSortedSet mempoolSetKey Nothing 0 0- return $ map (uncurry f) <$> xs- where- f t s = (memRefTime (scoreBlockRef s), t)--xpubText ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- XPubSpec ->- CacheX m Text-xpubText xpub = do- net <- lift getNetwork- let suffix = case xPubDeriveType xpub of- DeriveNormal -> ""- DeriveP2SH -> "/p2sh"- DeriveP2WPKH -> "/p2wpkh"- return . cs $ suffix <> xPubExport net (xPubSpecKey xpub)+module Haskoin.Store.Cache+ ( CacheConfig (..),+ CacheMetrics,+ CacheT,+ CacheError (..),+ newCacheMetrics,+ withCache,+ connectRedis,+ blockRefScore,+ scoreBlockRef,+ CacheWriter,+ CacheWriterInbox,+ cacheNewBlock,+ cacheNewTx,+ cacheWriter,+ cacheDelXPubs,+ isInCache,+ )+where++import Control.DeepSeq (NFData)+import Control.Monad (forM, forM_, forever, guard, unless, void, when, (>=>))+import Control.Monad.Logger+ ( MonadLoggerIO,+ logDebugS,+ logErrorS,+ logInfoS,+ logWarnS,+ )+import Control.Monad.Reader (ReaderT (..), ask, asks)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Bits (complement, shift, (.&.), (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Default (def)+import Data.Either (fromRight, isRight, rights)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import qualified Data.IntMap.Strict as I+import Data.List (sort)+import qualified Data.Map.Strict as Map+import Data.Maybe+ ( catMaybes,+ fromMaybe,+ isJust,+ isNothing,+ mapMaybe,+ )+import Data.Serialize (Serialize, decode, encode)+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Time.Clock (NominalDiffTime, diffUTCTime)+import Data.Time.Clock.System+ ( getSystemTime,+ systemSeconds,+ systemToUTCTime,+ )+import Data.Word (Word32, Word64)+import Database.Redis+ ( Connection,+ Redis,+ RedisCtx,+ Reply,+ checkedConnect,+ defaultConnectInfo,+ hgetall,+ parseConnectInfo,+ zadd,+ zrangeWithscores,+ zrangebyscoreWithscoresLimit,+ zrem,+ )+import qualified Database.Redis as Redis+import GHC.Generics (Generic)+import Haskoin+ ( Address,+ BlockHash,+ BlockHeader (..),+ BlockNode (..),+ DerivPathI (..),+ KeyIndex,+ OutPoint (..),+ Tx (..),+ TxHash,+ TxIn (..),+ TxOut (..),+ XPubKey,+ blockHashToHex,+ derivePubPath,+ eitherToMaybe,+ headerHash,+ pathToList,+ scriptToAddressBS,+ txHash,+ txHashToHex,+ xPubAddr,+ xPubCompatWitnessAddr,+ xPubExport,+ xPubWitnessAddr,+ )+import Haskoin.Node+ ( Chain,+ chainBlockMain,+ chainGetAncestor,+ chainGetBest,+ chainGetBlock,+ )+import Haskoin.Store.Common+import Haskoin.Store.Data+import Haskoin.Store.Stats+import NQE+ ( Inbox,+ Listen,+ Mailbox,+ inboxToMailbox,+ query,+ receive,+ send,+ )+import qualified System.Metrics as Metrics+import qualified System.Metrics.Counter as Metrics (Counter)+import qualified System.Metrics.Counter as Metrics.Counter+import qualified System.Metrics.Distribution as Metrics (Distribution)+import qualified System.Metrics.Distribution as Metrics.Distribution+import qualified System.Metrics.Gauge as Metrics (Gauge)+import qualified System.Metrics.Gauge as Metrics.Gauge+import System.Random (randomIO, randomRIO)+import UnliftIO+ ( Exception,+ MonadIO,+ MonadUnliftIO,+ TQueue,+ TVar,+ async,+ atomically,+ bracket,+ liftIO,+ link,+ modifyTVar,+ newTVarIO,+ readTQueue,+ readTVar,+ throwIO,+ wait,+ withAsync,+ writeTQueue,+ writeTVar,+ )+import UnliftIO.Concurrent (threadDelay)++runRedis :: MonadLoggerIO m => Redis (Either Reply a) -> CacheX m a+runRedis action =+ asks cacheConn >>= \conn ->+ liftIO (Redis.runRedis conn action) >>= \case+ Right x -> return x+ Left e -> do+ $(logErrorS) "Cache" $ "Got error from Redis: " <> cs (show e)+ throwIO (RedisError e)++data CacheConfig = CacheConfig+ { cacheConn :: !Connection,+ cacheMin :: !Int,+ cacheMax :: !Integer,+ cacheChain :: !Chain,+ cacheRetryDelay :: !Int, -- microseconds+ cacheMetrics :: !(Maybe CacheMetrics)+ }++data CacheMetrics = CacheMetrics+ { cacheHits :: !Metrics.Counter,+ cacheMisses :: !Metrics.Counter,+ cacheLockAcquired :: !Metrics.Counter,+ cacheLockReleased :: !Metrics.Counter,+ cacheLockFailed :: !Metrics.Counter,+ cacheXPubBals :: !Metrics.Counter,+ cacheXPubUnspents :: !Metrics.Counter,+ cacheXPubTxs :: !Metrics.Counter,+ cacheXPubTxCount :: !Metrics.Counter,+ cacheIndexTime :: !StatDist+ }++newCacheMetrics :: MonadIO m => Metrics.Store -> m CacheMetrics+newCacheMetrics s = liftIO $ do+ cacheHits <- c "cache.hits"+ cacheMisses <- c "cache.misses"+ cacheLockAcquired <- c "cache.lock_acquired"+ cacheLockReleased <- c "cache.lock_released"+ cacheLockFailed <- c "cache.lock_failed"+ cacheIndexTime <- d "cache.index"+ cacheXPubBals <- c "cache.xpub_balances_cached"+ cacheXPubUnspents <- c "cache.xpub_unspents_cached"+ cacheXPubTxs <- c "cache.xpub_txs_cached"+ cacheXPubTxCount <- c "cache.xpub_tx_count_cached"+ return CacheMetrics {..}+ where+ c x = Metrics.createCounter x s+ d x = createStatDist x s++withMetrics ::+ MonadUnliftIO m =>+ (CacheMetrics -> StatDist) ->+ CacheX m a ->+ CacheX m a+withMetrics df go =+ asks cacheMetrics >>= \case+ Nothing -> go+ Just m ->+ bracket+ (systemToUTCTime <$> liftIO getSystemTime)+ (end m)+ (const go)+ where+ end metrics t1 = do+ t2 <- systemToUTCTime <$> liftIO getSystemTime+ let diff = round $ diffUTCTime t2 t1 * 1000+ df metrics `addStatTime` diff+ addStatQuery (df metrics)++incrementCounter ::+ MonadIO m =>+ (CacheMetrics -> Metrics.Counter) ->+ Int ->+ CacheX m ()+incrementCounter f i =+ asks cacheMetrics >>= \case+ Just s -> liftIO $ Metrics.Counter.add (f s) (fromIntegral i)+ Nothing -> return ()++type CacheT = ReaderT (Maybe CacheConfig)++type CacheX = ReaderT CacheConfig++data CacheError+ = RedisError Reply+ | RedisTxError !String+ | LogicError !String+ deriving (Show, Eq, Generic, NFData, Exception)++connectRedis :: MonadIO m => String -> m Connection+connectRedis redisurl = do+ conninfo <-+ if null redisurl+ then return defaultConnectInfo+ else case parseConnectInfo redisurl of+ Left e -> error e+ Right r -> return r+ liftIO (checkedConnect conninfo)++instance+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ StoreReadBase (CacheT m)+ where+ getNetwork = lift getNetwork+ getBestBlock = lift getBestBlock+ getBlocksAtHeight = lift . getBlocksAtHeight+ getBlock = lift . getBlock+ getTxData = lift . getTxData+ getSpender = lift . getSpender+ getBalance = lift . getBalance+ getUnspent = lift . getUnspent+ getMempool = lift getMempool++instance+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ StoreReadExtra (CacheT m)+ where+ getBalances = lift . getBalances+ getAddressesTxs addrs = lift . getAddressesTxs addrs+ getAddressTxs addr = lift . getAddressTxs addr+ getAddressUnspents addr = lift . getAddressUnspents addr+ getAddressesUnspents addrs = lift . getAddressesUnspents addrs+ getMaxGap = lift getMaxGap+ getInitialGap = lift getInitialGap+ getNumTxData = lift . getNumTxData+ xPubBals xpub =+ ask >>= \case+ Nothing ->+ lift $+ xPubBals xpub+ Just cfg ->+ lift $+ runReaderT (getXPubBalances xpub) cfg+ xPubUnspents xpub xbals limits =+ ask >>= \case+ Nothing ->+ lift $+ xPubUnspents xpub xbals limits+ Just cfg ->+ lift $+ runReaderT (getXPubUnspents xpub xbals limits) cfg+ xPubTxs xpub xbals limits =+ ask >>= \case+ Nothing ->+ lift $+ xPubTxs xpub xbals limits+ Just cfg ->+ lift $+ runReaderT (getXPubTxs xpub xbals limits) cfg+ xPubTxCount xpub xbals =+ ask >>= \case+ Nothing ->+ lift $+ xPubTxCount xpub xbals+ Just cfg ->+ lift $+ runReaderT (getXPubTxCount xpub xbals) cfg++withCache :: StoreReadBase m => Maybe CacheConfig -> CacheT m a -> m a+withCache s f = runReaderT f s++balancesPfx :: ByteString+balancesPfx = "b"++txSetPfx :: ByteString+txSetPfx = "t"++utxoPfx :: ByteString+utxoPfx = "u"++idxPfx :: ByteString+idxPfx = "i"++getXPubTxs ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ XPubSpec ->+ [XPubBal] ->+ Limits ->+ CacheX m [TxRef]+getXPubTxs xpub xbals limits = go False+ where+ go m =+ isXPubCached xpub >>= \case+ True -> do+ txs <- cacheGetXPubTxs xpub limits+ incrementCounter cacheXPubTxs (length txs)+ return txs+ False ->+ case m of+ True -> lift $ xPubTxs xpub xbals limits+ False -> do+ newXPubC xpub xbals+ go True++getXPubTxCount ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ XPubSpec ->+ [XPubBal] ->+ CacheX m Word32+getXPubTxCount xpub xbals =+ go False+ where+ go t =+ isXPubCached xpub >>= \case+ True -> do+ incrementCounter cacheXPubTxCount 1+ cacheGetXPubTxCount xpub+ False ->+ if t+ then lift $ xPubTxCount xpub xbals+ else do+ newXPubC xpub xbals+ go True++getXPubUnspents ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ XPubSpec ->+ [XPubBal] ->+ Limits ->+ CacheX m [XPubUnspent]+getXPubUnspents xpub xbals limits =+ go False+ where+ xm =+ let f x = (balanceAddress (xPubBal x), x)+ g = (> 0) . balanceUnspentCount . xPubBal+ in HashMap.fromList $ map f $ filter g xbals+ go m =+ isXPubCached xpub >>= \case+ True -> do+ process+ False -> case m of+ True -> do+ us <- lift $ xPubUnspents xpub xbals limits+ return us+ False -> do+ newXPubC xpub xbals+ go True+ process = do+ ops <- map snd <$> cacheGetXPubUnspents xpub limits+ uns <- catMaybes <$> lift (mapM getUnspent ops)+ let f u =+ either+ (const Nothing)+ (\a -> Just (a, u))+ (scriptToAddressBS (unspentScript u))+ g a = HashMap.lookup a xm+ h u x =+ XPubUnspent+ { xPubUnspent = u,+ xPubUnspentPath = xPubBalPath x+ }+ us = mapMaybe f uns+ i a u = h u <$> g a+ incrementCounter cacheXPubUnspents (length us)+ return $ mapMaybe (uncurry i) us++getXPubBalances ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ XPubSpec ->+ CacheX m [XPubBal]+getXPubBalances xpub =+ isXPubCached xpub >>= \case+ True -> do+ xbals <- cacheGetXPubBalances xpub+ incrementCounter cacheXPubBals (length xbals)+ return xbals+ False -> do+ bals <- lift $ xPubBals xpub+ newXPubC xpub bals+ return bals++isInCache :: MonadLoggerIO m => XPubSpec -> CacheT m Bool+isInCache xpub =+ ask >>= \case+ Nothing -> return False+ Just cfg -> runReaderT (isXPubCached xpub) cfg++isXPubCached :: MonadLoggerIO m => XPubSpec -> CacheX m Bool+isXPubCached xpub = do+ cached <- runRedis (redisIsXPubCached xpub)+ if cached+ then incrementCounter cacheHits 1+ else incrementCounter cacheMisses 1+ return cached++redisIsXPubCached :: RedisCtx m f => XPubSpec -> m (f Bool)+redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub)++cacheGetXPubBalances :: MonadLoggerIO m => XPubSpec -> CacheX m [XPubBal]+cacheGetXPubBalances xpub = do+ bals <- runRedis $ redisGetXPubBalances xpub+ touchKeys [xpub]+ return bals++cacheGetXPubTxCount ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ XPubSpec ->+ CacheX m Word32+cacheGetXPubTxCount xpub = do+ count <- fromInteger <$> runRedis (redisGetXPubTxCount xpub)+ touchKeys [xpub]+ return count++redisGetXPubTxCount :: RedisCtx m f => XPubSpec -> m (f Integer)+redisGetXPubTxCount xpub = Redis.zcard (txSetPfx <> encode xpub)++cacheGetXPubTxs ::+ (StoreReadBase m, MonadLoggerIO m) =>+ XPubSpec ->+ Limits ->+ CacheX m [TxRef]+cacheGetXPubTxs xpub limits =+ case start limits of+ Nothing ->+ go1 Nothing+ Just (AtTx th) ->+ lift (getTxData th) >>= \case+ Just TxData {txDataBlock = b@BlockRef {}} ->+ go1 $ Just (blockRefScore b)+ _ ->+ go2 th+ Just (AtBlock h) ->+ go1 (Just (blockRefScore (BlockRef h maxBound)))+ where+ go1 score = do+ xs <-+ runRedis $+ getFromSortedSet+ (txSetPfx <> encode xpub)+ score+ (offset limits)+ (limit limits)+ touchKeys [xpub]+ return $ map (uncurry f) xs+ go2 hash = do+ xs <-+ runRedis $+ getFromSortedSet+ (txSetPfx <> encode xpub)+ Nothing+ 0+ 0+ touchKeys [xpub]+ let xs' =+ if any ((== hash) . fst) xs+ then dropWhile ((/= hash) . fst) xs+ else []+ return $+ map (uncurry f) $+ l $+ drop (fromIntegral (offset limits)) xs'+ l =+ if limit limits > 0+ then take (fromIntegral (limit limits))+ else id+ f t s = TxRef {txRefHash = t, txRefBlock = scoreBlockRef s}++cacheGetXPubUnspents ::+ (StoreReadBase m, MonadLoggerIO m) =>+ XPubSpec ->+ Limits ->+ CacheX m [(BlockRef, OutPoint)]+cacheGetXPubUnspents xpub limits =+ case start limits of+ Nothing ->+ go1 Nothing+ Just (AtTx th) ->+ lift (getTxData th) >>= \case+ Just TxData {txDataBlock = b@BlockRef {}} ->+ go1 (Just (blockRefScore b))+ _ ->+ go2 th+ Just (AtBlock h) ->+ go1 (Just (blockRefScore (BlockRef h maxBound)))+ where+ go1 score = do+ xs <-+ runRedis $+ getFromSortedSet+ (utxoPfx <> encode xpub)+ score+ (offset limits)+ (limit limits)+ touchKeys [xpub]+ return $ map (uncurry f) xs+ go2 hash = do+ xs <-+ runRedis $+ getFromSortedSet+ (utxoPfx <> encode xpub)+ Nothing+ 0+ 0+ touchKeys [xpub]+ let xs' =+ if any ((== hash) . outPointHash . fst) xs+ then dropWhile ((/= hash) . outPointHash . fst) xs+ else []+ return $+ map (uncurry f) $+ l $+ drop (fromIntegral (offset limits)) xs'+ l =+ if limit limits > 0+ then take (fromIntegral (limit limits))+ else id+ f o s = (scoreBlockRef s, o)++redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal])+redisGetXPubBalances xpub =+ fmap (sort . map (uncurry f)) <$> getAllFromMap (balancesPfx <> encode xpub)+ where+ f p b = XPubBal {xPubBalPath = p, xPubBal = b}++blockRefScore :: BlockRef -> Double+blockRefScore BlockRef {blockRefHeight = h, blockRefPos = p} =+ fromIntegral (0x001fffffffffffff - (h' .|. p'))+ where+ h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64+ p' = (fromIntegral p .&. 0x03ffffff) :: Word64+blockRefScore MemRef {memRefTime = t} = negate t'+ where+ t' = fromIntegral (t .&. 0x001fffffffffffff)++scoreBlockRef :: Double -> BlockRef+scoreBlockRef s+ | s < 0 = MemRef {memRefTime = n}+ | otherwise = BlockRef {blockRefHeight = h, blockRefPos = p}+ where+ n = truncate (abs s) :: Word64+ m = 0x001fffffffffffff - n+ h = fromIntegral (m `shift` (-26))+ p = fromIntegral (m .&. 0x03ffffff)++getFromSortedSet ::+ (Applicative f, RedisCtx m f, Serialize a) =>+ ByteString ->+ Maybe Double ->+ Word32 ->+ Word32 ->+ m (f [(a, Double)])+getFromSortedSet key Nothing off 0 = do+ xs <- zrangeWithscores key (fromIntegral off) (-1)+ return $ do+ ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs+ return (rights ys)+getFromSortedSet key Nothing off count = do+ xs <-+ zrangeWithscores+ key+ (fromIntegral off)+ (fromIntegral off + fromIntegral count - 1)+ return $ do+ ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs+ return (rights ys)+getFromSortedSet key (Just score) off 0 = do+ xs <-+ zrangebyscoreWithscoresLimit+ key+ score+ (1 / 0)+ (fromIntegral off)+ (-1)+ return $ do+ ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs+ return (rights ys)+getFromSortedSet key (Just score) off count = do+ xs <-+ zrangebyscoreWithscoresLimit+ key+ score+ (1 / 0)+ (fromIntegral off)+ (fromIntegral count)+ return $ do+ ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs+ return (rights ys)++getAllFromMap ::+ (Functor f, RedisCtx m f, Serialize k, Serialize v) =>+ ByteString ->+ m (f [(k, v)])+getAllFromMap n = do+ fxs <- hgetall n+ return $ do+ xs <- fxs+ return+ [ (k, v)+ | (k', v') <- xs,+ let Right k = decode k',+ let Right v = decode v'+ ]++data CacheWriterMessage+ = CacheNewBlock+ | CacheNewTx TxHash++type CacheWriterInbox = Inbox CacheWriterMessage++type CacheWriter = Mailbox CacheWriterMessage++data AddressXPub = AddressXPub+ { addressXPubSpec :: !XPubSpec,+ addressXPubPath :: ![KeyIndex]+ }+ deriving (Show, Eq, Generic, NFData, Serialize)++mempoolSetKey :: ByteString+mempoolSetKey = "mempool"++addrPfx :: ByteString+addrPfx = "a"++bestBlockKey :: ByteString+bestBlockKey = "head"++maxKey :: ByteString+maxKey = "max"++xPubAddrFunction :: DeriveType -> XPubKey -> Address+xPubAddrFunction DeriveNormal = xPubAddr+xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr+xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr++cacheWriter ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ CacheConfig ->+ CacheWriterInbox ->+ m ()+cacheWriter cfg inbox =+ runReaderT go cfg+ where+ go = do+ newBlockC+ syncMempoolC+ forever $ do+ x <- receive inbox+ cacheWriterReact x++lockIt :: MonadLoggerIO m => CacheX m (Maybe Word32)+lockIt = do+ rnd <- liftIO randomIO+ go rnd >>= \case+ Right Redis.Ok -> do+ $(logDebugS) "Cache" $+ "Acquired lock with value " <> cs (show rnd)+ incrementCounter cacheLockAcquired 1+ return (Just rnd)+ Right Redis.Pong -> do+ $(logErrorS)+ "Cache"+ "Unexpected pong when acquiring lock"+ incrementCounter cacheLockFailed 1+ return Nothing+ Right (Redis.Status s) -> do+ $(logErrorS) "Cache" $+ "Unexpected status acquiring lock: " <> cs s+ incrementCounter cacheLockFailed 1+ return Nothing+ Left (Redis.Bulk Nothing) -> do+ $(logDebugS) "Cache" "Lock already taken"+ incrementCounter cacheLockFailed 1+ return Nothing+ Left e -> do+ $(logErrorS)+ "Cache"+ "Error when trying to acquire lock"+ incrementCounter cacheLockFailed 1+ throwIO (RedisError e)+ where+ go rnd = do+ conn <- asks cacheConn+ liftIO . Redis.runRedis conn $ do+ let opts =+ Redis.SetOpts+ { Redis.setSeconds = Just 300,+ Redis.setMilliseconds = Nothing,+ Redis.setCondition = Just Redis.Nx+ }+ Redis.setOpts "lock" (cs (show rnd)) opts++unlockIt :: MonadLoggerIO m => Maybe Word32 -> CacheX m ()+unlockIt Nothing = return ()+unlockIt (Just i) =+ runRedis (Redis.get "lock") >>= \case+ Nothing ->+ $(logErrorS) "Cache" $+ "Not releasing lock with value " <> cs (show i)+ <> ": not locked"+ Just bs ->+ if read (cs bs) == i+ then do+ void $ runRedis (Redis.del ["lock"])+ $(logDebugS) "Cache" $+ "Released lock with value "+ <> cs (show i)+ incrementCounter cacheLockReleased 1+ else+ $(logErrorS) "Cache" $+ "Could not release lock: value is not "+ <> cs (show i)++withLock ::+ (MonadLoggerIO m, MonadUnliftIO m) =>+ CacheX m a ->+ CacheX m (Maybe a)+withLock f =+ bracket lockIt unlockIt $ \case+ Just _ -> Just <$> f+ Nothing -> return Nothing++smallDelay :: MonadUnliftIO m => CacheX m ()+smallDelay = do+ delay <- asks cacheRetryDelay+ let delayMin = delay `div` 2+ let delayMax = delay * 3 `div` 2+ threadDelay =<< liftIO (randomRIO (delayMin, delayMax))++withLockForever ::+ (MonadLoggerIO m, MonadUnliftIO m) =>+ CacheX m a ->+ CacheX m a+withLockForever go =+ withLock go >>= \case+ Nothing -> do+ smallDelay+ $(logDebugS) "Cache" "Retrying lock aquisition without limits"+ withLockForever go+ Just x -> return x++withLockRetry ::+ (MonadLoggerIO m, MonadUnliftIO m) =>+ Int ->+ CacheX m a ->+ CacheX m (Maybe a)+withLockRetry i f+ | i <= 0 = return Nothing+ | otherwise =+ withLock f >>= \case+ 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+pruneDB = do+ x <- asks cacheMax+ s <- runRedis Redis.dbsize+ if s > x then flush (s - x) else return 0+ where+ flush n =+ case n `div` 64 of+ 0 -> return 0+ x -> fmap (fromMaybe 0) $+ withLock $ do+ ks <-+ fmap (map fst) . runRedis $+ getFromSortedSet maxKey Nothing 0 (fromIntegral x)+ $(logDebugS) "Cache" $+ "Pruning " <> cs (show (length ks)) <> " old xpubs"+ delXPubKeys ks++touchKeys :: MonadLoggerIO m => [XPubSpec] -> CacheX m ()+touchKeys xpubs = do+ now <- systemSeconds <$> liftIO getSystemTime+ runRedis $ redisTouchKeys now xpubs++redisTouchKeys :: (Monad f, RedisCtx m f, Real a) => a -> [XPubSpec] -> m (f ())+redisTouchKeys _ [] = return $ return ()+redisTouchKeys now xpubs =+ void <$> Redis.zadd maxKey (map ((realToFrac now,) . encode) xpubs)++cacheWriterReact ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ CacheWriterMessage ->+ CacheX m ()+cacheWriterReact CacheNewBlock =+ doSync+cacheWriterReact (CacheNewTx txid) =+ withLock go >>= \case+ Just () -> return ()+ Nothing -> smallDelay >> cacheWriterReact (CacheNewTx txid)+ where+ hex = txHashToHex txid+ go =+ $(logDebugS) "Cache" ("Locking to import tx: " <> hex)+ >> cacheIsInMempool txid >>= \case+ True ->+ $(logDebugS) "Cache" $ "Already imported tx: " <> hex+ False ->+ lift (getTxData txid) >>= mapM_ \tx -> do+ $(logDebugS) "Cache" $ "Importing mempool tx: " <> hex+ importMultiTxC [tx]++doSync ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ CacheX m ()+doSync = newBlockC >> void pruneDB++lenNotNull :: [XPubBal] -> Int+lenNotNull = length . filter (not . nullBalance . xPubBal)++newXPubC ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ XPubSpec ->+ [XPubBal] ->+ CacheX m ()+newXPubC xpub xbals =+ should_index >>= \i -> when i $+ bracket set_index unset_index $ \j -> when j $+ withMetrics cacheIndexTime $ do+ xpubtxt <- xpubText xpub+ $(logDebugS) "Cache" $+ "Caching " <> xpubtxt <> ": "+ <> cs (show (length xbals))+ <> " addresses / "+ <> cs (show (lenNotNull xbals))+ <> " used"+ utxo <- lift $ xPubUnspents xpub xbals def+ $(logDebugS) "Cache" $+ "Caching " <> xpubtxt <> ": " <> cs (show (length utxo))+ <> " utxos"+ xtxs <- lift $ xPubTxs xpub xbals def+ $(logDebugS) "Cache" $+ "Caching " <> xpubtxt <> ": " <> cs (show (length xtxs))+ <> " txs"+ now <- systemSeconds <$> liftIO getSystemTime+ runRedis $ do+ b <- redisTouchKeys now [xpub]+ c <- redisAddXPubBalances xpub xbals+ d <- redisAddXPubUnspents xpub (map op utxo)+ e <- redisAddXPubTxs xpub xtxs+ return $ b >> c >> d >> e >> return ()+ $(logDebugS) "Cache" $ "Cached " <> xpubtxt+ where+ op XPubUnspent {xPubUnspent = u} = (unspentPoint u, unspentBlock u)+ should_index =+ asks cacheMin >>= \x ->+ if x <= lenNotNull xbals then inSync else return False+ key = idxPfx <> encode xpub+ opts =+ Redis.SetOpts+ { Redis.setSeconds = Just 600,+ Redis.setMilliseconds = Nothing,+ Redis.setCondition = Just Redis.Nx+ }+ red = Redis.setOpts key "1" opts+ unset_index y = when y . void . runRedis $ Redis.del [key]+ set_index =+ asks cacheConn >>= \conn ->+ liftIO (Redis.runRedis conn red) >>= return . isRight++inSync ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ CacheX m Bool+inSync =+ lift getBestBlock >>= \case+ Nothing -> return False+ Just bb ->+ asks cacheChain >>= \ch ->+ chainGetBest ch >>= \cb ->+ return $ headerHash (nodeHeader cb) == bb++newBlockC ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ CacheX m ()+newBlockC =+ inSync >>= \s ->+ when s $+ asks cacheChain >>= \ch ->+ chainGetBest ch >>= \bn ->+ cacheGetHead >>= \case+ Nothing ->+ $(logInfoS) "Cache" "Initializing best cache block"+ >> withLock (do_import bn) >>= \case+ Nothing -> smallDelay >> newBlockC+ Just () -> return ()+ Just hb ->+ if hb == headerHash (nodeHeader bn)+ then $(logDebugS) "Cache" "Cache in sync"+ else+ withLock (sync ch hb bn) >>= \case+ Nothing -> smallDelay >> newBlockC+ Just () -> return ()+ where+ sync ch hb bn =+ chainGetBlock hb ch >>= \case+ Nothing -> do+ $(logErrorS) "Cache" $+ "Cache head block node not found: "+ <> blockHashToHex hb+ throwIO $+ LogicError $+ "Cache head block node not found: "+ <> cs (blockHashToHex hb)+ Just hn ->+ chainBlockMain hb ch >>= \m ->+ if m+ then next ch bn hn+ else do+ $(logDebugS) "Cache" $+ "Reverting cache head not in main chain: "+ <> blockHashToHex hb+ removeHeadC hb+ cacheGetHead >>= \case+ Nothing -> do_import bn+ Just hb' -> sync ch hb' bn+ next ch bn hn =+ if+ | prevBlock (nodeHeader bn) == headerHash (nodeHeader hn) ->+ do_import bn+ | nodeHeight bn > nodeHeight hn ->+ chainGetAncestor (nodeHeight hn + 1) bn ch >>= \case+ Nothing -> do+ $(logErrorS) "Cache" $+ "Ancestor not found at height "+ <> cs (show (nodeHeight hn + 1))+ <> " for block: "+ <> blockHashToHex (headerHash (nodeHeader bn))+ throwIO $+ LogicError $+ "Ancestor not found at height "+ <> show (nodeHeight hn + 1)+ <> " for block: "+ <> cs (blockHashToHex (headerHash (nodeHeader bn)))+ Just hn' -> do+ do_import hn'+ next ch bn hn'+ | otherwise ->+ $(logInfoS) "Cache" "Cache best block higher than this node's"+ do_import = importBlockC . headerHash . nodeHeader++importBlockC ::+ (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) =>+ BlockHash ->+ CacheX m ()+importBlockC bh =+ lift (getBlock bh) >>= \case+ Just bd -> do+ let ths = blockDataTxs bd+ tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths+ $(logDebugS) "Cache" $+ "Importing " <> cs (show (length tds))+ <> " transactions from block "+ <> blockHashToHex bh+ importMultiTxC tds+ $(logDebugS) "Cache" $+ "Done importing " <> cs (show (length tds))+ <> " transactions from block "+ <> blockHashToHex bh+ cacheSetHead bh+ Nothing -> do+ $(logErrorS) "Cache" $+ "Could not get block: "+ <> blockHashToHex bh+ throwIO . LogicError . cs $+ "Could not get block: "+ <> blockHashToHex bh++removeHeadC ::+ (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) =>+ BlockHash ->+ CacheX m ()+removeHeadC cb =+ void . runMaybeT $ do+ bh <- MaybeT cacheGetHead+ guard (cb == bh)+ bd <- MaybeT (lift (getBlock bh))+ lift $ do+ tds <-+ sortTxData . catMaybes+ <$> mapM (lift . getTxData) (blockDataTxs bd)+ $(logDebugS) "Cache" $ "Reverting head: " <> blockHashToHex bh+ importMultiTxC tds+ $(logWarnS) "Cache" $+ "Reverted block head "+ <> blockHashToHex bh+ <> " to parent "+ <> blockHashToHex (prevBlock (blockDataHeader bd))+ cacheSetHead (prevBlock (blockDataHeader bd))++importMultiTxC ::+ (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) =>+ [TxData] ->+ CacheX m ()+importMultiTxC txs = do+ $(logDebugS) "Cache" $ "Processing " <> cs (show (length txs)) <> " txs"+ $(logDebugS) "Cache" $+ "Getting address information for "+ <> cs (show (length alladdrs))+ <> " addresses"+ addrmap <- getaddrmap+ let addrs = HashMap.keys addrmap+ $(logDebugS) "Cache" $+ "Getting balances for "+ <> cs (show (HashMap.size addrmap))+ <> " addresses"+ balmap <- getbalances addrs+ $(logDebugS) "Cache" $+ "Getting unspent data for "+ <> cs (show (length allops))+ <> " outputs"+ unspentmap <- getunspents+ gap <- lift getMaxGap+ now <- systemSeconds <$> liftIO getSystemTime+ let xpubs = allxpubsls addrmap+ forM_ (zip [(1 :: Int) ..] xpubs) $ \(i, xpub) -> do+ xpubtxt <- xpubText xpub+ $(logDebugS) "Cache" $+ "Affected xpub "+ <> cs (show i)+ <> "/"+ <> cs (show (length xpubs))+ <> ": "+ <> xpubtxt+ addrs' <- do+ $(logDebugS) "Cache" $+ "Getting xpub balances for "+ <> cs (show (length xpubs))+ <> " xpubs"+ xmap <- getxbals xpubs+ let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap+ $(logDebugS) "Cache" "Starting Redis import pipeline"+ runRedis $ do+ x <- redisImportMultiTx addrmap' unspentmap txs+ y <- redisUpdateBalances addrmap' balmap+ z <- redisTouchKeys now (HashMap.keys xmap)+ return $ x >> y >> z >> return ()+ $(logDebugS) "Cache" "Completed Redis pipeline"+ return $ getNewAddrs gap xmap (HashMap.elems addrmap')+ cacheAddAddresses addrs'+ where+ alladdrsls = HashSet.toList alladdrs+ faddrmap xmap = HashMap.filter (\a -> addressXPubSpec a `elem` xmap)+ getaddrmap =+ HashMap.fromList . catMaybes . zipWith (\a -> fmap (a,)) alladdrsls+ <$> cacheGetAddrsInfo alladdrsls+ getunspents =+ HashMap.fromList . catMaybes . zipWith (\p -> fmap (p,)) allops+ <$> lift (mapM getUnspent allops)+ getbalances addrs =+ HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs+ getxbals xpubs = do+ bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do+ bs <- redisGetXPubBalances xpub+ return $ (,) xpub <$> bs+ return $ HashMap.filter (not . null) (HashMap.fromList bals)+ allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs+ alladdrs =+ HashSet.fromList . map fst $+ concatMap txInputs txs <> concatMap txOutputs txs+ allxpubsls addrmap = HashSet.toList (allxpubs addrmap)+ allxpubs addrmap =+ HashSet.fromList . map addressXPubSpec $ HashMap.elems addrmap++redisImportMultiTx ::+ (Monad f, RedisCtx m f) =>+ HashMap Address AddressXPub ->+ HashMap OutPoint Unspent ->+ [TxData] ->+ m (f ())+redisImportMultiTx addrmap unspentmap txs = do+ xs <- mapM importtxentries txs+ return $ sequence_ xs+ where+ uns p i =+ case HashMap.lookup p unspentmap of+ Just u ->+ redisAddXPubUnspents (addressXPubSpec i) [(p, unspentBlock u)]+ Nothing -> redisRemXPubUnspents (addressXPubSpec i) [p]+ addtx tx a p =+ case HashMap.lookup a addrmap of+ Just i -> do+ let tr =+ TxRef+ { txRefHash = txHash (txData tx),+ txRefBlock = txDataBlock tx+ }+ x <- redisAddXPubTxs (addressXPubSpec i) [tr]+ y <- uns p i+ return $ x >> y >> return ()+ Nothing -> return (pure ())+ remtx tx a p =+ case HashMap.lookup a addrmap of+ Just i -> do+ x <- redisRemXPubTxs (addressXPubSpec i) [txHash (txData tx)]+ y <- uns p i+ return $ x >> y >> return ()+ Nothing -> return (pure ())+ importtxentries tx =+ if txDataDeleted tx+ then do+ x <- mapM (uncurry (remtx tx)) (txaddrops tx)+ y <- redisRemFromMempool [txHash (txData tx)]+ return $ sequence_ x >> void y+ else do+ a <- sequence <$> mapM (uncurry (addtx tx)) (txaddrops tx)+ b <-+ case txDataBlock tx of+ b@MemRef {} ->+ let tr =+ TxRef+ { txRefHash = txHash (txData tx),+ txRefBlock = b+ }+ in redisAddToMempool [tr]+ _ -> redisRemFromMempool [txHash (txData tx)]+ return $ a >> b >> return ()+ txaddrops td = txInputs td <> txOutputs td++redisUpdateBalances ::+ (Monad f, RedisCtx m f) =>+ HashMap Address AddressXPub ->+ HashMap Address Balance ->+ m (f ())+redisUpdateBalances addrmap balmap =+ fmap (fmap mconcat . sequence) . forM (HashMap.keys addrmap) $ \a ->+ case (HashMap.lookup a addrmap, HashMap.lookup a balmap) of+ (Just ainfo, Just bal) ->+ redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal]+ _ -> return (pure ())+ where+ xpubbal ainfo bal =+ XPubBal {xPubBalPath = addressXPubPath ainfo, xPubBal = bal}++cacheAddAddresses ::+ (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) =>+ [(Address, AddressXPub)] ->+ CacheX m ()+cacheAddAddresses [] = $(logDebugS) "Cache" "No further addresses to add"+cacheAddAddresses addrs = do+ $(logDebugS) "Cache" $+ "Adding " <> cs (show (length addrs)) <> " new generated addresses"+ $(logDebugS) "Cache" "Getting balances"+ balmap <- HashMap.fromListWith (<>) <$> mapM (uncurry getbal) addrs+ $(logDebugS) "Cache" "Getting unspent outputs"+ utxomap <- HashMap.fromListWith (<>) <$> mapM (uncurry getutxo) addrs+ $(logDebugS) "Cache" "Getting transactions"+ txmap <- HashMap.fromListWith (<>) <$> mapM (uncurry gettxmap) addrs+ $(logDebugS) "Cache" "Running Redis pipeline"+ runRedis $ do+ a <- forM (HashMap.toList balmap) (uncurry redisAddXPubBalances)+ b <- forM (HashMap.toList utxomap) (uncurry redisAddXPubUnspents)+ c <- forM (HashMap.toList txmap) (uncurry redisAddXPubTxs)+ return $ sequence_ a >> sequence_ b >> sequence_ c+ $(logDebugS) "Cache" "Completed Redis pipeline"+ let xpubs =+ HashSet.toList+ . HashSet.fromList+ . map addressXPubSpec+ $ Map.elems amap+ $(logDebugS) "Cache" "Getting xpub balances"+ xmap <- getbals xpubs+ gap <- lift getMaxGap+ let notnulls = getnotnull balmap+ addrs' = getNewAddrs gap xmap notnulls+ cacheAddAddresses addrs'+ where+ getbals xpubs = runRedis $ do+ bs <- sequence <$> forM xpubs redisGetXPubBalances+ return $+ HashMap.filter (not . null) . HashMap.fromList . zip xpubs <$> bs+ amap = Map.fromList addrs+ getnotnull =+ let f xpub =+ map $ \bal ->+ AddressXPub+ { addressXPubSpec = xpub,+ addressXPubPath = xPubBalPath bal+ }+ g = filter (not . nullBalance . xPubBal)+ in concatMap (uncurry f) . HashMap.toList . HashMap.map g+ getbal a i =+ let f b =+ ( addressXPubSpec i,+ [XPubBal {xPubBal = b, xPubBalPath = addressXPubPath i}]+ )+ in f <$> lift (getDefaultBalance a)+ getutxo a i =+ let f us =+ ( addressXPubSpec i,+ map (\u -> (unspentPoint u, unspentBlock u)) us+ )+ in f <$> lift (getAddressUnspents a def)+ gettxmap a i =+ let f ts = (addressXPubSpec i, ts)+ in f <$> lift (getAddressTxs a def)++getNewAddrs ::+ KeyIndex ->+ HashMap XPubSpec [XPubBal] ->+ [AddressXPub] ->+ [(Address, AddressXPub)]+getNewAddrs gap xpubs =+ concatMap $ \a ->+ case HashMap.lookup (addressXPubSpec a) xpubs of+ Nothing -> []+ Just bals -> addrsToAdd gap bals a++syncMempoolC ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) =>+ CacheX m ()+syncMempoolC = void . withLockForever $ do+ nodepool <- HashSet.fromList . map snd <$> lift getMempool+ cachepool <- HashSet.fromList . map snd <$> cacheGetMempool+ getem (HashSet.difference nodepool cachepool)+ getem (HashSet.difference cachepool nodepool)+ where+ getem tset = do+ let tids = HashSet.toList tset+ txs <- catMaybes <$> mapM (lift . getTxData) tids+ unless (null txs) $ do+ $(logDebugS) "Cache" $+ "Importing mempool transactions: " <> cs (show (length txs))+ importMultiTxC txs++cacheGetMempool :: MonadLoggerIO m => CacheX m [(UnixTime, TxHash)]+cacheGetMempool = runRedis redisGetMempool++cacheIsInMempool :: MonadLoggerIO m => TxHash -> CacheX m Bool+cacheIsInMempool = runRedis . redisIsInMempool++cacheGetHead :: MonadLoggerIO m => CacheX m (Maybe BlockHash)+cacheGetHead = runRedis redisGetHead++cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockHash -> CacheX m ()+cacheSetHead bh = do+ $(logDebugS) "Cache" $ "Cache head set to: " <> blockHashToHex bh+ void $ runRedis (redisSetHead bh)++cacheGetAddrsInfo ::+ MonadLoggerIO m => [Address] -> CacheX m [Maybe AddressXPub]+cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as)++redisAddToMempool :: (Applicative f, RedisCtx m f) => [TxRef] -> m (f Integer)+redisAddToMempool [] = return (pure 0)+redisAddToMempool btxs =+ zadd mempoolSetKey $+ map+ (\btx -> (blockRefScore (txRefBlock btx), encode (txRefHash btx)))+ btxs++redisIsInMempool :: (Applicative f, RedisCtx m f) => TxHash -> m (f Bool)+redisIsInMempool txid =+ fmap isJust <$> Redis.zrank mempoolSetKey (encode txid)++redisRemFromMempool ::+ (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer)+redisRemFromMempool [] = return (pure 0)+redisRemFromMempool xs = zrem mempoolSetKey $ map encode xs++redisSetAddrInfo ::+ (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ())+redisSetAddrInfo a i = void <$> Redis.set (addrPfx <> encode a) (encode i)++cacheDelXPubs ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ [XPubSpec] ->+ CacheT m Integer+cacheDelXPubs xpubs = ReaderT $ \case+ Just cache -> runReaderT (delXPubKeys xpubs) cache+ Nothing -> return 0++delXPubKeys ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ [XPubSpec] ->+ CacheX m Integer+delXPubKeys [] = return 0+delXPubKeys xpubs = do+ forM_ xpubs $ \x -> do+ xtxt <- xpubText x+ $(logDebugS) "Cache" $ "Deleting xpub: " <> xtxt+ xbals <-+ runRedis . fmap sequence . forM xpubs $ \xpub -> do+ bs <- redisGetXPubBalances xpub+ return $ (xpub,) <$> bs+ runRedis $ fmap sum . sequence <$> forM xbals (uncurry redisDelXPubKeys)++redisDelXPubKeys ::+ (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f Integer)+redisDelXPubKeys xpub bals = go (map (balanceAddress . xPubBal) bals)+ where+ go addrs = do+ addrcount <-+ case addrs of+ [] -> return (pure 0)+ _ -> Redis.del (map ((addrPfx <>) . encode) addrs)+ txsetcount <- Redis.del [txSetPfx <> encode xpub]+ utxocount <- Redis.del [utxoPfx <> encode xpub]+ balcount <- Redis.del [balancesPfx <> encode xpub]+ x <- Redis.zrem maxKey [encode xpub]+ return $ do+ _ <- x+ addrs' <- addrcount+ txset' <- txsetcount+ utxo' <- utxocount+ bal' <- balcount+ return $ addrs' + txset' + utxo' + bal'++redisAddXPubTxs ::+ (Applicative f, RedisCtx m f) => XPubSpec -> [TxRef] -> m (f Integer)+redisAddXPubTxs _ [] = return (pure 0)+redisAddXPubTxs xpub btxs =+ zadd (txSetPfx <> encode xpub) $+ map (\t -> (blockRefScore (txRefBlock t), encode (txRefHash t))) btxs++redisRemXPubTxs ::+ (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer)+redisRemXPubTxs _ [] = return (pure 0)+redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs)++redisAddXPubUnspents ::+ (Applicative f, RedisCtx m f) =>+ XPubSpec ->+ [(OutPoint, BlockRef)] ->+ m (f Integer)+redisAddXPubUnspents _ [] =+ return (pure 0)+redisAddXPubUnspents xpub utxo =+ zadd (utxoPfx <> encode xpub) $+ map (\(p, r) -> (blockRefScore r, encode p)) utxo++redisRemXPubUnspents ::+ (Applicative f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f Integer)+redisRemXPubUnspents _ [] =+ return (pure 0)+redisRemXPubUnspents xpub ops =+ zrem (utxoPfx <> encode xpub) (map encode ops)++redisAddXPubBalances ::+ (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ())+redisAddXPubBalances _ [] = return (pure ())+redisAddXPubBalances xpub bals = do+ xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries+ ys <- forM bals $ \b ->+ redisSetAddrInfo+ (balanceAddress (xPubBal b))+ AddressXPub+ { addressXPubSpec = xpub,+ addressXPubPath = xPubBalPath b+ }+ return $ sequence_ xs >> sequence_ ys+ where+ entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals++redisSetHead :: RedisCtx m f => BlockHash -> m (f Redis.Status)+redisSetHead bh = Redis.set bestBlockKey (encode bh)++redisGetAddrsInfo ::+ (Monad f, RedisCtx m f) => [Address] -> m (f [Maybe AddressXPub])+redisGetAddrsInfo [] = return (pure [])+redisGetAddrsInfo as = do+ is <- mapM (\a -> Redis.get (addrPfx <> encode a)) as+ return $ do+ is' <- sequence is+ return $ map (eitherToMaybe . decode =<<) is'++addrsToAdd :: KeyIndex -> [XPubBal] -> AddressXPub -> [(Address, AddressXPub)]+addrsToAdd gap xbals addrinfo+ | null fbals = []+ | otherwise = zipWith f addrs list+ where+ f a p = (a, AddressXPub {addressXPubSpec = xpub, addressXPubPath = p})+ dchain = head (addressXPubPath addrinfo)+ fbals = filter ((== dchain) . head . xPubBalPath) xbals+ maxidx = maximum (map (head . tail . xPubBalPath) fbals)+ xpub = addressXPubSpec addrinfo+ aidx = (head . tail) (addressXPubPath addrinfo)+ ixs =+ if gap > maxidx - aidx+ then [maxidx + 1 .. aidx + gap]+ else []+ paths = map (Deriv :/ dchain :/) ixs+ keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths+ list = map pathToList paths+ xpubf = xPubAddrFunction (xPubDeriveType xpub)+ addrs = map xpubf keys++sortTxData :: [TxData] -> [TxData]+sortTxData tds =+ let txm = Map.fromList (map (\d -> (txHash (txData d), d)) tds)+ ths = map (txHash . snd) (sortTxs (map txData tds))+ in mapMaybe (`Map.lookup` txm) ths++txInputs :: TxData -> [(Address, OutPoint)]+txInputs td =+ let is = txIn (txData td)+ ps = I.toAscList (txDataPrevs td)+ as = map (scriptToAddressBS . prevScript . snd) ps+ f (Right a) i = Just (a, prevOutput i)+ f (Left _) _ = Nothing+ in catMaybes (zipWith f as is)++txOutputs :: TxData -> [(Address, OutPoint)]+txOutputs td =+ let ps =+ zipWith+ ( \i _ ->+ OutPoint+ { outPointHash = txHash (txData td),+ outPointIndex = i+ }+ )+ [0 ..]+ (txOut (txData td))+ as = map (scriptToAddressBS . scriptOutput) (txOut (txData td))+ f (Right a) p = Just (a, p)+ f (Left _) _ = Nothing+ in catMaybes (zipWith f as ps)++redisGetHead :: (Functor f, RedisCtx m f) => m (f (Maybe BlockHash))+redisGetHead = do+ x <- Redis.get bestBlockKey+ return $ (eitherToMaybe . decode =<<) <$> x++redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [(UnixTime, TxHash)])+redisGetMempool = do+ xs <- getFromSortedSet mempoolSetKey Nothing 0 0+ return $ map (uncurry f) <$> xs+ where+ f t s = (memRefTime (scoreBlockRef s), t)++xpubText ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ XPubSpec ->+ CacheX m Text+xpubText xpub = do+ net <- lift getNetwork+ let suffix = case xPubDeriveType xpub of+ DeriveNormal -> ""+ DeriveP2SH -> "/p2sh"+ DeriveP2WPKH -> "/p2wpkh"+ return . cs $ suffix <> xPubExport net (xPubSpecKey xpub) cacheNewBlock :: MonadIO m => CacheWriter -> m () cacheNewBlock = send CacheNewBlock
src/Haskoin/Store/Common.hs view
@@ -7,8 +7,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.Common (- Limits (..),+module Haskoin.Store.Common+ ( Limits (..), Start (..), StoreReadBase (..), StoreReadExtra (..),@@ -39,10 +39,11 @@ streamThings, joinDescStreams, createDataMetrics,-) where+ )+where -import Conduit (- ConduitT,+import Conduit+ ( ConduitT, await, dropC, mapC,@@ -50,7 +51,7 @@ takeC, yield, ($$++),- )+ ) import Control.DeepSeq (NFData) import Control.Exception (Exception) import Control.Monad (forM)@@ -68,15 +69,15 @@ import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..)) import Data.Serialize (Serialize (..))-import Data.Time.Clock.System (- getSystemTime,+import Data.Time.Clock.System+ ( getSystemTime, systemNanoseconds, systemSeconds,- )+ ) import Data.Word (Word32, Word64) import GHC.Generics (Generic)-import Haskoin (- Address,+import Haskoin+ ( Address, BlockHash, BlockHeader (..), BlockHeight,@@ -98,10 +99,10 @@ mtp, pubSubKey, txHash,- )+ ) import Haskoin.Node (Chain, Peer)-import Haskoin.Store.Data (- Balance (..),+import Haskoin.Store.Data+ ( Balance (..), BlockData (..), DeriveType (..), Spender,@@ -117,7 +118,7 @@ nullBalance, toTransaction, zeroBalance,- )+ ) import qualified System.Metrics as Metrics import System.Metrics.Counter (Counter) import qualified System.Metrics.Counter as Counter@@ -126,95 +127,96 @@ type DeriveAddr = XPubKey -> KeyIndex -> Address type Offset = Word32+ type Limit = Word32 data Start- = AtTx {atTxHash :: !TxHash}- | AtBlock {atBlockHeight :: !BlockHeight}- deriving (Eq, Show)+ = AtTx {atTxHash :: !TxHash}+ | AtBlock {atBlockHeight :: !BlockHeight}+ deriving (Eq, Show) data Limits = Limits- { limit :: !Word32- , offset :: !Word32- , start :: !(Maybe Start)- }- deriving (Eq, Show)+ { limit :: !Word32,+ offset :: !Word32,+ start :: !(Maybe Start)+ }+ deriving (Eq, Show) defaultLimits :: Limits-defaultLimits = Limits{limit = 0, offset = 0, start = Nothing}+defaultLimits = Limits {limit = 0, offset = 0, start = Nothing} instance Default Limits where- def = defaultLimits+ def = defaultLimits class Monad m => StoreReadBase m where- getNetwork :: m Network- getBestBlock :: m (Maybe BlockHash)- getBlocksAtHeight :: BlockHeight -> m [BlockHash]- getBlock :: BlockHash -> m (Maybe BlockData)- getTxData :: TxHash -> m (Maybe TxData)- getSpender :: OutPoint -> m (Maybe Spender)- getBalance :: Address -> m (Maybe Balance)- getUnspent :: OutPoint -> m (Maybe Unspent)- getMempool :: m [(UnixTime, TxHash)]+ getNetwork :: m Network+ getBestBlock :: m (Maybe BlockHash)+ getBlocksAtHeight :: BlockHeight -> m [BlockHash]+ getBlock :: BlockHash -> m (Maybe BlockData)+ getTxData :: TxHash -> m (Maybe TxData)+ getSpender :: OutPoint -> m (Maybe Spender)+ getBalance :: Address -> m (Maybe Balance)+ getUnspent :: OutPoint -> m (Maybe Unspent)+ getMempool :: m [(UnixTime, TxHash)] class StoreReadBase m => StoreReadExtra m where- getAddressesTxs :: [Address] -> Limits -> m [TxRef]- getAddressesUnspents :: [Address] -> Limits -> m [Unspent]- getInitialGap :: m Word32- getMaxGap :: m Word32- getNumTxData :: Word64 -> m [TxData]- getBalances :: [Address] -> m [Balance]- getAddressTxs :: Address -> Limits -> m [TxRef]- getAddressUnspents :: Address -> Limits -> m [Unspent]- xPubBals :: XPubSpec -> m [XPubBal]- xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent]- xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> m [TxRef]- xPubTxCount :: XPubSpec -> [XPubBal] -> m Word32+ getAddressesTxs :: [Address] -> Limits -> m [TxRef]+ getAddressesUnspents :: [Address] -> Limits -> m [Unspent]+ getInitialGap :: m Word32+ getMaxGap :: m Word32+ getNumTxData :: Word64 -> m [TxData]+ getBalances :: [Address] -> m [Balance]+ getAddressTxs :: Address -> Limits -> m [TxRef]+ getAddressUnspents :: Address -> Limits -> m [Unspent]+ xPubBals :: XPubSpec -> m [XPubBal]+ xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent]+ xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> m [TxRef]+ xPubTxCount :: XPubSpec -> [XPubBal] -> m Word32 class StoreWrite m where- setBest :: BlockHash -> m ()- insertBlock :: BlockData -> m ()- setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m ()- insertTx :: TxData -> m ()- insertSpender :: OutPoint -> Spender -> m ()- deleteSpender :: OutPoint -> m ()- insertAddrTx :: Address -> TxRef -> m ()- deleteAddrTx :: Address -> TxRef -> m ()- insertAddrUnspent :: Address -> Unspent -> m ()- deleteAddrUnspent :: Address -> Unspent -> m ()- addToMempool :: TxHash -> UnixTime -> m ()- deleteFromMempool :: TxHash -> m ()- setBalance :: Balance -> m ()- insertUnspent :: Unspent -> m ()- deleteUnspent :: OutPoint -> m ()+ setBest :: BlockHash -> m ()+ insertBlock :: BlockData -> m ()+ setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m ()+ insertTx :: TxData -> m ()+ insertSpender :: OutPoint -> Spender -> m ()+ deleteSpender :: OutPoint -> m ()+ insertAddrTx :: Address -> TxRef -> m ()+ deleteAddrTx :: Address -> TxRef -> m ()+ insertAddrUnspent :: Address -> Unspent -> m ()+ deleteAddrUnspent :: Address -> Unspent -> m ()+ addToMempool :: TxHash -> UnixTime -> m ()+ deleteFromMempool :: TxHash -> m ()+ setBalance :: Balance -> m ()+ insertUnspent :: Unspent -> m ()+ deleteUnspent :: OutPoint -> m () getSpenders :: StoreReadBase m => TxHash -> m (IntMap Spender) getSpenders th =- getActiveTxData th >>= \case- Nothing -> return I.empty- Just td ->- I.fromList . catMaybes- <$> mapM get_spender [0 .. length (txOut (txData td)) - 1]+ getActiveTxData th >>= \case+ Nothing -> return I.empty+ Just td ->+ I.fromList . catMaybes+ <$> mapM get_spender [0 .. length (txOut (txData td)) - 1] where get_spender i = fmap (i,) <$> getSpender (OutPoint th (fromIntegral i)) getActiveBlock :: StoreReadExtra m => BlockHash -> m (Maybe BlockData) getActiveBlock bh =- getBlock bh >>= \case- Just b | blockDataMainChain b -> return (Just b)- _ -> return Nothing+ getBlock bh >>= \case+ Just b | blockDataMainChain b -> return (Just b)+ _ -> return Nothing getActiveTxData :: StoreReadBase m => TxHash -> m (Maybe TxData) getActiveTxData th =- getTxData th >>= \case- Just td | not (txDataDeleted td) -> return (Just td)- _ -> return Nothing+ getTxData th >>= \case+ Just td | not (txDataDeleted td) -> return (Just td)+ _ -> return Nothing getDefaultBalance :: StoreReadBase m => Address -> m Balance getDefaultBalance a =- getBalance a >>= \case- Nothing -> return $ zeroBalance a- Just b -> return b+ getBalance a >>= \case+ Nothing -> return $ zeroBalance a+ Just b -> return b deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)] deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]@@ -226,117 +228,117 @@ xPubSummary :: XPubSpec -> [XPubBal] -> XPubSummary xPubSummary _xspec xbals =- XPubSummary- { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)- , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)- , xPubSummaryReceived = rx- , xPubUnspentCount = uc- , xPubChangeIndex = ch- , xPubExternalIndex = ex- }+ XPubSummary+ { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs),+ xPubSummaryZero = sum (map (balanceZero . xPubBal) bs),+ xPubSummaryReceived = rx,+ xPubUnspentCount = uc,+ xPubChangeIndex = ch,+ xPubExternalIndex = ex+ } where bs = filter (not . nullBalance . xPubBal) xbals- ex = foldl max 0 [i | XPubBal{xPubBalPath = [0, i]} <- bs]- ch = foldl max 0 [i | XPubBal{xPubBalPath = [1, i]} <- bs]+ ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]+ ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs] uc = sum [balanceUnspentCount (xPubBal b) | b <- bs]- xt = [b | b@XPubBal{xPubBalPath = [0, _]} <- bs]+ xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs] rx = sum [balanceTotalReceived (xPubBal b) | b <- xt] getTransaction ::- (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction)+ (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction) getTransaction h = runMaybeT $ do- d <- MaybeT $ getTxData h- sm <- lift $ getSpenders h- return $ toTransaction d sm+ d <- MaybeT $ getTxData h+ sm <- lift $ getSpenders h+ return $ toTransaction d sm getNumTransaction ::- (Monad m, StoreReadExtra m) => Word64 -> m [Transaction]+ (Monad m, StoreReadExtra m) => Word64 -> m [Transaction] getNumTransaction i = do- ds <- getNumTxData i- forM ds $ \d -> do- sm <- getSpenders (txHash (txData d))- return $ toTransaction d sm+ ds <- getNumTxData i+ forM ds $ \d -> do+ sm <- getSpenders (txHash (txData d))+ return $ toTransaction d sm blockAtOrAfter ::- (MonadIO m, StoreReadExtra m) =>- Chain ->- UnixTime ->- m (Maybe BlockData)+ (MonadIO m, StoreReadExtra m) =>+ Chain ->+ UnixTime ->+ m (Maybe BlockData) blockAtOrAfter ch q = runMaybeT $ do- net <- lift getNetwork- x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch- MaybeT $ getBlock (headerHash (nodeHeader x))+ net <- lift getNetwork+ x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch+ MaybeT $ getBlock (headerHash (nodeHeader x)) where f x =- let t = fromIntegral (blockTimestamp (nodeHeader x))- in return $ t `compare` q+ let t = fromIntegral (blockTimestamp (nodeHeader x))+ in return $ t `compare` q blockAtOrBefore ::- (MonadIO m, StoreReadExtra m) =>- Chain ->- UnixTime ->- m (Maybe BlockData)+ (MonadIO m, StoreReadExtra m) =>+ Chain ->+ UnixTime ->+ m (Maybe BlockData) blockAtOrBefore ch q = runMaybeT $ do- net <- lift getNetwork- x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch- MaybeT $ getBlock (headerHash (nodeHeader x))+ net <- lift getNetwork+ x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch+ MaybeT $ getBlock (headerHash (nodeHeader x)) where f x =- let t = fromIntegral (blockTimestamp (nodeHeader x))- in return $ t `compare` q+ let t = fromIntegral (blockTimestamp (nodeHeader x))+ in return $ t `compare` q blockAtOrAfterMTP ::- (MonadIO m, StoreReadExtra m) =>- Chain ->- UnixTime ->- m (Maybe BlockData)+ (MonadIO m, StoreReadExtra m) =>+ Chain ->+ UnixTime ->+ m (Maybe BlockData) blockAtOrAfterMTP ch q = runMaybeT $ do- net <- lift getNetwork- x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch- MaybeT $ getBlock (headerHash (nodeHeader x))+ net <- lift getNetwork+ x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch+ MaybeT $ getBlock (headerHash (nodeHeader x)) where f x = do- t <- fromIntegral <$> mtp x- return $ t `compare` q+ t <- fromIntegral <$> mtp x+ return $ t `compare` q -- | Events that the store can generate. data StoreEvent- = StoreBestBlock !BlockHash- | StoreMempoolNew !TxHash- | StoreMempoolDelete !TxHash- | StorePeerConnected !Peer- | StorePeerDisconnected !Peer- | StorePeerPong !Peer !Word64- | StoreTxAnnounce !Peer ![TxHash]- | StoreTxReject !Peer !TxHash !RejectCode !ByteString+ = StoreBestBlock !BlockHash+ | StoreMempoolNew !TxHash+ | StoreMempoolDelete !TxHash+ | StorePeerConnected !Peer+ | StorePeerDisconnected !Peer+ | StorePeerPong !Peer !Word64+ | StoreTxAnnounce !Peer ![TxHash]+ | StoreTxReject !Peer !TxHash !RejectCode !ByteString data PubExcept- = PubNoPeers- | PubReject RejectCode- | PubTimeout- | PubPeerDisconnected- deriving (Eq, NFData, Generic, Serialize)+ = PubNoPeers+ | PubReject RejectCode+ | PubTimeout+ | PubPeerDisconnected+ deriving (Eq, NFData, Generic, Serialize) instance Show PubExcept where- show PubNoPeers = "no peers"- show (PubReject c) =- "rejected: "- <> case c of- RejectMalformed -> "malformed"- RejectInvalid -> "invalid"- RejectObsolete -> "obsolete"- RejectDuplicate -> "duplicate"- RejectNonStandard -> "not standard"- RejectDust -> "dust"- RejectInsufficientFee -> "insufficient fee"- RejectCheckpoint -> "checkpoint"- show PubTimeout = "peer timeout or silent rejection"- show PubPeerDisconnected = "peer disconnected"+ show PubNoPeers = "no peers"+ show (PubReject c) =+ "rejected: "+ <> case c of+ RejectMalformed -> "malformed"+ RejectInvalid -> "invalid"+ RejectObsolete -> "obsolete"+ RejectDuplicate -> "duplicate"+ RejectNonStandard -> "not standard"+ RejectDust -> "dust"+ RejectInsufficientFee -> "insufficient fee"+ RejectCheckpoint -> "checkpoint"+ show PubTimeout = "peer timeout or silent rejection"+ show PubPeerDisconnected = "peer disconnected" instance Exception PubExcept applyLimits :: Limits -> [a] -> [a]-applyLimits Limits{..} = applyLimit limit . applyOffset offset+applyLimits Limits {..} = applyLimit limit . applyOffset offset applyOffset :: Offset -> [a] -> [a] applyOffset = drop . fromIntegral@@ -347,11 +349,11 @@ deOffset :: Limits -> Limits deOffset l = case limit l of- 0 -> l{offset = 0}- _ -> l{limit = limit l + offset l, offset = 0}+ 0 -> l {offset = 0}+ _ -> l {limit = limit l + offset l, offset = 0} applyLimitsC :: Monad m => Limits -> ConduitT i i m ()-applyLimitsC Limits{..} = applyOffsetC offset >> applyLimitC limit+applyLimitsC Limits {..} = applyOffsetC offset >> applyLimitC limit applyOffsetC :: Monad m => Offset -> ConduitT i i m () applyOffsetC = dropC . fromIntegral@@ -367,97 +369,97 @@ go [] _ [] = [] go orphans ths [] = go [] ths orphans go orphans ths ((i, tx) : xs) =- let ops = map (outPointHash . prevOutput) (txIn tx)- orp = any (`H.member` ths) ops- in if orp- then go ((i, tx) : orphans) ths xs- else (i, tx) : go orphans (txHash tx `H.delete` ths) xs+ let ops = map (outPointHash . prevOutput) (txIn tx)+ orp = any (`H.member` ths) ops+ in if orp+ then go ((i, tx) : orphans) ths xs+ else (i, tx) : go orphans (txHash tx `H.delete` ths) xs nub' :: (Eq a, Hashable a) => [a] -> [a] nub' = H.toList . H.fromList microseconds :: MonadIO m => m Integer microseconds =- let f t =- toInteger (systemSeconds t) * 1000000- + toInteger (systemNanoseconds t) `div` 1000- in liftIO $ f <$> getSystemTime+ let f t =+ toInteger (systemSeconds t) * 1000000+ + toInteger (systemNanoseconds t) `div` 1000+ in liftIO $ f <$> getSystemTime streamThings ::- Monad m =>- (Limits -> m [a]) ->- Maybe (a -> TxHash) ->- Limits ->- ConduitT () a m ()+ Monad m =>+ (Limits -> m [a]) ->+ Maybe (a -> TxHash) ->+ Limits ->+ ConduitT () a m () streamThings getit gettx limits =- lift (getit limits) >>= \case- [] -> return ()- ls -> mapM_ yield ls >> go limits (last ls)+ lift (getit limits) >>= \case+ [] -> return ()+ ls -> mapM_ yield ls >> go limits (last ls) where h l x = case gettx of- Just g -> Just l{offset = 1, start = Just (AtTx (g x))}- Nothing -> case limit l of- 0 -> Nothing- _ -> Just l{offset = offset l + limit l}+ Just g -> Just l {offset = 1, start = Just (AtTx (g x))}+ Nothing -> case limit l of+ 0 -> Nothing+ _ -> Just l {offset = offset l + limit l} go l x = case h l x of- Nothing -> return ()- Just l' ->- lift (getit l') >>= \case- [] -> return ()- ls -> mapM_ yield ls >> go l' (last ls)+ Nothing -> return ()+ Just l' ->+ lift (getit l') >>= \case+ [] -> return ()+ ls -> mapM_ yield ls >> go l' (last ls) joinDescStreams ::- (Monad m, Ord a) =>- [ConduitT () a m ()] ->- ConduitT () a m ()+ (Monad m, Ord a) =>+ [ConduitT () a m ()] ->+ ConduitT () a m () joinDescStreams xs = do- let ss = map sealConduitT xs- go Nothing =<< g ss+ let ss = map sealConduitT xs+ go Nothing =<< g ss where j (x, y) = (,[x]) <$> y g ss =- let l = mapMaybe j <$> lift (traverse ($$++ await) ss)- in Map.fromListWith (++) <$> l+ let l = mapMaybe j <$> lift (traverse ($$++ await) ss)+ in Map.fromListWith (++) <$> l go m mp = case Map.lookupMax mp of- Nothing -> return ()- Just (x, ss) -> do- case m of- Nothing -> yield x- Just x'- | x == x' -> return ()- | otherwise -> yield x- mp1 <- g ss- let mp2 = Map.deleteMax mp- mp' = Map.unionWith (++) mp1 mp2- go (Just x) mp'+ Nothing -> return ()+ Just (x, ss) -> do+ case m of+ Nothing -> yield x+ Just x'+ | x == x' -> return ()+ | otherwise -> yield x+ mp1 <- g ss+ let mp2 = Map.deleteMax mp+ mp' = Map.unionWith (++) mp1 mp2+ go (Just x) mp' data DataMetrics = DataMetrics- { dataBestCount :: !Counter- , dataBlockCount :: !Counter- , dataTxCount :: !Counter- , dataSpenderCount :: !Counter- , dataMempoolCount :: !Counter- , dataBalanceCount :: !Counter- , dataUnspentCount :: !Counter- , dataAddrTxCount :: !Counter- , dataXPubBals :: !Counter- , dataXPubUnspents :: !Counter- , dataXPubTxs :: !Counter- , dataXPubTxCount :: !Counter- }+ { dataBestCount :: !Counter,+ dataBlockCount :: !Counter,+ dataTxCount :: !Counter,+ dataSpenderCount :: !Counter,+ dataMempoolCount :: !Counter,+ dataBalanceCount :: !Counter,+ dataUnspentCount :: !Counter,+ dataAddrTxCount :: !Counter,+ dataXPubBals :: !Counter,+ dataXPubUnspents :: !Counter,+ dataXPubTxs :: !Counter,+ dataXPubTxCount :: !Counter+ } createDataMetrics :: MonadIO m => Metrics.Store -> m DataMetrics createDataMetrics s = liftIO $ do- dataBestCount <- Metrics.createCounter "data.best_block" s- dataBlockCount <- Metrics.createCounter "data.blocks" s- dataTxCount <- Metrics.createCounter "data.txs" s- dataSpenderCount <- Metrics.createCounter "data.spenders" s- dataMempoolCount <- Metrics.createCounter "data.mempool" s- dataBalanceCount <- Metrics.createCounter "data.balances" s- dataUnspentCount <- Metrics.createCounter "data.unspents" s- dataAddrTxCount <- Metrics.createCounter "data.address_txs" s- dataXPubBals <- Metrics.createCounter "data.xpub_balances" s- dataXPubUnspents <- Metrics.createCounter "data.xpub_unspents" s- dataXPubTxs <- Metrics.createCounter "data.xpub_txs" s- dataXPubTxCount <- Metrics.createCounter "data.xpub_tx_count" s- return DataMetrics{..}+ dataBestCount <- Metrics.createCounter "data.best_block" s+ dataBlockCount <- Metrics.createCounter "data.blocks" s+ dataTxCount <- Metrics.createCounter "data.txs" s+ dataSpenderCount <- Metrics.createCounter "data.spenders" s+ dataMempoolCount <- Metrics.createCounter "data.mempool" s+ dataBalanceCount <- Metrics.createCounter "data.balances" s+ dataUnspentCount <- Metrics.createCounter "data.unspents" s+ dataAddrTxCount <- Metrics.createCounter "data.address_txs" s+ dataXPubBals <- Metrics.createCounter "data.xpub_balances" s+ dataXPubUnspents <- Metrics.createCounter "data.xpub_unspents" s+ dataXPubTxs <- Metrics.createCounter "data.xpub_txs" s+ dataXPubTxCount <- Metrics.createCounter "data.xpub_tx_count" s+ return DataMetrics {..}
src/Haskoin/Store/Database/Reader.hs view
@@ -4,8 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Haskoin.Store.Database.Reader (- -- * RocksDB Database Access+module Haskoin.Store.Database.Reader+ ( -- * RocksDB Database Access DatabaseReader (..), DatabaseReaderT, withDatabaseReader,@@ -17,17 +17,20 @@ blockCF, heightCF, balanceCF,-) where+ )+where -import Conduit (- ConduitT,+import Conduit+ ( ConduitT,+ dropC, dropWhileC, lift, mapC, runConduit, sinkList,+ takeC, (.|),- )+ ) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) import Data.Bits ((.&.))@@ -39,24 +42,24 @@ import Data.Ord (Down (..)) import Data.Serialize (encode) import Data.Word (Word32, Word64)-import Database.RocksDB (- ColumnFamily,+import Database.RocksDB+ ( ColumnFamily, Config (..), DB (..), Iterator, withDBCF, withIterCF,- )-import Database.RocksDB.Query (- insert,+ )+import Database.RocksDB.Query+ ( insert, matching, matchingAsListCF, matchingSkip, retrieve, retrieveCF,- )-import Haskoin (- Address,+ )+import Haskoin+ ( Address, BlockHash, BlockHeight, Network,@@ -64,7 +67,7 @@ TxHash, pubSubKey, txHash,- )+ ) import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types@@ -76,61 +79,61 @@ type DatabaseReaderT = ReaderT DatabaseReader data DatabaseReader = DatabaseReader- { databaseHandle :: !DB- , databaseMaxGap :: !Word32- , databaseInitialGap :: !Word32- , databaseNetwork :: !Network- , databaseMetrics :: !(Maybe DataMetrics)- }+ { databaseHandle :: !DB,+ databaseMaxGap :: !Word32,+ databaseInitialGap :: !Word32,+ databaseNetwork :: !Network,+ databaseMetrics :: !(Maybe DataMetrics)+ } incrementCounter ::- MonadIO m =>- (DataMetrics -> Counter) ->- Int ->- ReaderT DatabaseReader m ()+ MonadIO m =>+ (DataMetrics -> Counter) ->+ Int ->+ ReaderT DatabaseReader m () incrementCounter f i =- asks databaseMetrics >>= \case- Just s -> liftIO $ Counter.add (f s) (fromIntegral i)- Nothing -> return ()+ asks databaseMetrics >>= \case+ Just s -> liftIO $ Counter.add (f s) (fromIntegral i)+ Nothing -> return () dataVersion :: Word32 dataVersion = 17 withDatabaseReader ::- MonadUnliftIO m =>- Network ->- Word32 ->- Word32 ->- FilePath ->- Maybe DataMetrics ->- DatabaseReaderT m a ->- m a+ MonadUnliftIO m =>+ Network ->+ Word32 ->+ Word32 ->+ FilePath ->+ Maybe DataMetrics ->+ DatabaseReaderT m a ->+ m a withDatabaseReader net igap gap dir stats f =- withDBCF dir cfg columnFamilyConfig $ \db -> do- let bdb =- DatabaseReader- { databaseHandle = db- , databaseMaxGap = gap- , databaseNetwork = net- , databaseInitialGap = igap- , databaseMetrics = stats- }- initRocksDB bdb- runReaderT f bdb+ withDBCF dir cfg columnFamilyConfig $ \db -> do+ let bdb =+ DatabaseReader+ { databaseHandle = db,+ databaseMaxGap = gap,+ databaseNetwork = net,+ databaseInitialGap = igap,+ databaseMetrics = stats+ }+ initRocksDB bdb+ runReaderT f bdb where- cfg = def{createIfMissing = True, maxFiles = Just (-1)}+ cfg = def {createIfMissing = True, maxFiles = Just (-1)} columnFamilyConfig :: [(String, Config)] columnFamilyConfig =- [ ("addr-tx", def{prefixLength = Just 22, bloomFilter = True})- , ("addr-out", def{prefixLength = Just 22, bloomFilter = True})- , ("tx", def{prefixLength = Just 33, bloomFilter = True})- , ("spender", def{prefixLength = Just 33, bloomFilter = True})- , ("unspent", def{prefixLength = Just 37, bloomFilter = True})- , ("block", def{prefixLength = Just 33, bloomFilter = True})- , ("height", def{prefixLength = Nothing, bloomFilter = True})- , ("balance", def{prefixLength = Just 22, bloomFilter = True})- ]+ [ ("addr-tx", def {prefixLength = Just 22, bloomFilter = True}),+ ("addr-out", def {prefixLength = Just 22, bloomFilter = True}),+ ("tx", def {prefixLength = Just 33, bloomFilter = True}),+ ("spender", def {prefixLength = Just 33, bloomFilter = True}),+ ("unspent", def {prefixLength = Just 37, bloomFilter = True}),+ ("block", def {prefixLength = Just 33, bloomFilter = True}),+ ("height", def {prefixLength = Nothing, bloomFilter = True}),+ ("balance", def {prefixLength = Just 22, bloomFilter = True})+ ] addrTxCF :: DB -> ColumnFamily addrTxCF = head . columnFamilies@@ -157,282 +160,276 @@ balanceCF db = columnFamilies db !! 7 initRocksDB :: MonadIO m => DatabaseReader -> m ()-initRocksDB DatabaseReader{databaseHandle = db} = do- e <-- runExceptT $- retrieve db VersionKey >>= \case- Just v- | v == dataVersion -> return ()- | otherwise -> throwError "Incorrect RocksDB database version"- Nothing -> setInitRocksDB db- case e of- Left s -> error s- Right () -> return ()+initRocksDB DatabaseReader {databaseHandle = db} = do+ e <-+ runExceptT $+ retrieve db VersionKey >>= \case+ Just v+ | v == dataVersion -> return ()+ | otherwise -> throwError "Incorrect RocksDB database version"+ Nothing -> setInitRocksDB db+ case e of+ Left s -> error s+ Right () -> return () setInitRocksDB :: MonadIO m => DB -> m () setInitRocksDB db = insert db VersionKey dataVersion addressConduit ::- MonadUnliftIO m =>- Address ->- Maybe Start ->- Iterator ->- ConduitT i TxRef (DatabaseReaderT m) ()+ MonadUnliftIO m =>+ Address ->+ Maybe Start ->+ Iterator ->+ ConduitT i TxRef (DatabaseReaderT m) () addressConduit a s it =- x .| mapC (uncurry f)+ x .| mapC (uncurry f) where f (AddrTxKey _ t) () = t f _ _ = undefined x = case s of- Nothing ->- matching it (AddrTxKeyA a)- Just (AtBlock bh) ->- matchingSkip- it- (AddrTxKeyA a)- (AddrTxKeyB a (BlockRef bh maxBound))- Just (AtTx txh) ->- lift (getTxData txh) >>= \case- Just TxData{txDataBlock = b@BlockRef{}} ->- matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b)- Just TxData{txDataBlock = MemRef{}} ->- let cond (AddrTxKey _a (TxRef MemRef{} th)) =- th /= txh- cond (AddrTxKey _a (TxRef BlockRef{} _th)) =- False- in matching it (AddrTxKeyA a)- .| (dropWhileC (cond . fst) >> mapC id)- Nothing -> return ()+ Nothing ->+ matching it (AddrTxKeyA a)+ Just (AtBlock bh) ->+ matchingSkip+ it+ (AddrTxKeyA a)+ (AddrTxKeyB a (BlockRef bh maxBound))+ Just (AtTx txh) ->+ lift (getTxData txh) >>= \case+ Just TxData {txDataBlock = b@BlockRef {}} ->+ matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b)+ Just TxData {txDataBlock = MemRef {}} ->+ let cond (AddrTxKey _a (TxRef MemRef {} th)) =+ th /= txh+ cond (AddrTxKey _a (TxRef BlockRef {} _th)) =+ False+ in matching it (AddrTxKeyA a)+ .| (dropWhileC (cond . fst) >> mapC id)+ Nothing -> return () unspentConduit ::- MonadUnliftIO m =>- Address ->- Maybe Start ->- Iterator ->- ConduitT i Unspent (DatabaseReaderT m) ()+ MonadUnliftIO m =>+ Address ->+ Maybe Start ->+ Iterator ->+ ConduitT i Unspent (DatabaseReaderT m) () unspentConduit a s it =- x .| mapC (uncurry toUnspent)+ x .| mapC (uncurry toUnspent) where x = case s of- Nothing ->- matching it (AddrOutKeyA a)- Just (AtBlock h) ->- matchingSkip- it- (AddrOutKeyA a)- (AddrOutKeyB a (BlockRef h maxBound))- Just (AtTx txh) ->- lift (getTxData txh) >>= \case- Just TxData{txDataBlock = b@BlockRef{}} ->- matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)- Just TxData{txDataBlock = MemRef{}} ->- let cond (AddrOutKey _a MemRef{} p) =- outPointHash p /= txh- cond (AddrOutKey _a BlockRef{} _p) =- False- in matching it (AddrOutKeyA a)- .| (dropWhileC (cond . fst) >> mapC id)- Nothing -> return ()+ Nothing ->+ matching it (AddrOutKeyA a)+ Just (AtBlock h) ->+ matchingSkip+ it+ (AddrOutKeyA a)+ (AddrOutKeyB a (BlockRef h maxBound))+ Just (AtTx txh) ->+ lift (getTxData txh) >>= \case+ Just TxData {txDataBlock = b@BlockRef {}} ->+ matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)+ Just TxData {txDataBlock = MemRef {}} ->+ let cond (AddrOutKey _a MemRef {} p) =+ outPointHash p /= txh+ cond (AddrOutKey _a BlockRef {} _p) =+ False+ in matching it (AddrOutKeyA a)+ .| (dropWhileC (cond . fst) >> mapC id)+ Nothing -> return () +withManyIters ::+ MonadUnliftIO m =>+ DB ->+ ColumnFamily ->+ Int ->+ ([Iterator] -> m a) ->+ m a+withManyIters db cf i f = go [] i+ where+ go acc 0 = f acc+ go acc n = withIterCF db cf $ \it -> go (it : acc) (n - 1)++joinConduits ::+ (Monad m, Ord o) =>+ [ConduitT () o m ()] ->+ Limits ->+ m [o]+joinConduits cs l =+ runConduit $ joinDescStreams cs .| applyLimitsC l .| sinkList+ instance MonadIO m => StoreReadBase (DatabaseReaderT m) where- getNetwork = asks databaseNetwork+ getNetwork = asks databaseNetwork - getTxData th = do- db <- asks databaseHandle- retrieveCF db (txCF db) (TxKey th) >>= \case- Nothing -> return Nothing- Just t -> do- incrementCounter dataTxCount 1- return (Just t)+ getTxData th = do+ db <- asks databaseHandle+ retrieveCF db (txCF db) (TxKey th) >>= \case+ Nothing -> return Nothing+ Just t -> do+ incrementCounter dataTxCount 1+ return (Just t) - getSpender op = do- db <- asks databaseHandle- retrieveCF db (spenderCF db) (SpenderKey op) >>= \case- Nothing -> return Nothing- Just s -> do- incrementCounter dataSpenderCount 1- return (Just s)+ getSpender op = do+ db <- asks databaseHandle+ retrieveCF db (spenderCF db) (SpenderKey op) >>= \case+ Nothing -> return Nothing+ Just s -> do+ incrementCounter dataSpenderCount 1+ return (Just s) - getUnspent p = do- db <- asks databaseHandle- fmap (valToUnspent p) <$> retrieveCF db (unspentCF db) (UnspentKey p) >>= \case- Nothing -> return Nothing- Just u -> do- incrementCounter dataUnspentCount 1- return (Just u)+ getUnspent p = do+ db <- asks databaseHandle+ val <- retrieveCF db (unspentCF db) (UnspentKey p)+ case fmap (valToUnspent p) val of+ Nothing -> return Nothing+ Just u -> do+ incrementCounter dataUnspentCount 1+ return (Just u) - getBalance a = do- db <- asks databaseHandle- incrementCounter dataBalanceCount 1- fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a)+ getBalance a = do+ db <- asks databaseHandle+ incrementCounter dataBalanceCount 1+ fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) - getMempool = do- db <- asks databaseHandle- incrementCounter dataMempoolCount 1- fromMaybe [] <$> retrieve db MemKey+ getMempool = do+ db <- asks databaseHandle+ incrementCounter dataMempoolCount 1+ fromMaybe [] <$> retrieve db MemKey - getBestBlock = do- incrementCounter dataBestCount 1- asks databaseHandle >>= (`retrieve` BestKey)+ getBestBlock = do+ incrementCounter dataBestCount 1+ asks databaseHandle >>= (`retrieve` BestKey) - getBlocksAtHeight h = do- db <- asks databaseHandle- retrieveCF db (heightCF db) (HeightKey h) >>= \case- Nothing -> return []- Just ls -> do- incrementCounter dataBlockCount (length ls)- return ls+ getBlocksAtHeight h = do+ db <- asks databaseHandle+ retrieveCF db (heightCF db) (HeightKey h) >>= \case+ Nothing -> return []+ Just ls -> do+ incrementCounter dataBlockCount (length ls)+ return ls - getBlock h = do- db <- asks databaseHandle- retrieveCF db (blockCF db) (BlockKey h) >>= \case- Nothing -> return Nothing- Just b -> do- incrementCounter dataBlockCount 1- return (Just b)+ getBlock h = do+ db <- asks databaseHandle+ retrieveCF db (blockCF db) (BlockKey h) >>= \case+ Nothing -> return Nothing+ Just b -> do+ incrementCounter dataBlockCount 1+ return (Just b) instance MonadUnliftIO m => StoreReadExtra (DatabaseReaderT m) where- getAddressesTxs addrs limits = do- txs <- applyLimits limits . sortOn Down . concat <$> mapM f addrs- incrementCounter dataAddrTxCount (length txs)- return txs- where- l = deOffset limits- f a = do- db <- asks databaseHandle- withIterCF db (addrTxCF db) $ \it ->- runConduit $- addressConduit a (start l) it- .| applyLimitC (limit l)- .| sinkList+ getAddressesTxs addrs limits = do+ db <- asks databaseHandle+ withManyIters db (addrTxCF db) (length addrs) $ \its -> do+ txs <- joinConduits (cs its) limits+ incrementCounter dataAddrTxCount (length txs)+ return txs+ where+ cs = map (uncurry c) . zip addrs+ c a = addressConduit a (start limits) - getAddressesUnspents addrs limits = do- us <- applyLimits limits . sortOn Down . concat <$> mapM f addrs- incrementCounter dataUnspentCount (length us)- return us- where- l = deOffset limits- f a = do- db <- asks databaseHandle- withIterCF db (addrOutCF db) $ \it ->- runConduit $- unspentConduit a (start l) it- .| applyLimitC (limit l)- .| sinkList+ getAddressesUnspents addrs limits = do+ db <- asks databaseHandle+ withManyIters db (addrOutCF db) (length addrs) $ \its -> do+ uns <- joinConduits (cs its) limits+ incrementCounter dataUnspentCount (length uns)+ return uns+ where+ cs = map (uncurry c) . zip addrs+ c a = unspentConduit a (start limits) - getAddressUnspents a limits = do- db <- asks databaseHandle- us <- withIterCF db (addrOutCF db) $ \it ->- runConduit $- x it .| applyLimitsC limits .| mapC (uncurry toUnspent) .| sinkList- incrementCounter dataUnspentCount (length us)- return us- where- x it = case start limits of- Nothing ->- matching it (AddrOutKeyA a)- Just (AtBlock h) ->- matchingSkip- it- (AddrOutKeyA a)- (AddrOutKeyB a (BlockRef h maxBound))- Just (AtTx txh) ->- lift (getTxData txh) >>= \case- Just TxData{txDataBlock = b@BlockRef{}} ->- matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)- Just TxData{txDataBlock = MemRef{}} ->- let cond (AddrOutKey _a MemRef{} p) =- outPointHash p /= txh- cond (AddrOutKey _a BlockRef{} _p) =- False- in matching it (AddrOutKeyA a)- .| (dropWhileC (cond . fst) >> mapC id)- _ -> matching it (AddrOutKeyA a)+ getAddressUnspents a limits = do+ db <- asks databaseHandle+ us <- withIterCF db (addrOutCF db) $ \it ->+ runConduit $+ unspentConduit a (start limits) it+ .| applyLimitsC limits+ .| sinkList+ incrementCounter dataUnspentCount (length us)+ return us - getAddressTxs a limits = do- db <- asks databaseHandle- txs <- withIterCF db (addrTxCF db) $ \it ->- runConduit $- addressConduit a (start limits) it- .| applyLimitsC limits- .| sinkList- incrementCounter dataAddrTxCount (length txs)- return txs+ getAddressTxs a limits = do+ db <- asks databaseHandle+ txs <- withIterCF db (addrTxCF db) $ \it ->+ runConduit $+ addressConduit a (start limits) it+ .| applyLimitsC limits+ .| sinkList+ incrementCounter dataAddrTxCount (length txs)+ return txs - getMaxGap = asks databaseMaxGap+ getMaxGap = asks databaseMaxGap - getInitialGap = asks databaseInitialGap+ getInitialGap = asks databaseInitialGap - getNumTxData i = do- db <- asks databaseHandle- let (sk, w) = decodeTxKey i- ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk)- let f t =- let bs = encode $ txHash (txData t)- b = BS.head (BS.drop 6 bs)- w' = b .&. 0xf8- in w == w'- txs = filter f $ map snd ls- incrementCounter dataTxCount (length txs)- return txs+ getNumTxData i = do+ db <- asks databaseHandle+ let (sk, w) = decodeTxKey i+ ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk)+ let f t =+ let bs = encode $ txHash (txData t)+ b = BS.head (BS.drop 6 bs)+ w' = b .&. 0xf8+ in w == w'+ txs = filter f $ map snd ls+ incrementCounter dataTxCount (length txs)+ return txs - getBalances as = do- zipWith f as <$> mapM getBalance as- where- f a Nothing = zeroBalance a- f _ (Just b) = b+ getBalances as = do+ zipWith f as <$> mapM getBalance as+ where+ f a Nothing = zeroBalance a+ f _ (Just b) = b - xPubBals xpub = do- igap <- getInitialGap- gap <- getMaxGap- ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0))- if all (nullBalance . xPubBal) ext1- then do- incrementCounter dataXPubBals (length ext1)- return ext1- else do- ext2 <- derive_until_gap gap 0 (aderiv 0 igap)- chg <- derive_until_gap gap 1 (aderiv 1 0)- let bals = ext1 <> ext2 <> chg- incrementCounter dataXPubBals (length bals)- return bals- where- aderiv m =- deriveAddresses- (deriveFunction (xPubDeriveType xpub))- (pubSubKey (xPubSpecKey xpub) m)- xbalance m b n = XPubBal{xPubBalPath = [m, n], xPubBal = b}- derive_until_gap _ _ [] = return []- derive_until_gap gap m as = do- let (as1, as2) = splitAt (fromIntegral gap) as- bs <- getBalances (map snd as1)- let xbs = zipWith (xbalance m) bs (map fst as1)- if all nullBalance bs- then return xbs- else (xbs <>) <$> derive_until_gap gap m as2+ xPubBals xpub = do+ igap <- getInitialGap+ gap <- getMaxGap+ ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0))+ if all (nullBalance . xPubBal) ext1+ then do+ incrementCounter dataXPubBals (length ext1)+ return ext1+ else do+ ext2 <- derive_until_gap gap 0 (aderiv 0 igap)+ chg <- derive_until_gap gap 1 (aderiv 1 0)+ let bals = ext1 <> ext2 <> chg+ incrementCounter dataXPubBals (length bals)+ return bals+ where+ aderiv m =+ deriveAddresses+ (deriveFunction (xPubDeriveType xpub))+ (pubSubKey (xPubSpecKey xpub) m)+ xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+ derive_until_gap _ _ [] = return []+ derive_until_gap gap m as = do+ let (as1, as2) = splitAt (fromIntegral gap) as+ bs <- getBalances (map snd as1)+ let xbs = zipWith (xbalance m) bs (map fst as1)+ if all nullBalance bs+ then return xbs+ else (xbs <>) <$> derive_until_gap gap m as2 - xPubUnspents _xspec xbals limits = do- us <- concat <$> mapM h cs- incrementCounter dataXPubUnspents (length us)- return . applyLimits limits $ sortOn Down us- where- l = deOffset limits- cs = filter ((> 0) . balanceUnspentCount . xPubBal) xbals- i b = do- us <- getAddressUnspents (balanceAddress (xPubBal b)) l- return us- f b t = XPubUnspent{xPubUnspentPath = xPubBalPath b, xPubUnspent = t}- h b = map (f b) <$> i b+ xPubUnspents _xspec xbals limits = do+ us <- concat <$> mapM h cs+ incrementCounter dataXPubUnspents (length us)+ return . applyLimits limits $ sortOn Down us+ where+ l = deOffset limits+ cs = filter ((> 0) . balanceUnspentCount . xPubBal) xbals+ i b = do+ us <- getAddressUnspents (balanceAddress (xPubBal b)) l+ return us+ f b t = XPubUnspent {xPubUnspentPath = xPubBalPath b, xPubUnspent = t}+ h b = map (f b) <$> i b - xPubTxs _xspec xbals limits = do- let as =- map balanceAddress $- filter (not . nullBalance) $- map xPubBal xbals- txs <- getAddressesTxs as limits- incrementCounter dataXPubTxs (length txs)- return txs+ xPubTxs _xspec xbals limits = do+ let as =+ map balanceAddress $+ filter (not . nullBalance) $+ map xPubBal xbals+ txs <- getAddressesTxs as limits+ incrementCounter dataXPubTxs (length txs)+ return txs - xPubTxCount xspec xbals = do- incrementCounter dataXPubTxCount 1- fromIntegral . length <$> xPubTxs xspec xbals def+ xPubTxCount xspec xbals = do+ incrementCounter dataXPubTxCount 1+ fromIntegral . length <$> xPubTxs xspec xbals def
src/Haskoin/Store/Database/Types.hs view
@@ -3,8 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Haskoin.Store.Database.Types (- AddrTxKey (..),+module Haskoin.Store.Database.Types+ ( AddrTxKey (..), AddrOutKey (..), BestKey (..), BlockKey (..),@@ -24,25 +24,26 @@ unspentToVal, valToUnspent, OutVal (..),-) where+ )+where import Control.DeepSeq (NFData) import Control.Monad (guard)-import Data.Bits (- Bits,+import Data.Bits+ ( Bits, shift, shiftL, shiftR, (.&.), (.|.),- )+ ) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Default (Default (..)) import Data.Either (fromRight) import Data.Hashable (Hashable)-import Data.Serialize (- Serialize (..),+import Data.Serialize+ ( Serialize (..), decode, encode, getBytes,@@ -54,21 +55,21 @@ putWord8, runGet, runPut,- )+ ) import Data.Word (Word16, Word32, Word64, Word8) import Database.RocksDB.Query (Key, KeyValue) import GHC.Generics (Generic)-import Haskoin (- Address,+import Haskoin+ ( Address, BlockHash, BlockHeight, OutPoint (..), TxHash, eitherToMaybe, scriptToAddressBS,- )-import Haskoin.Store.Data (- Balance (..),+ )+import Haskoin.Store.Data+ ( Balance (..), BlockData, BlockRef, Spender,@@ -76,393 +77,403 @@ TxRef (..), UnixTime, Unspent (..),- )+ ) -- | Database key for an address transaction. data AddrTxKey- = -- | key for a transaction affecting an address- AddrTxKey- { addrTxKeyA :: !Address- , addrTxKeyT :: !TxRef- }- | -- | short key that matches all entries- AddrTxKeyA {addrTxKeyA :: !Address}- | AddrTxKeyB- { addrTxKeyA :: !Address- , addrTxKeyB :: !BlockRef- }- | AddrTxKeyS- deriving (Show, Eq, Ord, Generic, Hashable)+ = -- | key for a transaction affecting an address+ AddrTxKey+ { addrTxKeyA :: !Address,+ addrTxKeyT :: !TxRef+ }+ | -- | short key that matches all entries+ AddrTxKeyA {addrTxKeyA :: !Address}+ | AddrTxKeyB+ { addrTxKeyA :: !Address,+ addrTxKeyB :: !BlockRef+ }+ | AddrTxKeyS+ deriving (Show, Eq, Ord, Generic, Hashable) instance Serialize AddrTxKey where- -- 0x05 · Address · BlockRef · TxHash+ -- 0x05 · Address · BlockRef · TxHash - put- AddrTxKey- { addrTxKeyA = a- , addrTxKeyT = TxRef{txRefBlock = b, txRefHash = t}- } = do- put AddrTxKeyB{addrTxKeyA = a, addrTxKeyB = b}- put t- -- 0x05 · Address- put AddrTxKeyA{addrTxKeyA = a} = do- put AddrTxKeyS- put a- -- 0x05 · Address · BlockRef- put AddrTxKeyB{addrTxKeyA = a, addrTxKeyB = b} = do- put AddrTxKeyA{addrTxKeyA = a}- put b- -- 0x05- put AddrTxKeyS = putWord8 0x05- get = do- guard . (== 0x05) =<< getWord8- a <- get- b <- get- t <- get- return- AddrTxKey- { addrTxKeyA = a- , addrTxKeyT = TxRef{txRefBlock = b, txRefHash = t}- }+ put+ AddrTxKey+ { addrTxKeyA = a,+ addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t}+ } = do+ put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b}+ put t+ -- 0x05 · Address+ put AddrTxKeyA {addrTxKeyA = a} = do+ put AddrTxKeyS+ put a+ -- 0x05 · Address · BlockRef+ put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do+ put AddrTxKeyA {addrTxKeyA = a}+ put b+ -- 0x05+ put AddrTxKeyS = putWord8 0x05+ get = do+ guard . (== 0x05) =<< getWord8+ a <- get+ b <- get+ t <- get+ return+ AddrTxKey+ { addrTxKeyA = a,+ addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t}+ } instance Key AddrTxKey+ instance KeyValue AddrTxKey () -- | Database key for an address output. data AddrOutKey- = -- | full key- AddrOutKey- { addrOutKeyA :: !Address- , addrOutKeyB :: !BlockRef- , addrOutKeyP :: !OutPoint- }- | -- | short key for all spent or unspent outputs- AddrOutKeyA {addrOutKeyA :: !Address}- | AddrOutKeyB- { addrOutKeyA :: !Address- , addrOutKeyB :: !BlockRef- }- | AddrOutKeyS- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ = -- | full key+ AddrOutKey+ { addrOutKeyA :: !Address,+ addrOutKeyB :: !BlockRef,+ addrOutKeyP :: !OutPoint+ }+ | -- | short key for all spent or unspent outputs+ AddrOutKeyA {addrOutKeyA :: !Address}+ | AddrOutKeyB+ { addrOutKeyA :: !Address,+ addrOutKeyB :: !BlockRef+ }+ | AddrOutKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize AddrOutKey where- -- 0x06 · StoreAddr · BlockRef · OutPoint+ -- 0x06 · StoreAddr · BlockRef · OutPoint - put AddrOutKey{addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do- put AddrOutKeyB{addrOutKeyA = a, addrOutKeyB = b}- put p- -- 0x06 · StoreAddr · BlockRef- put AddrOutKeyB{addrOutKeyA = a, addrOutKeyB = b} = do- put AddrOutKeyA{addrOutKeyA = a}- put b- -- 0x06 · StoreAddr- put AddrOutKeyA{addrOutKeyA = a} = do- put AddrOutKeyS- put a- -- 0x06- put AddrOutKeyS = putWord8 0x06- get = do- guard . (== 0x06) =<< getWord8- AddrOutKey <$> get <*> get <*> get+ put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do+ put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b}+ put p+ -- 0x06 · StoreAddr · BlockRef+ put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} = do+ put AddrOutKeyA {addrOutKeyA = a}+ put b+ -- 0x06 · StoreAddr+ put AddrOutKeyA {addrOutKeyA = a} = do+ put AddrOutKeyS+ put a+ -- 0x06+ put AddrOutKeyS = putWord8 0x06+ get = do+ guard . (== 0x06) =<< getWord8+ AddrOutKey <$> get <*> get <*> get instance Key AddrOutKey data OutVal = OutVal- { outValAmount :: !Word64- , outValScript :: !ByteString- }- deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize)+ { outValAmount :: !Word64,+ outValScript :: !ByteString+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) instance KeyValue AddrOutKey OutVal -- | Transaction database key. data TxKey- = TxKey {txKey :: TxHash}- | TxKeyS {txKeyShort :: (Word32, Word16)}- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ = TxKey {txKey :: TxHash}+ | TxKeyS {txKeyShort :: (Word32, Word16)}+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize TxKey where- -- 0x02 · TxHash- put (TxKey h) = do- putWord8 0x02- put h- put (TxKeyS h) = do- putWord8 0x02- put h- get = do- guard . (== 0x02) =<< getWord8- TxKey <$> get+ -- 0x02 · TxHash+ put (TxKey h) = do+ putWord8 0x02+ put h+ put (TxKeyS h) = do+ putWord8 0x02+ put h+ get = do+ guard . (== 0x02) =<< getWord8+ TxKey <$> get decodeTxKey :: Word64 -> ((Word32, Word16), Word8) decodeTxKey i =- let masked = i .&. 0x001fffffffffffff- wb = masked `shift` 11- bs = runPut (putWord64be wb)- g = do- w1 <- getWord32be- w2 <- getWord16be- w3 <- getWord8- return (w1, w2, w3)- Right (w1, w2, w3) = runGet g bs- in ((w1, w2), w3)+ let masked = i .&. 0x001fffffffffffff+ wb = masked `shift` 11+ bs = runPut (putWord64be wb)+ g = do+ w1 <- getWord32be+ w2 <- getWord16be+ w3 <- getWord8+ return (w1, w2, w3)+ Right (w1, w2, w3) = runGet g bs+ in ((w1, w2), w3) instance Key TxKey+ instance KeyValue TxKey TxData data SpenderKey- = SpenderKey {outputPoint :: !OutPoint}- | SpenderKeyS {outputKeyS :: !TxHash}- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ = SpenderKey {outputPoint :: !OutPoint}+ | SpenderKeyS {outputKeyS :: !TxHash}+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize SpenderKey where- -- 0x10 · TxHash · Index- put (SpenderKey OutPoint{outPointHash = h, outPointIndex = i}) = do- put (SpenderKeyS h)- put i- -- 0x10 · TxHash- put (SpenderKeyS h) = do- putWord8 0x10- put h- get = do- guard . (== 0x10) =<< getWord8- op <- OutPoint <$> get <*> get- return $ SpenderKey op+ -- 0x10 · TxHash · Index+ put (SpenderKey OutPoint {outPointHash = h, outPointIndex = i}) = do+ put (SpenderKeyS h)+ put i+ -- 0x10 · TxHash+ put (SpenderKeyS h) = do+ putWord8 0x10+ put h+ get = do+ guard . (== 0x10) =<< getWord8+ op <- OutPoint <$> get <*> get+ return $ SpenderKey op instance Key SpenderKey+ instance KeyValue SpenderKey Spender -- | Unspent output database key. data UnspentKey- = UnspentKey {unspentKey :: !OutPoint}- | UnspentKeyS {unspentKeyS :: !TxHash}- | UnspentKeyB- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ = UnspentKey {unspentKey :: !OutPoint}+ | UnspentKeyS {unspentKeyS :: !TxHash}+ | UnspentKeyB+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize UnspentKey where- -- 0x09 · TxHash · Index- put UnspentKey{unspentKey = OutPoint{outPointHash = h, outPointIndex = i}} = do- putWord8 0x09- put h- put i- -- 0x09 · TxHash- put UnspentKeyS{unspentKeyS = t} = do- putWord8 0x09- put t- -- 0x09- put UnspentKeyB = putWord8 0x09- get = do- guard . (== 0x09) =<< getWord8- h <- get- i <- get- return $ UnspentKey OutPoint{outPointHash = h, outPointIndex = i}+ -- 0x09 · TxHash · Index+ put UnspentKey {unspentKey = OutPoint {outPointHash = h, outPointIndex = i}} = do+ putWord8 0x09+ put h+ put i+ -- 0x09 · TxHash+ put UnspentKeyS {unspentKeyS = t} = do+ putWord8 0x09+ put t+ -- 0x09+ put UnspentKeyB = putWord8 0x09+ get = do+ guard . (== 0x09) =<< getWord8+ h <- get+ i <- get+ return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i} instance Key UnspentKey+ instance KeyValue UnspentKey UnspentVal toUnspent :: AddrOutKey -> OutVal -> Unspent toUnspent b v =- Unspent- { unspentBlock = addrOutKeyB b- , unspentAmount = outValAmount v- , unspentScript = outValScript v- , unspentPoint = addrOutKeyP b- , unspentAddress = eitherToMaybe (scriptToAddressBS (outValScript v))- }+ Unspent+ { unspentBlock = addrOutKeyB b,+ unspentAmount = outValAmount v,+ unspentScript = outValScript v,+ unspentPoint = addrOutKeyP b,+ unspentAddress = eitherToMaybe (scriptToAddressBS (outValScript v))+ } -- | Mempool transaction database key. data MemKey- = MemKey- deriving (Show, Read)+ = MemKey+ deriving (Show, Read) instance Serialize MemKey where- -- 0x07- put MemKey = putWord8 0x07- get = do- guard . (== 0x07) =<< getWord8- return MemKey+ -- 0x07+ put MemKey = putWord8 0x07+ get = do+ guard . (== 0x07) =<< getWord8+ return MemKey instance Key MemKey+ instance KeyValue MemKey [(UnixTime, TxHash)] -- | Block entry database key. newtype BlockKey = BlockKey- { blockKey :: BlockHash- }- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ { blockKey :: BlockHash+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BlockKey where- -- 0x01 · BlockHash- put (BlockKey h) = do- putWord8 0x01- put h- get = do- guard . (== 0x01) =<< getWord8- BlockKey <$> get+ -- 0x01 · BlockHash+ put (BlockKey h) = do+ putWord8 0x01+ put h+ get = do+ guard . (== 0x01) =<< getWord8+ BlockKey <$> get instance Key BlockKey+ instance KeyValue BlockKey BlockData -- | Block height database key. newtype HeightKey = HeightKey- { heightKey :: BlockHeight- }- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ { heightKey :: BlockHeight+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize HeightKey where- -- 0x03 · BlockHeight- put (HeightKey height) = do- putWord8 0x03- put height- get = do- guard . (== 0x03) =<< getWord8- HeightKey <$> get+ -- 0x03 · BlockHeight+ put (HeightKey height) = do+ putWord8 0x03+ put height+ get = do+ guard . (== 0x03) =<< getWord8+ HeightKey <$> get instance Key HeightKey+ instance KeyValue HeightKey [BlockHash] -- | Address balance database key. data BalKey- = BalKey- { balanceKey :: !Address- }- | BalKeyS- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ = BalKey+ { balanceKey :: !Address+ }+ | BalKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BalKey where- -- 0x04 · Address- put BalKey{balanceKey = a} = do- putWord8 0x04- put a- -- 0x04- put BalKeyS = putWord8 0x04- get = do- guard . (== 0x04) =<< getWord8- BalKey <$> get+ -- 0x04 · Address+ put BalKey {balanceKey = a} = do+ putWord8 0x04+ put a+ -- 0x04+ put BalKeyS = putWord8 0x04+ get = do+ guard . (== 0x04) =<< getWord8+ BalKey <$> get instance Key BalKey+ instance KeyValue BalKey BalVal -- | Key for best block in database. data BestKey- = BestKey- deriving (Show, Read, Eq, Ord, Generic, Hashable)+ = BestKey+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BestKey where- -- 0x00 × 32- put BestKey = put (BS.replicate 32 0x00)- get = do- guard . (== BS.replicate 32 0x00) =<< getBytes 32- return BestKey+ -- 0x00 × 32+ put BestKey = put (BS.replicate 32 0x00)+ get = do+ guard . (== BS.replicate 32 0x00) =<< getBytes 32+ return BestKey instance Key BestKey+ instance KeyValue BestKey BlockHash -- | Key for database version. data VersionKey- = VersionKey- deriving (Eq, Show, Read, Ord, Generic, Hashable)+ = VersionKey+ deriving (Eq, Show, Read, Ord, Generic, Hashable) instance Serialize VersionKey where- -- 0x0a- put VersionKey = putWord8 0x0a- get = do- guard . (== 0x0a) =<< getWord8- return VersionKey+ -- 0x0a+ put VersionKey = putWord8 0x0a+ get = do+ guard . (== 0x0a) =<< getWord8+ return VersionKey instance Key VersionKey+ instance KeyValue VersionKey Word32 data BalVal = BalVal- { balValAmount :: !Word64- , balValZero :: !Word64- , balValUnspentCount :: !Word64- , balValTxCount :: !Word64- , balValTotalReceived :: !Word64- }- deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)+ { balValAmount :: !Word64,+ balValZero :: !Word64,+ balValUnspentCount :: !Word64,+ balValTxCount :: !Word64,+ balValTotalReceived :: !Word64+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) valToBalance :: Address -> BalVal -> Balance valToBalance- a- BalVal- { balValAmount = v- , balValZero = z- , balValUnspentCount = u- , balValTxCount = t- , balValTotalReceived = r- } =- Balance- { balanceAddress = a- , balanceAmount = v- , balanceZero = z- , balanceUnspentCount = u- , balanceTxCount = t- , balanceTotalReceived = r- }+ a+ BalVal+ { balValAmount = v,+ balValZero = z,+ balValUnspentCount = u,+ balValTxCount = t,+ balValTotalReceived = r+ } =+ Balance+ { balanceAddress = a,+ balanceAmount = v,+ balanceZero = z,+ balanceUnspentCount = u,+ balanceTxCount = t,+ balanceTotalReceived = r+ } balanceToVal :: Balance -> BalVal balanceToVal- Balance- { balanceAmount = v- , balanceZero = z- , balanceUnspentCount = u- , balanceTxCount = t- , balanceTotalReceived = r- } =- BalVal- { balValAmount = v- , balValZero = z- , balValUnspentCount = u- , balValTxCount = t- , balValTotalReceived = r- }+ Balance+ { balanceAmount = v,+ balanceZero = z,+ balanceUnspentCount = u,+ balanceTxCount = t,+ balanceTotalReceived = r+ } =+ BalVal+ { balValAmount = v,+ balValZero = z,+ balValUnspentCount = u,+ balValTxCount = t,+ balValTotalReceived = r+ } -- | Default balance for an address. instance Default BalVal where- def =- BalVal- { balValAmount = 0- , balValZero = 0- , balValUnspentCount = 0- , balValTxCount = 0- , balValTotalReceived = 0- }+ def =+ BalVal+ { balValAmount = 0,+ balValZero = 0,+ balValUnspentCount = 0,+ balValTxCount = 0,+ balValTotalReceived = 0+ } data UnspentVal = UnspentVal- { unspentValBlock :: !BlockRef- , unspentValAmount :: !Word64- , unspentValScript :: !ByteString- }- deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)+ { unspentValBlock :: !BlockRef,+ unspentValAmount :: !Word64,+ unspentValScript :: !ByteString+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) unspentToVal :: Unspent -> (OutPoint, UnspentVal) unspentToVal- Unspent- { unspentBlock = b- , unspentPoint = p- , unspentAmount = v- , unspentScript = s- } =- ( p- , UnspentVal- { unspentValBlock = b- , unspentValAmount = v- , unspentValScript = s- }- )+ Unspent+ { unspentBlock = b,+ unspentPoint = p,+ unspentAmount = v,+ unspentScript = s+ } =+ ( p,+ UnspentVal+ { unspentValBlock = b,+ unspentValAmount = v,+ unspentValScript = s+ }+ ) valToUnspent :: OutPoint -> UnspentVal -> Unspent valToUnspent- p- UnspentVal- { unspentValBlock = b- , unspentValAmount = v- , unspentValScript = s- } =- Unspent- { unspentBlock = b- , unspentPoint = p- , unspentAmount = v- , unspentScript = s- , unspentAddress = eitherToMaybe (scriptToAddressBS s)- }+ p+ UnspentVal+ { unspentValBlock = b,+ unspentValAmount = v,+ unspentValScript = s+ } =+ Unspent+ { unspentBlock = b,+ unspentPoint = p,+ unspentAmount = v,+ unspentScript = s,+ unspentAddress = eitherToMaybe (scriptToAddressBS s)+ }
src/Haskoin/Store/Database/Writer.hs view
@@ -13,15 +13,15 @@ import Data.Ord (Down (..)) import Data.Tuple (swap) import Database.RocksDB (BatchOp, DB)-import Database.RocksDB.Query (- deleteOp,+import Database.RocksDB.Query+ ( deleteOp, deleteOpCF, insertOp, insertOpCF, writeBatch,- )-import Haskoin (- Address,+ )+import Haskoin+ ( Address, BlockHash, BlockHeight, Network,@@ -29,164 +29,164 @@ TxHash, headerHash, txHash,- )+ ) import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Reader import Haskoin.Store.Database.Types-import UnliftIO (- MonadIO,+import UnliftIO+ ( MonadIO, TVar, atomically, liftIO, modifyTVar, newTVarIO, readTVarIO,- )+ ) data Writer = Writer- { getReader :: !DatabaseReader- , getState :: !(TVar Memory)- }+ { getReader :: !DatabaseReader,+ getState :: !(TVar Memory)+ } type WriterT = ReaderT Writer instance MonadIO m => StoreReadBase (WriterT m) where- getNetwork = getNetworkI- getBestBlock = getBestBlockI- getBlocksAtHeight = getBlocksAtHeightI- getBlock = getBlockI- getTxData = getTxDataI- getSpender = getSpenderI- getUnspent = getUnspentI- getBalance = getBalanceI- getMempool = getMempoolI+ getNetwork = getNetworkI+ getBestBlock = getBestBlockI+ getBlocksAtHeight = getBlocksAtHeightI+ getBlock = getBlockI+ getTxData = getTxDataI+ getSpender = getSpenderI+ getUnspent = getUnspentI+ getBalance = getBalanceI+ getMempool = getMempoolI data Memory = Memory- { hNet ::- !(Maybe Network)- , hBest ::- !(Maybe (Maybe BlockHash))- , hBlock ::- !(HashMap BlockHash (Maybe BlockData))- , hHeight ::- !(HashMap BlockHeight [BlockHash])- , hTx ::- !(HashMap TxHash (Maybe TxData))- , hSpender ::- !(HashMap OutPoint (Maybe Spender))- , hUnspent ::- !(HashMap OutPoint (Maybe Unspent))- , hBalance ::- !(HashMap Address (Maybe Balance))- , hAddrTx ::- !(HashMap (Address, TxRef) (Maybe ()))- , hAddrOut ::- !(HashMap (Address, BlockRef, OutPoint) (Maybe OutVal))- , hMempool ::- !(HashMap TxHash UnixTime)- }- deriving (Eq, Show)+ { hNet ::+ !(Maybe Network),+ hBest ::+ !(Maybe (Maybe BlockHash)),+ hBlock ::+ !(HashMap BlockHash (Maybe BlockData)),+ hHeight ::+ !(HashMap BlockHeight [BlockHash]),+ hTx ::+ !(HashMap TxHash (Maybe TxData)),+ hSpender ::+ !(HashMap OutPoint (Maybe Spender)),+ hUnspent ::+ !(HashMap OutPoint (Maybe Unspent)),+ hBalance ::+ !(HashMap Address (Maybe Balance)),+ hAddrTx ::+ !(HashMap (Address, TxRef) (Maybe ())),+ hAddrOut ::+ !(HashMap (Address, BlockRef, OutPoint) (Maybe OutVal)),+ hMempool ::+ !(HashMap TxHash UnixTime)+ }+ deriving (Eq, Show) instance MonadIO m => StoreWrite (WriterT m) where- setBest h =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- setBestH h- insertBlock b =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- insertBlockH b- setBlocksAtHeight h g =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- setBlocksAtHeightH h g- insertTx t =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- insertTxH t- insertSpender p s' =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- insertSpenderH p s'- deleteSpender p =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- deleteSpenderH p- insertAddrTx a t =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- insertAddrTxH a t- deleteAddrTx a t =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- deleteAddrTxH a t- insertAddrUnspent a u =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- insertAddrUnspentH a u- deleteAddrUnspent a u =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- deleteAddrUnspentH a u- addToMempool x t =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- addToMempoolH x t- deleteFromMempool x =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- deleteFromMempoolH x- setBalance b =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- setBalanceH b- insertUnspent h =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- insertUnspentH h- deleteUnspent p =- ReaderT $ \Writer{getState = s} ->- liftIO . atomically . modifyTVar s $- deleteUnspentH p+ setBest h =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ setBestH h+ insertBlock b =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertBlockH b+ setBlocksAtHeight h g =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ setBlocksAtHeightH h g+ insertTx t =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertTxH t+ insertSpender p s' =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertSpenderH p s'+ deleteSpender p =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ deleteSpenderH p+ insertAddrTx a t =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertAddrTxH a t+ deleteAddrTx a t =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ deleteAddrTxH a t+ insertAddrUnspent a u =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertAddrUnspentH a u+ deleteAddrUnspent a u =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ deleteAddrUnspentH a u+ addToMempool x t =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ addToMempoolH x t+ deleteFromMempool x =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ deleteFromMempoolH x+ setBalance b =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ setBalanceH b+ insertUnspent h =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertUnspentH h+ deleteUnspent p =+ ReaderT $ \Writer {getState = s} ->+ liftIO . atomically . modifyTVar s $+ deleteUnspentH p getLayered ::- MonadIO m =>- (Memory -> Maybe a) ->- DatabaseReaderT m a ->- WriterT m a+ MonadIO m =>+ (Memory -> Maybe a) ->+ DatabaseReaderT m a ->+ WriterT m a getLayered f g =- ReaderT $ \Writer{getReader = db, getState = tmem} ->- f <$> readTVarIO tmem >>= \case- Just x -> return x- Nothing -> runReaderT g db+ ReaderT $ \Writer {getReader = db, getState = tmem} ->+ f <$> readTVarIO tmem >>= \case+ Just x -> return x+ Nothing -> runReaderT g db runWriter ::- MonadIO m =>- DatabaseReader ->- WriterT m a ->- m a-runWriter bdb@DatabaseReader{databaseHandle = db} f = do- mem <- runReaderT getMempool bdb- hm <- newTVarIO (newMemory mem)- x <- R.runReaderT f Writer{getReader = bdb, getState = hm}- mem' <- readTVarIO hm- let ops = hashMapOps db mem'- writeBatch db ops- return x+ MonadIO m =>+ DatabaseReader ->+ WriterT m a ->+ m a+runWriter bdb@DatabaseReader {databaseHandle = db} f = do+ mem <- runReaderT getMempool bdb+ hm <- newTVarIO (newMemory mem)+ x <- R.runReaderT f Writer {getReader = bdb, getState = hm}+ mem' <- readTVarIO hm+ let ops = hashMapOps db mem'+ writeBatch db ops+ return x hashMapOps :: DB -> Memory -> [BatchOp] hashMapOps db mem =- bestBlockOp (hBest mem)- <> blockHashOps db (hBlock mem)- <> blockHeightOps db (hHeight mem)- <> txOps db (hTx mem)- <> spenderOps db (hSpender mem)- <> balOps db (hBalance mem)- <> addrTxOps db (hAddrTx mem)- <> addrOutOps db (hAddrOut mem)- <> mempoolOp (hMempool mem)- <> unspentOps db (hUnspent mem)+ bestBlockOp (hBest mem)+ <> blockHashOps db (hBlock mem)+ <> blockHeightOps db (hHeight mem)+ <> txOps db (hTx mem)+ <> spenderOps db (hSpender mem)+ <> balOps db (hBalance mem)+ <> addrTxOps db (hAddrTx mem)+ <> addrOutOps db (hAddrOut mem)+ <> mempoolOp (hMempool mem)+ <> unspentOps db (hUnspent mem) bestBlockOp :: Maybe (Maybe BlockHash) -> [BatchOp] bestBlockOp Nothing = []@@ -229,29 +229,29 @@ f (a, t) Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t) addrOutOps ::- DB ->- HashMap (Address, BlockRef, OutPoint) (Maybe OutVal) ->- [BatchOp]+ DB ->+ HashMap (Address, BlockRef, OutPoint) (Maybe OutVal) ->+ [BatchOp] addrOutOps db = map (uncurry f) . M.toList where f (a, b, p) (Just l) =- insertOpCF- (addrOutCF db)- ( AddrOutKey- { addrOutKeyA = a- , addrOutKeyB = b- , addrOutKeyP = p- }- )- l+ insertOpCF+ (addrOutCF db)+ ( AddrOutKey+ { addrOutKeyA = a,+ addrOutKeyB = b,+ addrOutKeyP = p+ }+ )+ l f (a, b, p) Nothing =- deleteOpCF- (addrOutCF db)- AddrOutKey- { addrOutKeyA = a- , addrOutKeyB = b- , addrOutKeyP = p- }+ deleteOpCF+ (addrOutCF db)+ AddrOutKey+ { addrOutKeyA = a,+ addrOutKeyB = b,+ addrOutKeyP = p+ } mempoolOp :: HashMap TxHash UnixTime -> [BatchOp] mempoolOp = return . insertOp MemKey . sortOn Down . map swap . M.toList@@ -260,9 +260,9 @@ unspentOps db = map (uncurry f) . M.toList where f p (Just u) =- insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u))+ insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u)) f p Nothing =- deleteOpCF (unspentCF db) (UnspentKey p)+ deleteOpCF (unspentCF db) (UnspentKey p) getNetworkI :: MonadIO m => WriterT m Network getNetworkI = getLayered hNet getNetwork@@ -272,7 +272,7 @@ getBlocksAtHeightI :: MonadIO m => BlockHeight -> WriterT m [BlockHash] getBlocksAtHeightI bh =- getLayered (getBlocksAtHeightH bh) (getBlocksAtHeight bh)+ getLayered (getBlocksAtHeightH bh) (getBlocksAtHeight bh) getBlockI :: MonadIO m => BlockHash -> WriterT m (Maybe BlockData) getBlockI bh = getLayered (getBlockH bh) (getBlock bh)@@ -291,24 +291,24 @@ getMempoolI :: MonadIO m => WriterT m [(UnixTime, TxHash)] getMempoolI =- ReaderT $ \Writer{getState = tmem} ->- getMempoolH <$> readTVarIO tmem+ ReaderT $ \Writer {getState = tmem} ->+ getMempoolH <$> readTVarIO tmem newMemory :: [(UnixTime, TxHash)] -> Memory newMemory mem =- Memory- { hNet = Nothing- , hBest = Nothing- , hBlock = M.empty- , hHeight = M.empty- , hTx = M.empty- , hSpender = M.empty- , hUnspent = M.empty- , hBalance = M.empty- , hAddrTx = M.empty- , hAddrOut = M.empty- , hMempool = M.fromList (map swap mem)- }+ Memory+ { hNet = Nothing,+ hBest = Nothing,+ hBlock = M.empty,+ hHeight = M.empty,+ hTx = M.empty,+ hSpender = M.empty,+ hUnspent = M.empty,+ hBalance = M.empty,+ hAddrTx = M.empty,+ hAddrOut = M.empty,+ hMempool = M.fromList (map swap mem)+ } getBestBlockH :: Memory -> Maybe (Maybe BlockHash) getBestBlockH = hBest@@ -332,77 +332,77 @@ getMempoolH = sortOn Down . map swap . M.toList . hMempool setBestH :: BlockHash -> Memory -> Memory-setBestH h db = db{hBest = Just (Just h)}+setBestH h db = db {hBest = Just (Just h)} insertBlockH :: BlockData -> Memory -> Memory insertBlockH bd db =- db- { hBlock =- M.insert- (headerHash (blockDataHeader bd))- (Just bd)- (hBlock db)- }+ db+ { hBlock =+ M.insert+ (headerHash (blockDataHeader bd))+ (Just bd)+ (hBlock db)+ } setBlocksAtHeightH :: [BlockHash] -> BlockHeight -> Memory -> Memory setBlocksAtHeightH hs g db =- db{hHeight = M.insert g hs (hHeight db)}+ db {hHeight = M.insert g hs (hHeight db)} insertTxH :: TxData -> Memory -> Memory insertTxH tx db =- db{hTx = M.insert (txHash (txData tx)) (Just tx) (hTx db)}+ db {hTx = M.insert (txHash (txData tx)) (Just tx) (hTx db)} insertSpenderH :: OutPoint -> Spender -> Memory -> Memory insertSpenderH op s db =- db{hSpender = M.insert op (Just s) (hSpender db)}+ db {hSpender = M.insert op (Just s) (hSpender db)} deleteSpenderH :: OutPoint -> Memory -> Memory deleteSpenderH op db =- db{hSpender = M.insert op Nothing (hSpender db)}+ db {hSpender = M.insert op Nothing (hSpender db)} setBalanceH :: Balance -> Memory -> Memory setBalanceH bal db =- db{hBalance = M.insert (balanceAddress bal) (Just bal) (hBalance db)}+ db {hBalance = M.insert (balanceAddress bal) (Just bal) (hBalance db)} insertAddrTxH :: Address -> TxRef -> Memory -> Memory insertAddrTxH a tr db =- db{hAddrTx = M.insert (a, tr) (Just ()) (hAddrTx db)}+ db {hAddrTx = M.insert (a, tr) (Just ()) (hAddrTx db)} deleteAddrTxH :: Address -> TxRef -> Memory -> Memory deleteAddrTxH a tr db =- db{hAddrTx = M.insert (a, tr) Nothing (hAddrTx db)}+ db {hAddrTx = M.insert (a, tr) Nothing (hAddrTx db)} insertAddrUnspentH :: Address -> Unspent -> Memory -> Memory insertAddrUnspentH a u db =- let k = (a, unspentBlock u, unspentPoint u)- v =- OutVal- { outValAmount = unspentAmount u- , outValScript = unspentScript u- }- in db{hAddrOut = M.insert k (Just v) (hAddrOut db)}+ let k = (a, unspentBlock u, unspentPoint u)+ v =+ OutVal+ { outValAmount = unspentAmount u,+ outValScript = unspentScript u+ }+ in db {hAddrOut = M.insert k (Just v) (hAddrOut db)} deleteAddrUnspentH :: Address -> Unspent -> Memory -> Memory deleteAddrUnspentH a u db =- let k = (a, unspentBlock u, unspentPoint u)- in db{hAddrOut = M.insert k Nothing (hAddrOut db)}+ let k = (a, unspentBlock u, unspentPoint u)+ in db {hAddrOut = M.insert k Nothing (hAddrOut db)} addToMempoolH :: TxHash -> UnixTime -> Memory -> Memory addToMempoolH h t db =- db{hMempool = M.insert h t (hMempool db)}+ db {hMempool = M.insert h t (hMempool db)} deleteFromMempoolH :: TxHash -> Memory -> Memory deleteFromMempoolH h db =- db{hMempool = M.delete h (hMempool db)}+ db {hMempool = M.delete h (hMempool db)} getUnspentH :: OutPoint -> Memory -> Maybe (Maybe Unspent) getUnspentH op db = M.lookup op (hUnspent db) insertUnspentH :: Unspent -> Memory -> Memory insertUnspentH u db =- let k = fst (unspentToVal u)- in db{hUnspent = M.insert k (Just u) (hUnspent db)}+ let k = fst (unspentToVal u)+ in db {hUnspent = M.insert k (Just u) (hUnspent db)} deleteUnspentH :: OutPoint -> Memory -> Memory deleteUnspentH op db =- db{hUnspent = M.insert op Nothing (hUnspent db)}+ db {hUnspent = M.insert op Nothing (hUnspent db)}
src/Haskoin/Store/Logic.hs view
@@ -6,762 +6,763 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.Logic (- ImportException (..),- MonadImport,- initBest,- revertBlock,- importBlock,- newMempoolTx,- deleteUnconfirmedTx,-) where--import Control.Monad (- forM,- forM_,- guard,- unless,- void,- when,- zipWithM_,- (<=<),- )-import Control.Monad.Except (MonadError, throwError)-import Control.Monad.Logger (- MonadLoggerIO (..),- logDebugS,- logErrorS,- )-import qualified Data.ByteString as B-import Data.Either (rights)-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import qualified Data.IntMap.Strict as I-import Data.List (nub)-import Data.Maybe (- catMaybes,- fromMaybe,- isJust,- isNothing,- )-import Data.Serialize (encode)-import Data.String.Conversions (cs)-import Data.Word (Word32, Word64)-import Haskoin (- Address,- Block (..),- BlockHash,- BlockHeader (..),- BlockNode (..),- Network (..),- OutPoint (..),- Tx (..),- TxHash,- TxIn (..),- TxOut (..),- blockHashToHex,- computeSubsidy,- eitherToMaybe,- genesisBlock,- genesisNode,- headerHash,- isGenesis,- nullOutPoint,- scriptToAddressBS,- txHash,- txHashToHex,- )-import Haskoin.Store.Common-import Haskoin.Store.Data (- Balance (..),- BlockData (..),- BlockRef (..),- Prev (..),- Spender (..),- TxData (..),- TxRef (..),- UnixTime,- Unspent (..),- confirmed,- )-import UnliftIO (Exception)--type MonadImport m =- ( MonadError ImportException m- , MonadLoggerIO m- , StoreReadBase m- , StoreWrite m- )--data ImportException- = PrevBlockNotBest- | Orphan- | UnexpectedCoinbase- | BestBlockNotFound- | BlockNotBest- | TxNotFound- | DoubleSpend- | TxConfirmed- | InsufficientFunds- | DuplicatePrevOutput- | TxSpent- deriving (Eq, Ord, Exception)--instance Show ImportException where- show PrevBlockNotBest = "Previous block not best"- show Orphan = "Orphan"- show UnexpectedCoinbase = "Unexpected coinbase"- show BestBlockNotFound = "Best block not found"- show BlockNotBest = "Block not best"- show TxNotFound = "Transaction not found"- show DoubleSpend = "Double spend"- show TxConfirmed = "Transaction confirmed"- show InsufficientFunds = "Insufficient funds"- show DuplicatePrevOutput = "Duplicate previous output"- show TxSpent = "Transaction is spent"--initBest :: MonadImport m => m ()-initBest = do- $(logDebugS) "BlockStore" "Initializing best block"- net <- getNetwork- m <- getBestBlock- when (isNothing m) . void $ do- $(logDebugS) "BlockStore" "Importing Genesis block"- importBlock (genesisBlock net) (genesisNode net)--newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool-newMempoolTx tx w =- getActiveTxData (txHash tx) >>= \case- Just _ ->- return False- Nothing -> do- freeOutputs True True tx- rbf <- isRBF (MemRef w) tx- checkNewTx tx- importTx (MemRef w) w rbf tx- return True--bestBlockData :: MonadImport m => m BlockData-bestBlockData = do- h <-- getBestBlock >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "Best block unknown"- throwError BestBlockNotFound- Just h -> return h- getBlock h >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "Best block not found"- throwError BestBlockNotFound- Just b -> return b--revertBlock :: MonadImport m => BlockHash -> m ()-revertBlock bh = do- bd <-- bestBlockData >>= \b ->- if headerHash (blockDataHeader b) == bh- then return b- else do- $(logErrorS) "BlockStore" $- "Cannot revert non-head block: " <> blockHashToHex bh- throwError BlockNotBest- $(logDebugS) "BlockStore" $- "Obtained block data for " <> blockHashToHex bh- tds <- mapM getImportTxData (blockDataTxs bd)- $(logDebugS) "BlockStore" $- "Obtained import tx data for block " <> blockHashToHex bh- setBest (prevBlock (blockDataHeader bd))- $(logDebugS) "BlockStore" $- "Set parent as best block "- <> blockHashToHex (prevBlock (blockDataHeader bd))- insertBlock bd{blockDataMainChain = False}- $(logDebugS) "BlockStore" $- "Updated as not in main chain: " <> blockHashToHex bh- forM_ (tail tds) unConfirmTx- $(logDebugS) "BlockStore" $- "Unconfirmed " <> cs (show (length tds)) <> " transactions"- deleteConfirmedTx (txHash (txData (head tds)))- $(logDebugS) "BlockStore" $- "Deleted coinbase: " <> txHashToHex (txHash (txData (head tds)))--checkNewBlock :: MonadImport m => Block -> BlockNode -> m ()-checkNewBlock b n =- getBestBlock >>= \case- Nothing- | isGenesis n -> return ()- | otherwise -> do- $(logErrorS) "BlockStore" $- "Cannot import non-genesis block: "- <> blockHashToHex (headerHash (blockHeader b))- throwError BestBlockNotFound- Just h- | prevBlock (blockHeader b) == h -> return ()- | otherwise -> do- $(logErrorS) "BlockStore" $- "Block does not build on head: "- <> blockHashToHex (headerHash (blockHeader b))- throwError PrevBlockNotBest--importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m ()-importOrConfirm bn txns = do- mapM_ (freeOutputs True False . snd) (reverse txs)- mapM_ (uncurry action) txs- where- txs = sortTxs txns- br i = BlockRef{blockRefHeight = nodeHeight bn, blockRefPos = i}- bn_time = fromIntegral . blockTimestamp $ nodeHeader bn- action i tx =- testPresent tx >>= \case- False -> import_it i tx- True -> confirm_it i tx- confirm_it i tx =- getActiveTxData (txHash tx) >>= \case- Just t -> do- $(logDebugS) "BlockStore" $- "Confirming tx: "- <> txHashToHex (txHash tx)- confirmTx t (br i)- return Nothing- Nothing -> do- $(logErrorS) "BlockStore" $- "Cannot find tx to confirm: "- <> txHashToHex (txHash tx)- throwError TxNotFound- import_it i tx = do- $(logDebugS) "BlockStore" $- "Importing tx: " <> txHashToHex (txHash tx)- importTx (br i) bn_time False tx- return Nothing--importBlock :: MonadImport m => Block -> BlockNode -> m ()-importBlock b n = do- $(logDebugS) "BlockStore" $- "Checking new block: "- <> blockHashToHex (headerHash (nodeHeader n))- checkNewBlock b n- $(logDebugS) "BlockStore" "Passed check"- net <- getNetwork- let subsidy = computeSubsidy net (nodeHeight n)- bs <- getBlocksAtHeight (nodeHeight n)- $(logDebugS) "BlockStore" $- "Inserting block entries for: "- <> blockHashToHex (headerHash (nodeHeader n))- insertBlock- BlockData- { blockDataHeight = nodeHeight n- , blockDataMainChain = True- , blockDataWork = nodeWork n- , blockDataHeader = nodeHeader n- , blockDataSize = fromIntegral (B.length (encode b))- , blockDataTxs = map txHash (blockTxns b)- , blockDataWeight = if getSegWit net then w else 0- , blockDataSubsidy = subsidy- , blockDataFees = cb_out_val - subsidy- , blockDataOutputs = ts_out_val- }- setBlocksAtHeight- (nub (headerHash (nodeHeader n) : bs))- (nodeHeight n)- setBest (headerHash (nodeHeader n))- importOrConfirm n (blockTxns b)- $(logDebugS) "BlockStore" $- "Finished importing transactions for: "- <> blockHashToHex (headerHash (nodeHeader n))- where- cb_out_val =- sum $ map outValue $ txOut $ head $ blockTxns b- ts_out_val =- sum $ map (sum . map outValue . txOut) $ tail $ blockTxns b- w =- let f t = t{txWitness = []}- b' = b{blockTxns = map f (blockTxns b)}- x = B.length (encode b)- s = B.length (encode b')- in fromIntegral $ s * 3 + x--checkNewTx :: MonadImport m => Tx -> m ()-checkNewTx tx = do- when (unique_inputs < length (txIn tx)) $ do- $(logErrorS) "BlockStore" $- "Transaction spends same output twice: "- <> txHashToHex (txHash tx)- throwError DuplicatePrevOutput- us <- getUnspentOutputs tx- when (any isNothing us) $ do- $(logErrorS) "BlockStore" $- "Orphan: " <> txHashToHex (txHash tx)- throwError Orphan- when (isCoinbase tx) $ do- $(logErrorS) "BlockStore" $- "Coinbase cannot be imported into mempool: "- <> txHashToHex (txHash tx)- throwError UnexpectedCoinbase- when (length (prevOuts tx) > length us) $ do- $(logErrorS) "BlockStore" $- "Orphan: " <> txHashToHex (txHash tx)- throwError Orphan- when (outputs > unspents us) $ do- $(logErrorS) "BlockStore" $- "Insufficient funds for tx: " <> txHashToHex (txHash tx)- throwError InsufficientFunds- where- unspents = sum . map unspentAmount . catMaybes- outputs = sum (map outValue (txOut tx))- unique_inputs = length (nub' (map prevOutput (txIn tx)))--getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent]-getUnspentOutputs tx = mapM getUnspent (prevOuts tx)--prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData-prepareTxData rbf br tt tx us =- TxData- { txDataBlock = br- , txData = tx- , txDataPrevs = ps- , txDataDeleted = False- , txDataRBF = rbf- , txDataTime = tt- }- where- mkprv u = Prev (unspentScript u) (unspentAmount u)- ps = I.fromList $ zip [0 ..] $ map mkprv us--importTx ::- MonadImport m =>- BlockRef ->- -- | unix time- Word64 ->- -- | RBF- Bool ->- Tx ->- m ()-importTx br tt rbf tx = do- mus <- getUnspentOutputs tx- us <- forM mus $ \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Attempted to import a tx missing UTXO: "- <> txHashToHex (txHash tx)- throwError Orphan- Just u -> return u- let td = prepareTxData rbf br tt tx us- commitAddTx td--unConfirmTx :: MonadImport m => TxData -> m ()-unConfirmTx t = confTx t Nothing--confirmTx :: MonadImport m => TxData -> BlockRef -> m ()-confirmTx t br = confTx t (Just br)--replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m ()-replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do- deleteAddrTx- a- TxRef- { txRefBlock = txDataBlock t- , txRefHash = txHash (txData t)- }- insertAddrTx- a- TxRef- { txRefBlock = new- , txRefHash = txHash (txData t)- }--adjustAddressOutput ::- MonadImport m =>- OutPoint ->- TxOut ->- BlockRef ->- BlockRef ->- m ()-adjustAddressOutput op o old new = do- let pk = scriptOutput o- getUnspent op >>= \case- Nothing -> return ()- Just u -> do- unless (unspentBlock u == old) $- error $ "Existing unspent block bad for output: " <> show op- replace_unspent pk- where- replace_unspent pk = do- let ma = eitherToMaybe (scriptToAddressBS pk)- deleteUnspent op- insertUnspent- Unspent- { unspentBlock = new- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = pk- , unspentAddress = ma- }- forM_ ma $ replace_addr_unspent pk- replace_addr_unspent pk a = do- deleteAddrUnspent- a- Unspent- { unspentBlock = old- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = pk- , unspentAddress = Just a- }- insertAddrUnspent- a- Unspent- { unspentBlock = new- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = pk- , unspentAddress = Just a- }- decreaseBalance (confirmed old) a (outValue o)- increaseBalance (confirmed new) a (outValue o)--confTx :: MonadImport m => TxData -> Maybe BlockRef -> m ()-confTx t mbr = do- replaceAddressTx t new- forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do- let op = OutPoint (txHash (txData t)) n- adjustAddressOutput op o old new- rbf <- isRBF new (txData t)- let td = t{txDataBlock = new, txDataRBF = rbf}- insertTx td- updateMempool td- where- new = fromMaybe (MemRef (txDataTime t)) mbr- old = txDataBlock t--freeOutputs ::- MonadImport m =>- -- | only delete transaction if unconfirmed- Bool ->- -- | only delete RBF- Bool ->- Tx ->- m ()-freeOutputs memonly rbfcheck tx = do- let prevs = prevOuts tx- unspents <- mapM getUnspent prevs- let spents = [p | (p, Nothing) <- zip prevs unspents]- spndrs <- catMaybes <$> mapM getSpender spents- let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs- mapM_ (deleteTx memonly rbfcheck) $ HashSet.toList txids--deleteConfirmedTx :: MonadImport m => TxHash -> m ()-deleteConfirmedTx = deleteTx False False--deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m ()-deleteUnconfirmedTx rbfcheck th =- getActiveTxData th >>= \case- Just _ -> deleteTx True rbfcheck th- Nothing ->- $(logDebugS) "BlockStore" $- "Not found or already deleted: " <> txHashToHex th--deleteTx ::- MonadImport m =>- -- | only delete transaction if unconfirmed- Bool ->- -- | only delete RBF- Bool ->- TxHash ->- m ()-deleteTx memonly rbfcheck th = do- chain <- getChain memonly rbfcheck th- $(logDebugS) "BlockStore" $- "Deleting " <> cs (show (length chain))- <> " txs from chain leading to "- <> txHashToHex th- mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain--getChain ::- (MonadImport m, MonadLoggerIO m) =>- -- | only delete transaction if unconfirmed- Bool ->- -- | only delete RBF- Bool ->- TxHash ->- m [Tx]-getChain memonly rbfcheck th' = do- $(logDebugS) "BlockStore" $- "Getting chain for tx " <> txHashToHex th'- sort_clean <$> go HashSet.empty (HashSet.singleton th')- where- sort_clean = reverse . map snd . sortTxs- get_tx th =- getActiveTxData th >>= \case- Nothing -> do- $(logDebugS) "BlockStore" $- "Transaction not found: " <> txHashToHex th- return Nothing- Just td- | memonly && confirmed (txDataBlock td) -> do- $(logErrorS) "BlockStore" $- "Transaction already confirmed: "- <> txHashToHex th- throwError TxConfirmed- | rbfcheck ->- isRBF (txDataBlock td) (txData td) >>= \case- True -> return $ Just $ txData td- False -> do- $(logErrorS) "BlockStore" $- "Double-spending transaction: "- <> txHashToHex th- throwError DoubleSpend- | otherwise -> return $ Just $ txData td- go txs pdg = do- txs1 <- HashSet.fromList . catMaybes <$> mapM get_tx (HashSet.toList pdg)- pdg1 <-- HashSet.fromList . concatMap (map spenderHash . I.elems)- <$> mapM getSpenders (HashSet.toList pdg)- let txs' = txs1 <> txs- pdg' = pdg1 `HashSet.difference` HashSet.map txHash txs'- if HashSet.null pdg'- then return $ HashSet.toList txs'- else go txs' pdg'--deleteSingleTx :: MonadImport m => TxHash -> m ()-deleteSingleTx th =- getActiveTxData th >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Already deleted: " <> txHashToHex th- throwError TxNotFound- Just td -> do- $(logDebugS) "BlockStore" $- "Deleting tx: " <> txHashToHex th- getSpenders th >>= \case- m- | I.null m -> commitDelTx td- | otherwise -> do- $(logErrorS) "BlockStore" $- "Tried to delete spent tx: "- <> txHashToHex th- throwError TxSpent--commitDelTx :: MonadImport m => TxData -> m ()-commitDelTx = commitModTx False--commitAddTx :: MonadImport m => TxData -> m ()-commitAddTx = commitModTx True--commitModTx :: MonadImport m => Bool -> TxData -> m ()-commitModTx add tx_data = do- mapM_ mod_addr_tx (txDataAddresses td)- mod_outputs- mod_unspent- insertTx td- updateMempool td- where- tx = txData td- br = txDataBlock td- td = tx_data{txDataDeleted = not add}- tx_ref = TxRef br (txHash tx)- mod_addr_tx a- | add = do- insertAddrTx a tx_ref- modAddressCount add a- | otherwise = do- deleteAddrTx a tx_ref- modAddressCount add a- mod_unspent- | add = spendOutputs tx- | otherwise = unspendOutputs tx- mod_outputs- | add = addOutputs br tx- | otherwise = delOutputs br tx--updateMempool :: MonadImport m => TxData -> m ()-updateMempool td@TxData{txDataDeleted = True} =- deleteFromMempool (txHash (txData td))-updateMempool td@TxData{txDataBlock = MemRef t} =- addToMempool (txHash (txData td)) t-updateMempool td@TxData{txDataBlock = BlockRef{}} =- deleteFromMempool (txHash (txData td))--spendOutputs :: MonadImport m => Tx -> m ()-spendOutputs tx =- zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx)--addOutputs :: MonadImport m => BlockRef -> Tx -> m ()-addOutputs br tx =- zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx)--isRBF ::- StoreReadBase m =>- BlockRef ->- Tx ->- m Bool-isRBF br tx- | confirmed br = return False- | otherwise =- getNetwork >>= \net ->- if getReplaceByFee net- then go- else return False- where- go- | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True- | otherwise = carry_on- carry_on =- let hs = nub' $ map (outPointHash . prevOutput) (txIn tx)- ck [] = return False- ck (h : hs') =- getActiveTxData h >>= \case- Nothing -> return False- Just t- | confirmed (txDataBlock t) -> ck hs'- | txDataRBF t -> return True- | otherwise -> ck hs'- in ck hs--addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()-addOutput = modOutput True--delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()-delOutput = modOutput False--modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m ()-modOutput add br op o = do- mod_unspent- forM_ ma $ \a -> do- mod_addr_unspent a u- modBalance (confirmed br) add a (outValue o)- modifyReceived a v- where- v- | add = (+ outValue o)- | otherwise = subtract (outValue o)- ma = eitherToMaybe (scriptToAddressBS (scriptOutput o))- u =- Unspent- { unspentScript = scriptOutput o- , unspentBlock = br- , unspentPoint = op- , unspentAmount = outValue o- , unspentAddress = ma- }- mod_unspent- | add = insertUnspent u- | otherwise = deleteUnspent op- mod_addr_unspent- | add = insertAddrUnspent- | otherwise = deleteAddrUnspent--delOutputs :: MonadImport m => BlockRef -> Tx -> m ()-delOutputs br tx =- forM_ (zip [0 ..] (txOut tx)) $ \(i, o) -> do- let op = OutPoint (txHash tx) i- delOutput br op o--getImportTxData :: MonadImport m => TxHash -> m TxData-getImportTxData th =- getActiveTxData th >>= \case- Nothing -> do- $(logDebugS) "BlockStore" $ "Tx not found: " <> txHashToHex th- throwError TxNotFound- Just d -> return d--getTxOut :: Word32 -> Tx -> Maybe TxOut-getTxOut i tx = do- guard (fromIntegral i < length (txOut tx))- return $ txOut tx !! fromIntegral i--spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m ()-spendOutput th ix op = do- u <-- getUnspent op >>= \case- Just u -> return u- Nothing -> error $ "Could not find UTXO to spend: " <> show op- deleteUnspent op- insertSpender op (Spender th ix)- let pk = unspentScript u- forM_ (scriptToAddressBS pk) $ \a -> do- decreaseBalance- (confirmed (unspentBlock u))- a- (unspentAmount u)- deleteAddrUnspent a u--unspendOutputs :: MonadImport m => Tx -> m ()-unspendOutputs = mapM_ unspendOutput . prevOuts--unspendOutput :: MonadImport m => OutPoint -> m ()-unspendOutput op = do- t <-- getActiveTxData (outPointHash op) >>= \case- Nothing -> error $ "Could not find tx data: " <> show (outPointHash op)- Just t -> return t- let o =- fromMaybe- (error ("Could not find output: " <> show op))- (getTxOut (outPointIndex op) (txData t))- m = eitherToMaybe (scriptToAddressBS (scriptOutput o))- u =- Unspent- { unspentAmount = outValue o- , unspentBlock = txDataBlock t- , unspentScript = scriptOutput o- , unspentPoint = op- , unspentAddress = m- }- deleteSpender op- insertUnspent u- forM_ m $ \a -> do- insertAddrUnspent a u- increaseBalance (confirmed (unspentBlock u)) a (outValue o)--modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m ()-modifyReceived a f = do- b <- getDefaultBalance a- setBalance b{balanceTotalReceived = f (balanceTotalReceived b)}--decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()-decreaseBalance conf = modBalance conf False--increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()-increaseBalance conf = modBalance conf True--modBalance ::- MonadImport m =>- -- | confirmed- Bool ->- -- | add- Bool ->- Address ->- Word64 ->- m ()-modBalance conf add a val = do- b <- getDefaultBalance a- setBalance $ (g . f) b- where- g b = b{balanceUnspentCount = m 1 (balanceUnspentCount b)}- f b- | conf = b{balanceAmount = m val (balanceAmount b)}- | otherwise = b{balanceZero = m val (balanceZero b)}- m- | add = (+)- | otherwise = subtract--modAddressCount :: MonadImport m => Bool -> Address -> m ()-modAddressCount add a = do- b <- getDefaultBalance a- setBalance b{balanceTxCount = f (balanceTxCount b)}- where- f- | add = (+ 1)- | otherwise = subtract 1--txOutAddrs :: [TxOut] -> [Address]-txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput)--txInAddrs :: [Prev] -> [Address]-txInAddrs = nub' . rights . map (scriptToAddressBS . prevScript)--txDataAddresses :: TxData -> [Address]-txDataAddresses t =- nub' $ txInAddrs prevs <> txOutAddrs outs+module Haskoin.Store.Logic+ ( ImportException (..),+ MonadImport,+ initBest,+ revertBlock,+ importBlock,+ newMempoolTx,+ deleteUnconfirmedTx,+ )+where++import Control.Monad+ ( forM,+ forM_,+ guard,+ unless,+ void,+ when,+ zipWithM_,+ (<=<),+ )+import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Logger+ ( MonadLoggerIO (..),+ logDebugS,+ logErrorS,+ )+import qualified Data.ByteString as B+import Data.Either (rights)+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import qualified Data.IntMap.Strict as I+import Data.List (nub)+import Data.Maybe+ ( catMaybes,+ fromMaybe,+ isJust,+ isNothing,+ )+import Data.Serialize (encode)+import Data.String.Conversions (cs)+import Data.Word (Word32, Word64)+import Haskoin+ ( Address,+ Block (..),+ BlockHash,+ BlockHeader (..),+ BlockNode (..),+ Network (..),+ OutPoint (..),+ Tx (..),+ TxHash,+ TxIn (..),+ TxOut (..),+ blockHashToHex,+ computeSubsidy,+ eitherToMaybe,+ genesisBlock,+ genesisNode,+ headerHash,+ isGenesis,+ nullOutPoint,+ scriptToAddressBS,+ txHash,+ txHashToHex,+ )+import Haskoin.Store.Common+import Haskoin.Store.Data+ ( Balance (..),+ BlockData (..),+ BlockRef (..),+ Prev (..),+ Spender (..),+ TxData (..),+ TxRef (..),+ UnixTime,+ Unspent (..),+ confirmed,+ )+import UnliftIO (Exception)++type MonadImport m =+ ( MonadError ImportException m,+ MonadLoggerIO m,+ StoreReadBase m,+ StoreWrite m+ )++data ImportException+ = PrevBlockNotBest+ | Orphan+ | UnexpectedCoinbase+ | BestBlockNotFound+ | BlockNotBest+ | TxNotFound+ | DoubleSpend+ | TxConfirmed+ | InsufficientFunds+ | DuplicatePrevOutput+ | TxSpent+ deriving (Eq, Ord, Exception)++instance Show ImportException where+ show PrevBlockNotBest = "Previous block not best"+ show Orphan = "Orphan"+ show UnexpectedCoinbase = "Unexpected coinbase"+ show BestBlockNotFound = "Best block not found"+ show BlockNotBest = "Block not best"+ show TxNotFound = "Transaction not found"+ show DoubleSpend = "Double spend"+ show TxConfirmed = "Transaction confirmed"+ show InsufficientFunds = "Insufficient funds"+ show DuplicatePrevOutput = "Duplicate previous output"+ show TxSpent = "Transaction is spent"++initBest :: MonadImport m => m ()+initBest = do+ $(logDebugS) "BlockStore" "Initializing best block"+ net <- getNetwork+ m <- getBestBlock+ when (isNothing m) . void $ do+ $(logDebugS) "BlockStore" "Importing Genesis block"+ importBlock (genesisBlock net) (genesisNode net)++newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool+newMempoolTx tx w =+ getActiveTxData (txHash tx) >>= \case+ Just _ ->+ return False+ Nothing -> do+ freeOutputs True True tx+ rbf <- isRBF (MemRef w) tx+ checkNewTx tx+ importTx (MemRef w) w rbf tx+ return True++bestBlockData :: MonadImport m => m BlockData+bestBlockData = do+ h <-+ getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Best block unknown"+ throwError BestBlockNotFound+ Just h -> return h+ getBlock h >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Best block not found"+ throwError BestBlockNotFound+ Just b -> return b++revertBlock :: MonadImport m => BlockHash -> m ()+revertBlock bh = do+ bd <-+ bestBlockData >>= \b ->+ if headerHash (blockDataHeader b) == bh+ then return b+ else do+ $(logErrorS) "BlockStore" $+ "Cannot revert non-head block: " <> blockHashToHex bh+ throwError BlockNotBest+ $(logDebugS) "BlockStore" $+ "Obtained block data for " <> blockHashToHex bh+ tds <- mapM getImportTxData (blockDataTxs bd)+ $(logDebugS) "BlockStore" $+ "Obtained import tx data for block " <> blockHashToHex bh+ setBest (prevBlock (blockDataHeader bd))+ $(logDebugS) "BlockStore" $+ "Set parent as best block "+ <> blockHashToHex (prevBlock (blockDataHeader bd))+ insertBlock bd {blockDataMainChain = False}+ $(logDebugS) "BlockStore" $+ "Updated as not in main chain: " <> blockHashToHex bh+ forM_ (tail tds) unConfirmTx+ $(logDebugS) "BlockStore" $+ "Unconfirmed " <> cs (show (length tds)) <> " transactions"+ deleteConfirmedTx (txHash (txData (head tds)))+ $(logDebugS) "BlockStore" $+ "Deleted coinbase: " <> txHashToHex (txHash (txData (head tds)))++checkNewBlock :: MonadImport m => Block -> BlockNode -> m ()+checkNewBlock b n =+ getBestBlock >>= \case+ Nothing+ | isGenesis n -> return ()+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Cannot import non-genesis block: "+ <> blockHashToHex (headerHash (blockHeader b))+ throwError BestBlockNotFound+ Just h+ | prevBlock (blockHeader b) == h -> return ()+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Block does not build on head: "+ <> blockHashToHex (headerHash (blockHeader b))+ throwError PrevBlockNotBest++importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m ()+importOrConfirm bn txns = do+ mapM_ (freeOutputs True False . snd) (reverse txs)+ mapM_ (uncurry action) txs+ where+ txs = sortTxs txns+ br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i}+ bn_time = fromIntegral . blockTimestamp $ nodeHeader bn+ action i tx =+ testPresent tx >>= \case+ False -> import_it i tx+ True -> confirm_it i tx+ confirm_it i tx =+ getActiveTxData (txHash tx) >>= \case+ Just t -> do+ $(logDebugS) "BlockStore" $+ "Confirming tx: "+ <> txHashToHex (txHash tx)+ confirmTx t (br i)+ return Nothing+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Cannot find tx to confirm: "+ <> txHashToHex (txHash tx)+ throwError TxNotFound+ import_it i tx = do+ $(logDebugS) "BlockStore" $+ "Importing tx: " <> txHashToHex (txHash tx)+ importTx (br i) bn_time False tx+ return Nothing++importBlock :: MonadImport m => Block -> BlockNode -> m ()+importBlock b n = do+ $(logDebugS) "BlockStore" $+ "Checking new block: "+ <> blockHashToHex (headerHash (nodeHeader n))+ checkNewBlock b n+ $(logDebugS) "BlockStore" "Passed check"+ net <- getNetwork+ let subsidy = computeSubsidy net (nodeHeight n)+ bs <- getBlocksAtHeight (nodeHeight n)+ $(logDebugS) "BlockStore" $+ "Inserting block entries for: "+ <> blockHashToHex (headerHash (nodeHeader n))+ insertBlock+ BlockData+ { blockDataHeight = nodeHeight n,+ blockDataMainChain = True,+ blockDataWork = nodeWork n,+ blockDataHeader = nodeHeader n,+ blockDataSize = fromIntegral (B.length (encode b)),+ blockDataTxs = map txHash (blockTxns b),+ blockDataWeight = if getSegWit net then w else 0,+ blockDataSubsidy = subsidy,+ blockDataFees = cb_out_val - subsidy,+ blockDataOutputs = ts_out_val+ }+ setBlocksAtHeight+ (nub (headerHash (nodeHeader n) : bs))+ (nodeHeight n)+ setBest (headerHash (nodeHeader n))+ importOrConfirm n (blockTxns b)+ $(logDebugS) "BlockStore" $+ "Finished importing transactions for: "+ <> blockHashToHex (headerHash (nodeHeader n))+ where+ cb_out_val =+ sum $ map outValue $ txOut $ head $ blockTxns b+ ts_out_val =+ sum $ map (sum . map outValue . txOut) $ tail $ blockTxns b+ w =+ let f t = t {txWitness = []}+ b' = b {blockTxns = map f (blockTxns b)}+ x = B.length (encode b)+ s = B.length (encode b')+ in fromIntegral $ s * 3 + x++checkNewTx :: MonadImport m => Tx -> m ()+checkNewTx tx = do+ when (unique_inputs < length (txIn tx)) $ do+ $(logErrorS) "BlockStore" $+ "Transaction spends same output twice: "+ <> txHashToHex (txHash tx)+ throwError DuplicatePrevOutput+ us <- getUnspentOutputs tx+ when (any isNothing us) $ do+ $(logErrorS) "BlockStore" $+ "Orphan: " <> txHashToHex (txHash tx)+ throwError Orphan+ when (isCoinbase tx) $ do+ $(logErrorS) "BlockStore" $+ "Coinbase cannot be imported into mempool: "+ <> txHashToHex (txHash tx)+ throwError UnexpectedCoinbase+ when (length (prevOuts tx) > length us) $ do+ $(logErrorS) "BlockStore" $+ "Orphan: " <> txHashToHex (txHash tx)+ throwError Orphan+ when (outputs > unspents us) $ do+ $(logErrorS) "BlockStore" $+ "Insufficient funds for tx: " <> txHashToHex (txHash tx)+ throwError InsufficientFunds+ where+ unspents = sum . map unspentAmount . catMaybes+ outputs = sum (map outValue (txOut tx))+ unique_inputs = length (nub' (map prevOutput (txIn tx)))++getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent]+getUnspentOutputs tx = mapM getUnspent (prevOuts tx)++prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData+prepareTxData rbf br tt tx us =+ TxData+ { txDataBlock = br,+ txData = tx,+ txDataPrevs = ps,+ txDataDeleted = False,+ txDataRBF = rbf,+ txDataTime = tt+ }+ where+ mkprv u = Prev (unspentScript u) (unspentAmount u)+ ps = I.fromList $ zip [0 ..] $ map mkprv us++importTx ::+ MonadImport m =>+ BlockRef ->+ -- | unix time+ Word64 ->+ -- | RBF+ Bool ->+ Tx ->+ m ()+importTx br tt rbf tx = do+ mus <- getUnspentOutputs tx+ us <- forM mus $ \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Attempted to import a tx missing UTXO: "+ <> txHashToHex (txHash tx)+ throwError Orphan+ Just u -> return u+ let td = prepareTxData rbf br tt tx us+ commitAddTx td++unConfirmTx :: MonadImport m => TxData -> m ()+unConfirmTx t = confTx t Nothing++confirmTx :: MonadImport m => TxData -> BlockRef -> m ()+confirmTx t br = confTx t (Just br)++replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m ()+replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do+ deleteAddrTx+ a+ TxRef+ { txRefBlock = txDataBlock t,+ txRefHash = txHash (txData t)+ }+ insertAddrTx+ a+ TxRef+ { txRefBlock = new,+ txRefHash = txHash (txData t)+ }++adjustAddressOutput ::+ MonadImport m =>+ OutPoint ->+ TxOut ->+ BlockRef ->+ BlockRef ->+ m ()+adjustAddressOutput op o old new = do+ let pk = scriptOutput o+ getUnspent op >>= \case+ Nothing -> return ()+ Just u -> do+ unless (unspentBlock u == old) $+ error $ "Existing unspent block bad for output: " <> show op+ replace_unspent pk+ where+ replace_unspent pk = do+ let ma = eitherToMaybe (scriptToAddressBS pk)+ deleteUnspent op+ insertUnspent+ Unspent+ { unspentBlock = new,+ unspentPoint = op,+ unspentAmount = outValue o,+ unspentScript = pk,+ unspentAddress = ma+ }+ forM_ ma $ replace_addr_unspent pk+ replace_addr_unspent pk a = do+ deleteAddrUnspent+ a+ Unspent+ { unspentBlock = old,+ unspentPoint = op,+ unspentAmount = outValue o,+ unspentScript = pk,+ unspentAddress = Just a+ }+ insertAddrUnspent+ a+ Unspent+ { unspentBlock = new,+ unspentPoint = op,+ unspentAmount = outValue o,+ unspentScript = pk,+ unspentAddress = Just a+ }+ decreaseBalance (confirmed old) a (outValue o)+ increaseBalance (confirmed new) a (outValue o)++confTx :: MonadImport m => TxData -> Maybe BlockRef -> m ()+confTx t mbr = do+ replaceAddressTx t new+ forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do+ let op = OutPoint (txHash (txData t)) n+ adjustAddressOutput op o old new+ rbf <- isRBF new (txData t)+ let td = t {txDataBlock = new, txDataRBF = rbf}+ insertTx td+ updateMempool td+ where+ new = fromMaybe (MemRef (txDataTime t)) mbr+ old = txDataBlock t++freeOutputs ::+ MonadImport m =>+ -- | only delete transaction if unconfirmed+ Bool ->+ -- | only delete RBF+ Bool ->+ Tx ->+ m ()+freeOutputs memonly rbfcheck tx = do+ let prevs = prevOuts tx+ unspents <- mapM getUnspent prevs+ let spents = [p | (p, Nothing) <- zip prevs unspents]+ spndrs <- catMaybes <$> mapM getSpender spents+ let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs+ mapM_ (deleteTx memonly rbfcheck) $ HashSet.toList txids++deleteConfirmedTx :: MonadImport m => TxHash -> m ()+deleteConfirmedTx = deleteTx False False++deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m ()+deleteUnconfirmedTx rbfcheck th =+ getActiveTxData th >>= \case+ Just _ -> deleteTx True rbfcheck th+ Nothing ->+ $(logDebugS) "BlockStore" $+ "Not found or already deleted: " <> txHashToHex th++deleteTx ::+ MonadImport m =>+ -- | only delete transaction if unconfirmed+ Bool ->+ -- | only delete RBF+ Bool ->+ TxHash ->+ m ()+deleteTx memonly rbfcheck th = do+ chain <- getChain memonly rbfcheck th+ $(logDebugS) "BlockStore" $+ "Deleting " <> cs (show (length chain))+ <> " txs from chain leading to "+ <> txHashToHex th+ mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain++getChain ::+ (MonadImport m, MonadLoggerIO m) =>+ -- | only delete transaction if unconfirmed+ Bool ->+ -- | only delete RBF+ Bool ->+ TxHash ->+ m [Tx]+getChain memonly rbfcheck th' = do+ $(logDebugS) "BlockStore" $+ "Getting chain for tx " <> txHashToHex th'+ sort_clean <$> go HashSet.empty (HashSet.singleton th')+ where+ sort_clean = reverse . map snd . sortTxs+ get_tx th =+ getActiveTxData th >>= \case+ Nothing -> do+ $(logDebugS) "BlockStore" $+ "Transaction not found: " <> txHashToHex th+ return Nothing+ Just td+ | memonly && confirmed (txDataBlock td) -> do+ $(logErrorS) "BlockStore" $+ "Transaction already confirmed: "+ <> txHashToHex th+ throwError TxConfirmed+ | rbfcheck ->+ isRBF (txDataBlock td) (txData td) >>= \case+ True -> return $ Just $ txData td+ False -> do+ $(logErrorS) "BlockStore" $+ "Double-spending transaction: "+ <> txHashToHex th+ throwError DoubleSpend+ | otherwise -> return $ Just $ txData td+ go txs pdg = do+ txs1 <- HashSet.fromList . catMaybes <$> mapM get_tx (HashSet.toList pdg)+ pdg1 <-+ HashSet.fromList . concatMap (map spenderHash . I.elems)+ <$> mapM getSpenders (HashSet.toList pdg)+ let txs' = txs1 <> txs+ pdg' = pdg1 `HashSet.difference` HashSet.map txHash txs'+ if HashSet.null pdg'+ then return $ HashSet.toList txs'+ else go txs' pdg'++deleteSingleTx :: MonadImport m => TxHash -> m ()+deleteSingleTx th =+ getActiveTxData th >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Already deleted: " <> txHashToHex th+ throwError TxNotFound+ Just td -> do+ $(logDebugS) "BlockStore" $+ "Deleting tx: " <> txHashToHex th+ getSpenders th >>= \case+ m+ | I.null m -> commitDelTx td+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Tried to delete spent tx: "+ <> txHashToHex th+ throwError TxSpent++commitDelTx :: MonadImport m => TxData -> m ()+commitDelTx = commitModTx False++commitAddTx :: MonadImport m => TxData -> m ()+commitAddTx = commitModTx True++commitModTx :: MonadImport m => Bool -> TxData -> m ()+commitModTx add tx_data = do+ mapM_ mod_addr_tx (txDataAddresses td)+ mod_outputs+ mod_unspent+ insertTx td+ updateMempool td+ where+ tx = txData td+ br = txDataBlock td+ td = tx_data {txDataDeleted = not add}+ tx_ref = TxRef br (txHash tx)+ mod_addr_tx a+ | add = do+ insertAddrTx a tx_ref+ modAddressCount add a+ | otherwise = do+ deleteAddrTx a tx_ref+ modAddressCount add a+ mod_unspent+ | add = spendOutputs tx+ | otherwise = unspendOutputs tx+ mod_outputs+ | add = addOutputs br tx+ | otherwise = delOutputs br tx++updateMempool :: MonadImport m => TxData -> m ()+updateMempool td@TxData {txDataDeleted = True} =+ deleteFromMempool (txHash (txData td))+updateMempool td@TxData {txDataBlock = MemRef t} =+ addToMempool (txHash (txData td)) t+updateMempool td@TxData {txDataBlock = BlockRef {}} =+ deleteFromMempool (txHash (txData td))++spendOutputs :: MonadImport m => Tx -> m ()+spendOutputs tx =+ zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx)++addOutputs :: MonadImport m => BlockRef -> Tx -> m ()+addOutputs br tx =+ zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx)++isRBF ::+ StoreReadBase m =>+ BlockRef ->+ Tx ->+ m Bool+isRBF br tx+ | confirmed br = return False+ | otherwise =+ getNetwork >>= \net ->+ if getReplaceByFee net+ then go+ else return False+ where+ go+ | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True+ | otherwise = carry_on+ carry_on =+ let hs = nub' $ map (outPointHash . prevOutput) (txIn tx)+ ck [] = return False+ ck (h : hs') =+ getActiveTxData h >>= \case+ Nothing -> return False+ Just t+ | confirmed (txDataBlock t) -> ck hs'+ | txDataRBF t -> return True+ | otherwise -> ck hs'+ in ck hs++addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()+addOutput = modOutput True++delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()+delOutput = modOutput False++modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m ()+modOutput add br op o = do+ mod_unspent+ forM_ ma $ \a -> do+ mod_addr_unspent a u+ modBalance (confirmed br) add a (outValue o)+ modifyReceived a v+ where+ v+ | add = (+ outValue o)+ | otherwise = subtract (outValue o)+ ma = eitherToMaybe (scriptToAddressBS (scriptOutput o))+ u =+ Unspent+ { unspentScript = scriptOutput o,+ unspentBlock = br,+ unspentPoint = op,+ unspentAmount = outValue o,+ unspentAddress = ma+ }+ mod_unspent+ | add = insertUnspent u+ | otherwise = deleteUnspent op+ mod_addr_unspent+ | add = insertAddrUnspent+ | otherwise = deleteAddrUnspent++delOutputs :: MonadImport m => BlockRef -> Tx -> m ()+delOutputs br tx =+ forM_ (zip [0 ..] (txOut tx)) $ \(i, o) -> do+ let op = OutPoint (txHash tx) i+ delOutput br op o++getImportTxData :: MonadImport m => TxHash -> m TxData+getImportTxData th =+ getActiveTxData th >>= \case+ Nothing -> do+ $(logDebugS) "BlockStore" $ "Tx not found: " <> txHashToHex th+ throwError TxNotFound+ Just d -> return d++getTxOut :: Word32 -> Tx -> Maybe TxOut+getTxOut i tx = do+ guard (fromIntegral i < length (txOut tx))+ return $ txOut tx !! fromIntegral i++spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m ()+spendOutput th ix op = do+ u <-+ getUnspent op >>= \case+ Just u -> return u+ Nothing -> error $ "Could not find UTXO to spend: " <> show op+ deleteUnspent op+ insertSpender op (Spender th ix)+ let pk = unspentScript u+ forM_ (scriptToAddressBS pk) $ \a -> do+ decreaseBalance+ (confirmed (unspentBlock u))+ a+ (unspentAmount u)+ deleteAddrUnspent a u++unspendOutputs :: MonadImport m => Tx -> m ()+unspendOutputs = mapM_ unspendOutput . prevOuts++unspendOutput :: MonadImport m => OutPoint -> m ()+unspendOutput op = do+ t <-+ getActiveTxData (outPointHash op) >>= \case+ Nothing -> error $ "Could not find tx data: " <> show (outPointHash op)+ Just t -> return t+ let o =+ fromMaybe+ (error ("Could not find output: " <> show op))+ (getTxOut (outPointIndex op) (txData t))+ m = eitherToMaybe (scriptToAddressBS (scriptOutput o))+ u =+ Unspent+ { unspentAmount = outValue o,+ unspentBlock = txDataBlock t,+ unspentScript = scriptOutput o,+ unspentPoint = op,+ unspentAddress = m+ }+ deleteSpender op+ insertUnspent u+ forM_ m $ \a -> do+ insertAddrUnspent a u+ increaseBalance (confirmed (unspentBlock u)) a (outValue o)++modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m ()+modifyReceived a f = do+ b <- getDefaultBalance a+ setBalance b {balanceTotalReceived = f (balanceTotalReceived b)}++decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()+decreaseBalance conf = modBalance conf False++increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()+increaseBalance conf = modBalance conf True++modBalance ::+ MonadImport m =>+ -- | confirmed+ Bool ->+ -- | add+ Bool ->+ Address ->+ Word64 ->+ m ()+modBalance conf add a val = do+ b <- getDefaultBalance a+ setBalance $ (g . f) b+ where+ g b = b {balanceUnspentCount = m 1 (balanceUnspentCount b)}+ f b+ | conf = b {balanceAmount = m val (balanceAmount b)}+ | otherwise = b {balanceZero = m val (balanceZero b)}+ m+ | add = (+)+ | otherwise = subtract++modAddressCount :: MonadImport m => Bool -> Address -> m ()+modAddressCount add a = do+ b <- getDefaultBalance a+ setBalance b {balanceTxCount = f (balanceTxCount b)}+ where+ f+ | add = (+ 1)+ | otherwise = subtract 1++txOutAddrs :: [TxOut] -> [Address]+txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput)++txInAddrs :: [Prev] -> [Address]+txInAddrs = nub' . rights . map (scriptToAddressBS . prevScript)++txDataAddresses :: TxData -> [Address]+txDataAddresses t =+ nub' $ txInAddrs prevs <> txOutAddrs outs where prevs = I.elems (txDataPrevs t) outs = txOut (txData t)
src/Haskoin/Store/Manager.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} -module Haskoin.Store.Manager (- StoreConfig (..),+module Haskoin.Store.Manager+ ( StoreConfig (..), Store (..), withStore,-) where+ )+where import Control.Monad (forever, unless, when) import Control.Monad.Logger (MonadLoggerIO)@@ -12,8 +13,8 @@ import Data.Serialize (decode) import Data.Time.Clock (NominalDiffTime) import Data.Word (Word32)-import Haskoin (- BlockHash (..),+import Haskoin+ ( BlockHash (..), Inv (..), InvType (..), InvVector (..),@@ -27,9 +28,9 @@ TxHash (..), VarString (..), sockToHostAddress,- )-import Haskoin.Node (- Chain,+ )+import Haskoin.Node+ ( Chain, ChainEvent (..), HostPort, Node (..),@@ -39,9 +40,9 @@ PeerManager, WithConnection, withNode,- )-import Haskoin.Store.BlockStore (- BlockStore,+ )+import Haskoin.Store.BlockStore+ ( BlockStore, BlockStoreConfig (..), blockStoreBlockSTM, blockStoreHeadSTM,@@ -51,27 +52,27 @@ blockStoreTxHashSTM, blockStoreTxSTM, withBlockStore,- )-import Haskoin.Store.Cache (- CacheConfig (..),+ )+import Haskoin.Store.Cache+ ( CacheConfig (..), CacheWriter, cacheNewBlock, cacheNewTx, cacheWriter, connectRedis, newCacheMetrics,- )-import Haskoin.Store.Common (- StoreEvent (..),+ )+import Haskoin.Store.Common+ ( StoreEvent (..), createDataMetrics,- )-import Haskoin.Store.Database.Reader (- DatabaseReader (..),+ )+import Haskoin.Store.Database.Reader+ ( DatabaseReader (..), DatabaseReaderT, withDatabaseReader,- )-import NQE (- Inbox,+ )+import NQE+ ( Inbox, Process (..), Publisher, publishSTM,@@ -79,199 +80,199 @@ withProcess, withPublisher, withSubscription,- )+ ) import Network.Socket (SockAddr (..)) import qualified System.Metrics as Metrics (Store)-import UnliftIO (- MonadIO,+import UnliftIO+ ( MonadIO, MonadUnliftIO, STM, atomically, link, withAsync,- )+ ) import UnliftIO.Concurrent (threadDelay) -- | Store mailboxes. data Store = Store- { storeManager :: !PeerManager- , storeChain :: !Chain- , storeBlock :: !BlockStore- , storeDB :: !DatabaseReader- , storeCache :: !(Maybe CacheConfig)- , storePublisher :: !(Publisher StoreEvent)- , storeNetwork :: !Network- }+ { storeManager :: !PeerManager,+ storeChain :: !Chain,+ storeBlock :: !BlockStore,+ storeDB :: !DatabaseReader,+ storeCache :: !(Maybe CacheConfig),+ storePublisher :: !(Publisher StoreEvent),+ storeNetwork :: !Network+ } -- | Configuration for a 'Store'. data StoreConfig = StoreConfig- { -- | max peers to connect to- storeConfMaxPeers :: !Int- , -- | static set of peers to connect to- storeConfInitPeers :: ![HostPort]- , -- | discover new peers- storeConfDiscover :: !Bool- , -- | RocksDB database path- storeConfDB :: !FilePath- , -- | network constants- storeConfNetwork :: !Network- , -- | Redis cache configuration- storeConfCache :: !(Maybe String)- , -- | gap on extended public key with no transactions- storeConfInitialGap :: !Word32- , -- | gap for extended public keys- storeConfGap :: !Word32- , -- | cache xpubs with more than this many used addresses- storeConfCacheMin :: !Int- , -- | maximum number of keys in Redis cache- storeConfMaxKeys :: !Integer- , -- | do not index new mempool transactions- storeConfNoMempool :: !Bool- , -- | wipe mempool when starting- storeConfWipeMempool :: !Bool- , -- | sync mempool from peers- storeConfSyncMempool :: !Bool- , -- | disconnect peer if message not received for this many seconds- storeConfPeerTimeout :: !NominalDiffTime- , -- | disconnect peer if it has been connected this long- storeConfPeerMaxLife :: !NominalDiffTime- , -- | connect to peers using the function 'withConnection'- storeConfConnect :: !(SockAddr -> WithConnection)- , -- | delay in microseconds to retry getting cache lock- storeConfCacheRetryDelay :: !Int- , -- | stats store- storeConfStats :: !(Maybe Metrics.Store)- }+ { -- | max peers to connect to+ storeConfMaxPeers :: !Int,+ -- | static set of peers to connect to+ storeConfInitPeers :: ![HostPort],+ -- | discover new peers+ storeConfDiscover :: !Bool,+ -- | RocksDB database path+ storeConfDB :: !FilePath,+ -- | network constants+ storeConfNetwork :: !Network,+ -- | Redis cache configuration+ storeConfCache :: !(Maybe String),+ -- | gap on extended public key with no transactions+ storeConfInitialGap :: !Word32,+ -- | gap for extended public keys+ storeConfGap :: !Word32,+ -- | cache xpubs with more than this many used addresses+ storeConfCacheMin :: !Int,+ -- | maximum number of keys in Redis cache+ storeConfMaxKeys :: !Integer,+ -- | do not index new mempool transactions+ storeConfNoMempool :: !Bool,+ -- | wipe mempool when starting+ storeConfWipeMempool :: !Bool,+ -- | sync mempool from peers+ storeConfSyncMempool :: !Bool,+ -- | disconnect peer if message not received for this many seconds+ storeConfPeerTimeout :: !NominalDiffTime,+ -- | disconnect peer if it has been connected this long+ storeConfPeerMaxLife :: !NominalDiffTime,+ -- | connect to peers using the function 'withConnection'+ storeConfConnect :: !(SockAddr -> WithConnection),+ -- | delay in microseconds to retry getting cache lock+ storeConfCacheRetryDelay :: !Int,+ -- | stats store+ storeConfStats :: !(Maybe Metrics.Store)+ } withStore ::- (MonadLoggerIO m, MonadUnliftIO m) =>- StoreConfig ->- (Store -> m a) ->- m a+ (MonadLoggerIO m, MonadUnliftIO m) =>+ StoreConfig ->+ (Store -> m a) ->+ m a withStore cfg action =- connectDB cfg $- ReaderT $ \db ->- withPublisher $ \pub ->- withPublisher $ \node_pub ->- withSubscription node_pub $ \node_sub ->- withNode (nodeCfg cfg db node_pub) $ \node ->- withCache cfg (nodeChain node) db pub $ \mcache ->- withBlockStore (blockStoreCfg cfg node pub db) $ \b ->- withAsync (nodeForwarder b pub node_sub) $ \a1 ->- link a1- >> action- Store- { storeManager = nodeManager node- , storeChain = nodeChain node- , storeBlock = b- , storeDB = db- , storeCache = mcache- , storePublisher = pub- , storeNetwork = storeConfNetwork cfg- }+ connectDB cfg $+ ReaderT $ \db ->+ withPublisher $ \pub ->+ withPublisher $ \node_pub ->+ withSubscription node_pub $ \node_sub ->+ withNode (nodeCfg cfg db node_pub) $ \node ->+ withCache cfg (nodeChain node) db pub $ \mcache ->+ withBlockStore (blockStoreCfg cfg node pub db) $ \b ->+ withAsync (nodeForwarder b pub node_sub) $ \a1 ->+ link a1+ >> action+ Store+ { storeManager = nodeManager node,+ storeChain = nodeChain node,+ storeBlock = b,+ storeDB = db,+ storeCache = mcache,+ storePublisher = pub,+ storeNetwork = storeConfNetwork cfg+ } connectDB :: MonadUnliftIO m => StoreConfig -> DatabaseReaderT m a -> m a connectDB cfg f = do- stats <- mapM createDataMetrics (storeConfStats cfg)- withDatabaseReader- (storeConfNetwork cfg)- (storeConfInitialGap cfg)- (storeConfGap cfg)- (storeConfDB cfg)- stats- f+ stats <- mapM createDataMetrics (storeConfStats cfg)+ withDatabaseReader+ (storeConfNetwork cfg)+ (storeConfInitialGap cfg)+ (storeConfGap cfg)+ (storeConfDB cfg)+ stats+ f blockStoreCfg ::- StoreConfig ->- Node ->- Publisher StoreEvent ->- DatabaseReader ->- BlockStoreConfig+ StoreConfig ->+ Node ->+ Publisher StoreEvent ->+ DatabaseReader ->+ BlockStoreConfig blockStoreCfg cfg node pub db =- BlockStoreConfig- { blockConfChain = nodeChain node- , blockConfManager = nodeManager node- , blockConfListener = pub- , blockConfDB = db- , blockConfNet = storeConfNetwork cfg- , blockConfNoMempool = storeConfNoMempool cfg- , blockConfWipeMempool = storeConfWipeMempool cfg- , blockConfSyncMempool = storeConfSyncMempool cfg- , blockConfPeerTimeout = storeConfPeerTimeout cfg- , blockConfStats = storeConfStats cfg- }+ BlockStoreConfig+ { blockConfChain = nodeChain node,+ blockConfManager = nodeManager node,+ blockConfListener = pub,+ blockConfDB = db,+ blockConfNet = storeConfNetwork cfg,+ blockConfNoMempool = storeConfNoMempool cfg,+ blockConfWipeMempool = storeConfWipeMempool cfg,+ blockConfSyncMempool = storeConfSyncMempool cfg,+ blockConfPeerTimeout = storeConfPeerTimeout cfg,+ blockConfStats = storeConfStats cfg+ } nodeCfg ::- StoreConfig ->- DatabaseReader ->- Publisher NodeEvent ->- NodeConfig+ StoreConfig ->+ DatabaseReader ->+ Publisher NodeEvent ->+ NodeConfig nodeCfg cfg db pub =- NodeConfig- { nodeConfMaxPeers = storeConfMaxPeers cfg- , nodeConfDB = databaseHandle db- , nodeConfColumnFamily = Nothing- , nodeConfPeers = storeConfInitPeers cfg- , nodeConfDiscover = storeConfDiscover cfg- , nodeConfEvents = pub- , nodeConfNetAddr =- NetworkAddress- 0- (sockToHostAddress (SockAddrInet 0 0))- , nodeConfNet = storeConfNetwork cfg- , nodeConfTimeout = storeConfPeerTimeout cfg- , nodeConfPeerMaxLife = storeConfPeerMaxLife cfg- , nodeConfConnect = storeConfConnect cfg- }+ NodeConfig+ { nodeConfMaxPeers = storeConfMaxPeers cfg,+ nodeConfDB = databaseHandle db,+ nodeConfColumnFamily = Nothing,+ nodeConfPeers = storeConfInitPeers cfg,+ nodeConfDiscover = storeConfDiscover cfg,+ nodeConfEvents = pub,+ nodeConfNetAddr =+ NetworkAddress+ 0+ (sockToHostAddress (SockAddrInet 0 0)),+ nodeConfNet = storeConfNetwork cfg,+ nodeConfTimeout = storeConfPeerTimeout cfg,+ nodeConfPeerMaxLife = storeConfPeerMaxLife cfg,+ nodeConfConnect = storeConfConnect cfg+ } withCache ::- (MonadUnliftIO m, MonadLoggerIO m) =>- StoreConfig ->- Chain ->- DatabaseReader ->- Publisher StoreEvent ->- (Maybe CacheConfig -> m a) ->- m a+ (MonadUnliftIO m, MonadLoggerIO m) =>+ StoreConfig ->+ Chain ->+ DatabaseReader ->+ Publisher StoreEvent ->+ (Maybe CacheConfig -> m a) ->+ m a withCache cfg chain db pub action =- case storeConfCache cfg of- Nothing ->- action Nothing- Just redisurl ->- mapM newCacheMetrics (storeConfStats cfg) >>= \metrics ->- connectRedis redisurl >>= \conn ->- withSubscription pub $ \evts ->- let conf = c conn metrics- in withProcess (f conf) $ \p ->- cacheWriterProcesses evts (getProcessMailbox p) $ do- action (Just conf)+ case storeConfCache cfg of+ Nothing ->+ action Nothing+ Just redisurl ->+ mapM newCacheMetrics (storeConfStats cfg) >>= \metrics ->+ connectRedis redisurl >>= \conn ->+ withSubscription pub $ \evts ->+ let conf = c conn metrics+ in withProcess (f conf) $ \p ->+ cacheWriterProcesses evts (getProcessMailbox p) $ do+ action (Just conf) where f conf cwinbox = runReaderT (cacheWriter conf cwinbox) db c conn metrics =- CacheConfig- { cacheConn = conn- , cacheMin = storeConfCacheMin cfg- , cacheChain = chain- , cacheMax = storeConfMaxKeys cfg- , cacheRetryDelay = storeConfCacheRetryDelay cfg- , cacheMetrics = metrics- }+ CacheConfig+ { cacheConn = conn,+ cacheMin = storeConfCacheMin cfg,+ cacheChain = chain,+ cacheMax = storeConfMaxKeys cfg,+ cacheRetryDelay = storeConfCacheRetryDelay cfg,+ cacheMetrics = metrics+ } cacheWriterProcesses ::- MonadUnliftIO m =>- Inbox StoreEvent ->- CacheWriter ->- m a ->- m a+ MonadUnliftIO m =>+ Inbox StoreEvent ->+ CacheWriter ->+ m a ->+ m a cacheWriterProcesses evts cwm action =- withAsync events $ \a1 -> link a1 >> action+ withAsync events $ \a1 -> link a1 >> action where events = cacheWriterEvents evts cwm cacheWriterEvents :: MonadIO m => Inbox StoreEvent -> CacheWriter -> m () cacheWriterEvents evts cwm =- forever $- receive evts >>= \e ->- e `cacheWriterDispatch` cwm+ forever $+ receive evts >>= \e ->+ e `cacheWriterDispatch` cwm cacheWriterDispatch :: MonadIO m => StoreEvent -> CacheWriter -> m () cacheWriterDispatch (StoreBestBlock _) = cacheNewBlock@@ -280,58 +281,58 @@ cacheWriterDispatch _ = const (return ()) nodeForwarder ::- MonadIO m =>- BlockStore ->- Publisher StoreEvent ->- Inbox NodeEvent ->- m ()+ MonadIO m =>+ BlockStore ->+ Publisher StoreEvent ->+ Inbox NodeEvent ->+ m () nodeForwarder b pub sub =- forever $ receive sub >>= atomically . storeDispatch b pub+ forever $ receive sub >>= atomically . storeDispatch b pub -- | Dispatcher of node events. storeDispatch ::- BlockStore ->- Publisher StoreEvent ->- NodeEvent ->- STM ()+ BlockStore ->+ Publisher StoreEvent ->+ NodeEvent ->+ STM () storeDispatch b pub (PeerEvent (PeerConnected p)) = do- publishSTM (StorePeerConnected p) pub- blockStorePeerConnectSTM p b+ publishSTM (StorePeerConnected p) pub+ blockStorePeerConnectSTM p b storeDispatch b pub (PeerEvent (PeerDisconnected p)) = do- publishSTM (StorePeerDisconnected p) pub- blockStorePeerDisconnectSTM p b+ publishSTM (StorePeerDisconnected p) pub+ blockStorePeerDisconnectSTM p b storeDispatch b _ (ChainEvent (ChainBestBlock bn)) =- blockStoreHeadSTM bn b+ blockStoreHeadSTM bn b storeDispatch _ _ (ChainEvent _) =- return ()+ return () storeDispatch _ pub (PeerMessage p (MPong (Pong n))) =- publishSTM (StorePeerPong p n) pub+ publishSTM (StorePeerPong p n) pub storeDispatch b _ (PeerMessage p (MBlock block)) =- blockStoreBlockSTM p block b+ blockStoreBlockSTM p block b storeDispatch b _ (PeerMessage p (MTx tx)) =- blockStoreTxSTM p tx b+ blockStoreTxSTM p tx b storeDispatch b _ (PeerMessage p (MNotFound (NotFound is))) = do- let blocks =- [ BlockHash h- | InvVector t h <- is- , t == InvBlock || t == InvWitnessBlock- ]- unless (null blocks) $ blockStoreNotFoundSTM p blocks b+ let blocks =+ [ BlockHash h+ | InvVector t h <- is,+ t == InvBlock || t == InvWitnessBlock+ ]+ unless (null blocks) $ blockStoreNotFoundSTM p blocks b storeDispatch b pub (PeerMessage p (MInv (Inv is))) = do- let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx]- publishSTM (StoreTxAnnounce p txs) pub- unless (null txs) $ blockStoreTxHashSTM p txs b+ let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx]+ publishSTM (StoreTxAnnounce p txs) pub+ unless (null txs) $ blockStoreTxHashSTM p txs b storeDispatch _ pub (PeerMessage p (MReject r)) =- when (rejectMessage r == MCTx) $- case decode (rejectData r) of- Left _ -> return ()- Right th ->- let reject =- StoreTxReject- p- th- (rejectCode r)- (getVarString (rejectReason r))- in publishSTM reject pub+ when (rejectMessage r == MCTx) $+ case decode (rejectData r) of+ Left _ -> return ()+ Right th ->+ let reject =+ StoreTxReject+ p+ th+ (rejectCode r)+ (getVarString (rejectReason r))+ in publishSTM reject pub storeDispatch _ _ _ =- return ()+ return ()
src/Haskoin/Store/Stats.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Haskoin.Store.Stats (- StatDist,+module Haskoin.Store.Stats+ ( StatDist, withStats, createStatDist, addStatTime,@@ -10,13 +10,14 @@ addServerError, addStatQuery, addStatItems,-) where+ )+where -import Control.Concurrent.STM.TQueue (- TQueue,+import Control.Concurrent.STM.TQueue+ ( TQueue, flushTQueue, writeTQueue,- )+ ) import qualified Control.Foldl as L import Control.Monad (forever) import Data.Function (on)@@ -28,24 +29,24 @@ import Data.Ord (Down (..), comparing) import Data.String.Conversions (cs) import Data.Text (Text)-import System.Metrics (- Store,+import System.Metrics+ ( Store, Value (..), newStore, registerGcMetrics, registerGroup, sampleAll,- )-import System.Remote.Monitoring.Statsd (- defaultStatsdOptions,+ )+import System.Remote.Monitoring.Statsd+ ( defaultStatsdOptions, flushInterval, forkStatsd, host, port, prefix,- )-import UnliftIO (- MonadIO,+ )+import UnliftIO+ ( MonadIO, TVar, atomically, liftIO,@@ -54,129 +55,118 @@ newTVarIO, readTVar, withAsync,- )+ ) import UnliftIO.Concurrent (threadDelay) withStats :: MonadIO m => Text -> Int -> Text -> (Store -> m a) -> m a withStats h p pfx go = do- store <- liftIO newStore- _statsd <-- liftIO $- forkStatsd- defaultStatsdOptions- { prefix = pfx- , host = h- , port = p- }- store- liftIO $ registerGcMetrics store- go store+ store <- liftIO newStore+ _statsd <-+ liftIO $+ forkStatsd+ defaultStatsdOptions+ { prefix = pfx,+ host = h,+ port = p+ }+ store+ liftIO $ registerGcMetrics store+ go store data StatData = StatData- { statTimes :: ![Int64]- , statQueries :: !Int64- , statItems :: !Int64- , statClientErrors :: !Int64- , statServerErrors :: !Int64- }+ { statTimes :: ![Int64],+ statQueries :: !Int64,+ statItems :: !Int64,+ statClientErrors :: !Int64,+ statServerErrors :: !Int64+ } data StatDist = StatDist- { distQueue :: !(TQueue Int64)- , distQueries :: !(TVar Int64)- , distItems :: !(TVar Int64)- , distClientErrors :: !(TVar Int64)- , distServerErrors :: !(TVar Int64)- }+ { distQueue :: !(TQueue Int64),+ distQueries :: !(TVar Int64),+ distItems :: !(TVar Int64),+ distClientErrors :: !(TVar Int64),+ distServerErrors :: !(TVar Int64)+ } createStatDist :: MonadIO m => Text -> Store -> m StatDist createStatDist t store = liftIO $ do- distQueue <- newTQueueIO- distQueries <- newTVarIO 0- distItems <- newTVarIO 0- distClientErrors <- newTVarIO 0- distServerErrors <- newTVarIO 0- let metrics =- HashMap.fromList- [- ( t <> ".request_count"- , Counter . statQueries- )- ,- ( t <> ".item_count"- , Counter . statItems- )- ,- ( t <> ".client_errors"- , Counter . statClientErrors- )- ,- ( t <> ".server_errors"- , Counter . statServerErrors- )- ,- ( t <> ".mean_ms"- , Gauge . mean . statTimes- )- ,- ( t <> ".avg_ms"- , Gauge . avg . statTimes- )- ,- ( t <> ".max_ms"- , Gauge . maxi . statTimes- )- ,- ( t <> ".min_ms"- , Gauge . mini . statTimes- )- ,- ( t <> ".p90max_ms"- , Gauge . p90max . statTimes- )- ,- ( t <> ".p90avg_ms"- , Gauge . p90avg . statTimes- )- ,- ( t <> ".var_ms"- , Gauge . var . statTimes- )- ]- let sd = StatDist{..}- registerGroup metrics (flush sd) store- return sd+ distQueue <- newTQueueIO+ distQueries <- newTVarIO 0+ distItems <- newTVarIO 0+ distClientErrors <- newTVarIO 0+ distServerErrors <- newTVarIO 0+ let metrics =+ HashMap.fromList+ [ ( t <> ".request_count",+ Counter . statQueries+ ),+ ( t <> ".item_count",+ Counter . statItems+ ),+ ( t <> ".client_errors",+ Counter . statClientErrors+ ),+ ( t <> ".server_errors",+ Counter . statServerErrors+ ),+ ( t <> ".mean_ms",+ Gauge . mean . statTimes+ ),+ ( t <> ".avg_ms",+ Gauge . avg . statTimes+ ),+ ( t <> ".max_ms",+ Gauge . maxi . statTimes+ ),+ ( t <> ".min_ms",+ Gauge . mini . statTimes+ ),+ ( t <> ".p90max_ms",+ Gauge . p90max . statTimes+ ),+ ( t <> ".p90avg_ms",+ Gauge . p90avg . statTimes+ ),+ ( t <> ".var_ms",+ Gauge . var . statTimes+ )+ ]+ let sd = StatDist {..}+ registerGroup metrics (flush sd) store+ return sd toDouble :: Int64 -> Double toDouble = fromIntegral addStatTime :: MonadIO m => StatDist -> Int64 -> m () addStatTime q =- liftIO . atomically . writeTQueue (distQueue q)+ liftIO . atomically . writeTQueue (distQueue q) addStatQuery :: MonadIO m => StatDist -> m () addStatQuery q =- liftIO . atomically $ modifyTVar (distQueries q) (+ 1)+ liftIO . atomically $ modifyTVar (distQueries q) (+ 1) addStatItems :: MonadIO m => StatDist -> Int64 -> m () addStatItems q =- liftIO . atomically . modifyTVar (distItems q) . (+)+ liftIO . atomically . modifyTVar (distItems q) . (+) addClientError :: MonadIO m => StatDist -> m () addClientError q =- liftIO . atomically $ modifyTVar (distClientErrors q) (+ 1)+ liftIO . atomically $ modifyTVar (distClientErrors q) (+ 1) addServerError :: MonadIO m => StatDist -> m () addServerError q =- liftIO . atomically $ modifyTVar (distServerErrors q) (+ 1)+ liftIO . atomically $ modifyTVar (distServerErrors q) (+ 1) flush :: MonadIO m => StatDist -> m StatData-flush StatDist{..} = atomically $ do- statTimes <- flushTQueue distQueue- statQueries <- readTVar distQueries- statItems <- readTVar distItems- statClientErrors <- readTVar distClientErrors- statServerErrors <- readTVar distServerErrors- return $ StatData{..}+flush StatDist {..} = atomically $ do+ statTimes <- flushTQueue distQueue+ statQueries <- readTVar distQueries+ statItems <- readTVar distItems+ statClientErrors <- readTVar distClientErrors+ statServerErrors <- readTVar distServerErrors+ return $ StatData {..} average :: Fractional a => L.Fold a a average = (/) <$> L.sum <*> L.genericLength@@ -198,9 +188,9 @@ p90max :: [Int64] -> Int64 p90max ls =- case chopped of- [] -> 0- h : _ -> h+ case chopped of+ [] -> 0+ h : _ -> h where sorted = sortBy (comparing Down) ls len = length sorted@@ -208,7 +198,7 @@ p90avg :: [Int64] -> Int64 p90avg ls =- avg chopped+ avg chopped where sorted = sortBy (comparing Down) ls len = length sorted
src/Haskoin/Store/Web.hs view
@@ -11,3053 +11,3140 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-deprecations #-} -module Haskoin.Store.Web (- -- * Web- WebConfig (..),- Except (..),- WebLimits (..),- WebTimeouts (..),- runWeb,-) where--import Conduit (- ConduitT,- await,- concatMapC,- concatMapMC,- dropC,- dropWhileC,- headC,- mapC,- runConduit,- sinkList,- takeC,- takeWhileC,- yield,- (.|),- )-import Control.Applicative ((<|>))-import Control.Arrow (second)-import Control.Lens ((.~), (^.))-import Control.Monad (- forM_,- forever,- join,- unless,- when,- (<=<),- )-import Control.Monad.Logger (- MonadLoggerIO,- logDebugS,- logErrorS,- logWarnS,- )-import Control.Monad.Reader (- ReaderT,- asks,- local,- runReaderT,- )-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Control (liftWith, restoreT)-import Control.Monad.Trans.Maybe (- MaybeT (..),- runMaybeT,- )-import Data.Aeson (- Encoding,- ToJSON (..),- Value,- )-import qualified Data.Aeson as A-import Data.Aeson.Encode.Pretty (- Config (..),- defConfig,- encodePretty',- )-import Data.Aeson.Encoding (- encodingToLazyByteString,- list,- )-import Data.Aeson.Text (encodeToLazyText)-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Base16 as B16-import Data.ByteString.Builder (lazyByteString)-import qualified Data.ByteString.Char8 as C-import qualified Data.ByteString.Lazy as L-import Data.Bytes.Get-import Data.Bytes.Put-import Data.Bytes.Serial-import Data.Char (isSpace)-import Data.Default (Default (..))-import Data.Function ((&))-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import Data.Int (Int64)-import Data.List (nub)-import Data.Maybe (- catMaybes,- fromJust,- fromMaybe,- isJust,- mapMaybe,- maybeToList,- )-import Data.Proxy (Proxy (..))-import Data.Serialize (decode)-import Data.String (fromString)-import Data.String.Conversions (cs)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Text.Lazy (toStrict)-import qualified Data.Text.Lazy as TL-import Data.Time.Clock (diffUTCTime)-import Data.Time.Clock.System (- getSystemTime,- systemSeconds,- systemToUTCTime,- )-import qualified Data.Vault.Lazy as V-import Data.Word (Word32, Word64)-import Database.RocksDB (- Property (..),- getProperty,- )-import Haskoin.Address-import qualified Haskoin.Block as H-import Haskoin.Constants-import Haskoin.Data-import Haskoin.Keys-import Haskoin.Network-import Haskoin.Node (- Chain,- OnlinePeer (..),- PeerManager,- chainGetAncestor,- chainGetBest,- getPeers,- sendMessage,- )-import Haskoin.Script-import Haskoin.Store.BlockStore-import Haskoin.Store.Cache-import Haskoin.Store.Common-import Haskoin.Store.Data-import Haskoin.Store.Database.Reader-import Haskoin.Store.Manager-import Haskoin.Store.Stats-import Haskoin.Store.WebCommon-import Haskoin.Transaction-import Haskoin.Util-import NQE (- Inbox,- Publisher,- receive,- withSubscription,- )-import Network.HTTP.Types (- Status (..),- requestEntityTooLarge413,- status400,- status404,- status409,- status413,- status500,- status503,- statusIsClientError,- statusIsServerError,- statusIsSuccessful,- )-import Network.Wai (- Middleware,- Request (..),- Response,- getRequestBodyChunk,- responseLBS,- responseStatus,- )-import Network.Wai.Handler.Warp (- defaultSettings,- setHost,- setPort,- )-import Network.Wai.Handler.WebSockets (websocketsOr)-import Network.Wai.Middleware.RequestSizeLimit-import Network.WebSockets (- ServerApp,- acceptRequest,- defaultConnectionOptions,- pendingRequest,- rejectRequestWith,- requestPath,- sendTextData,- )-import qualified Network.WebSockets as WebSockets-import qualified Network.Wreq as Wreq-import Network.Wreq.Session as Wreq (Session)-import qualified Network.Wreq.Session as Wreq.Session-import System.IO.Unsafe (unsafeInterleaveIO)-import qualified System.Metrics as Metrics-import qualified System.Metrics.Gauge as Metrics (Gauge)-import qualified System.Metrics.Gauge as Metrics.Gauge-import UnliftIO (- MonadIO,- MonadUnliftIO,- TVar,- askRunInIO,- atomically,- bracket,- bracket_,- handleAny,- liftIO,- modifyTVar,- newTVarIO,- readTVarIO,- timeout,- withAsync,- withRunInIO,- writeTVar,- )-import UnliftIO.Concurrent (threadDelay)-import Web.Scotty.Internal.Types (ActionT)-import qualified Web.Scotty.Trans as S--type WebT m = ActionT Except (ReaderT WebState m)--data WebLimits = WebLimits- { maxLimitCount :: !Word32- , maxLimitFull :: !Word32- , maxLimitOffset :: !Word32- , maxLimitDefault :: !Word32- , maxLimitGap :: !Word32- , maxLimitInitialGap :: !Word32- , maxLimitBody :: !Word32- }- deriving (Eq, Show)--instance Default WebLimits where- def =- WebLimits- { maxLimitCount = 200000- , maxLimitFull = 5000- , maxLimitOffset = 50000- , maxLimitDefault = 100- , maxLimitGap = 32- , maxLimitInitialGap = 20- , maxLimitBody = 1024 * 1024- }--data WebConfig = WebConfig- { webHost :: !String- , webPort :: !Int- , webStore :: !Store- , webMaxDiff :: !Int- , webMaxPending :: !Int- , webMaxLimits :: !WebLimits- , webTimeouts :: !WebTimeouts- , webVersion :: !String- , webNoMempool :: !Bool- , webStats :: !(Maybe Metrics.Store)- , webPriceGet :: !Int- , webTickerURL :: !String- , webHistoryURL :: !String- }--data WebState = WebState- { webConfig :: !WebConfig- , webTicker :: !(TVar (HashMap Text BinfoTicker))- , webMetrics :: !(Maybe WebMetrics)- , webWreqSession :: !Wreq.Session- }--data WebMetrics = WebMetrics- { statAll :: !StatDist- , -- Addresses- statAddressTransactions :: !StatDist- , statAddressTransactionsFull :: !StatDist- , statAddressBalance :: !StatDist- , statAddressUnspent :: !StatDist- , statXpub :: !StatDist- , statXpubDelete :: !StatDist- , statXpubTransactionsFull :: !StatDist- , statXpubTransactions :: !StatDist- , statXpubBalances :: !StatDist- , statXpubUnspent :: !StatDist- , -- Transactions- statTransaction :: !StatDist- , statTransactionRaw :: !StatDist- , statTransactionAfter :: !StatDist- , statTransactionsBlock :: !StatDist- , statTransactionsBlockRaw :: !StatDist- , statTransactionPost :: !StatDist- , statMempool :: !StatDist- , -- Blocks- statBlock :: !StatDist- , statBlockRaw :: !StatDist- , -- Blockchain- statBlockchainMultiaddr :: !StatDist- , statBlockchainBalance :: !StatDist- , statBlockchainRawaddr :: !StatDist- , statBlockchainUnspent :: !StatDist- , statBlockchainRawtx :: !StatDist- , statBlockchainRawblock :: !StatDist- , statBlockchainMempool :: !StatDist- , statBlockchainBlockHeight :: !StatDist- , statBlockchainBlocks :: !StatDist- , statBlockchainLatestblock :: !StatDist- , statBlockchainExportHistory :: !StatDist- , -- Blockchain /q endpoints- statBlockchainQaddresstohash :: !StatDist- , statBlockchainQhashtoaddress :: !StatDist- , statBlockchainQaddrpubkey :: !StatDist- , statBlockchainQpubkeyaddr :: !StatDist- , statBlockchainQhashpubkey :: !StatDist- , statBlockchainQgetblockcount :: !StatDist- , statBlockchainQlatesthash :: !StatDist- , statBlockchainQbcperblock :: !StatDist- , statBlockchainQtxtotalbtcoutput :: !StatDist- , statBlockchainQtxtotalbtcinput :: !StatDist- , statBlockchainQtxfee :: !StatDist- , statBlockchainQtxresult :: !StatDist- , statBlockchainQgetreceivedbyaddress :: !StatDist- , statBlockchainQgetsentbyaddress :: !StatDist- , statBlockchainQaddressbalance :: !StatDist- , statBlockchainQaddressfirstseen :: !StatDist- , -- Others- statHealth :: !StatDist- , statPeers :: !StatDist- , statDbstats :: !StatDist- , statEvents :: !Metrics.Gauge.Gauge- , -- Request- statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist))))- }--createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics-createMetrics s = liftIO $ do- statAll <- d "all"-- -- Addresses- statAddressTransactions <- d "address_transactions"- statAddressTransactionsFull <- d "address_transactions_full"- statAddressBalance <- d "address_balance"- statAddressUnspent <- d "address_unspent"- statXpub <- d "xpub"- statXpubDelete <- d "xpub_delete"- statXpubTransactionsFull <- d "xpub_transactions_full"- statXpubTransactions <- d "xpub_transactions"- statXpubBalances <- d "xpub_balances"- statXpubUnspent <- d "xpub_unspent"-- -- Transactions- statTransaction <- d "transaction"- statTransactionRaw <- d "transaction_raw"- statTransactionAfter <- d "transaction_after"- statTransactionPost <- d "transaction_post"- statTransactionsBlock <- d "transactions_block"- statTransactionsBlockRaw <- d "transactions_block_raw"- statMempool <- d "mempool"-- -- Blocks- statBlockBest <- d "block_best"- statBlockLatest <- d "block_latest"- statBlock <- d "block"- statBlockRaw <- d "block_raw"- statBlockHeight <- d "block_height"- statBlockHeightRaw <- d "block_height_raw"- statBlockTime <- d "block_time"- statBlockTimeRaw <- d "block_time_raw"- statBlockMtp <- d "block_mtp"- statBlockMtpRaw <- d "block_mtp_raw"-- -- Blockchain- statBlockchainMultiaddr <- d "blockchain_multiaddr"- statBlockchainBalance <- d "blockchain_balance"- statBlockchainRawaddr <- d "blockchain_rawaddr"- statBlockchainUnspent <- d "blockchain_unspent"- statBlockchainRawtx <- d "blockchain_rawtx"- statBlockchainRawblock <- d "blockchain_rawblock"- statBlockchainLatestblock <- d "blockchain_latestblock"- statBlockchainMempool <- d "blockchain_mempool"- statBlockchainBlockHeight <- d "blockchain_block_height"- statBlockchainBlocks <- d "blockchain_blocks"- statBlockchainExportHistory <- d "blockchain_export_history"-- -- Blockchain /q endpoints- statBlockchainQaddresstohash <- d "blockchain_q_addresstohash"- statBlockchainQhashtoaddress <- d "blockchain_q_hashtoaddress"- statBlockchainQaddrpubkey <- d "blockckhain_q_addrpubkey"- statBlockchainQpubkeyaddr <- d "blockchain_q_pubkeyaddr"- statBlockchainQhashpubkey <- d "blockchain_q_hashpubkey"- statBlockchainQgetblockcount <- d "blockchain_q_getblockcount"- statBlockchainQlatesthash <- d "blockchain_q_latesthash"- statBlockchainQbcperblock <- d "blockchain_q_bcperblock"- statBlockchainQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput"- statBlockchainQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput"- statBlockchainQtxfee <- d "blockchain_q_txfee"- statBlockchainQtxresult <- d "blockchain_q_txresult"- statBlockchainQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress"- statBlockchainQgetsentbyaddress <- d "blockchain_q_getsentbyaddress"- statBlockchainQaddressbalance <- d "blockchain_q_addressbalance"- statBlockchainQaddressfirstseen <- d "blockchain_q_addressfirstseen"-- -- Others- statHealth <- d "health"- statPeers <- d "peers"- statDbstats <- d "dbstats"-- statEvents <- g "events_connected"- statKey <- V.newKey- return WebMetrics{..}- where- d x = createStatDist ("web." <> x) s- g x = Metrics.createGauge ("web." <> x) s--withGaugeIO :: MonadUnliftIO m => Metrics.Gauge -> m a -> m a-withGaugeIO g =- bracket_- (liftIO $ Metrics.Gauge.inc g)- (liftIO $ Metrics.Gauge.dec g)--withGaugeIncrease ::- MonadUnliftIO m =>- (WebMetrics -> Metrics.Gauge) ->- WebT m a ->- WebT m a-withGaugeIncrease gf go =- lift (asks webMetrics) >>= \case- Nothing -> go- Just m -> do- s <- liftWith $ \run -> withGaugeIO (gf m) (run go)- restoreT $ return s--setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) -> WebT m ()-setMetrics df =- asks webMetrics >>= mapM_ go- where- go m = do- req <- S.request- let t = fromMaybe e $ V.lookup (statKey m) (vault req)- atomically $ writeTVar t (Just df)- e = error "the ways of the warrior are yet to be mastered"--addItemCount :: MonadUnliftIO m => Int -> WebT m ()-addItemCount i =- asks webMetrics >>= mapM_ \m ->- addStatItems (statAll m) (fromIntegral i)- >> S.request >>= \req ->- forM_ (V.lookup (statKey m) (vault req)) \t ->- readTVarIO t >>= mapM_ \s ->- addStatItems (s m) (fromIntegral i)--data WebTimeouts = WebTimeouts- { txTimeout :: !Word64- , blockTimeout :: !Word64- }- deriving (Eq, Show)--data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON- deriving (Eq, Show)--instance Default WebTimeouts where- def = WebTimeouts{txTimeout = 300, blockTimeout = 7200}--instance- (MonadUnliftIO m, MonadLoggerIO m) =>- StoreReadBase (ReaderT WebState m)- where- getNetwork = runInWebReader getNetwork- getBestBlock = runInWebReader getBestBlock- getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height)- getBlock bh = runInWebReader (getBlock bh)- getTxData th = runInWebReader (getTxData th)- getSpender op = runInWebReader (getSpender op)- getUnspent op = runInWebReader (getUnspent op)- getBalance a = runInWebReader (getBalance a)- getMempool = runInWebReader getMempool--instance- (MonadUnliftIO m, MonadLoggerIO m) =>- StoreReadExtra (ReaderT WebState m)- where- getMaxGap = runInWebReader getMaxGap- getInitialGap = runInWebReader getInitialGap- getBalances as = runInWebReader (getBalances as)- getAddressesTxs as = runInWebReader . getAddressesTxs as- getAddressTxs a = runInWebReader . getAddressTxs a- getAddressUnspents a = runInWebReader . getAddressUnspents a- getAddressesUnspents as = runInWebReader . getAddressesUnspents as- xPubBals = runInWebReader . xPubBals- xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals- xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals- xPubTxCount xpub = runInWebReader . xPubTxCount xpub- getNumTxData = runInWebReader . getNumTxData--instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where- getNetwork = lift getNetwork- getBestBlock = lift getBestBlock- getBlocksAtHeight = lift . getBlocksAtHeight- getBlock = lift . getBlock- getTxData = lift . getTxData- getSpender = lift . getSpender- getUnspent = lift . getUnspent- getBalance = lift . getBalance- getMempool = lift getMempool--instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where- getBalances = lift . getBalances- getAddressesTxs as = lift . getAddressesTxs as- getAddressTxs a = lift . getAddressTxs a- getAddressUnspents a = lift . getAddressUnspents a- getAddressesUnspents as = lift . getAddressesUnspents as- xPubBals = lift . xPubBals- xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals- xPubTxs xpub xbals = lift . xPubTxs xpub xbals- xPubTxCount xpub = lift . xPubTxCount xpub- getMaxGap = lift getMaxGap- getInitialGap = lift getInitialGap- getNumTxData = lift . getNumTxData------------------------ Path Handlers ------------------------runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => WebConfig -> m ()-runWeb- cfg@WebConfig- { webHost = host- , webPort = port- , webStore = store'- , webStats = stats- , webPriceGet = pget- , webTickerURL = turl- , webMaxLimits = WebLimits{..}- } = do- ticker <- newTVarIO HashMap.empty- metrics <- mapM createMetrics stats- session <- liftIO Wreq.Session.newAPISession- let st =- WebState- { webConfig = cfg- , webTicker = ticker- , webMetrics = metrics- , webWreqSession = session- }- net = storeNetwork store'- withAsync (price net session turl pget ticker) $- const $ do- reqLogger <- logIt metrics- runner <- askRunInIO- S.scottyOptsT opts (runner . (`runReaderT` st)) $ do- S.middleware (webSocketEvents st)- S.middleware reqLogger- S.middleware (reqSizeLimit maxLimitBody)- S.defaultHandler defHandler- handlePaths- S.notFound $ raise ThingNotFound- where- opts = def{S.settings = settings defaultSettings}- settings = setPort port . setHost (fromString host)--getRates ::- (MonadUnliftIO m, MonadLoggerIO m) =>- Network ->- Wreq.Session ->- String ->- Text ->- [Word64] ->- m [BinfoRate]-getRates net session url currency times = do- handleAny err $ do- r <-- liftIO $- Wreq.asJSON- =<< Wreq.Session.postWith opts session url body- return $ r ^. Wreq.responseBody- where- err _ = do- $(logErrorS) "Web" "Could not get historic prices"- return []- body = toJSON times- base =- Wreq.defaults- & Wreq.param "base" .~ [T.toUpper (T.pack (getNetworkName net))]- opts = base & Wreq.param "quote" .~ [currency]--price ::- (MonadUnliftIO m, MonadLoggerIO m) =>- Network ->- Wreq.Session ->- String ->- Int ->- TVar (HashMap Text BinfoTicker) ->- m ()-price net session url pget v = forM_ purl $ \u -> forever $ do- let err e = $(logErrorS) "Price" $ cs (show e)- handleAny err $ do- r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u- atomically . writeTVar v $ r ^. Wreq.responseBody- threadDelay pget- where- purl = case code of- Nothing -> Nothing- Just x -> Just (url <> "?base=" <> x)- where- code- | net == btc = Just "btc"- | net == bch = Just "bch"- | otherwise = Nothing--raise :: MonadIO m => Except -> WebT m a-raise err =- lift (asks webMetrics) >>= \case- Nothing -> S.raise err- Just m -> do- req <- S.request- mM <- case V.lookup (statKey m) (vault req) of- Nothing -> return Nothing- Just t -> readTVarIO t- let status = errStatus err- if- | statusIsClientError status ->- liftIO $ do- addClientError (statAll m)- forM_ mM $ \f -> addClientError (f m)- | statusIsServerError status ->- liftIO $ do- addServerError (statAll m)- forM_ mM $ \f -> addServerError (f m)- | otherwise ->- return ()- S.raise err--errStatus :: Except -> Status-errStatus ThingNotFound = status404-errStatus BadRequest = status400-errStatus UserError{} = status400-errStatus StringError{} = status400-errStatus ServerError = status500-errStatus TxIndexConflict{} = status409-errStatus ServerTimeout = status500-errStatus RequestTooLarge = status413--defHandler :: Monad m => Except -> WebT m ()-defHandler e = do- setHeaders- S.status $ errStatus e- S.json e--handlePaths ::- (MonadUnliftIO m, MonadLoggerIO m) =>- S.ScottyT Except (ReaderT WebState m) ()-handlePaths = do- -- Block Paths- pathCompact- (GetBlock <$> paramLazy <*> paramDef)- scottyBlock- blockDataToEncoding- blockDataToJSON- pathCompact- (GetBlocks <$> param <*> paramDef)- (fmap SerialList . scottyBlocks)- (\n -> list (blockDataToEncoding n) . getSerialList)- (\n -> json_list blockDataToJSON n . getSerialList)- pathCompact- (GetBlockRaw <$> paramLazy)- scottyBlockRaw- (const toEncoding)- (const toJSON)- pathCompact- (GetBlockBest <$> paramDef)- scottyBlockBest- blockDataToEncoding- blockDataToJSON- pathCompact- (GetBlockBestRaw & return)- scottyBlockBestRaw- (const toEncoding)- (const toJSON)- pathCompact- (GetBlockLatest <$> paramDef)- (fmap SerialList . scottyBlockLatest)- (\n -> list (blockDataToEncoding n) . getSerialList)- (\n -> json_list blockDataToJSON n . getSerialList)- pathCompact- (GetBlockHeight <$> paramLazy <*> paramDef)- (fmap SerialList . scottyBlockHeight)- (\n -> list (blockDataToEncoding n) . getSerialList)- (\n -> json_list blockDataToJSON n . getSerialList)- pathCompact- (GetBlockHeights <$> param <*> paramDef)- (fmap SerialList . scottyBlockHeights)- (\n -> list (blockDataToEncoding n) . getSerialList)- (\n -> json_list blockDataToJSON n . getSerialList)- pathCompact- (GetBlockHeightRaw <$> paramLazy)- scottyBlockHeightRaw- (const toEncoding)- (const toJSON)- pathCompact- (GetBlockTime <$> paramLazy <*> paramDef)- scottyBlockTime- blockDataToEncoding- blockDataToJSON- pathCompact- (GetBlockTimeRaw <$> paramLazy)- scottyBlockTimeRaw- (const toEncoding)- (const toJSON)- pathCompact- (GetBlockMTP <$> paramLazy <*> paramDef)- scottyBlockMTP- blockDataToEncoding- blockDataToJSON- pathCompact- (GetBlockMTPRaw <$> paramLazy)- scottyBlockMTPRaw- (const toEncoding)- (const toJSON)- -- Transaction Paths- pathCompact- (GetTx <$> paramLazy)- scottyTx- transactionToEncoding- transactionToJSON- pathCompact- (GetTxs <$> param)- (fmap SerialList . scottyTxs)- (\n -> list (transactionToEncoding n) . getSerialList)- (\n -> json_list transactionToJSON n . getSerialList)- pathCompact- (GetTxRaw <$> paramLazy)- scottyTxRaw- (const toEncoding)- (const toJSON)- pathCompact- (GetTxsRaw <$> param)- scottyTxsRaw- (const toEncoding)- (const toJSON)- pathCompact- (GetTxsBlock <$> paramLazy)- (fmap SerialList . scottyTxsBlock)- (\n -> list (transactionToEncoding n) . getSerialList)- (\n -> json_list transactionToJSON n . getSerialList)- pathCompact- (GetTxsBlockRaw <$> paramLazy)- scottyTxsBlockRaw- (const toEncoding)- (const toJSON)- pathCompact- (GetTxAfter <$> paramLazy <*> paramLazy)- scottyTxAfter- (const toEncoding)- (const toJSON)- pathCompact- (PostTx <$> parseBody)- scottyPostTx- (const toEncoding)- (const toJSON)- pathCompact- (GetMempool <$> paramOptional <*> parseOffset)- (fmap SerialList . scottyMempool)- (const toEncoding)- (const toJSON)- -- Address Paths- pathCompact- (GetAddrTxs <$> paramLazy <*> parseLimits)- (fmap SerialList . scottyAddrTxs)- (const toEncoding)- (const toJSON)- pathCompact- (GetAddrsTxs <$> param <*> parseLimits)- (fmap SerialList . scottyAddrsTxs)- (const toEncoding)- (const toJSON)- pathCompact- (GetAddrTxsFull <$> paramLazy <*> parseLimits)- (fmap SerialList . scottyAddrTxsFull)- (\n -> list (transactionToEncoding n) . getSerialList)- (\n -> json_list transactionToJSON n . getSerialList)- pathCompact- (GetAddrsTxsFull <$> param <*> parseLimits)- (fmap SerialList . scottyAddrsTxsFull)- (\n -> list (transactionToEncoding n) . getSerialList)- (\n -> json_list transactionToJSON n . getSerialList)- pathCompact- (GetAddrBalance <$> paramLazy)- scottyAddrBalance- balanceToEncoding- balanceToJSON- pathCompact- (GetAddrsBalance <$> param)- (fmap SerialList . scottyAddrsBalance)- (\n -> list (balanceToEncoding n) . getSerialList)- (\n -> json_list balanceToJSON n . getSerialList)- pathCompact- (GetAddrUnspent <$> paramLazy <*> parseLimits)- (fmap SerialList . scottyAddrUnspent)- (\n -> list (unspentToEncoding n) . getSerialList)- (\n -> json_list unspentToJSON n . getSerialList)- pathCompact- (GetAddrsUnspent <$> param <*> parseLimits)- (fmap SerialList . scottyAddrsUnspent)- (\n -> list (unspentToEncoding n) . getSerialList)- (\n -> json_list unspentToJSON n . getSerialList)- -- XPubs- pathCompact- (GetXPub <$> paramLazy <*> paramDef <*> paramDef)- scottyXPub- (const toEncoding)- (const toJSON)- pathCompact- (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)- (fmap SerialList . scottyXPubTxs)- (const toEncoding)- (const toJSON)- pathCompact- (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)- (fmap SerialList . scottyXPubTxsFull)- (\n -> list (transactionToEncoding n) . getSerialList)- (\n -> json_list transactionToJSON n . getSerialList)- pathCompact- (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef)- (fmap SerialList . scottyXPubBalances)- (\n -> list (xPubBalToEncoding n) . getSerialList)- (\n -> json_list xPubBalToJSON n . getSerialList)- pathCompact- (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)- (fmap SerialList . scottyXPubUnspent)- (\n -> list (xPubUnspentToEncoding n) . getSerialList)- (\n -> json_list xPubUnspentToJSON n . getSerialList)- pathCompact- (DelCachedXPub <$> paramLazy <*> paramDef)- scottyDelXPub- (const toEncoding)- (const toJSON)- -- Network- pathCompact- (GetPeers & return)- (fmap SerialList . scottyPeers)- (const toEncoding)- (const toJSON)- pathCompact- (GetHealth & return)- scottyHealth- (const toEncoding)- (const toJSON)- S.get "/events" scottyEvents- S.get "/dbstats" scottyDbStats- -- Blockchain.info- S.post "/blockchain/multiaddr" scottyMultiAddr- S.get "/blockchain/multiaddr" scottyMultiAddr- S.get "/blockchain/balance" scottyShortBal- S.post "/blockchain/balance" scottyShortBal- S.get "/blockchain/rawaddr/:addr" scottyRawAddr- S.get "/blockchain/address/:addr" scottyRawAddr- S.get "/blockchain/xpub/:addr" scottyRawAddr- S.post "/blockchain/unspent" scottyBinfoUnspent- S.get "/blockchain/unspent" scottyBinfoUnspent- S.get "/blockchain/rawtx/:txid" scottyBinfoTx- S.get "/blockchain/rawblock/:block" scottyBinfoBlock- S.get "/blockchain/latestblock" scottyBinfoLatest- S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool- S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight- S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay- S.get "/blockchain/export-history" scottyBinfoHistory- S.post "/blockchain/export-history" scottyBinfoHistory- S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash- S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr- S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey- S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr- S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey- S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount- S.get "/blockchain/q/latesthash" scottyBinfoLatestHash- S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy- S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut- S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput- S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees- S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult- S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived- S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent- S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance- S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen- where- json_list f net = toJSONList . map (f net)--pathCompact ::- (ApiResource a b, MonadIO m) =>- WebT m a ->- (a -> WebT m b) ->- (Network -> b -> Encoding) ->- (Network -> b -> Value) ->- S.ScottyT Except (ReaderT WebState m) ()-pathCompact parser action encJson encValue =- pathCommon parser action encJson encValue False--pathCommon ::- (ApiResource a b, MonadIO m) =>- WebT m a ->- (a -> WebT m b) ->- (Network -> b -> Encoding) ->- (Network -> b -> Value) ->- Bool ->- S.ScottyT Except (ReaderT WebState m) ()-pathCommon parser action encJson encValue pretty =- S.addroute (resourceMethod proxy) (capturePath proxy) $ do- setHeaders- proto <- setupContentType pretty- net <- lift $ asks (storeNetwork . webStore . webConfig)- apiRes <- parser- res <- action apiRes- S.raw $ protoSerial proto (encJson net) (encValue net) res- where- toProxy :: WebT m a -> Proxy a- toProxy = const Proxy- proxy = toProxy parser--streamEncoding :: Monad m => Encoding -> WebT m ()-streamEncoding e = do- S.setHeader "Content-Type" "application/json; charset=utf-8"- S.raw (encodingToLazyByteString e)--protoSerial ::- Serial a =>- SerialAs ->- (a -> Encoding) ->- (a -> Value) ->- a ->- L.ByteString-protoSerial SerialAsBinary _ _ = runPutL . serialize-protoSerial SerialAsJSON f _ = encodingToLazyByteString . f-protoSerial SerialAsPrettyJSON _ g =- encodePretty' defConfig{confTrailingNewline = True} . g--setHeaders :: (Monad m, S.ScottyError e) => ActionT e m ()-setHeaders = S.setHeader "Access-Control-Allow-Origin" "*"--waiExcept :: Status -> Except -> Response-waiExcept s e =- responseLBS s hs e'- where- hs =- [ ("Access-Control-Allow-Origin", "*")- , ("Content-Type", "application/json")- ]- e' = A.encode e--setupJSON :: Monad m => Bool -> ActionT Except m SerialAs-setupJSON pretty = do- S.setHeader "Content-Type" "application/json"- p <- S.param "pretty" `S.rescue` const (return pretty)- return $ if p then SerialAsPrettyJSON else SerialAsJSON--setupBinary :: Monad m => ActionT Except m SerialAs-setupBinary = do- S.setHeader "Content-Type" "application/octet-stream"- return SerialAsBinary--setupContentType :: Monad m => Bool -> ActionT Except m SerialAs-setupContentType pretty = do- accept <- S.header "accept"- maybe (setupJSON pretty) setType accept- where- setType "application/octet-stream" = setupBinary- setType _ = setupJSON pretty---- GET Block / GET Blocks ----scottyBlock ::- (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData-scottyBlock (GetBlock h (NoTx noTx)) = do- setMetrics statBlock- getBlock h >>= \case- Nothing ->- raise ThingNotFound- Just b -> do- addItemCount 1- return $ pruneTx noTx b--getBlocks ::- (MonadUnliftIO m, MonadLoggerIO m) =>- [H.BlockHash] ->- Bool ->- WebT m [BlockData]-getBlocks hs notx =- (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs)--scottyBlocks ::- (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData]-scottyBlocks (GetBlocks hs (NoTx notx)) = do- setMetrics statBlock- bs <- getBlocks hs notx- addItemCount (length bs)- return bs--pruneTx :: Bool -> BlockData -> BlockData-pruneTx False b = b-pruneTx True b = b{blockDataTxs = take 1 (blockDataTxs b)}---- GET BlockRaw ----scottyBlockRaw ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockRaw ->- WebT m (RawResult H.Block)-scottyBlockRaw (GetBlockRaw h) = do- setMetrics statBlockRaw- b <- getRawBlock h- addItemCount (1 + length (H.blockTxns b))- return $ RawResult b--getRawBlock ::- (MonadUnliftIO m, MonadLoggerIO m) =>- H.BlockHash ->- WebT m H.Block-getRawBlock h = do- b <- getBlock h >>= maybe (raise ThingNotFound) return- lift (toRawBlock b)--toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block-toRawBlock b = do- let ths = blockDataTxs b- txs <- mapM f ths- return H.Block{H.blockHeader = blockDataHeader b, H.blockTxns = txs}- where- f x = withRunInIO $ \run ->- unsafeInterleaveIO . run $- getTransaction x >>= \case- Nothing -> undefined- Just t -> return $ transactionData t---- GET BlockBest / BlockBestRaw ----scottyBlockBest ::- (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData-scottyBlockBest (GetBlockBest (NoTx notx)) = do- setMetrics statBlock- getBestBlock >>= \case- Nothing -> raise ThingNotFound- Just bb ->- getBlock bb >>= \case- Nothing -> raise ThingNotFound- Just b -> do- addItemCount 1- return $ pruneTx notx b--scottyBlockBestRaw ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockBestRaw ->- WebT m (RawResult H.Block)-scottyBlockBestRaw _ = do- setMetrics statBlockRaw- getBestBlock >>= \case- Nothing -> raise ThingNotFound- Just bb -> do- b <- getRawBlock bb- addItemCount (1 + length (H.blockTxns b))- return $ RawResult b---- GET BlockLatest ----scottyBlockLatest ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockLatest ->- WebT m [BlockData]-scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do- setMetrics statBlock- blocks <-- getBestBlock- >>= maybe- (raise ThingNotFound)- (go [] <=< getBlock)- addItemCount (length blocks)- return blocks- where- go acc Nothing = return $ reverse acc- go acc (Just b)- | blockDataHeight b <= 0 = return $ reverse acc- | length acc == 99 = return . reverse $ pruneTx noTx b : acc- | otherwise = do- let prev = H.prevBlock (blockDataHeader b)- go (pruneTx noTx b : acc) =<< getBlock prev---- GET BlockHeight / BlockHeights / BlockHeightRaw ----scottyBlockHeight ::- (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData]-scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do- setMetrics statBlock- blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h)- addItemCount (length blocks)- return blocks--scottyBlockHeights ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockHeights ->- WebT m [BlockData]-scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do- setMetrics statBlock- bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights)- blocks <- getBlocks bhs notx- addItemCount (length blocks)- return blocks--scottyBlockHeightRaw ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockHeightRaw ->- WebT m (RawResultList H.Block)-scottyBlockHeightRaw (GetBlockHeightRaw h) = do- setMetrics statBlockRaw- blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h)- addItemCount (length blocks + sum (map (length . H.blockTxns) blocks))- return $ RawResultList blocks---- GET BlockTime / BlockTimeRaw ----scottyBlockTime ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockTime ->- WebT m BlockData-scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do- setMetrics statBlock- ch <- lift $ asks (storeChain . webStore . webConfig)- blockAtOrBefore ch t >>= \case- Nothing -> raise ThingNotFound- Just b -> do- addItemCount 1- return $ pruneTx notx b--scottyBlockMTP ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockMTP ->- WebT m BlockData-scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = do- setMetrics statBlock- ch <- lift $ asks (storeChain . webStore . webConfig)- blockAtOrAfterMTP ch t >>= \case- Nothing -> raise ThingNotFound- Just b -> do- addItemCount 1- return $ pruneTx notx b--scottyBlockTimeRaw ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockTimeRaw ->- WebT m (RawResult H.Block)-scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do- setMetrics statBlockRaw- ch <- lift $ asks (storeChain . webStore . webConfig)- blockAtOrBefore ch t >>= \case- Nothing -> raise ThingNotFound- Just b -> do- raw <- lift $ toRawBlock b- addItemCount (1 + length (H.blockTxns raw))- return $ RawResult raw--scottyBlockMTPRaw ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetBlockMTPRaw ->- WebT m (RawResult H.Block)-scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do- setMetrics statBlockRaw- ch <- lift $ asks (storeChain . webStore . webConfig)- blockAtOrAfterMTP ch t >>= \case- Nothing -> raise ThingNotFound- Just b -> do- raw <- lift $ toRawBlock b- addItemCount (1 + length (H.blockTxns raw))- return $ RawResult raw---- GET Transactions ----scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction-scottyTx (GetTx txid) = do- setMetrics statTransaction- getTransaction txid >>= \case- Nothing -> raise ThingNotFound- Just tx -> do- addItemCount 1- return tx--scottyTxs ::- (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction]-scottyTxs (GetTxs txids) = do- setMetrics statTransaction- txs <- catMaybes <$> mapM f (nub txids)- addItemCount (length txs)- return txs- where- f x = lift $- withRunInIO $ \run ->- unsafeInterleaveIO . run $- getTransaction x--scottyTxRaw ::- (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx)-scottyTxRaw (GetTxRaw txid) = do- setMetrics statTransactionRaw- getTransaction txid >>= \case- Nothing -> raise ThingNotFound- Just tx -> do- addItemCount 1- return $ RawResult (transactionData tx)--scottyTxsRaw ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetTxsRaw ->- WebT m (RawResultList Tx)-scottyTxsRaw (GetTxsRaw txids) = do- setMetrics statTransactionRaw- txs <- catMaybes <$> mapM f (nub txids)- addItemCount (length txs)- return $ RawResultList $ transactionData <$> txs- where- f x = lift $- withRunInIO $ \run ->- unsafeInterleaveIO . run $- getTransaction x--getTxsBlock ::- (MonadUnliftIO m, MonadLoggerIO m) =>- H.BlockHash ->- WebT m [Transaction]-getTxsBlock h =- getBlock h >>= \case- Nothing -> raise ThingNotFound- Just b -> do- txs <- mapM f (blockDataTxs b)- addItemCount (length txs)- return txs- where- f x = lift $- withRunInIO $ \run ->- unsafeInterleaveIO . run $- getTransaction x >>= \case- Nothing -> undefined- Just t -> return t--scottyTxsBlock ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetTxsBlock ->- WebT m [Transaction]-scottyTxsBlock (GetTxsBlock h) = do- setMetrics statTransactionsBlock- txs <- getTxsBlock h- addItemCount (length txs)- return txs--scottyTxsBlockRaw ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetTxsBlockRaw ->- WebT m (RawResultList Tx)-scottyTxsBlockRaw (GetTxsBlockRaw h) = do- setMetrics statTransactionsBlockRaw- txs <- fmap transactionData <$> getTxsBlock h- addItemCount (length txs)- return $ RawResultList txs---- GET TransactionAfterHeight ----scottyTxAfter ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetTxAfter ->- WebT m (GenericResult (Maybe Bool))-scottyTxAfter (GetTxAfter txid height) = do- setMetrics statTransactionAfter- (result, count) <- cbAfterHeight (fromIntegral height) txid- addItemCount count- return $ GenericResult result--{- | Check if any of the ancestors of this transaction is a coinbase after the- specified height. Returns 'Nothing' if answer cannot be computed before- hitting limits.--}-cbAfterHeight ::- (MonadIO m, StoreReadBase m) =>- H.BlockHeight ->- TxHash ->- m (Maybe Bool, Int)-cbAfterHeight height txid =- inputs n HashSet.empty HashSet.empty [txid]- where- n = 10000- inputs 0 _ _ [] = return (Nothing, 10000)- inputs i is ns [] =- let is' = HashSet.union is ns- ns' = HashSet.empty- ts = HashSet.toList (HashSet.difference ns is)- in case ts of- [] -> return (Just False, n - i)- _ -> inputs i is' ns' ts- inputs i is ns (t : ts) =- getTransaction t >>= \case- Nothing -> return (Nothing, n - i)- Just tx- | height_check tx ->- if cb_check tx- then return (Just True, n - i + 1)- else- let ns' = HashSet.union (ins tx) ns- in inputs (i - 1) is ns' ts- | otherwise -> inputs (i - 1) is ns ts- cb_check = any isCoinbase . transactionInputs- ins = HashSet.fromList . map (outPointHash . inputPoint) . transactionInputs- height_check tx =- case transactionBlock tx of- BlockRef h _ -> h > height- _ -> True---- POST Transaction ----scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId-scottyPostTx (PostTx tx) = do- setMetrics statTransactionPost- addItemCount 1- lift (asks webConfig) >>= \cfg ->- lift (publishTx cfg tx) >>= \case- Right () -> return (TxId (txHash tx))- Left e@(PubReject _) -> raise $ UserError (show e)- _ -> raise ServerError---- | Publish a new transaction to the network.-publishTx ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- WebConfig ->- Tx ->- m (Either PubExcept ())-publishTx cfg tx =- withSubscription pub $ \s ->- getTransaction (txHash tx) >>= \case- Just _ -> return $ Right ()- Nothing -> go s- where- pub = storePublisher (webStore cfg)- mgr = storeManager (webStore cfg)- net = storeNetwork (webStore cfg)- go s =- getPeers mgr >>= \case- [] -> return $ Left PubNoPeers- OnlinePeer{onlinePeerMailbox = p} : _ -> do- MTx tx `sendMessage` p- let v =- if getSegWit net- then InvWitnessTx- else InvTx- sendMessage- (MGetData (GetData [InvVector v (getTxHash (txHash tx))]))- p- f p s- t = 5 * 1000 * 1000- f p s- | webNoMempool cfg = return $ Right ()- | otherwise =- liftIO (timeout t (g p s)) >>= \case- Nothing -> return $ Left PubTimeout- Just (Left e) -> return $ Left e- Just (Right ()) -> return $ Right ()- g p s =- receive s >>= \case- StoreTxReject p' h' c _- | p == p' && h' == txHash tx -> return . Left $ PubReject c- StorePeerDisconnected p'- | p == p' -> return $ Left PubPeerDisconnected- StoreMempoolNew h'- | h' == txHash tx -> return $ Right ()- _ -> g p s---- GET Mempool / Events ----scottyMempool ::- (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash]-scottyMempool (GetMempool limitM (OffsetParam o)) = do- setMetrics statMempool- wl <- lift $ asks (webMaxLimits . webConfig)- let wl' = wl{maxLimitCount = 0}- l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing- ths <- map snd . applyLimits l <$> getMempool- addItemCount 1- return ths--webSocketEvents :: WebState -> Middleware-webSocketEvents s =- websocketsOr defaultConnectionOptions events- where- pub = (storePublisher . webStore . webConfig) s- gauge = statEvents <$> webMetrics s- events pending = withSubscription pub $ \sub -> do- let path = requestPath $ pendingRequest pending- if path == "/events"- then do- conn <- acceptRequest pending- forever $- receiveEvent sub >>= \case- Nothing -> return ()- Just event -> sendTextData conn (A.encode event)- else- rejectRequestWith- pending- WebSockets.defaultRejectRequest- { WebSockets.rejectBody = L.toStrict $ A.encode ThingNotFound- , WebSockets.rejectCode = 404- , WebSockets.rejectMessage = "Not Found"- , WebSockets.rejectHeaders = [("Content-Type", "application/json")]- }--scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyEvents =- withGaugeIncrease statEvents $ do- setHeaders- proto <- setupContentType False- pub <- lift $ asks (storePublisher . webStore . webConfig)- S.stream $ \io flush' ->- withSubscription pub $ \sub ->- forever $- flush' >> receiveEvent sub >>= maybe (return ()) (io . serial proto)- where- serial proto e =- lazyByteString $ protoSerial proto toEncoding toJSON e <> newLine proto- newLine SerialAsBinary = mempty- newLine SerialAsJSON = "\n"- newLine SerialAsPrettyJSON = mempty--receiveEvent :: Inbox StoreEvent -> IO (Maybe Event)-receiveEvent sub =- go <$> receive sub- where- go = \case- StoreBestBlock b -> Just (EventBlock b)- StoreMempoolNew t -> Just (EventTx t)- StoreMempoolDelete t -> Just (EventTx t)- _ -> Nothing---- GET Address Transactions ----scottyAddrTxs ::- (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef]-scottyAddrTxs (GetAddrTxs addr pLimits) = do- setMetrics statAddressTransactions- txs <- getAddressTxs addr =<< paramToLimits False pLimits- addItemCount (length txs)- return txs--scottyAddrsTxs ::- (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef]-scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do- setMetrics statAddressTransactions- txs <- getAddressesTxs addrs =<< paramToLimits False pLimits- addItemCount (length txs)- return txs--scottyAddrTxsFull ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetAddrTxsFull ->- WebT m [Transaction]-scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do- setMetrics statAddressTransactionsFull- txs <- getAddressTxs addr =<< paramToLimits True pLimits- ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs- addItemCount (length ts)- return ts--scottyAddrsTxsFull ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetAddrsTxsFull ->- WebT m [Transaction]-scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do- setMetrics statAddressTransactionsFull- txs <- getAddressesTxs addrs =<< paramToLimits True pLimits- ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs- addItemCount (length ts)- return ts--scottyAddrBalance ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetAddrBalance ->- WebT m Balance-scottyAddrBalance (GetAddrBalance addr) = do- setMetrics statAddressBalance- addItemCount 1- getDefaultBalance addr--scottyAddrsBalance ::- (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance]-scottyAddrsBalance (GetAddrsBalance addrs) = do- setMetrics statAddressBalance- balances <- getBalances addrs- addItemCount (length balances)- return balances--scottyAddrUnspent ::- (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent]-scottyAddrUnspent (GetAddrUnspent addr pLimits) = do- setMetrics statAddressUnspent- unspents <- getAddressUnspents addr =<< paramToLimits False pLimits- addItemCount (length unspents)- return unspents--scottyAddrsUnspent ::- (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent]-scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do- setMetrics statAddressUnspent- unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits- addItemCount (length unspents)- return unspents---- GET XPubs ----scottyXPub ::- (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary-scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do- setMetrics statXpub- let xspec = XPubSpec xpub deriv- xbals <- lift . runNoCache noCache $ xPubBals xspec- addItemCount (length xbals)- return $ xPubSummary xspec xbals--scottyDelXPub ::- (MonadUnliftIO m, MonadLoggerIO m) =>- DelCachedXPub ->- WebT m (GenericResult Bool)-scottyDelXPub (DelCachedXPub xpub deriv) = do- setMetrics statXpubDelete- let xspec = XPubSpec xpub deriv- cacheM <- lift (asks (storeCache . webStore . webConfig))- n <- lift $ withCache cacheM (cacheDelXPubs [xspec])- addItemCount (fromIntegral n)- return (GenericResult (n > 0))--getXPubTxs ::- (MonadUnliftIO m, MonadLoggerIO m) =>- XPubKey ->- DeriveType ->- LimitsParam ->- Bool ->- WebT m [TxRef]-getXPubTxs xpub deriv plimits nocache = do- limits <- paramToLimits False plimits- let xspec = XPubSpec xpub deriv- xbals <- xPubBals xspec- addItemCount (length xbals)- lift . runNoCache nocache $ xPubTxs xspec xbals limits--scottyXPubTxs ::- (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef]-scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do- setMetrics statXpubTransactions- txs <- getXPubTxs xpub deriv plimits nocache- addItemCount (length txs)- return txs--scottyXPubTxsFull ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetXPubTxsFull ->- WebT m [Transaction]-scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do- setMetrics statXpubTransactionsFull- refs <- getXPubTxs xpub deriv plimits nocache- txs <-- fmap catMaybes $- lift . runNoCache nocache $- mapM (getTransaction . txRefHash) refs- addItemCount (length txs)- return txs--scottyXPubBalances ::- (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal]-scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do- setMetrics statXpubBalances- balances <- filter f <$> lift (runNoCache noCache (xPubBals spec))- addItemCount (length balances)- return balances- where- spec = XPubSpec xpub deriv- f = not . nullBalance . xPubBal--scottyXPubUnspent ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetXPubUnspent ->- WebT m [XPubUnspent]-scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do- setMetrics statXpubUnspent- limits <- paramToLimits False pLimits- let xspec = XPubSpec xpub deriv- xbals <- xPubBals xspec- addItemCount (length xbals)- unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits- addItemCount (length unspents)- return unspents-------------------------------------------- Blockchain.info API Compatibility --------------------------------------------netBinfoSymbol :: Network -> BinfoSymbol-netBinfoSymbol net- | net == btc =- BinfoSymbol- { getBinfoSymbolCode = "BTC"- , getBinfoSymbolString = "BTC"- , getBinfoSymbolName = "Bitcoin"- , getBinfoSymbolConversion = 100 * 1000 * 1000- , getBinfoSymbolAfter = True- , getBinfoSymbolLocal = False- }- | net == bch =- BinfoSymbol- { getBinfoSymbolCode = "BCH"- , getBinfoSymbolString = "BCH"- , getBinfoSymbolName = "Bitcoin Cash"- , getBinfoSymbolConversion = 100 * 1000 * 1000- , getBinfoSymbolAfter = True- , getBinfoSymbolLocal = False- }- | otherwise =- BinfoSymbol- { getBinfoSymbolCode = "XTS"- , getBinfoSymbolString = "¤"- , getBinfoSymbolName = "Test"- , getBinfoSymbolConversion = 100 * 1000 * 1000- , getBinfoSymbolAfter = False- , getBinfoSymbolLocal = False- }--binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol-binfoTickerToSymbol code BinfoTicker{..} =- BinfoSymbol- { getBinfoSymbolCode = code- , getBinfoSymbolString = binfoTickerSymbol- , getBinfoSymbolName = name- , getBinfoSymbolConversion =- 100 * 1000 * 1000 / binfoTicker15m -- sat/usd- , getBinfoSymbolAfter = False- , getBinfoSymbolLocal = True- }- where- name = case code of- "EUR" -> "Euro"- "USD" -> "U.S. dollar"- "GBP" -> "British pound"- x -> x--getBinfoAddrsParam ::- MonadIO m =>- Text ->- WebT m (HashSet BinfoAddr)-getBinfoAddrsParam name = do- net <- lift (asks (storeNetwork . webStore . webConfig))- p <- S.param (cs name) `S.rescue` const (return "")- if T.null p- then return HashSet.empty- else case parseBinfoAddr net p of- Nothing -> raise (UserError "invalid address")- Just xs -> return $ HashSet.fromList xs--getBinfoActive ::- MonadIO m =>- WebT m (HashSet XPubSpec, HashSet Address)-getBinfoActive = do- active <- getBinfoAddrsParam "active"- p2sh <- getBinfoAddrsParam "activeP2SH"- bech32 <- getBinfoAddrsParam "activeBech32"- let xspec d b = (`XPubSpec` d) <$> xpub b- xspecs =- HashSet.fromList $- concat- [ mapMaybe (xspec DeriveNormal) (HashSet.toList active)- , mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh)- , mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32)- ]- addrs = HashSet.fromList . mapMaybe addr $ HashSet.toList active- return (xspecs, addrs)- where- addr (BinfoAddr a) = Just a- addr (BinfoXpub _) = Nothing- xpub (BinfoXpub x) = Just x- xpub (BinfoAddr _) = Nothing--getNumTxId :: MonadIO m => WebT m Bool-getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False)--getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight-getChainHeight = do- ch <- lift $ asks (storeChain . webStore . webConfig)- H.nodeHeight <$> chainGetBest ch--scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoUnspent = do- setMetrics statBlockchainUnspent- (xspecs, addrs) <- getBinfoActive- numtxid <- getNumTxId- limit <- get_limit- min_conf <- get_min_conf- net <- lift $ asks (storeNetwork . webStore . webConfig)- height <- getChainHeight- let mn BinfoUnspent{..} = min_conf > getBinfoUnspentConfirmations- xbals <- lift $ getXBals xspecs- addItemCount . sum . map length $ HashMap.elems xbals- bus <-- lift . runConduit $- getBinfoUnspents numtxid height xbals xspecs addrs- .| (dropWhileC mn >> takeC limit .| sinkList)- addItemCount (length bus) -- TODO: does not include bypassed items- setHeaders- streamEncoding (binfoUnspentsToEncoding net (BinfoUnspents bus))- where- get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250)- get_min_conf = S.param "confirmations" `S.rescue` const (return 0)--getBinfoUnspents ::- (StoreReadExtra m, MonadIO m) =>- Bool ->- H.BlockHeight ->- HashMap XPubSpec [XPubBal] ->- HashSet XPubSpec ->- HashSet Address ->- ConduitT () BinfoUnspent m ()-getBinfoUnspents numtxid height xbals xspecs addrs = do- cs' <- conduits- joinDescStreams cs' .| mapC (uncurry binfo)- where- binfo Unspent{..} xp =- let conf = case unspentBlock of- MemRef{} -> 0- BlockRef h _ -> height - h + 1- hash = outPointHash unspentPoint- idx = outPointIndex unspentPoint- val = unspentAmount- script = unspentScript- txi = encodeBinfoTxId numtxid hash- in BinfoUnspent- { getBinfoUnspentHash = hash- , getBinfoUnspentOutputIndex = idx- , getBinfoUnspentScript = script- , getBinfoUnspentValue = val- , getBinfoUnspentConfirmations = fromIntegral conf- , getBinfoUnspentTxIndex = txi- , getBinfoUnspentXPub = xp- }- conduits = (<>) <$> xconduits <*> pure acounduits- xconduits = lift $ do- let f x (XPubUnspent u p) =- let path = toSoft (listToPath p)- xp = BinfoXPubPath (xPubSpecKey x) <$> path- in (u, xp)- g x = do- return $- streamThings- (xPubUnspents x (xBals x xbals))- Nothing- def{limit = 250}- .| mapC (f x)- mapM g (HashSet.toList xspecs)- acounduits =- let f u = (u, Nothing)- g a =- streamThings- (getAddressUnspents a)- Nothing- def{limit = 250}- .| mapC f- in map g (HashSet.toList addrs)--getXBals :: StoreReadExtra m => HashSet XPubSpec -> m (HashMap XPubSpec [XPubBal])-getXBals = fmap HashMap.fromList . mapM (\x -> (x,) . filter (not . nullBalance . xPubBal) <$> (xPubBals x)) . HashSet.toList--xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal]-xBals = HashMap.findWithDefault []--getBinfoTxs ::- (StoreReadExtra m, MonadIO m) =>- HashMap XPubSpec [XPubBal] -> -- xpub balances- HashMap Address (Maybe BinfoXPubPath) -> -- address book- HashSet XPubSpec -> -- show xpubs- HashSet Address -> -- show addrs- HashSet Address -> -- balance addresses- BinfoFilter ->- Bool -> -- numtxid- Bool -> -- prune outputs- Int64 -> -- starting balance- ConduitT () BinfoTx m ()-getBinfoTxs xbals abook sxspecs saddrs baddrs bfilter numtxid prune bal = do- cs' <- conduits- joinDescStreams cs' .| go bal- where- sxspecs_ls = HashSet.toList sxspecs- saddrs_ls = HashSet.toList saddrs- conduits = (<>) <$> mapM xpub_c sxspecs_ls <*> pure (map addr_c saddrs_ls)- xpub_c x = lift $- return $ streamThings (xPubTxs x (xBals x xbals)) (Just txRefHash) def{limit = 50}- addr_c a = streamThings (getAddressTxs a) (Just txRefHash) def{limit = 50}- binfo_tx b = toBinfoTx numtxid abook prune b- compute_bal_change BinfoTx{..} =- let ins = map getBinfoTxInputPrevOut getBinfoTxInputs- out = getBinfoTxOutputs- f b BinfoTxOutput{..} =- let val = fromIntegral getBinfoTxOutputValue- in case getBinfoTxOutputAddress of- Nothing -> 0- Just a- | a `HashSet.member` baddrs ->- if b then val else negate val- | otherwise -> 0- in sum $ map (f False) ins <> map (f True) out- go b =- await >>= \case- Nothing -> return ()- Just (TxRef _ t) ->- lift (getTransaction t) >>= \case- Nothing -> go b- Just x -> do- let a = binfo_tx b x- b' = b - compute_bal_change a- c = isJust (getBinfoTxBlockHeight a)- Just (d, _) = getBinfoTxResultBal a- r = d + fromIntegral (getBinfoTxFee a)- case bfilter of- BinfoFilterAll ->- yield a >> go b'- BinfoFilterSent- | 0 > r -> yield a >> go b'- | otherwise -> go b'- BinfoFilterReceived- | r > 0 -> yield a >> go b'- | otherwise -> go b'- BinfoFilterMoved- | r == 0 -> yield a >> go b'- | otherwise -> go b'- BinfoFilterConfirmed- | c -> yield a >> go b'- | otherwise -> go b'- BinfoFilterMempool- | c -> return ()- | otherwise -> yield a >> go b'--getCashAddr :: Monad m => WebT m Bool-getCashAddr = S.param "cashaddr" `S.rescue` const (return False)--getAddress :: (Monad m, MonadUnliftIO m) => TL.Text -> WebT m Address-getAddress param' = do- txt <- S.param param'- net <- lift $ asks (storeNetwork . webStore . webConfig)- case textToAddr net txt of- Nothing -> raise ThingNotFound- Just a -> return a--getBinfoAddr :: Monad m => TL.Text -> WebT m BinfoAddr-getBinfoAddr param' = do- txt <- S.param param'- net <- lift $ asks (storeNetwork . webStore . webConfig)- let x =- BinfoAddr <$> textToAddr net txt- <|> BinfoXpub <$> xPubImport net txt- maybe S.next return x--scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoHistory = do- setMetrics statBlockchainExportHistory- (xspecs, addrs) <- getBinfoActive- (startM, endM) <- get_dates- (code, price') <- getPrice- xbals <- getXBals xspecs- addItemCount . sum . map length $ HashMap.elems xbals- let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals)- aaddrs = xaddrs <> addrs- cur = binfoTicker15m price'- cs' = conduits (HashMap.toList xbals) addrs endM- txs <-- lift . runConduit $- joinDescStreams cs'- .| takeWhileC (is_newer startM)- .| concatMapMC get_transaction- .| sinkList- addItemCount (length txs)- let times = map transactionTime txs- net <- lift $ asks (storeNetwork . webStore . webConfig)- url <- lift $ asks (webHistoryURL . webConfig)- session <- lift $ asks webWreqSession- rates <- map binfoRatePrice <$> lift (getRates net session url code times)- addItemCount (length rates)- let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0)- setHeaders- streamEncoding $ toEncoding hs- where- is_newer (Just BlockData{..}) TxRef{txRefBlock = BlockRef{..}} =- blockRefHeight >= blockDataHeight- is_newer _ _ = True- get_addr = balanceAddress . xPubBal- get_transaction TxRef{txRefHash = h} =- getTransaction h- convert cur addrs tx rate =- let ins = transactionInputs tx- outs = transactionOutputs tx- fins = filter (input_addr addrs) ins- fouts = filter (output_addr addrs) outs- vin = fromIntegral . sum $ map inputAmount fins- vout = fromIntegral . sum $ map outputAmount fouts- v = vout - vin- t = transactionTime tx- h = txHash $ transactionData tx- in toBinfoHistory v t rate cur h- input_addr addrs' StoreInput{inputAddress = Just a} =- a `HashSet.member` addrs'- input_addr _ _ = False- output_addr addrs' StoreOutput{outputAddr = Just a} =- a `HashSet.member` addrs'- output_addr _ _ = False- get_dates = do- BinfoDate start <- S.param "start"- BinfoDate end' <- S.param "end"- let end = end' + 24 * 60 * 60- ch <- lift $ asks (storeChain . webStore . webConfig)- startM <- blockAtOrAfter ch start- endM <- blockAtOrBefore ch end- return (startM, endM)- conduits xpubs addrs endM =- map (uncurry (xpub_c endM)) xpubs- <> map (addr_c endM) (HashSet.toList addrs)- addr_c endM a =- streamThings- (getAddressTxs a)- (Just txRefHash)- def- { limit = 50- , start = AtBlock . blockDataHeight <$> endM- }- xpub_c endM x bs =- streamThings- (xPubTxs x bs)- (Just txRefHash)- def- { limit = 50- , start = AtBlock . blockDataHeight <$> endM- }--getPrice :: MonadIO m => WebT m (Text, BinfoTicker)-getPrice = do- code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD")- ticker <- lift $ asks webTicker- prices <- readTVarIO ticker- case HashMap.lookup code prices of- Nothing -> return (code, def)- Just p -> return (code, p)--getSymbol :: MonadIO m => WebT m BinfoSymbol-getSymbol = uncurry binfoTickerToSymbol <$> getPrice--scottyBinfoBlocksDay :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoBlocksDay = do- setMetrics statBlockchainBlocks- t <- min h . (`div` 1000) <$> S.param "milliseconds"- ch <- lift $ asks (storeChain . webStore . webConfig)- m <- blockAtOrBefore ch t- bs <- go (d t) m- addItemCount (length bs)- streamEncoding $ toEncoding $ map toBinfoBlockInfo bs- where- h = fromIntegral (maxBound :: H.Timestamp)- d = subtract (24 * 3600)- go _ Nothing = return []- go t (Just b)- | H.blockTimestamp (blockDataHeader b) <= fromIntegral t =- return []- | otherwise = do- b' <- getBlock (H.prevBlock (blockDataHeader b))- (b :) <$> go t b'--scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyMultiAddr = do- setMetrics statBlockchainMultiaddr- (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs- numtxid <- getNumTxId- cashaddr <- getCashAddr- local' <- getSymbol- offset <- getBinfoOffset- n <- getBinfoCount "n"- prune <- get_prune- fltr <- get_filter- xbals <- getXBals xspecs- addItemCount . sum . map length $ HashMap.elems xbals- xtxns <- get_xpub_tx_count xbals xspecs- addItemCount (length xtxns)- let sxbals = only_show_xbals sxpubs xbals- xabals = compute_xabals xbals- addrs = addrs' `HashSet.difference` HashMap.keysSet xabals- abals <- get_abals addrs- addItemCount (length abals)- let sxspecs = only_show_xspecs sxpubs xspecs- sxabals = compute_xabals sxbals- sabals = only_show_abals saddrs abals- sallbals = sabals <> sxabals- sbal = compute_bal sallbals- allbals = abals <> xabals- abook = compute_abook addrs xbals- sxaddrs = compute_xaddrs sxbals- salladdrs = saddrs <> sxaddrs- bal = compute_bal allbals- let ibal = fromIntegral sbal- ftxs <-- lift . runConduit $- getBinfoTxs xbals abook sxspecs saddrs salladdrs fltr numtxid prune ibal- .| (dropC offset >> takeC n .| sinkList)- addItemCount (length ftxs)- best <- get_best_block- addItemCount 1- peers <- get_peers- addItemCount (fromIntegral peers)- net <- lift $ asks (storeNetwork . webStore . webConfig)- let baddrs = toBinfoAddrs sabals sxbals xtxns- abaddrs = toBinfoAddrs abals xbals xtxns- recv = sum $ map getBinfoAddrReceived abaddrs- sent' = sum $ map getBinfoAddrSent abaddrs- txn = fromIntegral $ length ftxs- wallet =- BinfoWallet- { getBinfoWalletBalance = bal- , getBinfoWalletTxCount = txn- , getBinfoWalletFilteredCount = txn- , getBinfoWalletTotalReceived = recv- , getBinfoWalletTotalSent = sent'- }- coin = netBinfoSymbol net- block =- BinfoBlockInfo- { getBinfoBlockInfoHash = H.headerHash (blockDataHeader best)- , getBinfoBlockInfoHeight = blockDataHeight best- , getBinfoBlockInfoTime = H.blockTimestamp (blockDataHeader best)- , getBinfoBlockInfoIndex = blockDataHeight best- }- info =- BinfoInfo- { getBinfoConnected = peers- , getBinfoConversion = 100 * 1000 * 1000- , getBinfoLocal = local'- , getBinfoBTC = coin- , getBinfoLatestBlock = block- }- setHeaders- streamEncoding $- binfoMultiAddrToEncoding- net- BinfoMultiAddr- { getBinfoMultiAddrAddresses = baddrs- , getBinfoMultiAddrWallet = wallet- , getBinfoMultiAddrTxs = ftxs- , getBinfoMultiAddrInfo = info- , getBinfoMultiAddrRecommendFee = True- , getBinfoMultiAddrCashAddr = cashaddr- }- where- get_xpub_tx_count xbals =- fmap HashMap.fromList . mapM (\x -> (x,) . fromIntegral <$> xPubTxCount x (xBals x xbals)) . HashSet.toList- get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll)- get_best_block =- getBestBlock >>= \case- Nothing -> raise ThingNotFound- Just bh ->- getBlock bh >>= \case- Nothing -> raise ThingNotFound- Just b -> return b- get_prune =- fmap not $- S.param "no_compact"- `S.rescue` const (return False)- only_show_xbals sxpubs = HashMap.filterWithKey (\k _ -> xPubSpecKey k `HashSet.member` sxpubs)- only_show_xspecs sxpubs = HashSet.filter (\k -> xPubSpecKey k `HashSet.member` sxpubs)- only_show_abals saddrs = HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs)- addr (BinfoAddr a) = Just a- addr (BinfoXpub _) = Nothing- xpub (BinfoXpub x) = Just x- xpub (BinfoAddr _) = Nothing- get_addrs = do- (xspecs, addrs) <- getBinfoActive- sh <- getBinfoAddrsParam "onlyShow"- let xpubs = HashSet.map xPubSpecKey xspecs- actives =- HashSet.map BinfoAddr addrs- <> HashSet.map BinfoXpub xpubs- sh' = if HashSet.null sh then actives else sh- saddrs = HashSet.fromList . mapMaybe addr $ HashSet.toList sh'- sxpubs = HashSet.fromList . mapMaybe xpub $ HashSet.toList sh'- return (addrs, xpubs, saddrs, sxpubs, xspecs)- get_abals =- let f b = (balanceAddress b, b)- g = HashMap.fromList . map f- in fmap g . getBalances . HashSet.toList- get_peers = do- ps <-- lift $- getPeersInformation- =<< asks (storeManager . webStore . webConfig)- return (fromIntegral (length ps))- compute_xabals =- let f b = (balanceAddress (xPubBal b), xPubBal b)- in HashMap.fromList . concatMap (map f) . HashMap.elems- compute_bal =- let f b = balanceAmount b + balanceZero b- in sum . map f . HashMap.elems- compute_abook addrs xbals =- let f XPubSpec{..} XPubBal{..} =- let a = balanceAddress xPubBal- e = error "lions and tigers and bears"- s = toSoft (listToPath xPubBalPath)- in (a, Just (BinfoXPubPath xPubSpecKey (fromMaybe e s)))- amap =- HashMap.map (const Nothing) $- HashSet.toMap addrs- xmap =- HashMap.fromList- . concatMap (uncurry (map . f))- $ HashMap.toList xbals- in amap <> xmap- compute_xaddrs =- let f = map (balanceAddress . xPubBal)- in HashSet.fromList . concatMap f . HashMap.elems--getBinfoCount :: (MonadUnliftIO m, MonadLoggerIO m) => TL.Text -> WebT m Int-getBinfoCount str = do- d <- lift (asks (maxLimitDefault . webMaxLimits . webConfig))- x <- lift (asks (maxLimitFull . webMaxLimits . webConfig))- i <- min x <$> (S.param str `S.rescue` const (return d))- return (fromIntegral i :: Int)--getBinfoOffset ::- (MonadUnliftIO m, MonadLoggerIO m) =>- WebT m Int-getBinfoOffset = do- x <- lift (asks (maxLimitOffset . webMaxLimits . webConfig))- o <- S.param "offset" `S.rescue` const (return 0)- when (o > x) $- raise $- UserError $ "offset exceeded: " <> show o <> " > " <> show x- return (fromIntegral o :: Int)--scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyRawAddr =- setMetrics statBlockchainRawaddr- >> getBinfoAddr "addr" >>= \case- BinfoAddr addr -> do_addr addr- BinfoXpub xpub -> do_xpub xpub- where- do_xpub xpub = do- numtxid <- getNumTxId- derive <- S.param "derive" `S.rescue` const (return DeriveNormal)- let xspec = XPubSpec xpub derive- n <- getBinfoCount "limit"- off <- getBinfoOffset- xbals <- getXBals $ HashSet.singleton xspec- addItemCount . sum . map length $ HashMap.elems xbals- net <- lift $ asks (storeNetwork . webStore . webConfig)- let summary = xPubSummary xspec (xBals xspec xbals)- abook = compute_abook xpub (xBals xspec xbals)- xspecs = HashSet.singleton xspec- saddrs = HashSet.empty- baddrs = HashMap.keysSet abook- bfilter = BinfoFilterAll- amnt =- xPubSummaryConfirmed summary- + xPubSummaryZero summary- txs <-- lift . runConduit $- getBinfoTxs- xbals- abook- xspecs- saddrs- baddrs- bfilter- numtxid- False- (fromIntegral amnt)- .| (dropC off >> takeC n .| sinkList)- addItemCount (length txs)- let ra =- BinfoRawAddr- { binfoRawAddr = BinfoXpub xpub- , binfoRawBalance = amnt- , binfoRawTxCount = fromIntegral $ length txs- , binfoRawUnredeemed = xPubUnspentCount summary- , binfoRawReceived = xPubSummaryReceived summary- , binfoRawSent =- fromIntegral (xPubSummaryReceived summary)- - fromIntegral amnt- , binfoRawTxs = txs- }- setHeaders- streamEncoding $ binfoRawAddrToEncoding net ra- compute_abook xpub xbals =- let f XPubBal{..} =- let a = balanceAddress xPubBal- e = error "black hole swallows all your code"- s = toSoft (listToPath xPubBalPath)- m = fromMaybe e s- in (a, Just (BinfoXPubPath xpub m))- in HashMap.fromList $ map f xbals- do_addr addr = do- numtxid <- getNumTxId- n <- getBinfoCount "limit"- off <- getBinfoOffset- bal <- fromMaybe (zeroBalance addr) <$> getBalance addr- addItemCount 1- net <- lift $ asks (storeNetwork . webStore . webConfig)- let abook = HashMap.singleton addr Nothing- xspecs = HashSet.empty- saddrs = HashSet.singleton addr- bfilter = BinfoFilterAll- amnt = balanceAmount bal + balanceZero bal- txs <-- lift . runConduit $- getBinfoTxs- HashMap.empty- abook- xspecs- saddrs- saddrs- bfilter- numtxid- False- (fromIntegral amnt)- .| (dropC off >> takeC n .| sinkList)- addItemCount (length txs)- let ra =- BinfoRawAddr- { binfoRawAddr = BinfoAddr addr- , binfoRawBalance = amnt- , binfoRawTxCount = balanceTxCount bal- , binfoRawUnredeemed = balanceUnspentCount bal- , binfoRawReceived = balanceTotalReceived bal- , binfoRawSent =- fromIntegral (balanceTotalReceived bal)- - fromIntegral amnt- , binfoRawTxs = txs- }- setHeaders- streamEncoding $ binfoRawAddrToEncoding net ra--scottyBinfoReceived :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoReceived = do- setMetrics statBlockchainQgetreceivedbyaddress- a <- getAddress "addr"- b <- fromMaybe (zeroBalance a) <$> getBalance a- setHeaders- addItemCount 1- S.text . cs . show $ balanceTotalReceived b--scottyBinfoSent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoSent = do- setMetrics statBlockchainQgetsentbyaddress- a <- getAddress "addr"- b <- fromMaybe (zeroBalance a) <$> getBalance a- setHeaders- addItemCount 1- S.text . cs . show $ balanceTotalReceived b - balanceAmount b - balanceZero b--scottyBinfoAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoAddrBalance = do- setMetrics statBlockchainQaddressbalance- a <- getAddress "addr"- b <- fromMaybe (zeroBalance a) <$> getBalance a- setHeaders- addItemCount 1- S.text . cs . show $ balanceAmount b + balanceZero b--scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyFirstSeen = do- setMetrics statBlockchainQaddressfirstseen- a <- getAddress "addr"- ch <- lift $ asks (storeChain . webStore . webConfig)- bb <- chainGetBest ch- let top = H.nodeHeight bb- bot = 0- i <- go ch bb a bot top- setHeaders- addItemCount 1- S.text . cs $ show i- where- go ch bb a bot top = do- let mid = bot + (top - bot) `div` 2- n = top - bot < 2- x <- hasone a bot- y <- hasone a mid- z <- hasone a top- if- | x -> getblocktime ch bb bot- | n -> getblocktime ch bb top- | y -> go ch bb a bot mid- | z -> go ch bb a mid top- | otherwise -> return 0- getblocktime ch bb h =- H.blockTimestamp . H.nodeHeader . fromJust- <$> chainGetAncestor h bb ch- hasone a h = do- let l = Limits 1 0 (Just (AtBlock h))- not . null <$> getAddressTxs a l--scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyShortBal = do- setMetrics statBlockchainBalance- (xspecs, addrs) <- getBinfoActive- cashaddr <- getCashAddr- net <- lift $ asks (storeNetwork . webStore . webConfig)- abals <-- catMaybes- <$> mapM (get_addr_balance net cashaddr) (HashSet.toList addrs)- addItemCount (length abals)- xbals <- mapM (get_xspec_balance net) (HashSet.toList xspecs)- let res = HashMap.fromList (abals <> xbals)- setHeaders- streamEncoding $ toEncoding res- where- to_short_bal Balance{..} =- BinfoShortBal- { binfoShortBalFinal = balanceAmount + balanceZero- , binfoShortBalTxCount = balanceTxCount- , binfoShortBalReceived = balanceTotalReceived- }- get_addr_balance net cashaddr a =- let net' =- if- | cashaddr -> net- | net == bch -> btc- | net == bchTest -> btcTest- | net == bchTest4 -> btcTest- | otherwise -> net- in case addrToText net' a of- Nothing -> return Nothing- Just a' ->- getBalance a >>= \case- Nothing -> return $ Just (a', to_short_bal (zeroBalance a))- Just b -> return $ Just (a', to_short_bal b)- is_ext XPubBal{xPubBalPath = 0 : _} = True- is_ext _ = False- get_xspec_balance net xpub = do- xbals <- xPubBals xpub- xts <- xPubTxCount xpub xbals- addItemCount (length xbals + 1)- let val = sum $ map (balanceAmount . xPubBal) xbals- zro = sum $ map (balanceZero . xPubBal) xbals- exs = filter is_ext xbals- rcv = sum $ map (balanceTotalReceived . xPubBal) exs- sbl =- BinfoShortBal- { binfoShortBalFinal = val + zro- , binfoShortBalTxCount = fromIntegral xts- , binfoShortBalReceived = rcv- }- return (xPubExport net (xPubSpecKey xpub), sbl)--getBinfoHex :: Monad m => WebT m Bool-getBinfoHex =- (== ("hex" :: Text))- <$> S.param "format" `S.rescue` const (return "json")--scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoBlockHeight = do- numtxid <- getNumTxId- height <- S.param "height"- setMetrics statBlockchainBlockHeight- block_hashes <- getBlocksAtHeight height- block_headers <- catMaybes <$> mapM getBlock block_hashes- addItemCount (length block_headers)- next_block_hashes <- getBlocksAtHeight (height + 1)- next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes- addItemCount (length next_block_headers)- binfo_blocks <-- mapM (get_binfo_blocks numtxid next_block_headers) block_headers- setHeaders- net <- lift $ asks (storeNetwork . webStore . webConfig)- streamEncoding $ binfoBlocksToEncoding net binfo_blocks- where- get_tx th =- withRunInIO $ \run ->- unsafeInterleaveIO $- run $ fromJust <$> getTransaction th- get_binfo_blocks numtxid next_block_headers block_header = do- let my_hash = H.headerHash (blockDataHeader block_header)- get_prev = H.prevBlock . blockDataHeader- get_hash = H.headerHash . blockDataHeader- txs <- lift $ mapM get_tx (blockDataTxs block_header)- addItemCount (length txs)- let next_blocks =- map get_hash $- filter- ((== my_hash) . get_prev)- next_block_headers- binfo_txs = map (toBinfoTxSimple numtxid) txs- binfo_block = toBinfoBlock block_header binfo_txs next_blocks- return binfo_block--scottyBinfoLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoLatest = do- numtxid <- getNumTxId- setMetrics statBlockchainLatestblock- best <- get_best_block- let binfoTxIndices = map (encodeBinfoTxId numtxid) (blockDataTxs best)- binfoHeaderHash = H.headerHash (blockDataHeader best)- binfoHeaderTime = H.blockTimestamp (blockDataHeader best)- binfoHeaderIndex = binfoHeaderTime- binfoHeaderHeight = blockDataHeight best- addItemCount 1- streamEncoding $ toEncoding BinfoHeader{..}- where- get_best_block =- getBestBlock >>= \case- Nothing -> raise ThingNotFound- Just bh ->- getBlock bh >>= \case- Nothing -> raise ThingNotFound- Just b -> return b--scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoBlock = do- numtxid <- getNumTxId- hex <- getBinfoHex- setMetrics statBlockchainRawblock- S.param "block" >>= \case- BinfoBlockHash bh -> go numtxid hex bh- BinfoBlockIndex i ->- getBlocksAtHeight i >>= \case- [] -> raise ThingNotFound- bh : _ -> go numtxid hex bh- where- get_tx th =- withRunInIO $ \run ->- unsafeInterleaveIO $- run $ fromJust <$> getTransaction th- go numtxid hex bh =- getBlock bh >>= \case- Nothing -> raise ThingNotFound- Just b -> do- addItemCount 1- txs <- lift $ mapM get_tx (blockDataTxs b)- addItemCount (length txs)- let my_hash = H.headerHash (blockDataHeader b)- get_prev = H.prevBlock . blockDataHeader- get_hash = H.headerHash . blockDataHeader- nxt_headers <-- fmap catMaybes $- mapM getBlock- =<< getBlocksAtHeight (blockDataHeight b + 1)- addItemCount (length nxt_headers)- let nxt =- map get_hash $- filter- ((== my_hash) . get_prev)- nxt_headers- if hex- then do- let x = H.Block (blockDataHeader b) (map transactionData txs)- setHeaders- S.text . encodeHexLazy . runPutL $ serialize x- else do- let btxs = map (toBinfoTxSimple numtxid) txs- y = toBinfoBlock b btxs nxt- setHeaders- net <- lift $ asks (storeNetwork . webStore . webConfig)- streamEncoding $ binfoBlockToEncoding net y--getBinfoTx ::- (MonadLoggerIO m, MonadUnliftIO m) =>- BinfoTxId ->- WebT m (Either Except Transaction)-getBinfoTx txid = do- tx <- case txid of- BinfoTxIdHash h -> maybeToList <$> getTransaction h- BinfoTxIdIndex i -> getNumTransaction i- case tx of- [t] -> return $ Right t- [] -> return $ Left ThingNotFound- ts ->- let tids = map (txHash . transactionData) ts- in return $ Left (TxIndexConflict tids)--scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoTx = do- numtxid <- getNumTxId- hex <- getBinfoHex- txid <- S.param "txid"- setMetrics statBlockchainRawtx- tx <-- getBinfoTx txid >>= \case- Right t -> return t- Left e -> raise e- addItemCount 1- if hex then hx tx else js numtxid tx- where- js numtxid t = do- net <- lift $ asks (storeNetwork . webStore . webConfig)- setHeaders- streamEncoding $ binfoTxToEncoding net $ toBinfoTxSimple numtxid t- hx t = do- setHeaders- S.text . encodeHexLazy . runPutL . serialize $ transactionData t--scottyBinfoTotalOut :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoTotalOut = do- txid <- S.param "txid"- setMetrics statBlockchainQtxtotalbtcoutput- tx <-- getBinfoTx txid >>= \case- Right t -> return t- Left e -> raise e- addItemCount 1- S.text . cs . show . sum . map outputAmount $ transactionOutputs tx--scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoTxFees = do- txid <- S.param "txid"- setMetrics statBlockchainQtxfee- tx <-- getBinfoTx txid >>= \case- Right t -> return t- Left e -> raise e- let i =- sum . map inputAmount . filter f $- transactionInputs tx- o = sum . map outputAmount $ transactionOutputs tx- addItemCount 1- S.text . cs . show $ i - o- where- f StoreInput{} = True- f StoreCoinbase{} = False--scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoTxResult = do- txid <- S.param "txid"- addr <- getAddress "addr"- setMetrics statBlockchainQtxresult- tx <-- getBinfoTx txid >>= \case- Right t -> return t- Left e -> raise e- let i =- toInteger . sum . map inputAmount . filter (f addr) $- transactionInputs tx- o =- toInteger . sum . map outputAmount . filter (g addr) $- transactionOutputs tx- addItemCount 1- S.text . cs . show $ o - i- where- f addr StoreInput{inputAddress = Just a} = a == addr- f _ _ = False- g addr StoreOutput{outputAddr = Just a} = a == addr- g _ _ = False--scottyBinfoTotalInput :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoTotalInput = do- txid <- S.param "txid"- setMetrics statBlockchainQtxtotalbtcinput- tx <-- getBinfoTx txid >>= \case- Right t -> return t- Left e -> raise e- addItemCount 1- S.text . cs . show . sum . map inputAmount . filter f $ transactionInputs tx- where- f StoreInput{} = True- f StoreCoinbase{} = False--scottyBinfoMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoMempool = do- setMetrics statBlockchainMempool- numtxid <- getNumTxId- offset <- getBinfoOffset- n <- getBinfoCount "limit"- mempool <- getMempool- let txids = map snd $ take n $ drop offset mempool- txs <- catMaybes <$> mapM getTransaction txids- net <- lift $ asks (storeNetwork . webStore . webConfig)- setHeaders- let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs- addItemCount (length txs)- streamEncoding $ binfoMempoolToEncoding net mem--scottyBinfoGetBlockCount :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoGetBlockCount = do- setMetrics statBlockchainQgetblockcount- ch <- asks (storeChain . webStore . webConfig)- bn <- chainGetBest ch- setHeaders- addItemCount 1- S.text . cs . show $ H.nodeHeight bn--scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoLatestHash = do- setMetrics statBlockchainQlatesthash- ch <- asks (storeChain . webStore . webConfig)- bn <- chainGetBest ch- setHeaders- addItemCount 1- S.text . TL.fromStrict . H.blockHashToHex . H.headerHash $ H.nodeHeader bn--scottyBinfoSubsidy :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoSubsidy = do- setMetrics statBlockchainQbcperblock- ch <- asks (storeChain . webStore . webConfig)- net <- asks (storeNetwork . webStore . webConfig)- bn <- chainGetBest ch- setHeaders- addItemCount 1- S.text . cs . show . (/ (100 * 1000 * 1000 :: Double)) . fromIntegral $- H.computeSubsidy net (H.nodeHeight bn + 1)--scottyBinfoAddrToHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoAddrToHash = do- setMetrics statBlockchainQaddresstohash- addr <- getAddress "addr"- setHeaders- addItemCount 1- S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr--scottyBinfoHashToAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoHashToAddr = do- setMetrics statBlockchainQhashtoaddress- bs <- maybe S.next return . decodeHex =<< S.param "hash"- net <- asks (storeNetwork . webStore . webConfig)- hash <- either (const S.next) return (decode bs)- addr <- maybe S.next return (addrToText net (PubKeyAddress hash))- setHeaders- addItemCount 1- S.text $ TL.fromStrict addr--scottyBinfoAddrPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoAddrPubkey = do- setMetrics statBlockchainQaddrpubkey- hex <- S.param "pubkey"- pubkey <-- maybe S.next (return . pubKeyAddr) $- eitherToMaybe . runGetS deserialize =<< decodeHex hex- net <- lift $ asks (storeNetwork . webStore . webConfig)- setHeaders- case addrToText net pubkey of- Nothing -> raise ThingNotFound- Just a -> do- addItemCount 1- S.text $ TL.fromStrict a--scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoPubKeyAddr = do- setMetrics statBlockchainQpubkeyaddr- addr <- getAddress "addr"- mi <- strm addr- i <- case mi of- Nothing -> raise ThingNotFound- Just i -> return i- pk <- case extr addr i of- Left e -> raise $ UserError e- Right t -> return t- setHeaders- addItemCount 1- S.text $ encodeHexLazy $ L.fromStrict pk- where- strm addr =- runConduit $- streamThings (getAddressTxs addr) (Just txRefHash) def{limit = 50}- .| concatMapMC (getTransaction . txRefHash)- .| concatMapC (filter (inp addr) . transactionInputs)- .| headC- inp addr StoreInput{inputAddress = Just a} = a == addr- inp _ _ = False- extr addr StoreInput{inputSigScript, inputPkScript, inputWitness} = do- Script sig <- decode inputSigScript- Script pks <- decode inputPkScript- case addr of- PubKeyAddress{} ->- case sig of- [OP_PUSHDATA _ _, OP_PUSHDATA pub _] ->- Right pub- [OP_PUSHDATA _ _] ->- case pks of- [OP_PUSHDATA pub _, OP_CHECKSIG] ->- Right pub- _ -> Left "Could not parse scriptPubKey"- _ -> Left "Could not parse scriptSig"- WitnessPubKeyAddress{} ->- case inputWitness of- [_, pub] -> return pub- _ -> Left "Could not parse scriptPubKey"- _ -> Left "Address does not have public key"- extr _ _ = Left "Incorrect input type"--scottyBinfoHashPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBinfoHashPubkey = do- setMetrics statBlockchainQhashpubkey- pkm <- (eitherToMaybe . runGetS deserialize <=< decodeHex) <$> S.param "pubkey"- addr <- case pkm of- Nothing -> raise $ UserError "Could not decode public key"- Just pk -> return $ pubKeyAddr pk- setHeaders- addItemCount 1- S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr---- GET Network Information ----scottyPeers ::- (MonadUnliftIO m, MonadLoggerIO m) =>- GetPeers ->- WebT m [PeerInformation]-scottyPeers _ = do- setMetrics statPeers- ps <-- lift $- getPeersInformation- =<< asks (storeManager . webStore . webConfig)- addItemCount (length ps)- return ps---- | Obtain information about connected peers from peer manager process.-getPeersInformation ::- MonadLoggerIO m => PeerManager -> m [PeerInformation]-getPeersInformation mgr =- mapMaybe toInfo <$> getPeers mgr- where- toInfo op = do- ver <- onlinePeerVersion op- let as = onlinePeerAddress op- ua = getVarString $ userAgent ver- vs = version ver- sv = services ver- rl = relay ver- return- PeerInformation- { peerUserAgent = ua- , peerAddress = show as- , peerVersion = vs- , peerServices = sv- , peerRelay = rl- }--scottyHealth ::- (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck-scottyHealth _ = do- setMetrics statHealth- h <- lift $ asks webConfig >>= healthCheck- unless (isOK h) $ S.status status503- addItemCount 1- return h--blockHealthCheck ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- WebConfig ->- m BlockHealth-blockHealthCheck cfg = do- let ch = storeChain $ webStore cfg- blockHealthMaxDiff = fromIntegral $ webMaxDiff cfg- 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) =>- WebConfig ->- m TimeHealth-lastTxHealthCheck WebConfig{..} = do- n <- fromIntegral . systemSeconds <$> liftIO getSystemTime- b <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch- t <-- getMempool >>= \case- t : _ ->- let x = fromIntegral $ fst t- in return $ max x b- [] -> return b- let timeHealthAge = n - t- timeHealthMax = fromIntegral to- return TimeHealth{..}- where- ch = storeChain webStore- to =- if webNoMempool- then blockTimeout webTimeouts- else txTimeout webTimeouts--pendingTxsHealthCheck ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- WebConfig ->- m MaxHealth-pendingTxsHealthCheck cfg = do- let maxHealthMax = fromIntegral $ webMaxPending cfg- maxHealthNum <-- fromIntegral- <$> blockStorePendingTxs (storeBlock (webStore cfg))- return MaxHealth{..}--peerHealthCheck ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- PeerManager ->- m CountHealth-peerHealthCheck mgr = do- let countHealthMin = 1- countHealthNum <- fromIntegral . length <$> getPeers mgr- return CountHealth{..}--healthCheck ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>- WebConfig ->- m HealthCheck-healthCheck cfg@WebConfig{..} = do- healthBlocks <- blockHealthCheck cfg- healthLastBlock <- lastBlockHealthCheck (storeChain webStore) webTimeouts- healthLastTx <- lastTxHealthCheck cfg- healthPendingTxs <- pendingTxsHealthCheck cfg- healthPeers <- peerHealthCheck (storeManager webStore)- let healthNetwork = getNetworkName (storeNetwork webStore)- healthVersion = webVersion- hc = HealthCheck{..}- unless (isOK hc) $ do- let t = toStrict $ encodeToLazyText hc- $(logErrorS) "Web" $ "Health check failed: " <> t- return hc--scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyDbStats = do- setMetrics statDbstats- setHeaders- db <- lift $ asks (databaseHandle . storeDB . webStore . webConfig)- statsM <- lift (getProperty db Stats)- addItemCount 1- S.text $ maybe "Could not get stats" cs statsM---------------------------- Parameter Parsing ----------------------------{- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on- parse failure.--}-paramOptional :: (Param a, MonadIO m) => WebT m (Maybe a)-paramOptional = go Proxy- where- go :: (Param a, MonadIO m) => Proxy a -> WebT m (Maybe a)- go proxy = do- net <- lift $ asks (storeNetwork . webStore . webConfig)- tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing)- case tsM of- Nothing -> return Nothing -- Parameter was not supplied- Just ts -> maybe (raise err) (return . Just) $ parseParam net ts- where- l = proxyLabel proxy- p = Just <$> S.param (cs l)- err = UserError $ "Unable to parse param " <> cs l---- | Raises an exception if the parameter is not supplied-param :: (Param a, MonadIO m) => WebT m a-param = go Proxy- where- go :: (Param a, MonadIO m) => Proxy a -> WebT m a- go proxy = do- resM <- paramOptional- case resM of- Just res -> return res- _ ->- raise . UserError $- "The param " <> cs (proxyLabel proxy) <> " was not defined"--{- | Returns the default value of a parameter if it is not supplied. Raises an- exception on parse failure.--}-paramDef :: (Default a, Param a, MonadIO m) => WebT m a-paramDef = fromMaybe def <$> paramOptional--{- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is- not supplied or if parsing fails.--}-paramLazy :: (Param a, MonadIO m) => WebT m a-paramLazy = do- resM <- paramOptional `S.rescue` const (return Nothing)- maybe S.next return resM--parseBody :: (MonadIO m, Serial a) => WebT m a-parseBody = do- b <- L.toStrict <$> S.body- case hex b <> bin b of- Left _ -> raise $ UserError "Failed to parse request body"- Right x -> return x- where- bin = runGetS deserialize- hex b = case B16.decodeBase16 $ C.filter (not . isSpace) b of- Right x -> bin x- Left s -> Left (T.unpack s)--parseOffset :: MonadIO m => WebT m OffsetParam-parseOffset = do- res@(OffsetParam o) <- paramDef- limits <- lift $ asks (webMaxLimits . webConfig)- when (maxLimitOffset limits > 0 && fromIntegral o > maxLimitOffset limits) $- raise . UserError $- "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits)- return res--parseStart ::- (MonadUnliftIO m, MonadLoggerIO m) =>- Maybe StartParam ->- WebT m (Maybe Start)-parseStart Nothing = return Nothing-parseStart (Just s) =- runMaybeT $- case s of- StartParamHash{startParamHash = h} -> start_tx h <|> start_block h- StartParamHeight{startParamHeight = h} -> start_height h- StartParamTime{startParamTime = q} -> start_time q- where- start_height h = return $ AtBlock $ fromIntegral h- start_block h = do- b <- MaybeT $ getBlock (H.BlockHash h)- return $ AtBlock (blockDataHeight b)- start_tx h = do- _ <- MaybeT $ getTxData (TxHash h)- return $ AtTx (TxHash h)- start_time q = do- ch <- lift $ asks (storeChain . webStore . webConfig)- b <- MaybeT $ blockAtOrBefore ch q- let g = blockDataHeight b- return $ AtBlock g--parseLimits :: MonadIO m => WebT m LimitsParam-parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional--paramToLimits ::- (MonadUnliftIO m, MonadLoggerIO m) =>- Bool ->- LimitsParam ->- WebT m Limits-paramToLimits full (LimitsParam limitM o startM) = do- wl <- lift $ asks (webMaxLimits . webConfig)- Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM--validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32-validateLimit wl full limitM =- f m $ maybe d (fromIntegral . getLimitParam) limitM- where- m- | full && maxLimitFull wl > 0 = maxLimitFull wl- | otherwise = maxLimitCount wl- d = maxLimitDefault wl- f a 0 = a- f 0 b = b- f a b = min a b-------------------- Utilities --------------------runInWebReader ::- MonadIO m =>- CacheT (DatabaseReaderT m) a ->- ReaderT WebState m a-runInWebReader f = do- bdb <- asks (storeDB . webStore . webConfig)- mc <- asks (storeCache . webStore . webConfig)- lift $ runReaderT (withCache mc f) bdb--runNoCache :: MonadIO m => Bool -> ReaderT WebState m a -> ReaderT WebState m a-runNoCache False f = f-runNoCache True f = local g f- where- g s = s{webConfig = h (webConfig s)}- h c = c{webStore = i (webStore c)}- i s = s{storeCache = Nothing}--logIt ::- (MonadUnliftIO m, MonadLoggerIO m) =>- Maybe WebMetrics ->- m Middleware-logIt metrics = do- runner <- askRunInIO- return $ \app req respond -> do- var <- newTVarIO B.empty- req' <-- let rb = req_body var (getRequestBodyChunk req)- rq = req{requestBody = rb}- in case metrics of- Nothing -> return rq- Just m -> do- stat_var <- newTVarIO Nothing- let vt =- V.insert (statKey m) stat_var $- vault rq- return rq{vault = vt}- bracket start (end var runner req') $ \_ ->- app req' $ \res -> do- b <- readTVarIO var- let s = responseStatus res- msg = fmtReq b req' <> ": " <> fmtStatus s- if statusIsSuccessful s- then runner $ $(logDebugS) "Web" msg- else runner $ $(logErrorS) "Web" msg- respond res- where- start = systemToUTCTime <$> getSystemTime- req_body var old_body = do- b <- old_body- unless (B.null b) . atomically $ modifyTVar var (<> b)- return b- add_stat d s = do- addStatQuery s- addStatTime s d- end var runner req t1 = do- t2 <- systemToUTCTime <$> getSystemTime- let diff = round $ diffUTCTime t2 t1 * 1000- case metrics of- Nothing -> return ()- Just m -> do- let m_stat_var = V.lookup (statKey m) (vault req)- add_stat diff (statAll m)- case m_stat_var of- Nothing -> return ()- Just stat_var ->- readTVarIO stat_var >>= \case- Nothing -> return ()- Just f -> add_stat diff (f m)- when (diff > 10000) $ do- b <- readTVarIO var- runner $- $(logWarnS) "Web" $- "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req--reqSizeLimit :: Integral i => i -> Middleware-reqSizeLimit i = requestSizeLimitMiddleware lim- where- max_len _req = return (Just (fromIntegral i))- lim =- setOnLengthExceeded too_big $- setMaxLengthForRequest- max_len- defaultRequestSizeLimitSettings- too_big _ = \_app _req send ->- send $- waiExcept requestEntityTooLarge413 RequestTooLarge--fmtReq :: ByteString -> Request -> Text-fmtReq bs req =- let m = requestMethod req- v = httpVersion req- p = rawPathInfo req- q = rawQueryString req- txt = case T.decodeUtf8' bs of- Left _ -> " {invalid utf8}"- Right "" -> ""- Right t -> " [" <> t <> "]"- in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt+module Haskoin.Store.Web+ ( -- * Web+ WebConfig (..),+ Except (..),+ WebLimits (..),+ WebTimeouts (..),+ runWeb,+ )+where++import Conduit+ ( ConduitT,+ await,+ concatMapC,+ concatMapMC,+ dropC,+ dropWhileC,+ headC,+ iterMC,+ mapC,+ runConduit,+ sinkList,+ takeC,+ takeWhileC,+ yield,+ (.|),+ )+import Control.Applicative ((<|>))+import Control.Arrow (second)+import Control.Lens ((.~), (^.))+import Control.Monad+ ( forM_,+ forever,+ join,+ unless,+ when,+ (<=<),+ )+import Control.Monad.Logger+ ( MonadLoggerIO,+ logDebugS,+ logErrorS,+ logWarnS,+ )+import Control.Monad.Reader+ ( ReaderT,+ asks,+ local,+ runReaderT,+ )+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Control (liftWith, restoreT)+import Control.Monad.Trans.Maybe+ ( MaybeT (..),+ runMaybeT,+ )+import Data.Aeson+ ( Encoding,+ ToJSON (..),+ Value,+ )+import qualified Data.Aeson as A+import Data.Aeson.Encode.Pretty+ ( Config (..),+ defConfig,+ encodePretty',+ )+import Data.Aeson.Encoding+ ( encodingToLazyByteString,+ list,+ )+import Data.Aeson.Text (encodeToLazyText)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import Data.ByteString.Builder (lazyByteString)+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+import Data.Bytes.Get+import Data.Bytes.Put+import Data.Bytes.Serial+import Data.Char (isSpace)+import Data.Default (Default (..))+import Data.Function ((&))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.Int (Int64)+import Data.List (nub)+import Data.Maybe+ ( catMaybes,+ fromJust,+ fromMaybe,+ isJust,+ mapMaybe,+ maybeToList,+ )+import Data.Proxy (Proxy (..))+import Data.Serialize (decode)+import Data.String (fromString)+import Data.String.Conversions (cs)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Text.Lazy (toStrict)+import qualified Data.Text.Lazy as TL+import Data.Time.Clock (diffUTCTime)+import Data.Time.Clock.System+ ( getSystemTime,+ systemSeconds,+ systemToUTCTime,+ )+import qualified Data.Vault.Lazy as V+import Data.Word (Word32, Word64)+import Database.RocksDB+ ( Property (..),+ getProperty,+ )+import Haskoin.Address+import qualified Haskoin.Block as H+import Haskoin.Constants+import Haskoin.Data+import Haskoin.Keys+import Haskoin.Network+import Haskoin.Node+ ( Chain,+ OnlinePeer (..),+ PeerManager,+ chainGetAncestor,+ chainGetBest,+ getPeers,+ sendMessage,+ )+import Haskoin.Script+import Haskoin.Store.BlockStore+import Haskoin.Store.Cache+import Haskoin.Store.Common+import Haskoin.Store.Data+import Haskoin.Store.Database.Reader+import Haskoin.Store.Manager+import Haskoin.Store.Stats+import Haskoin.Store.WebCommon+import Haskoin.Transaction+import Haskoin.Util+import NQE+ ( Inbox,+ Publisher,+ receive,+ withSubscription,+ )+import Network.HTTP.Types+ ( Status (..),+ requestEntityTooLarge413,+ status400,+ status404,+ status409,+ status413,+ status500,+ status503,+ statusIsClientError,+ statusIsServerError,+ statusIsSuccessful,+ )+import Network.Wai+ ( Middleware,+ Request (..),+ Response,+ getRequestBodyChunk,+ responseLBS,+ responseStatus,+ )+import Network.Wai.Handler.Warp+ ( defaultSettings,+ setHost,+ setPort,+ )+import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.Wai.Middleware.RequestSizeLimit+import Network.WebSockets+ ( ServerApp,+ acceptRequest,+ defaultConnectionOptions,+ pendingRequest,+ rejectRequestWith,+ requestPath,+ sendTextData,+ )+import qualified Network.WebSockets as WebSockets+import qualified Network.Wreq as Wreq+import Network.Wreq.Session as Wreq (Session)+import qualified Network.Wreq.Session as Wreq.Session+import System.IO.Unsafe (unsafeInterleaveIO)+import qualified System.Metrics as Metrics+import qualified System.Metrics.Gauge as Metrics (Gauge)+import qualified System.Metrics.Gauge as Metrics.Gauge+import UnliftIO+ ( MonadIO,+ MonadUnliftIO,+ TVar,+ askRunInIO,+ atomically,+ bracket,+ bracket_,+ handleAny,+ liftIO,+ modifyTVar,+ newTVarIO,+ readTVarIO,+ timeout,+ withAsync,+ withRunInIO,+ writeTVar,+ )+import UnliftIO.Concurrent (threadDelay)+import Web.Scotty.Internal.Types (ActionT)+import qualified Web.Scotty.Trans as S++type WebT m = ActionT Except (ReaderT WebState m)++data WebLimits = WebLimits+ { maxLimitCount :: !Word32,+ maxLimitFull :: !Word32,+ maxLimitOffset :: !Word32,+ maxLimitDefault :: !Word32,+ maxLimitGap :: !Word32,+ maxLimitInitialGap :: !Word32,+ maxLimitBody :: !Word32+ }+ deriving (Eq, Show)++instance Default WebLimits where+ def =+ WebLimits+ { maxLimitCount = 200000,+ maxLimitFull = 5000,+ maxLimitOffset = 50000,+ maxLimitDefault = 100,+ maxLimitGap = 32,+ maxLimitInitialGap = 20,+ maxLimitBody = 1024 * 1024+ }++data WebConfig = WebConfig+ { webHost :: !String,+ webPort :: !Int,+ webStore :: !Store,+ webMaxDiff :: !Int,+ webMaxPending :: !Int,+ webMaxLimits :: !WebLimits,+ webTimeouts :: !WebTimeouts,+ webVersion :: !String,+ webNoMempool :: !Bool,+ webStats :: !(Maybe Metrics.Store),+ webPriceGet :: !Int,+ webTickerURL :: !String,+ webHistoryURL :: !String+ }++data WebState = WebState+ { webConfig :: !WebConfig,+ webTicker :: !(TVar (HashMap Text BinfoTicker)),+ webMetrics :: !(Maybe WebMetrics),+ webWreqSession :: !Wreq.Session+ }++data WebMetrics = WebMetrics+ { statAll :: !StatDist,+ -- Addresses+ statAddressTransactions :: !StatDist,+ statAddressTransactionsFull :: !StatDist,+ statAddressBalance :: !StatDist,+ statAddressUnspent :: !StatDist,+ statXpub :: !StatDist,+ statXpubDelete :: !StatDist,+ statXpubTransactionsFull :: !StatDist,+ statXpubTransactions :: !StatDist,+ statXpubBalances :: !StatDist,+ statXpubUnspent :: !StatDist,+ -- Transactions+ statTransaction :: !StatDist,+ statTransactionRaw :: !StatDist,+ statTransactionAfter :: !StatDist,+ statTransactionsBlock :: !StatDist,+ statTransactionsBlockRaw :: !StatDist,+ statTransactionPost :: !StatDist,+ statMempool :: !StatDist,+ -- Blocks+ statBlock :: !StatDist,+ statBlockRaw :: !StatDist,+ -- Blockchain+ statBlockchainMultiaddr :: !StatDist,+ statBlockchainBalance :: !StatDist,+ statBlockchainRawaddr :: !StatDist,+ statBlockchainUnspent :: !StatDist,+ statBlockchainRawtx :: !StatDist,+ statBlockchainRawblock :: !StatDist,+ statBlockchainMempool :: !StatDist,+ statBlockchainBlockHeight :: !StatDist,+ statBlockchainBlocks :: !StatDist,+ statBlockchainLatestblock :: !StatDist,+ statBlockchainExportHistory :: !StatDist,+ -- Blockchain /q endpoints+ statBlockchainQaddresstohash :: !StatDist,+ statBlockchainQhashtoaddress :: !StatDist,+ statBlockchainQaddrpubkey :: !StatDist,+ statBlockchainQpubkeyaddr :: !StatDist,+ statBlockchainQhashpubkey :: !StatDist,+ statBlockchainQgetblockcount :: !StatDist,+ statBlockchainQlatesthash :: !StatDist,+ statBlockchainQbcperblock :: !StatDist,+ statBlockchainQtxtotalbtcoutput :: !StatDist,+ statBlockchainQtxtotalbtcinput :: !StatDist,+ statBlockchainQtxfee :: !StatDist,+ statBlockchainQtxresult :: !StatDist,+ statBlockchainQgetreceivedbyaddress :: !StatDist,+ statBlockchainQgetsentbyaddress :: !StatDist,+ statBlockchainQaddressbalance :: !StatDist,+ statBlockchainQaddressfirstseen :: !StatDist,+ -- Others+ statHealth :: !StatDist,+ statPeers :: !StatDist,+ statDbstats :: !StatDist,+ statEvents :: !Metrics.Gauge.Gauge,+ -- Request+ statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist))))+ }++createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics+createMetrics s = liftIO $ do+ statAll <- d "all"++ -- Addresses+ statAddressTransactions <- d "address_transactions"+ statAddressTransactionsFull <- d "address_transactions_full"+ statAddressBalance <- d "address_balance"+ statAddressUnspent <- d "address_unspent"+ statXpub <- d "xpub"+ statXpubDelete <- d "xpub_delete"+ statXpubTransactionsFull <- d "xpub_transactions_full"+ statXpubTransactions <- d "xpub_transactions"+ statXpubBalances <- d "xpub_balances"+ statXpubUnspent <- d "xpub_unspent"++ -- Transactions+ statTransaction <- d "transaction"+ statTransactionRaw <- d "transaction_raw"+ statTransactionAfter <- d "transaction_after"+ statTransactionPost <- d "transaction_post"+ statTransactionsBlock <- d "transactions_block"+ statTransactionsBlockRaw <- d "transactions_block_raw"+ statMempool <- d "mempool"++ -- Blocks+ statBlockBest <- d "block_best"+ statBlockLatest <- d "block_latest"+ statBlock <- d "block"+ statBlockRaw <- d "block_raw"+ statBlockHeight <- d "block_height"+ statBlockHeightRaw <- d "block_height_raw"+ statBlockTime <- d "block_time"+ statBlockTimeRaw <- d "block_time_raw"+ statBlockMtp <- d "block_mtp"+ statBlockMtpRaw <- d "block_mtp_raw"++ -- Blockchain+ statBlockchainMultiaddr <- d "blockchain_multiaddr"+ statBlockchainBalance <- d "blockchain_balance"+ statBlockchainRawaddr <- d "blockchain_rawaddr"+ statBlockchainUnspent <- d "blockchain_unspent"+ statBlockchainRawtx <- d "blockchain_rawtx"+ statBlockchainRawblock <- d "blockchain_rawblock"+ statBlockchainLatestblock <- d "blockchain_latestblock"+ statBlockchainMempool <- d "blockchain_mempool"+ statBlockchainBlockHeight <- d "blockchain_block_height"+ statBlockchainBlocks <- d "blockchain_blocks"+ statBlockchainExportHistory <- d "blockchain_export_history"++ -- Blockchain /q endpoints+ statBlockchainQaddresstohash <- d "blockchain_q_addresstohash"+ statBlockchainQhashtoaddress <- d "blockchain_q_hashtoaddress"+ statBlockchainQaddrpubkey <- d "blockckhain_q_addrpubkey"+ statBlockchainQpubkeyaddr <- d "blockchain_q_pubkeyaddr"+ statBlockchainQhashpubkey <- d "blockchain_q_hashpubkey"+ statBlockchainQgetblockcount <- d "blockchain_q_getblockcount"+ statBlockchainQlatesthash <- d "blockchain_q_latesthash"+ statBlockchainQbcperblock <- d "blockchain_q_bcperblock"+ statBlockchainQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput"+ statBlockchainQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput"+ statBlockchainQtxfee <- d "blockchain_q_txfee"+ statBlockchainQtxresult <- d "blockchain_q_txresult"+ statBlockchainQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress"+ statBlockchainQgetsentbyaddress <- d "blockchain_q_getsentbyaddress"+ statBlockchainQaddressbalance <- d "blockchain_q_addressbalance"+ statBlockchainQaddressfirstseen <- d "blockchain_q_addressfirstseen"++ -- Others+ statHealth <- d "health"+ statPeers <- d "peers"+ statDbstats <- d "dbstats"++ statEvents <- g "events_connected"+ statKey <- V.newKey+ return WebMetrics {..}+ where+ d x = createStatDist ("web." <> x) s+ g x = Metrics.createGauge ("web." <> x) s++withGaugeIO :: MonadUnliftIO m => Metrics.Gauge -> m a -> m a+withGaugeIO g =+ bracket_+ (liftIO $ Metrics.Gauge.inc g)+ (liftIO $ Metrics.Gauge.dec g)++withGaugeIncrease ::+ MonadUnliftIO m =>+ (WebMetrics -> Metrics.Gauge) ->+ WebT m a ->+ WebT m a+withGaugeIncrease gf go =+ lift (asks webMetrics) >>= \case+ Nothing -> go+ Just m -> do+ s <- liftWith $ \run -> withGaugeIO (gf m) (run go)+ restoreT $ return s++setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) -> WebT m ()+setMetrics df =+ asks webMetrics >>= mapM_ go+ where+ go m = do+ req <- S.request+ let t = fromMaybe e $ V.lookup (statKey m) (vault req)+ atomically $ writeTVar t (Just df)+ e = error "the ways of the warrior are yet to be mastered"++addItemCount :: MonadUnliftIO m => Int -> WebT m ()+addItemCount i =+ asks webMetrics >>= mapM_ \m ->+ addStatItems (statAll m) (fromIntegral i)+ >> S.request >>= \req ->+ forM_ (V.lookup (statKey m) (vault req)) \t ->+ readTVarIO t >>= mapM_ \s ->+ addStatItems (s m) (fromIntegral i)++getItemCounter :: (MonadIO m, MonadIO n) => WebT m (Int -> n ())+getItemCounter =+ fromMaybe (\_ -> return ()) <$> runMaybeT do+ q <- lift S.request+ m <- MaybeT $ asks webMetrics+ t <- MaybeT . return $ V.lookup (statKey m) (vault q)+ s <- MaybeT $ readTVarIO t+ return $ addStatItems (s m) . fromIntegral++data WebTimeouts = WebTimeouts+ { txTimeout :: !Word64,+ blockTimeout :: !Word64+ }+ deriving (Eq, Show)++data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON+ deriving (Eq, Show)++instance Default WebTimeouts where+ def = WebTimeouts {txTimeout = 300, blockTimeout = 7200}++instance+ (MonadUnliftIO m, MonadLoggerIO m) =>+ StoreReadBase (ReaderT WebState m)+ where+ getNetwork = runInWebReader getNetwork+ getBestBlock = runInWebReader getBestBlock+ getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height)+ getBlock bh = runInWebReader (getBlock bh)+ getTxData th = runInWebReader (getTxData th)+ getSpender op = runInWebReader (getSpender op)+ getUnspent op = runInWebReader (getUnspent op)+ getBalance a = runInWebReader (getBalance a)+ getMempool = runInWebReader getMempool++instance+ (MonadUnliftIO m, MonadLoggerIO m) =>+ StoreReadExtra (ReaderT WebState m)+ where+ getMaxGap = runInWebReader getMaxGap+ getInitialGap = runInWebReader getInitialGap+ getBalances as = runInWebReader (getBalances as)+ getAddressesTxs as = runInWebReader . getAddressesTxs as+ getAddressTxs a = runInWebReader . getAddressTxs a+ getAddressUnspents a = runInWebReader . getAddressUnspents a+ getAddressesUnspents as = runInWebReader . getAddressesUnspents as+ xPubBals = runInWebReader . xPubBals+ xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals+ xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals+ xPubTxCount xpub = runInWebReader . xPubTxCount xpub+ getNumTxData = runInWebReader . getNumTxData++instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where+ getNetwork = lift getNetwork+ getBestBlock = lift getBestBlock+ getBlocksAtHeight = lift . getBlocksAtHeight+ getBlock = lift . getBlock+ getTxData = lift . getTxData+ getSpender = lift . getSpender+ getUnspent = lift . getUnspent+ getBalance = lift . getBalance+ getMempool = lift getMempool++instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where+ getBalances = lift . getBalances+ getAddressesTxs as = lift . getAddressesTxs as+ getAddressTxs a = lift . getAddressTxs a+ getAddressUnspents a = lift . getAddressUnspents a+ getAddressesUnspents as = lift . getAddressesUnspents as+ xPubBals = lift . xPubBals+ xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals+ xPubTxs xpub xbals = lift . xPubTxs xpub xbals+ xPubTxCount xpub = lift . xPubTxCount xpub+ getMaxGap = lift getMaxGap+ getInitialGap = lift getInitialGap+ getNumTxData = lift . getNumTxData++-------------------+-- Path Handlers --+-------------------++runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => WebConfig -> m ()+runWeb+ cfg@WebConfig+ { webHost = host,+ webPort = port,+ webStore = store',+ webStats = stats,+ webPriceGet = pget,+ webTickerURL = turl,+ webMaxLimits = WebLimits {..}+ } = do+ ticker <- newTVarIO HashMap.empty+ metrics <- mapM createMetrics stats+ session <- liftIO Wreq.Session.newAPISession+ let st =+ WebState+ { webConfig = cfg,+ webTicker = ticker,+ webMetrics = metrics,+ webWreqSession = session+ }+ net = storeNetwork store'+ withAsync (price net session turl pget ticker) $+ const $ do+ reqLogger <- logIt metrics+ runner <- askRunInIO+ S.scottyOptsT opts (runner . (`runReaderT` st)) $ do+ S.middleware (webSocketEvents st)+ S.middleware reqLogger+ S.middleware (reqSizeLimit maxLimitBody)+ S.defaultHandler defHandler+ handlePaths+ S.notFound $ raise ThingNotFound+ where+ opts = def {S.settings = settings defaultSettings}+ settings = setPort port . setHost (fromString host)++getRates ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ Network ->+ Wreq.Session ->+ String ->+ Text ->+ [Word64] ->+ m [BinfoRate]+getRates net session url currency times = do+ handleAny err $ do+ r <-+ liftIO $+ Wreq.asJSON+ =<< Wreq.Session.postWith opts session url body+ return $ r ^. Wreq.responseBody+ where+ err _ = do+ $(logErrorS) "Web" "Could not get historic prices"+ return []+ body = toJSON times+ base =+ Wreq.defaults+ & Wreq.param "base" .~ [T.toUpper (T.pack (getNetworkName net))]+ opts = base & Wreq.param "quote" .~ [currency]++price ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ Network ->+ Wreq.Session ->+ String ->+ Int ->+ TVar (HashMap Text BinfoTicker) ->+ m ()+price net session url pget v = forM_ purl $ \u -> forever $ do+ let err e = $(logErrorS) "Price" $ cs (show e)+ handleAny err $ do+ r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u+ atomically . writeTVar v $ r ^. Wreq.responseBody+ threadDelay pget+ where+ purl = case code of+ Nothing -> Nothing+ Just x -> Just (url <> "?base=" <> x)+ where+ code+ | net == btc = Just "btc"+ | net == bch = Just "bch"+ | otherwise = Nothing++raise :: MonadIO m => Except -> WebT m a+raise err =+ lift (asks webMetrics) >>= \case+ Nothing -> S.raise err+ Just m -> do+ req <- S.request+ mM <- case V.lookup (statKey m) (vault req) of+ Nothing -> return Nothing+ Just t -> readTVarIO t+ let status = errStatus err+ if+ | statusIsClientError status ->+ liftIO $ do+ addClientError (statAll m)+ forM_ mM $ \f -> addClientError (f m)+ | statusIsServerError status ->+ liftIO $ do+ addServerError (statAll m)+ forM_ mM $ \f -> addServerError (f m)+ | otherwise ->+ return ()+ S.raise err++errStatus :: Except -> Status+errStatus ThingNotFound = status404+errStatus BadRequest = status400+errStatus UserError {} = status400+errStatus StringError {} = status400+errStatus ServerError = status500+errStatus TxIndexConflict {} = status409+errStatus ServerTimeout = status500+errStatus RequestTooLarge = status413++defHandler :: Monad m => Except -> WebT m ()+defHandler e = do+ setHeaders+ S.status $ errStatus e+ S.json e++handlePaths ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ S.ScottyT Except (ReaderT WebState m) ()+handlePaths = do+ -- Block Paths+ pathCompact+ (GetBlock <$> paramLazy <*> paramDef)+ scottyBlock+ blockDataToEncoding+ blockDataToJSON+ pathCompact+ (GetBlocks <$> param <*> paramDef)+ (fmap SerialList . scottyBlocks)+ (\n -> list (blockDataToEncoding n) . getSerialList)+ (\n -> json_list blockDataToJSON n . getSerialList)+ pathCompact+ (GetBlockRaw <$> paramLazy)+ scottyBlockRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetBlockBest <$> paramDef)+ scottyBlockBest+ blockDataToEncoding+ blockDataToJSON+ pathCompact+ (GetBlockBestRaw & return)+ scottyBlockBestRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetBlockLatest <$> paramDef)+ (fmap SerialList . scottyBlockLatest)+ (\n -> list (blockDataToEncoding n) . getSerialList)+ (\n -> json_list blockDataToJSON n . getSerialList)+ pathCompact+ (GetBlockHeight <$> paramLazy <*> paramDef)+ (fmap SerialList . scottyBlockHeight)+ (\n -> list (blockDataToEncoding n) . getSerialList)+ (\n -> json_list blockDataToJSON n . getSerialList)+ pathCompact+ (GetBlockHeights <$> param <*> paramDef)+ (fmap SerialList . scottyBlockHeights)+ (\n -> list (blockDataToEncoding n) . getSerialList)+ (\n -> json_list blockDataToJSON n . getSerialList)+ pathCompact+ (GetBlockHeightRaw <$> paramLazy)+ scottyBlockHeightRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetBlockTime <$> paramLazy <*> paramDef)+ scottyBlockTime+ blockDataToEncoding+ blockDataToJSON+ pathCompact+ (GetBlockTimeRaw <$> paramLazy)+ scottyBlockTimeRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetBlockMTP <$> paramLazy <*> paramDef)+ scottyBlockMTP+ blockDataToEncoding+ blockDataToJSON+ pathCompact+ (GetBlockMTPRaw <$> paramLazy)+ scottyBlockMTPRaw+ (const toEncoding)+ (const toJSON)+ -- Transaction Paths+ pathCompact+ (GetTx <$> paramLazy)+ scottyTx+ transactionToEncoding+ transactionToJSON+ pathCompact+ (GetTxs <$> param)+ (fmap SerialList . scottyTxs)+ (\n -> list (transactionToEncoding n) . getSerialList)+ (\n -> json_list transactionToJSON n . getSerialList)+ pathCompact+ (GetTxRaw <$> paramLazy)+ scottyTxRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetTxsRaw <$> param)+ scottyTxsRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetTxsBlock <$> paramLazy)+ (fmap SerialList . scottyTxsBlock)+ (\n -> list (transactionToEncoding n) . getSerialList)+ (\n -> json_list transactionToJSON n . getSerialList)+ pathCompact+ (GetTxsBlockRaw <$> paramLazy)+ scottyTxsBlockRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetTxAfter <$> paramLazy <*> paramLazy)+ scottyTxAfter+ (const toEncoding)+ (const toJSON)+ pathCompact+ (PostTx <$> parseBody)+ scottyPostTx+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetMempool <$> paramOptional <*> parseOffset)+ (fmap SerialList . scottyMempool)+ (const toEncoding)+ (const toJSON)+ -- Address Paths+ pathCompact+ (GetAddrTxs <$> paramLazy <*> parseLimits)+ (fmap SerialList . scottyAddrTxs)+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetAddrsTxs <$> param <*> parseLimits)+ (fmap SerialList . scottyAddrsTxs)+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetAddrTxsFull <$> paramLazy <*> parseLimits)+ (fmap SerialList . scottyAddrTxsFull)+ (\n -> list (transactionToEncoding n) . getSerialList)+ (\n -> json_list transactionToJSON n . getSerialList)+ pathCompact+ (GetAddrsTxsFull <$> param <*> parseLimits)+ (fmap SerialList . scottyAddrsTxsFull)+ (\n -> list (transactionToEncoding n) . getSerialList)+ (\n -> json_list transactionToJSON n . getSerialList)+ pathCompact+ (GetAddrBalance <$> paramLazy)+ scottyAddrBalance+ balanceToEncoding+ balanceToJSON+ pathCompact+ (GetAddrsBalance <$> param)+ (fmap SerialList . scottyAddrsBalance)+ (\n -> list (balanceToEncoding n) . getSerialList)+ (\n -> json_list balanceToJSON n . getSerialList)+ pathCompact+ (GetAddrUnspent <$> paramLazy <*> parseLimits)+ (fmap SerialList . scottyAddrUnspent)+ (\n -> list (unspentToEncoding n) . getSerialList)+ (\n -> json_list unspentToJSON n . getSerialList)+ pathCompact+ (GetAddrsUnspent <$> param <*> parseLimits)+ (fmap SerialList . scottyAddrsUnspent)+ (\n -> list (unspentToEncoding n) . getSerialList)+ (\n -> json_list unspentToJSON n . getSerialList)+ -- XPubs+ pathCompact+ (GetXPub <$> paramLazy <*> paramDef <*> paramDef)+ scottyXPub+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)+ (fmap SerialList . scottyXPubTxs)+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)+ (fmap SerialList . scottyXPubTxsFull)+ (\n -> list (transactionToEncoding n) . getSerialList)+ (\n -> json_list transactionToJSON n . getSerialList)+ pathCompact+ (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef)+ (fmap SerialList . scottyXPubBalances)+ (\n -> list (xPubBalToEncoding n) . getSerialList)+ (\n -> json_list xPubBalToJSON n . getSerialList)+ pathCompact+ (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)+ (fmap SerialList . scottyXPubUnspent)+ (\n -> list (xPubUnspentToEncoding n) . getSerialList)+ (\n -> json_list xPubUnspentToJSON n . getSerialList)+ pathCompact+ (DelCachedXPub <$> paramLazy <*> paramDef)+ scottyDelXPub+ (const toEncoding)+ (const toJSON)+ -- Network+ pathCompact+ (GetPeers & return)+ (fmap SerialList . scottyPeers)+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetHealth & return)+ scottyHealth+ (const toEncoding)+ (const toJSON)+ S.get "/events" scottyEvents+ S.get "/dbstats" scottyDbStats+ -- Blockchain.info+ S.post "/blockchain/multiaddr" scottyMultiAddr+ S.get "/blockchain/multiaddr" scottyMultiAddr+ S.get "/blockchain/balance" scottyShortBal+ S.post "/blockchain/balance" scottyShortBal+ S.get "/blockchain/rawaddr/:addr" scottyRawAddr+ S.get "/blockchain/address/:addr" scottyRawAddr+ S.get "/blockchain/xpub/:addr" scottyRawAddr+ S.post "/blockchain/unspent" scottyBinfoUnspent+ S.get "/blockchain/unspent" scottyBinfoUnspent+ S.get "/blockchain/rawtx/:txid" scottyBinfoTx+ S.get "/blockchain/rawblock/:block" scottyBinfoBlock+ S.get "/blockchain/latestblock" scottyBinfoLatest+ S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool+ S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight+ S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay+ S.get "/blockchain/export-history" scottyBinfoHistory+ S.post "/blockchain/export-history" scottyBinfoHistory+ S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash+ S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr+ S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey+ S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr+ S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey+ S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount+ S.get "/blockchain/q/latesthash" scottyBinfoLatestHash+ S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy+ S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut+ S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput+ S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees+ S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult+ S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived+ S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent+ S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance+ S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen+ where+ json_list f net = toJSONList . map (f net)++pathCompact ::+ (ApiResource a b, MonadIO m) =>+ WebT m a ->+ (a -> WebT m b) ->+ (Network -> b -> Encoding) ->+ (Network -> b -> Value) ->+ S.ScottyT Except (ReaderT WebState m) ()+pathCompact parser action encJson encValue =+ pathCommon parser action encJson encValue False++pathCommon ::+ (ApiResource a b, MonadIO m) =>+ WebT m a ->+ (a -> WebT m b) ->+ (Network -> b -> Encoding) ->+ (Network -> b -> Value) ->+ Bool ->+ S.ScottyT Except (ReaderT WebState m) ()+pathCommon parser action encJson encValue pretty =+ S.addroute (resourceMethod proxy) (capturePath proxy) $ do+ setHeaders+ proto <- setupContentType pretty+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ apiRes <- parser+ res <- action apiRes+ S.raw $ protoSerial proto (encJson net) (encValue net) res+ where+ toProxy :: WebT m a -> Proxy a+ toProxy = const Proxy+ proxy = toProxy parser++streamEncoding :: Monad m => Encoding -> WebT m ()+streamEncoding e = do+ S.setHeader "Content-Type" "application/json; charset=utf-8"+ S.raw (encodingToLazyByteString e)++protoSerial ::+ Serial a =>+ SerialAs ->+ (a -> Encoding) ->+ (a -> Value) ->+ a ->+ L.ByteString+protoSerial SerialAsBinary _ _ = runPutL . serialize+protoSerial SerialAsJSON f _ = encodingToLazyByteString . f+protoSerial SerialAsPrettyJSON _ g =+ encodePretty' defConfig {confTrailingNewline = True} . g++setHeaders :: (Monad m, S.ScottyError e) => ActionT e m ()+setHeaders = S.setHeader "Access-Control-Allow-Origin" "*"++waiExcept :: Status -> Except -> Response+waiExcept s e =+ responseLBS s hs e'+ where+ hs =+ [ ("Access-Control-Allow-Origin", "*"),+ ("Content-Type", "application/json")+ ]+ e' = A.encode e++setupJSON :: Monad m => Bool -> ActionT Except m SerialAs+setupJSON pretty = do+ S.setHeader "Content-Type" "application/json"+ p <- S.param "pretty" `S.rescue` const (return pretty)+ return $ if p then SerialAsPrettyJSON else SerialAsJSON++setupBinary :: Monad m => ActionT Except m SerialAs+setupBinary = do+ S.setHeader "Content-Type" "application/octet-stream"+ return SerialAsBinary++setupContentType :: Monad m => Bool -> ActionT Except m SerialAs+setupContentType pretty = do+ accept <- S.header "accept"+ maybe (setupJSON pretty) setType accept+ where+ setType "application/octet-stream" = setupBinary+ setType _ = setupJSON pretty++-- GET Block / GET Blocks --++scottyBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData+scottyBlock (GetBlock h (NoTx noTx)) = do+ setMetrics statBlock+ getBlock h >>= \case+ Nothing ->+ raise ThingNotFound+ Just b -> do+ addItemCount 1+ return $ pruneTx noTx b++getBlocks ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ [H.BlockHash] ->+ Bool ->+ WebT m [BlockData]+getBlocks hs notx =+ (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs)++scottyBlocks ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData]+scottyBlocks (GetBlocks hs (NoTx notx)) = do+ setMetrics statBlock+ bs <- getBlocks hs notx+ addItemCount (length bs)+ return bs++pruneTx :: Bool -> BlockData -> BlockData+pruneTx False b = b+pruneTx True b = b {blockDataTxs = take 1 (blockDataTxs b)}++-- GET BlockRaw --++scottyBlockRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockRaw ->+ WebT m (RawResult H.Block)+scottyBlockRaw (GetBlockRaw h) = do+ setMetrics statBlockRaw+ b <- getRawBlock h+ addItemCount (1 + length (H.blockTxns b))+ return $ RawResult b++getRawBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ H.BlockHash ->+ WebT m H.Block+getRawBlock h = do+ b <- getBlock h >>= maybe (raise ThingNotFound) return+ lift (toRawBlock b)++toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block+toRawBlock b = do+ let ths = blockDataTxs b+ txs <- mapM f ths+ return H.Block {H.blockHeader = blockDataHeader b, H.blockTxns = txs}+ where+ f x = withRunInIO $ \run ->+ unsafeInterleaveIO . run $+ getTransaction x >>= \case+ Nothing -> undefined+ Just t -> return $ transactionData t++-- GET BlockBest / BlockBestRaw --++scottyBlockBest ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData+scottyBlockBest (GetBlockBest (NoTx notx)) = do+ setMetrics statBlock+ getBestBlock >>= \case+ Nothing -> raise ThingNotFound+ Just bb ->+ getBlock bb >>= \case+ Nothing -> raise ThingNotFound+ Just b -> do+ addItemCount 1+ return $ pruneTx notx b++scottyBlockBestRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockBestRaw ->+ WebT m (RawResult H.Block)+scottyBlockBestRaw _ = do+ setMetrics statBlockRaw+ getBestBlock >>= \case+ Nothing -> raise ThingNotFound+ Just bb -> do+ b <- getRawBlock bb+ addItemCount (1 + length (H.blockTxns b))+ return $ RawResult b++-- GET BlockLatest --++scottyBlockLatest ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockLatest ->+ WebT m [BlockData]+scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do+ setMetrics statBlock+ blocks <-+ getBestBlock+ >>= maybe+ (raise ThingNotFound)+ (go [] <=< getBlock)+ addItemCount (length blocks)+ return blocks+ where+ go acc Nothing = return $ reverse acc+ go acc (Just b)+ | blockDataHeight b <= 0 = return $ reverse acc+ | length acc == 99 = return . reverse $ pruneTx noTx b : acc+ | otherwise = do+ let prev = H.prevBlock (blockDataHeader b)+ go (pruneTx noTx b : acc) =<< getBlock prev++-- GET BlockHeight / BlockHeights / BlockHeightRaw --++scottyBlockHeight ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData]+scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do+ setMetrics statBlock+ blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h)+ addItemCount (length blocks)+ return blocks++scottyBlockHeights ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockHeights ->+ WebT m [BlockData]+scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do+ setMetrics statBlock+ bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights)+ blocks <- getBlocks bhs notx+ addItemCount (length blocks)+ return blocks++scottyBlockHeightRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockHeightRaw ->+ WebT m (RawResultList H.Block)+scottyBlockHeightRaw (GetBlockHeightRaw h) = do+ setMetrics statBlockRaw+ blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h)+ addItemCount (length blocks + sum (map (length . H.blockTxns) blocks))+ return $ RawResultList blocks++-- GET BlockTime / BlockTimeRaw --++scottyBlockTime ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockTime ->+ WebT m BlockData+scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do+ setMetrics statBlock+ ch <- lift $ asks (storeChain . webStore . webConfig)+ blockAtOrBefore ch t >>= \case+ Nothing -> raise ThingNotFound+ Just b -> do+ addItemCount 1+ return $ pruneTx notx b++scottyBlockMTP ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockMTP ->+ WebT m BlockData+scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = do+ setMetrics statBlock+ ch <- lift $ asks (storeChain . webStore . webConfig)+ blockAtOrAfterMTP ch t >>= \case+ Nothing -> raise ThingNotFound+ Just b -> do+ addItemCount 1+ return $ pruneTx notx b++scottyBlockTimeRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockTimeRaw ->+ WebT m (RawResult H.Block)+scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do+ setMetrics statBlockRaw+ ch <- lift $ asks (storeChain . webStore . webConfig)+ blockAtOrBefore ch t >>= \case+ Nothing -> raise ThingNotFound+ Just b -> do+ raw <- lift $ toRawBlock b+ addItemCount (1 + length (H.blockTxns raw))+ return $ RawResult raw++scottyBlockMTPRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetBlockMTPRaw ->+ WebT m (RawResult H.Block)+scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do+ setMetrics statBlockRaw+ ch <- lift $ asks (storeChain . webStore . webConfig)+ blockAtOrAfterMTP ch t >>= \case+ Nothing -> raise ThingNotFound+ Just b -> do+ raw <- lift $ toRawBlock b+ addItemCount (1 + length (H.blockTxns raw))+ return $ RawResult raw++-- GET Transactions --++scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction+scottyTx (GetTx txid) = do+ setMetrics statTransaction+ getTransaction txid >>= \case+ Nothing -> raise ThingNotFound+ Just tx -> do+ addItemCount 1+ return tx++scottyTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction]+scottyTxs (GetTxs txids) = do+ setMetrics statTransaction+ txs <- catMaybes <$> mapM f (nub txids)+ addItemCount (length txs)+ return txs+ where+ f x = lift $+ withRunInIO $ \run ->+ unsafeInterleaveIO . run $+ getTransaction x++scottyTxRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx)+scottyTxRaw (GetTxRaw txid) = do+ setMetrics statTransactionRaw+ getTransaction txid >>= \case+ Nothing -> raise ThingNotFound+ Just tx -> do+ addItemCount 1+ return $ RawResult (transactionData tx)++scottyTxsRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetTxsRaw ->+ WebT m (RawResultList Tx)+scottyTxsRaw (GetTxsRaw txids) = do+ setMetrics statTransactionRaw+ txs <- catMaybes <$> mapM f (nub txids)+ addItemCount (length txs)+ return $ RawResultList $ transactionData <$> txs+ where+ f x = lift $+ withRunInIO $ \run ->+ unsafeInterleaveIO . run $+ getTransaction x++getTxsBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ H.BlockHash ->+ WebT m [Transaction]+getTxsBlock h =+ getBlock h >>= \case+ Nothing -> raise ThingNotFound+ Just b -> do+ txs <- mapM f (blockDataTxs b)+ addItemCount (length txs)+ return txs+ where+ f x = lift $+ withRunInIO $ \run ->+ unsafeInterleaveIO . run $+ getTransaction x >>= \case+ Nothing -> undefined+ Just t -> return t++scottyTxsBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetTxsBlock ->+ WebT m [Transaction]+scottyTxsBlock (GetTxsBlock h) = do+ setMetrics statTransactionsBlock+ txs <- getTxsBlock h+ addItemCount (length txs)+ return txs++scottyTxsBlockRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetTxsBlockRaw ->+ WebT m (RawResultList Tx)+scottyTxsBlockRaw (GetTxsBlockRaw h) = do+ setMetrics statTransactionsBlockRaw+ txs <- fmap transactionData <$> getTxsBlock h+ addItemCount (length txs)+ return $ RawResultList txs++-- GET TransactionAfterHeight --++scottyTxAfter ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetTxAfter ->+ WebT m (GenericResult (Maybe Bool))+scottyTxAfter (GetTxAfter txid height) = do+ setMetrics statTransactionAfter+ (result, count) <- cbAfterHeight (fromIntegral height) txid+ addItemCount count+ return $ GenericResult result++-- | Check if any of the ancestors of this transaction is a coinbase after the+-- specified height. Returns 'Nothing' if answer cannot be computed before+-- hitting limits.+cbAfterHeight ::+ (MonadIO m, StoreReadBase m) =>+ H.BlockHeight ->+ TxHash ->+ m (Maybe Bool, Int)+cbAfterHeight height txid =+ inputs n HashSet.empty HashSet.empty [txid]+ where+ n = 10000+ inputs 0 _ _ [] = return (Nothing, 10000)+ inputs i is ns [] =+ let is' = HashSet.union is ns+ ns' = HashSet.empty+ ts = HashSet.toList (HashSet.difference ns is)+ in case ts of+ [] -> return (Just False, n - i)+ _ -> inputs i is' ns' ts+ inputs i is ns (t : ts) =+ getTransaction t >>= \case+ Nothing -> return (Nothing, n - i)+ Just tx+ | height_check tx ->+ if cb_check tx+ then return (Just True, n - i + 1)+ else+ let ns' = HashSet.union (ins tx) ns+ in inputs (i - 1) is ns' ts+ | otherwise -> inputs (i - 1) is ns ts+ cb_check = any isCoinbase . transactionInputs+ ins = HashSet.fromList . map (outPointHash . inputPoint) . transactionInputs+ height_check tx =+ case transactionBlock tx of+ BlockRef h _ -> h > height+ _ -> True++-- POST Transaction --++scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId+scottyPostTx (PostTx tx) = do+ setMetrics statTransactionPost+ addItemCount 1+ lift (asks webConfig) >>= \cfg ->+ lift (publishTx cfg tx) >>= \case+ Right () -> return (TxId (txHash tx))+ Left e@(PubReject _) -> raise $ UserError (show e)+ _ -> raise ServerError++-- | Publish a new transaction to the network.+publishTx ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ WebConfig ->+ Tx ->+ m (Either PubExcept ())+publishTx cfg tx =+ withSubscription pub $ \s ->+ getTransaction (txHash tx) >>= \case+ Just _ -> return $ Right ()+ Nothing -> go s+ where+ pub = storePublisher (webStore cfg)+ mgr = storeManager (webStore cfg)+ net = storeNetwork (webStore cfg)+ go s =+ getPeers mgr >>= \case+ [] -> return $ Left PubNoPeers+ OnlinePeer {onlinePeerMailbox = p} : _ -> do+ MTx tx `sendMessage` p+ let v =+ if getSegWit net+ then InvWitnessTx+ else InvTx+ sendMessage+ (MGetData (GetData [InvVector v (getTxHash (txHash tx))]))+ p+ f p s+ t = 5 * 1000 * 1000+ f p s+ | webNoMempool cfg = return $ Right ()+ | otherwise =+ liftIO (timeout t (g p s)) >>= \case+ Nothing -> return $ Left PubTimeout+ Just (Left e) -> return $ Left e+ Just (Right ()) -> return $ Right ()+ g p s =+ receive s >>= \case+ StoreTxReject p' h' c _+ | p == p' && h' == txHash tx -> return . Left $ PubReject c+ StorePeerDisconnected p'+ | p == p' -> return $ Left PubPeerDisconnected+ StoreMempoolNew h'+ | h' == txHash tx -> return $ Right ()+ _ -> g p s++-- GET Mempool / Events --++scottyMempool ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash]+scottyMempool (GetMempool limitM (OffsetParam o)) = do+ setMetrics statMempool+ wl <- lift $ asks (webMaxLimits . webConfig)+ let wl' = wl {maxLimitCount = 0}+ l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing+ ths <- map snd . applyLimits l <$> getMempool+ addItemCount 1+ return ths++webSocketEvents :: WebState -> Middleware+webSocketEvents s =+ websocketsOr defaultConnectionOptions events+ where+ pub = (storePublisher . webStore . webConfig) s+ gauge = statEvents <$> webMetrics s+ events pending = withSubscription pub $ \sub -> do+ let path = requestPath $ pendingRequest pending+ if path == "/events"+ then do+ conn <- acceptRequest pending+ forever $+ receiveEvent sub >>= \case+ Nothing -> return ()+ Just event -> sendTextData conn (A.encode event)+ else+ rejectRequestWith+ pending+ WebSockets.defaultRejectRequest+ { WebSockets.rejectBody = L.toStrict $ A.encode ThingNotFound,+ WebSockets.rejectCode = 404,+ WebSockets.rejectMessage = "Not Found",+ WebSockets.rejectHeaders = [("Content-Type", "application/json")]+ }++scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyEvents =+ withGaugeIncrease statEvents $ do+ setHeaders+ proto <- setupContentType False+ pub <- lift $ asks (storePublisher . webStore . webConfig)+ S.stream $ \io flush' ->+ withSubscription pub $ \sub ->+ forever $+ flush' >> receiveEvent sub >>= maybe (return ()) (io . serial proto)+ where+ serial proto e =+ lazyByteString $ protoSerial proto toEncoding toJSON e <> newLine proto+ newLine SerialAsBinary = mempty+ newLine SerialAsJSON = "\n"+ newLine SerialAsPrettyJSON = mempty++receiveEvent :: Inbox StoreEvent -> IO (Maybe Event)+receiveEvent sub =+ go <$> receive sub+ where+ go = \case+ StoreBestBlock b -> Just (EventBlock b)+ StoreMempoolNew t -> Just (EventTx t)+ StoreMempoolDelete t -> Just (EventTx t)+ _ -> Nothing++-- GET Address Transactions --++scottyAddrTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef]+scottyAddrTxs (GetAddrTxs addr pLimits) = do+ setMetrics statAddressTransactions+ txs <- getAddressTxs addr =<< paramToLimits False pLimits+ addItemCount (length txs)+ return txs++scottyAddrsTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef]+scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do+ setMetrics statAddressTransactions+ txs <- getAddressesTxs addrs =<< paramToLimits False pLimits+ addItemCount (length txs)+ return txs++scottyAddrTxsFull ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetAddrTxsFull ->+ WebT m [Transaction]+scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do+ setMetrics statAddressTransactionsFull+ txs <- getAddressTxs addr =<< paramToLimits True pLimits+ ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs+ addItemCount (length ts)+ return ts++scottyAddrsTxsFull ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetAddrsTxsFull ->+ WebT m [Transaction]+scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do+ setMetrics statAddressTransactionsFull+ txs <- getAddressesTxs addrs =<< paramToLimits True pLimits+ ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs+ addItemCount (length ts)+ return ts++scottyAddrBalance ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetAddrBalance ->+ WebT m Balance+scottyAddrBalance (GetAddrBalance addr) = do+ setMetrics statAddressBalance+ addItemCount 1+ getDefaultBalance addr++scottyAddrsBalance ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance]+scottyAddrsBalance (GetAddrsBalance addrs) = do+ setMetrics statAddressBalance+ balances <- getBalances addrs+ addItemCount (length balances)+ return balances++scottyAddrUnspent ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent]+scottyAddrUnspent (GetAddrUnspent addr pLimits) = do+ setMetrics statAddressUnspent+ unspents <- getAddressUnspents addr =<< paramToLimits False pLimits+ addItemCount (length unspents)+ return unspents++scottyAddrsUnspent ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent]+scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do+ setMetrics statAddressUnspent+ unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits+ addItemCount (length unspents)+ return unspents++-- GET XPubs --++scottyXPub ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary+scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do+ setMetrics statXpub+ let xspec = XPubSpec xpub deriv+ xbals <- lift . runNoCache noCache $ xPubBals xspec+ addItemCount (length xbals)+ return $ xPubSummary xspec xbals++scottyDelXPub ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ DelCachedXPub ->+ WebT m (GenericResult Bool)+scottyDelXPub (DelCachedXPub xpub deriv) = do+ setMetrics statXpubDelete+ let xspec = XPubSpec xpub deriv+ cacheM <- lift (asks (storeCache . webStore . webConfig))+ n <- lift $ withCache cacheM (cacheDelXPubs [xspec])+ addItemCount (fromIntegral n)+ return (GenericResult (n > 0))++getXPubTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ XPubKey ->+ DeriveType ->+ LimitsParam ->+ Bool ->+ WebT m [TxRef]+getXPubTxs xpub deriv plimits nocache = do+ limits <- paramToLimits False plimits+ let xspec = XPubSpec xpub deriv+ xbals <- xPubBals xspec+ addItemCount (length xbals)+ lift . runNoCache nocache $ xPubTxs xspec xbals limits++scottyXPubTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef]+scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do+ setMetrics statXpubTransactions+ txs <- getXPubTxs xpub deriv plimits nocache+ addItemCount (length txs)+ return txs++scottyXPubTxsFull ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetXPubTxsFull ->+ WebT m [Transaction]+scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do+ setMetrics statXpubTransactionsFull+ refs <- getXPubTxs xpub deriv plimits nocache+ txs <-+ fmap catMaybes $+ lift . runNoCache nocache $+ mapM (getTransaction . txRefHash) refs+ addItemCount (length txs)+ return txs++scottyXPubBalances ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal]+scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do+ setMetrics statXpubBalances+ balances <- filter f <$> lift (runNoCache noCache (xPubBals spec))+ addItemCount (length balances)+ return balances+ where+ spec = XPubSpec xpub deriv+ f = not . nullBalance . xPubBal++scottyXPubUnspent ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetXPubUnspent ->+ WebT m [XPubUnspent]+scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do+ setMetrics statXpubUnspent+ limits <- paramToLimits False pLimits+ let xspec = XPubSpec xpub deriv+ xbals <- xPubBals xspec+ addItemCount (length xbals)+ unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits+ addItemCount (length unspents)+ return unspents++---------------------------------------+-- Blockchain.info API Compatibility --+---------------------------------------++netBinfoSymbol :: Network -> BinfoSymbol+netBinfoSymbol net+ | net == btc =+ BinfoSymbol+ { getBinfoSymbolCode = "BTC",+ getBinfoSymbolString = "BTC",+ getBinfoSymbolName = "Bitcoin",+ getBinfoSymbolConversion = 100 * 1000 * 1000,+ getBinfoSymbolAfter = True,+ getBinfoSymbolLocal = False+ }+ | net == bch =+ BinfoSymbol+ { getBinfoSymbolCode = "BCH",+ getBinfoSymbolString = "BCH",+ getBinfoSymbolName = "Bitcoin Cash",+ getBinfoSymbolConversion = 100 * 1000 * 1000,+ getBinfoSymbolAfter = True,+ getBinfoSymbolLocal = False+ }+ | otherwise =+ BinfoSymbol+ { getBinfoSymbolCode = "XTS",+ getBinfoSymbolString = "¤",+ getBinfoSymbolName = "Test",+ getBinfoSymbolConversion = 100 * 1000 * 1000,+ getBinfoSymbolAfter = False,+ getBinfoSymbolLocal = False+ }++binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol+binfoTickerToSymbol code BinfoTicker {..} =+ BinfoSymbol+ { getBinfoSymbolCode = code,+ getBinfoSymbolString = binfoTickerSymbol,+ getBinfoSymbolName = name,+ getBinfoSymbolConversion =+ 100 * 1000 * 1000 / binfoTicker15m, -- sat/usd+ getBinfoSymbolAfter = False,+ getBinfoSymbolLocal = True+ }+ where+ name = case code of+ "EUR" -> "Euro"+ "USD" -> "U.S. dollar"+ "GBP" -> "British pound"+ x -> x++getBinfoAddrsParam ::+ MonadIO m =>+ Text ->+ WebT m (HashSet BinfoAddr)+getBinfoAddrsParam name = do+ net <- lift (asks (storeNetwork . webStore . webConfig))+ p <- S.param (cs name) `S.rescue` const (return "")+ if T.null p+ then return HashSet.empty+ else case parseBinfoAddr net p of+ Nothing -> raise (UserError "invalid address")+ Just xs -> return $ HashSet.fromList xs++getBinfoActive ::+ MonadIO m =>+ WebT m (HashSet XPubSpec, HashSet Address)+getBinfoActive = do+ active <- getBinfoAddrsParam "active"+ p2sh <- getBinfoAddrsParam "activeP2SH"+ bech32 <- getBinfoAddrsParam "activeBech32"+ let xspec d b = (`XPubSpec` d) <$> xpub b+ xspecs =+ HashSet.fromList $+ concat+ [ mapMaybe (xspec DeriveNormal) (HashSet.toList active),+ mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh),+ mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32)+ ]+ addrs = HashSet.fromList . mapMaybe addr $ HashSet.toList active+ return (xspecs, addrs)+ where+ addr (BinfoAddr a) = Just a+ addr (BinfoXpub _) = Nothing+ xpub (BinfoXpub x) = Just x+ xpub (BinfoAddr _) = Nothing++getNumTxId :: MonadIO m => WebT m Bool+getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False)++getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight+getChainHeight = do+ ch <- lift $ asks (storeChain . webStore . webConfig)+ H.nodeHeight <$> chainGetBest ch++scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoUnspent = do+ setMetrics statBlockchainUnspent+ (xspecs, addrs) <- getBinfoActive+ numtxid <- getNumTxId+ limit <- get_limit+ min_conf <- get_min_conf+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ height <- getChainHeight+ let mn BinfoUnspent {..} = min_conf > getBinfoUnspentConfirmations+ xbals <- lift $ getXBals xspecs+ addItemCount . sum . map length $ HashMap.elems xbals+ counter <- getItemCounter+ bus <-+ lift . runConduit $+ getBinfoUnspents counter numtxid height xbals xspecs addrs+ .| (dropWhileC mn >> takeC limit .| sinkList)+ setHeaders+ streamEncoding (binfoUnspentsToEncoding net (BinfoUnspents bus))+ where+ get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250)+ get_min_conf = S.param "confirmations" `S.rescue` const (return 0)++getBinfoUnspents ::+ (StoreReadExtra m, MonadIO m) =>+ (Int -> m ()) ->+ Bool ->+ H.BlockHeight ->+ HashMap XPubSpec [XPubBal] ->+ HashSet XPubSpec ->+ HashSet Address ->+ ConduitT () BinfoUnspent m ()+getBinfoUnspents counter numtxid height xbals xspecs addrs = do+ cs' <- conduits+ joinDescStreams cs' .| mapC (uncurry binfo)+ where+ binfo Unspent {..} xp =+ let conf = case unspentBlock of+ MemRef {} -> 0+ BlockRef h _ -> height - h + 1+ hash = outPointHash unspentPoint+ idx = outPointIndex unspentPoint+ val = unspentAmount+ script = unspentScript+ txi = encodeBinfoTxId numtxid hash+ in BinfoUnspent+ { getBinfoUnspentHash = hash,+ getBinfoUnspentOutputIndex = idx,+ getBinfoUnspentScript = script,+ getBinfoUnspentValue = val,+ getBinfoUnspentConfirmations = fromIntegral conf,+ getBinfoUnspentTxIndex = txi,+ getBinfoUnspentXPub = xp+ }+ conduits = (<>) <$> xconduits <*> pure acounduits+ xconduits = lift $ do+ let f x (XPubUnspent u p) =+ let path = toSoft (listToPath p)+ xp = BinfoXPubPath (xPubSpecKey x) <$> path+ in (u, xp)+ g x = do+ return $+ streamThings+ ( \l -> do+ us <- xPubUnspents x (xBals x xbals) l+ counter (length us)+ return us+ )+ Nothing+ def {limit = 16}+ .| mapC (f x)+ mapM g (HashSet.toList xspecs)+ acounduits =+ let f u = (u, Nothing)+ g a =+ streamThings+ ( \l -> do+ us <- getAddressUnspents a l+ counter (length us)+ return us+ )+ Nothing+ def {limit = 16}+ .| mapC f+ in map g (HashSet.toList addrs)++getXBals :: StoreReadExtra m => HashSet XPubSpec -> m (HashMap XPubSpec [XPubBal])+getXBals =+ fmap HashMap.fromList+ . mapM+ ( \x ->+ (x,) . filter (not . nullBalance . xPubBal)+ <$> (xPubBals x)+ )+ . HashSet.toList++xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal]+xBals = HashMap.findWithDefault []++getBinfoTxs ::+ (StoreReadExtra m, MonadIO m) =>+ (Int -> m ()) -> -- counter+ HashMap XPubSpec [XPubBal] -> -- xpub balances+ HashMap Address (Maybe BinfoXPubPath) -> -- address book+ HashSet XPubSpec -> -- show xpubs+ HashSet Address -> -- show addrs+ HashSet Address -> -- balance addresses+ BinfoFilter ->+ Bool -> -- numtxid+ Bool -> -- prune outputs+ Int64 -> -- starting balance+ ConduitT () BinfoTx m ()+getBinfoTxs+ counter+ xbals+ abook+ sxspecs+ saddrs+ baddrs+ bfilter+ numtxid+ prune+ bal = do+ cs' <- conduits+ joinDescStreams cs' .| go bal+ where+ sxspecs_ls = HashSet.toList sxspecs+ saddrs_ls = HashSet.toList saddrs+ conduits = (<>) <$> mapM xpub_c sxspecs_ls <*> pure (map addr_c saddrs_ls)+ xpub_c x =+ lift . return $+ streamThings+ ( \l -> do+ ts <- xPubTxs x (xBals x xbals) l+ counter (length ts)+ return ts+ )+ (Just txRefHash)+ def {limit = 16}+ addr_c a =+ streamThings+ ( \l -> do+ as <- getAddressTxs a l+ counter (length as)+ return as+ )+ (Just txRefHash)+ def {limit = 16}+ binfo_tx b = toBinfoTx numtxid abook prune b+ compute_bal_change BinfoTx {..} =+ let ins = map getBinfoTxInputPrevOut getBinfoTxInputs+ out = getBinfoTxOutputs+ f b BinfoTxOutput {..} =+ let val = fromIntegral getBinfoTxOutputValue+ in case getBinfoTxOutputAddress of+ Nothing -> 0+ Just a+ | a `HashSet.member` baddrs ->+ if b then val else negate val+ | otherwise -> 0+ in sum $ map (f False) ins <> map (f True) out+ go b =+ await >>= \case+ Nothing -> return ()+ Just (TxRef _ t) ->+ lift (getTransaction t) >>= \case+ Nothing -> go b+ Just x -> do+ lift $ counter 1+ let a = binfo_tx b x+ b' = b - compute_bal_change a+ c = isJust (getBinfoTxBlockHeight a)+ Just (d, _) = getBinfoTxResultBal a+ r = d + fromIntegral (getBinfoTxFee a)+ case bfilter of+ BinfoFilterAll ->+ yield a >> go b'+ BinfoFilterSent+ | 0 > r -> yield a >> go b'+ | otherwise -> go b'+ BinfoFilterReceived+ | r > 0 -> yield a >> go b'+ | otherwise -> go b'+ BinfoFilterMoved+ | r == 0 -> yield a >> go b'+ | otherwise -> go b'+ BinfoFilterConfirmed+ | c -> yield a >> go b'+ | otherwise -> go b'+ BinfoFilterMempool+ | c -> return ()+ | otherwise -> yield a >> go b'++getCashAddr :: Monad m => WebT m Bool+getCashAddr = S.param "cashaddr" `S.rescue` const (return False)++getAddress :: (Monad m, MonadUnliftIO m) => TL.Text -> WebT m Address+getAddress param' = do+ txt <- S.param param'+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ case textToAddr net txt of+ Nothing -> raise ThingNotFound+ Just a -> return a++getBinfoAddr :: Monad m => TL.Text -> WebT m BinfoAddr+getBinfoAddr param' = do+ txt <- S.param param'+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ let x =+ BinfoAddr <$> textToAddr net txt+ <|> BinfoXpub <$> xPubImport net txt+ maybe S.next return x++scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoHistory = do+ setMetrics statBlockchainExportHistory+ (xspecs, addrs) <- getBinfoActive+ (startM, endM) <- get_dates+ (code, price') <- getPrice+ xbals <- getXBals xspecs+ addItemCount . sum . map length $ HashMap.elems xbals+ counter <- getItemCounter+ let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals)+ aaddrs = xaddrs <> addrs+ cur = binfoTicker15m price'+ cs' = conduits counter (HashMap.toList xbals) addrs endM+ txs <-+ lift . runConduit $+ joinDescStreams cs'+ .| takeWhileC (is_newer startM)+ .| concatMapMC get_transaction+ .| sinkList+ addItemCount (length txs)+ let times = map transactionTime txs+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ url <- lift $ asks (webHistoryURL . webConfig)+ session <- lift $ asks webWreqSession+ rates <- map binfoRatePrice <$> lift (getRates net session url code times)+ addItemCount (length rates)+ let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0)+ setHeaders+ streamEncoding $ toEncoding hs+ where+ is_newer (Just BlockData {..}) TxRef {txRefBlock = BlockRef {..}} =+ blockRefHeight >= blockDataHeight+ is_newer _ _ = True+ get_addr = balanceAddress . xPubBal+ get_transaction TxRef {txRefHash = h} =+ getTransaction h+ convert cur addrs tx rate =+ let ins = transactionInputs tx+ outs = transactionOutputs tx+ fins = filter (input_addr addrs) ins+ fouts = filter (output_addr addrs) outs+ vin = fromIntegral . sum $ map inputAmount fins+ vout = fromIntegral . sum $ map outputAmount fouts+ v = vout - vin+ t = transactionTime tx+ h = txHash $ transactionData tx+ in toBinfoHistory v t rate cur h+ input_addr addrs' StoreInput {inputAddress = Just a} =+ a `HashSet.member` addrs'+ input_addr _ _ = False+ output_addr addrs' StoreOutput {outputAddr = Just a} =+ a `HashSet.member` addrs'+ output_addr _ _ = False+ get_dates = do+ BinfoDate start <- S.param "start"+ BinfoDate end' <- S.param "end"+ let end = end' + 24 * 60 * 60+ ch <- lift $ asks (storeChain . webStore . webConfig)+ startM <- blockAtOrAfter ch start+ endM <- blockAtOrBefore ch end+ return (startM, endM)+ conduits counter xpubs addrs endM =+ map (uncurry (xpub_c counter endM)) xpubs+ <> map (addr_c counter endM) (HashSet.toList addrs)+ addr_c counter endM a =+ streamThings+ ( \l -> do+ ts <- getAddressTxs a l+ counter (length ts)+ return ts+ )+ (Just txRefHash)+ def+ { limit = 16,+ start = AtBlock . blockDataHeight <$> endM+ }+ xpub_c counter endM x bs =+ streamThings+ ( \l -> do+ ts <- xPubTxs x bs l+ counter (length ts)+ return ts+ )+ (Just txRefHash)+ def+ { limit = 16,+ start = AtBlock . blockDataHeight <$> endM+ }++getPrice :: MonadIO m => WebT m (Text, BinfoTicker)+getPrice = do+ code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD")+ ticker <- lift $ asks webTicker+ prices <- readTVarIO ticker+ case HashMap.lookup code prices of+ Nothing -> return (code, def)+ Just p -> return (code, p)++getSymbol :: MonadIO m => WebT m BinfoSymbol+getSymbol = uncurry binfoTickerToSymbol <$> getPrice++scottyBinfoBlocksDay :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoBlocksDay = do+ setMetrics statBlockchainBlocks+ t <- min h . (`div` 1000) <$> S.param "milliseconds"+ ch <- lift $ asks (storeChain . webStore . webConfig)+ m <- blockAtOrBefore ch t+ bs <- go (d t) m+ addItemCount (length bs)+ streamEncoding $ toEncoding $ map toBinfoBlockInfo bs+ where+ h = fromIntegral (maxBound :: H.Timestamp)+ d = subtract (24 * 3600)+ go _ Nothing = return []+ go t (Just b)+ | H.blockTimestamp (blockDataHeader b) <= fromIntegral t =+ return []+ | otherwise = do+ b' <- getBlock (H.prevBlock (blockDataHeader b))+ (b :) <$> go t b'++scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyMultiAddr = do+ setMetrics statBlockchainMultiaddr+ (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs+ numtxid <- getNumTxId+ cashaddr <- getCashAddr+ local' <- getSymbol+ offset <- getBinfoOffset+ n <- getBinfoCount "n"+ prune <- get_prune+ fltr <- get_filter+ xbals <- getXBals xspecs+ addItemCount . sum . map length $ HashMap.elems xbals+ xtxns <- get_xpub_tx_count xbals xspecs+ addItemCount (length xtxns)+ let sxbals = only_show_xbals sxpubs xbals+ xabals = compute_xabals xbals+ addrs = addrs' `HashSet.difference` HashMap.keysSet xabals+ abals <- get_abals addrs+ addItemCount (length abals)+ let sxspecs = only_show_xspecs sxpubs xspecs+ sxabals = compute_xabals sxbals+ sabals = only_show_abals saddrs abals+ sallbals = sabals <> sxabals+ sbal = compute_bal sallbals+ allbals = abals <> xabals+ abook = compute_abook addrs xbals+ sxaddrs = compute_xaddrs sxbals+ salladdrs = saddrs <> sxaddrs+ bal = compute_bal allbals+ ibal = fromIntegral sbal+ counter <- getItemCounter+ ftxs <-+ lift . runConduit $+ getBinfoTxs+ counter+ xbals+ abook+ sxspecs+ saddrs+ salladdrs+ fltr+ numtxid+ prune+ ibal+ .| (dropC offset >> takeC n .| sinkList)+ best <- get_best_block+ addItemCount 1+ peers <- get_peers+ addItemCount (fromIntegral peers)+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ let baddrs = toBinfoAddrs sabals sxbals xtxns+ abaddrs = toBinfoAddrs abals xbals xtxns+ recv = sum $ map getBinfoAddrReceived abaddrs+ sent' = sum $ map getBinfoAddrSent abaddrs+ txn = fromIntegral $ length ftxs+ wallet =+ BinfoWallet+ { getBinfoWalletBalance = bal,+ getBinfoWalletTxCount = txn,+ getBinfoWalletFilteredCount = txn,+ getBinfoWalletTotalReceived = recv,+ getBinfoWalletTotalSent = sent'+ }+ coin = netBinfoSymbol net+ block =+ BinfoBlockInfo+ { getBinfoBlockInfoHash = H.headerHash (blockDataHeader best),+ getBinfoBlockInfoHeight = blockDataHeight best,+ getBinfoBlockInfoTime = H.blockTimestamp (blockDataHeader best),+ getBinfoBlockInfoIndex = blockDataHeight best+ }+ info =+ BinfoInfo+ { getBinfoConnected = peers,+ getBinfoConversion = 100 * 1000 * 1000,+ getBinfoLocal = local',+ getBinfoBTC = coin,+ getBinfoLatestBlock = block+ }+ setHeaders+ streamEncoding $+ binfoMultiAddrToEncoding+ net+ BinfoMultiAddr+ { getBinfoMultiAddrAddresses = baddrs,+ getBinfoMultiAddrWallet = wallet,+ getBinfoMultiAddrTxs = ftxs,+ getBinfoMultiAddrInfo = info,+ getBinfoMultiAddrRecommendFee = True,+ getBinfoMultiAddrCashAddr = cashaddr+ }+ where+ get_xpub_tx_count xbals =+ fmap HashMap.fromList+ . mapM+ ( \x ->+ (x,)+ . fromIntegral+ <$> xPubTxCount x (xBals x xbals)+ )+ . HashSet.toList+ get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll)+ get_best_block =+ getBestBlock >>= \case+ Nothing -> raise ThingNotFound+ Just bh ->+ getBlock bh >>= \case+ Nothing -> raise ThingNotFound+ Just b -> return b+ get_prune =+ fmap not $+ S.param "no_compact"+ `S.rescue` const (return False)+ only_show_xbals sxpubs = HashMap.filterWithKey (\k _ -> xPubSpecKey k `HashSet.member` sxpubs)+ only_show_xspecs sxpubs = HashSet.filter (\k -> xPubSpecKey k `HashSet.member` sxpubs)+ only_show_abals saddrs = HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs)+ addr (BinfoAddr a) = Just a+ addr (BinfoXpub _) = Nothing+ xpub (BinfoXpub x) = Just x+ xpub (BinfoAddr _) = Nothing+ get_addrs = do+ (xspecs, addrs) <- getBinfoActive+ sh <- getBinfoAddrsParam "onlyShow"+ let xpubs = HashSet.map xPubSpecKey xspecs+ actives =+ HashSet.map BinfoAddr addrs+ <> HashSet.map BinfoXpub xpubs+ sh' = if HashSet.null sh then actives else sh+ saddrs = HashSet.fromList . mapMaybe addr $ HashSet.toList sh'+ sxpubs = HashSet.fromList . mapMaybe xpub $ HashSet.toList sh'+ return (addrs, xpubs, saddrs, sxpubs, xspecs)+ get_abals =+ let f b = (balanceAddress b, b)+ g = HashMap.fromList . map f+ in fmap g . getBalances . HashSet.toList+ get_peers = do+ ps <-+ lift $+ getPeersInformation+ =<< asks (storeManager . webStore . webConfig)+ return (fromIntegral (length ps))+ compute_xabals =+ let f b = (balanceAddress (xPubBal b), xPubBal b)+ in HashMap.fromList . concatMap (map f) . HashMap.elems+ compute_bal =+ let f b = balanceAmount b + balanceZero b+ in sum . map f . HashMap.elems+ compute_abook addrs xbals =+ let f XPubSpec {..} XPubBal {..} =+ let a = balanceAddress xPubBal+ e = error "lions and tigers and bears"+ s = toSoft (listToPath xPubBalPath)+ in (a, Just (BinfoXPubPath xPubSpecKey (fromMaybe e s)))+ amap =+ HashMap.map (const Nothing) $+ HashSet.toMap addrs+ xmap =+ HashMap.fromList+ . concatMap (uncurry (map . f))+ $ HashMap.toList xbals+ in amap <> xmap+ compute_xaddrs =+ let f = map (balanceAddress . xPubBal)+ in HashSet.fromList . concatMap f . HashMap.elems++getBinfoCount :: (MonadUnliftIO m, MonadLoggerIO m) => TL.Text -> WebT m Int+getBinfoCount str = do+ d <- lift (asks (maxLimitDefault . webMaxLimits . webConfig))+ x <- lift (asks (maxLimitFull . webMaxLimits . webConfig))+ i <- min x <$> (S.param str `S.rescue` const (return d))+ return (fromIntegral i :: Int)++getBinfoOffset ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ WebT m Int+getBinfoOffset = do+ x <- lift (asks (maxLimitOffset . webMaxLimits . webConfig))+ o <- S.param "offset" `S.rescue` const (return 0)+ when (o > x) $+ raise $+ UserError $ "offset exceeded: " <> show o <> " > " <> show x+ return (fromIntegral o :: Int)++scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyRawAddr =+ setMetrics statBlockchainRawaddr+ >> getBinfoAddr "addr" >>= \case+ BinfoAddr addr -> do_addr addr+ BinfoXpub xpub -> do_xpub xpub+ where+ do_xpub xpub = do+ numtxid <- getNumTxId+ derive <- S.param "derive" `S.rescue` const (return DeriveNormal)+ let xspec = XPubSpec xpub derive+ n <- getBinfoCount "limit"+ off <- getBinfoOffset+ xbals <- getXBals $ HashSet.singleton xspec+ addItemCount . sum . map length $ HashMap.elems xbals+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ let summary = xPubSummary xspec (xBals xspec xbals)+ abook = compute_abook xpub (xBals xspec xbals)+ xspecs = HashSet.singleton xspec+ saddrs = HashSet.empty+ baddrs = HashMap.keysSet abook+ bfilter = BinfoFilterAll+ amnt =+ xPubSummaryConfirmed summary+ + xPubSummaryZero summary+ counter <- getItemCounter+ txs <-+ lift . runConduit $+ getBinfoTxs+ counter+ xbals+ abook+ xspecs+ saddrs+ baddrs+ bfilter+ numtxid+ False+ (fromIntegral amnt)+ .| (dropC off >> takeC n .| sinkList)+ let ra =+ BinfoRawAddr+ { binfoRawAddr = BinfoXpub xpub,+ binfoRawBalance = amnt,+ binfoRawTxCount = fromIntegral $ length txs,+ binfoRawUnredeemed = xPubUnspentCount summary,+ binfoRawReceived = xPubSummaryReceived summary,+ binfoRawSent =+ fromIntegral (xPubSummaryReceived summary)+ - fromIntegral amnt,+ binfoRawTxs = txs+ }+ setHeaders+ streamEncoding $ binfoRawAddrToEncoding net ra+ compute_abook xpub xbals =+ let f XPubBal {..} =+ let a = balanceAddress xPubBal+ e = error "black hole swallows all your code"+ s = toSoft (listToPath xPubBalPath)+ m = fromMaybe e s+ in (a, Just (BinfoXPubPath xpub m))+ in HashMap.fromList $ map f xbals+ do_addr addr = do+ numtxid <- getNumTxId+ n <- getBinfoCount "limit"+ off <- getBinfoOffset+ bal <- fromMaybe (zeroBalance addr) <$> getBalance addr+ addItemCount 1+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ let abook = HashMap.singleton addr Nothing+ xspecs = HashSet.empty+ saddrs = HashSet.singleton addr+ bfilter = BinfoFilterAll+ amnt = balanceAmount bal + balanceZero bal+ counter <- getItemCounter+ txs <-+ lift . runConduit $+ getBinfoTxs+ counter+ HashMap.empty+ abook+ xspecs+ saddrs+ saddrs+ bfilter+ numtxid+ False+ (fromIntegral amnt)+ .| (dropC off >> takeC n .| sinkList)+ let ra =+ BinfoRawAddr+ { binfoRawAddr = BinfoAddr addr,+ binfoRawBalance = amnt,+ binfoRawTxCount = balanceTxCount bal,+ binfoRawUnredeemed = balanceUnspentCount bal,+ binfoRawReceived = balanceTotalReceived bal,+ binfoRawSent =+ fromIntegral (balanceTotalReceived bal)+ - fromIntegral amnt,+ binfoRawTxs = txs+ }+ setHeaders+ streamEncoding $ binfoRawAddrToEncoding net ra++scottyBinfoReceived :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoReceived = do+ setMetrics statBlockchainQgetreceivedbyaddress+ a <- getAddress "addr"+ b <- fromMaybe (zeroBalance a) <$> getBalance a+ setHeaders+ addItemCount 1+ S.text . cs . show $ balanceTotalReceived b++scottyBinfoSent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoSent = do+ setMetrics statBlockchainQgetsentbyaddress+ a <- getAddress "addr"+ b <- fromMaybe (zeroBalance a) <$> getBalance a+ setHeaders+ addItemCount 1+ S.text . cs . show $ balanceTotalReceived b - balanceAmount b - balanceZero b++scottyBinfoAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoAddrBalance = do+ setMetrics statBlockchainQaddressbalance+ a <- getAddress "addr"+ b <- fromMaybe (zeroBalance a) <$> getBalance a+ setHeaders+ addItemCount 1+ S.text . cs . show $ balanceAmount b + balanceZero b++scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyFirstSeen = do+ setMetrics statBlockchainQaddressfirstseen+ a <- getAddress "addr"+ ch <- lift $ asks (storeChain . webStore . webConfig)+ bb <- chainGetBest ch+ let top = H.nodeHeight bb+ bot = 0+ i <- go ch bb a bot top+ setHeaders+ addItemCount 1+ S.text . cs $ show i+ where+ go ch bb a bot top = do+ let mid = bot + (top - bot) `div` 2+ n = top - bot < 2+ x <- hasone a bot+ y <- hasone a mid+ z <- hasone a top+ if+ | x -> getblocktime ch bb bot+ | n -> getblocktime ch bb top+ | y -> go ch bb a bot mid+ | z -> go ch bb a mid top+ | otherwise -> return 0+ getblocktime ch bb h =+ H.blockTimestamp . H.nodeHeader . fromJust+ <$> chainGetAncestor h bb ch+ hasone a h = do+ let l = Limits 1 0 (Just (AtBlock h))+ not . null <$> getAddressTxs a l++scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyShortBal = do+ setMetrics statBlockchainBalance+ (xspecs, addrs) <- getBinfoActive+ cashaddr <- getCashAddr+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ abals <-+ catMaybes+ <$> mapM (get_addr_balance net cashaddr) (HashSet.toList addrs)+ addItemCount (length abals)+ xbals <- mapM (get_xspec_balance net) (HashSet.toList xspecs)+ let res = HashMap.fromList (abals <> xbals)+ setHeaders+ streamEncoding $ toEncoding res+ where+ to_short_bal Balance {..} =+ BinfoShortBal+ { binfoShortBalFinal = balanceAmount + balanceZero,+ binfoShortBalTxCount = balanceTxCount,+ binfoShortBalReceived = balanceTotalReceived+ }+ get_addr_balance net cashaddr a =+ let net' =+ if+ | cashaddr -> net+ | net == bch -> btc+ | net == bchTest -> btcTest+ | net == bchTest4 -> btcTest+ | otherwise -> net+ in case addrToText net' a of+ Nothing -> return Nothing+ Just a' ->+ getBalance a >>= \case+ Nothing -> return $ Just (a', to_short_bal (zeroBalance a))+ Just b -> return $ Just (a', to_short_bal b)+ is_ext XPubBal {xPubBalPath = 0 : _} = True+ is_ext _ = False+ get_xspec_balance net xpub = do+ xbals <- xPubBals xpub+ xts <- xPubTxCount xpub xbals+ addItemCount (length xbals + 1)+ let val = sum $ map (balanceAmount . xPubBal) xbals+ zro = sum $ map (balanceZero . xPubBal) xbals+ exs = filter is_ext xbals+ rcv = sum $ map (balanceTotalReceived . xPubBal) exs+ sbl =+ BinfoShortBal+ { binfoShortBalFinal = val + zro,+ binfoShortBalTxCount = fromIntegral xts,+ binfoShortBalReceived = rcv+ }+ return (xPubExport net (xPubSpecKey xpub), sbl)++getBinfoHex :: Monad m => WebT m Bool+getBinfoHex =+ (== ("hex" :: Text))+ <$> S.param "format" `S.rescue` const (return "json")++scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoBlockHeight = do+ numtxid <- getNumTxId+ height <- S.param "height"+ setMetrics statBlockchainBlockHeight+ block_hashes <- getBlocksAtHeight height+ block_headers <- catMaybes <$> mapM getBlock block_hashes+ addItemCount (length block_headers)+ next_block_hashes <- getBlocksAtHeight (height + 1)+ next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes+ addItemCount (length next_block_headers)+ binfo_blocks <-+ mapM (get_binfo_blocks numtxid next_block_headers) block_headers+ setHeaders+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ streamEncoding $ binfoBlocksToEncoding net binfo_blocks+ where+ get_tx th =+ withRunInIO $ \run ->+ unsafeInterleaveIO $+ run $ fromJust <$> getTransaction th+ get_binfo_blocks numtxid next_block_headers block_header = do+ let my_hash = H.headerHash (blockDataHeader block_header)+ get_prev = H.prevBlock . blockDataHeader+ get_hash = H.headerHash . blockDataHeader+ txs <- lift $ mapM get_tx (blockDataTxs block_header)+ addItemCount (length txs)+ let next_blocks =+ map get_hash $+ filter+ ((== my_hash) . get_prev)+ next_block_headers+ binfo_txs = map (toBinfoTxSimple numtxid) txs+ binfo_block = toBinfoBlock block_header binfo_txs next_blocks+ return binfo_block++scottyBinfoLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoLatest = do+ numtxid <- getNumTxId+ setMetrics statBlockchainLatestblock+ best <- get_best_block+ let binfoTxIndices = map (encodeBinfoTxId numtxid) (blockDataTxs best)+ binfoHeaderHash = H.headerHash (blockDataHeader best)+ binfoHeaderTime = H.blockTimestamp (blockDataHeader best)+ binfoHeaderIndex = binfoHeaderTime+ binfoHeaderHeight = blockDataHeight best+ addItemCount 1+ streamEncoding $ toEncoding BinfoHeader {..}+ where+ get_best_block =+ getBestBlock >>= \case+ Nothing -> raise ThingNotFound+ Just bh ->+ getBlock bh >>= \case+ Nothing -> raise ThingNotFound+ Just b -> return b++scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoBlock = do+ numtxid <- getNumTxId+ hex <- getBinfoHex+ setMetrics statBlockchainRawblock+ S.param "block" >>= \case+ BinfoBlockHash bh -> go numtxid hex bh+ BinfoBlockIndex i ->+ getBlocksAtHeight i >>= \case+ [] -> raise ThingNotFound+ bh : _ -> go numtxid hex bh+ where+ get_tx th =+ withRunInIO $ \run ->+ unsafeInterleaveIO $+ run $ fromJust <$> getTransaction th+ go numtxid hex bh =+ getBlock bh >>= \case+ Nothing -> raise ThingNotFound+ Just b -> do+ addItemCount 1+ txs <- lift $ mapM get_tx (blockDataTxs b)+ addItemCount (length txs)+ let my_hash = H.headerHash (blockDataHeader b)+ get_prev = H.prevBlock . blockDataHeader+ get_hash = H.headerHash . blockDataHeader+ nxt_headers <-+ fmap catMaybes $+ mapM getBlock+ =<< getBlocksAtHeight (blockDataHeight b + 1)+ addItemCount (length nxt_headers)+ let nxt =+ map get_hash $+ filter+ ((== my_hash) . get_prev)+ nxt_headers+ if hex+ then do+ let x = H.Block (blockDataHeader b) (map transactionData txs)+ setHeaders+ S.text . encodeHexLazy . runPutL $ serialize x+ else do+ let btxs = map (toBinfoTxSimple numtxid) txs+ y = toBinfoBlock b btxs nxt+ setHeaders+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ streamEncoding $ binfoBlockToEncoding net y++getBinfoTx ::+ (MonadLoggerIO m, MonadUnliftIO m) =>+ BinfoTxId ->+ WebT m (Either Except Transaction)+getBinfoTx txid = do+ tx <- case txid of+ BinfoTxIdHash h -> maybeToList <$> getTransaction h+ BinfoTxIdIndex i -> getNumTransaction i+ case tx of+ [t] -> return $ Right t+ [] -> return $ Left ThingNotFound+ ts ->+ let tids = map (txHash . transactionData) ts+ in return $ Left (TxIndexConflict tids)++scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoTx = do+ numtxid <- getNumTxId+ hex <- getBinfoHex+ txid <- S.param "txid"+ setMetrics statBlockchainRawtx+ tx <-+ getBinfoTx txid >>= \case+ Right t -> return t+ Left e -> raise e+ addItemCount 1+ if hex then hx tx else js numtxid tx+ where+ js numtxid t = do+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ setHeaders+ streamEncoding $ binfoTxToEncoding net $ toBinfoTxSimple numtxid t+ hx t = do+ setHeaders+ S.text . encodeHexLazy . runPutL . serialize $ transactionData t++scottyBinfoTotalOut :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoTotalOut = do+ txid <- S.param "txid"+ setMetrics statBlockchainQtxtotalbtcoutput+ tx <-+ getBinfoTx txid >>= \case+ Right t -> return t+ Left e -> raise e+ addItemCount 1+ S.text . cs . show . sum . map outputAmount $ transactionOutputs tx++scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoTxFees = do+ txid <- S.param "txid"+ setMetrics statBlockchainQtxfee+ tx <-+ getBinfoTx txid >>= \case+ Right t -> return t+ Left e -> raise e+ let i =+ sum . map inputAmount . filter f $+ transactionInputs tx+ o = sum . map outputAmount $ transactionOutputs tx+ addItemCount 1+ S.text . cs . show $ i - o+ where+ f StoreInput {} = True+ f StoreCoinbase {} = False++scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoTxResult = do+ txid <- S.param "txid"+ addr <- getAddress "addr"+ setMetrics statBlockchainQtxresult+ tx <-+ getBinfoTx txid >>= \case+ Right t -> return t+ Left e -> raise e+ let i =+ toInteger . sum . map inputAmount . filter (f addr) $+ transactionInputs tx+ o =+ toInteger . sum . map outputAmount . filter (g addr) $+ transactionOutputs tx+ addItemCount 1+ S.text . cs . show $ o - i+ where+ f addr StoreInput {inputAddress = Just a} = a == addr+ f _ _ = False+ g addr StoreOutput {outputAddr = Just a} = a == addr+ g _ _ = False++scottyBinfoTotalInput :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoTotalInput = do+ txid <- S.param "txid"+ setMetrics statBlockchainQtxtotalbtcinput+ tx <-+ getBinfoTx txid >>= \case+ Right t -> return t+ Left e -> raise e+ addItemCount 1+ S.text . cs . show . sum . map inputAmount . filter f $ transactionInputs tx+ where+ f StoreInput {} = True+ f StoreCoinbase {} = False++scottyBinfoMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoMempool = do+ setMetrics statBlockchainMempool+ numtxid <- getNumTxId+ offset <- getBinfoOffset+ n <- getBinfoCount "limit"+ mempool <- getMempool+ let txids = map snd $ take n $ drop offset mempool+ txs <- catMaybes <$> mapM getTransaction txids+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ setHeaders+ let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs+ addItemCount (length txs)+ streamEncoding $ binfoMempoolToEncoding net mem++scottyBinfoGetBlockCount :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoGetBlockCount = do+ setMetrics statBlockchainQgetblockcount+ ch <- asks (storeChain . webStore . webConfig)+ bn <- chainGetBest ch+ setHeaders+ addItemCount 1+ S.text . cs . show $ H.nodeHeight bn++scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoLatestHash = do+ setMetrics statBlockchainQlatesthash+ ch <- asks (storeChain . webStore . webConfig)+ bn <- chainGetBest ch+ setHeaders+ addItemCount 1+ S.text . TL.fromStrict . H.blockHashToHex . H.headerHash $ H.nodeHeader bn++scottyBinfoSubsidy :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoSubsidy = do+ setMetrics statBlockchainQbcperblock+ ch <- asks (storeChain . webStore . webConfig)+ net <- asks (storeNetwork . webStore . webConfig)+ bn <- chainGetBest ch+ setHeaders+ addItemCount 1+ S.text . cs . show . (/ (100 * 1000 * 1000 :: Double)) . fromIntegral $+ H.computeSubsidy net (H.nodeHeight bn + 1)++scottyBinfoAddrToHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoAddrToHash = do+ setMetrics statBlockchainQaddresstohash+ addr <- getAddress "addr"+ setHeaders+ addItemCount 1+ S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr++scottyBinfoHashToAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoHashToAddr = do+ setMetrics statBlockchainQhashtoaddress+ bs <- maybe S.next return . decodeHex =<< S.param "hash"+ net <- asks (storeNetwork . webStore . webConfig)+ hash <- either (const S.next) return (decode bs)+ addr <- maybe S.next return (addrToText net (PubKeyAddress hash))+ setHeaders+ addItemCount 1+ S.text $ TL.fromStrict addr++scottyBinfoAddrPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoAddrPubkey = do+ setMetrics statBlockchainQaddrpubkey+ hex <- S.param "pubkey"+ pubkey <-+ maybe S.next (return . pubKeyAddr) $+ eitherToMaybe . runGetS deserialize =<< decodeHex hex+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ setHeaders+ case addrToText net pubkey of+ Nothing -> raise ThingNotFound+ Just a -> do+ addItemCount 1+ S.text $ TL.fromStrict a++scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoPubKeyAddr = do+ setMetrics statBlockchainQpubkeyaddr+ addr <- getAddress "addr"+ mi <- strm addr+ i <- case mi of+ Nothing -> raise ThingNotFound+ Just i -> return i+ pk <- case extr addr i of+ Left e -> raise $ UserError e+ Right t -> return t+ setHeaders+ S.text $ encodeHexLazy $ L.fromStrict pk+ where+ strm addr = do+ counter <- getItemCounter+ runConduit $+ streamThings+ ( \l -> do+ ts <- getAddressTxs addr l+ counter (length ts)+ return ts+ )+ (Just txRefHash)+ def {limit = 8}+ .| concatMapMC (getTransaction . txRefHash)+ .| iterMC (\_ -> counter 1)+ .| concatMapC (filter (inp addr) . transactionInputs)+ .| headC+ inp addr StoreInput {inputAddress = Just a} = a == addr+ inp _ _ = False+ extr addr StoreInput {inputSigScript, inputPkScript, inputWitness} = do+ Script sig <- decode inputSigScript+ Script pks <- decode inputPkScript+ case addr of+ PubKeyAddress {} ->+ case sig of+ [OP_PUSHDATA _ _, OP_PUSHDATA pub _] ->+ Right pub+ [OP_PUSHDATA _ _] ->+ case pks of+ [OP_PUSHDATA pub _, OP_CHECKSIG] ->+ Right pub+ _ -> Left "Could not parse scriptPubKey"+ _ -> Left "Could not parse scriptSig"+ WitnessPubKeyAddress {} ->+ case inputWitness of+ [_, pub] -> return pub+ _ -> Left "Could not parse scriptPubKey"+ _ -> Left "Address does not have public key"+ extr _ _ = Left "Incorrect input type"++scottyBinfoHashPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyBinfoHashPubkey = do+ setMetrics statBlockchainQhashpubkey+ pkm <- (eitherToMaybe . runGetS deserialize <=< decodeHex) <$> S.param "pubkey"+ addr <- case pkm of+ Nothing -> raise $ UserError "Could not decode public key"+ Just pk -> return $ pubKeyAddr pk+ setHeaders+ addItemCount 1+ S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr++-- GET Network Information --++scottyPeers ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ GetPeers ->+ WebT m [PeerInformation]+scottyPeers _ = do+ setMetrics statPeers+ ps <-+ lift $+ getPeersInformation+ =<< asks (storeManager . webStore . webConfig)+ addItemCount (length ps)+ return ps++-- | Obtain information about connected peers from peer manager process.+getPeersInformation ::+ MonadLoggerIO m => PeerManager -> m [PeerInformation]+getPeersInformation mgr =+ mapMaybe toInfo <$> getPeers mgr+ where+ toInfo op = do+ ver <- onlinePeerVersion op+ let as = onlinePeerAddress op+ ua = getVarString $ userAgent ver+ vs = version ver+ sv = services ver+ rl = relay ver+ return+ PeerInformation+ { peerUserAgent = ua,+ peerAddress = show as,+ peerVersion = vs,+ peerServices = sv,+ peerRelay = rl+ }++scottyHealth ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck+scottyHealth _ = do+ setMetrics statHealth+ h <- lift $ asks webConfig >>= healthCheck+ unless (isOK h) $ S.status status503+ addItemCount 1+ return h++blockHealthCheck ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ WebConfig ->+ m BlockHealth+blockHealthCheck cfg = do+ let ch = storeChain $ webStore cfg+ blockHealthMaxDiff = fromIntegral $ webMaxDiff cfg+ 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) =>+ WebConfig ->+ m TimeHealth+lastTxHealthCheck WebConfig {..} = do+ n <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ b <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch+ t <-+ getMempool >>= \case+ t : _ ->+ let x = fromIntegral $ fst t+ in return $ max x b+ [] -> return b+ let timeHealthAge = n - t+ timeHealthMax = fromIntegral to+ return TimeHealth {..}+ where+ ch = storeChain webStore+ to =+ if webNoMempool+ then blockTimeout webTimeouts+ else txTimeout webTimeouts++pendingTxsHealthCheck ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ WebConfig ->+ m MaxHealth+pendingTxsHealthCheck cfg = do+ let maxHealthMax = fromIntegral $ webMaxPending cfg+ maxHealthNum <-+ fromIntegral+ <$> blockStorePendingTxs (storeBlock (webStore cfg))+ return MaxHealth {..}++peerHealthCheck ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ PeerManager ->+ m CountHealth+peerHealthCheck mgr = do+ let countHealthMin = 1+ countHealthNum <- fromIntegral . length <$> getPeers mgr+ return CountHealth {..}++healthCheck ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>+ WebConfig ->+ m HealthCheck+healthCheck cfg@WebConfig {..} = do+ healthBlocks <- blockHealthCheck cfg+ healthLastBlock <- lastBlockHealthCheck (storeChain webStore) webTimeouts+ healthLastTx <- lastTxHealthCheck cfg+ healthPendingTxs <- pendingTxsHealthCheck cfg+ healthPeers <- peerHealthCheck (storeManager webStore)+ let healthNetwork = getNetworkName (storeNetwork webStore)+ healthVersion = webVersion+ hc = HealthCheck {..}+ unless (isOK hc) $ do+ let t = toStrict $ encodeToLazyText hc+ $(logErrorS) "Web" $ "Health check failed: " <> t+ return hc++scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()+scottyDbStats = do+ setMetrics statDbstats+ setHeaders+ db <- lift $ asks (databaseHandle . storeDB . webStore . webConfig)+ statsM <- lift (getProperty db Stats)+ addItemCount 1+ S.text $ maybe "Could not get stats" cs statsM++-----------------------+-- Parameter Parsing --+-----------------------++-- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on+-- parse failure.+paramOptional :: (Param a, MonadIO m) => WebT m (Maybe a)+paramOptional = go Proxy+ where+ go :: (Param a, MonadIO m) => Proxy a -> WebT m (Maybe a)+ go proxy = do+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing)+ case tsM of+ Nothing -> return Nothing -- Parameter was not supplied+ Just ts -> maybe (raise err) (return . Just) $ parseParam net ts+ where+ l = proxyLabel proxy+ p = Just <$> S.param (cs l)+ err = UserError $ "Unable to parse param " <> cs l++-- | Raises an exception if the parameter is not supplied+param :: (Param a, MonadIO m) => WebT m a+param = go Proxy+ where+ go :: (Param a, MonadIO m) => Proxy a -> WebT m a+ go proxy = do+ resM <- paramOptional+ case resM of+ Just res -> return res+ _ ->+ raise . UserError $+ "The param " <> cs (proxyLabel proxy) <> " was not defined"++-- | Returns the default value of a parameter if it is not supplied. Raises an+-- exception on parse failure.+paramDef :: (Default a, Param a, MonadIO m) => WebT m a+paramDef = fromMaybe def <$> paramOptional++-- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is+-- not supplied or if parsing fails.+paramLazy :: (Param a, MonadIO m) => WebT m a+paramLazy = do+ resM <- paramOptional `S.rescue` const (return Nothing)+ maybe S.next return resM++parseBody :: (MonadIO m, Serial a) => WebT m a+parseBody = do+ b <- L.toStrict <$> S.body+ case hex b <> bin b of+ Left _ -> raise $ UserError "Failed to parse request body"+ Right x -> return x+ where+ bin = runGetS deserialize+ hex b = case B16.decodeBase16 $ C.filter (not . isSpace) b of+ Right x -> bin x+ Left s -> Left (T.unpack s)++parseOffset :: MonadIO m => WebT m OffsetParam+parseOffset = do+ res@(OffsetParam o) <- paramDef+ limits <- lift $ asks (webMaxLimits . webConfig)+ when (maxLimitOffset limits > 0 && fromIntegral o > maxLimitOffset limits) $+ raise . UserError $+ "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits)+ return res++parseStart ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ Maybe StartParam ->+ WebT m (Maybe Start)+parseStart Nothing = return Nothing+parseStart (Just s) =+ runMaybeT $+ case s of+ StartParamHash {startParamHash = h} -> start_tx h <|> start_block h+ StartParamHeight {startParamHeight = h} -> start_height h+ StartParamTime {startParamTime = q} -> start_time q+ where+ start_height h = return $ AtBlock $ fromIntegral h+ start_block h = do+ b <- MaybeT $ getBlock (H.BlockHash h)+ return $ AtBlock (blockDataHeight b)+ start_tx h = do+ _ <- MaybeT $ getTxData (TxHash h)+ return $ AtTx (TxHash h)+ start_time q = do+ ch <- lift $ asks (storeChain . webStore . webConfig)+ b <- MaybeT $ blockAtOrBefore ch q+ let g = blockDataHeight b+ return $ AtBlock g++parseLimits :: MonadIO m => WebT m LimitsParam+parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional++paramToLimits ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ Bool ->+ LimitsParam ->+ WebT m Limits+paramToLimits full (LimitsParam limitM o startM) = do+ wl <- lift $ asks (webMaxLimits . webConfig)+ Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM++validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32+validateLimit wl full limitM =+ f m $ maybe d (fromIntegral . getLimitParam) limitM+ where+ m+ | full && maxLimitFull wl > 0 = maxLimitFull wl+ | otherwise = maxLimitCount wl+ d = maxLimitDefault wl+ f a 0 = a+ f 0 b = b+ f a b = min a b++---------------+-- Utilities --+---------------++runInWebReader ::+ MonadIO m =>+ CacheT (DatabaseReaderT m) a ->+ ReaderT WebState m a+runInWebReader f = do+ bdb <- asks (storeDB . webStore . webConfig)+ mc <- asks (storeCache . webStore . webConfig)+ lift $ runReaderT (withCache mc f) bdb++runNoCache :: MonadIO m => Bool -> ReaderT WebState m a -> ReaderT WebState m a+runNoCache False f = f+runNoCache True f = local g f+ where+ g s = s {webConfig = h (webConfig s)}+ h c = c {webStore = i (webStore c)}+ i s = s {storeCache = Nothing}++logIt ::+ (MonadUnliftIO m, MonadLoggerIO m) =>+ Maybe WebMetrics ->+ m Middleware+logIt metrics = do+ runner <- askRunInIO+ return $ \app req respond -> do+ var <- newTVarIO B.empty+ req' <-+ let rb = req_body var (getRequestBodyChunk req)+ rq = req {requestBody = rb}+ in case metrics of+ Nothing -> return rq+ Just m -> do+ stat_var <- newTVarIO Nothing+ let vt =+ V.insert (statKey m) stat_var $+ vault rq+ return rq {vault = vt}+ bracket start (end var runner req') $ \_ ->+ app req' $ \res -> do+ b <- readTVarIO var+ let s = responseStatus res+ msg = fmtReq b req' <> ": " <> fmtStatus s+ if statusIsSuccessful s+ then runner $ $(logDebugS) "Web" msg+ else runner $ $(logErrorS) "Web" msg+ respond res+ where+ start = systemToUTCTime <$> getSystemTime+ req_body var old_body = do+ b <- old_body+ unless (B.null b) . atomically $ modifyTVar var (<> b)+ return b+ add_stat d s = do+ addStatQuery s+ addStatTime s d+ end var runner req t1 = do+ t2 <- systemToUTCTime <$> getSystemTime+ let diff = round $ diffUTCTime t2 t1 * 1000+ case metrics of+ Nothing -> return ()+ Just m -> do+ let m_stat_var = V.lookup (statKey m) (vault req)+ add_stat diff (statAll m)+ case m_stat_var of+ Nothing -> return ()+ Just stat_var ->+ readTVarIO stat_var >>= \case+ Nothing -> return ()+ Just f -> add_stat diff (f m)+ when (diff > 10000) $ do+ b <- readTVarIO var+ runner $+ $(logWarnS) "Web" $+ "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req++reqSizeLimit :: Integral i => i -> Middleware+reqSizeLimit i = requestSizeLimitMiddleware lim+ where+ max_len _req = return (Just (fromIntegral i))+ lim =+ setOnLengthExceeded too_big $+ setMaxLengthForRequest+ max_len+ defaultRequestSizeLimitSettings+ too_big _ = \_app _req send ->+ send $+ waiExcept requestEntityTooLarge413 RequestTooLarge++fmtReq :: ByteString -> Request -> Text+fmtReq bs req =+ let m = requestMethod req+ v = httpVersion req+ p = rawPathInfo req+ q = rawQueryString req+ txt = case T.decodeUtf8' bs of+ Left _ -> " {invalid utf8}"+ Right "" -> ""+ Right t -> " [" <> t <> "]"+ in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt fmtStatus :: Status -> Text fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)
test/Haskoin/Store/CacheSpec.hs view
@@ -9,16 +9,16 @@ spec :: Spec spec = do- describe "Score for block reference" $ do- prop "sorts correctly" $- forAll arbitraryBlockRefs $ \ts ->- let scores = map blockRefScore (sort ts)- in sort scores == reverse scores- prop "respects identity" $- forAll arbitraryBlockRef $ \b ->- let score = blockRefScore b- ref = scoreBlockRef score- in ref == b+ describe "Score for block reference" $ do+ prop "sorts correctly" $+ forAll arbitraryBlockRefs $ \ts ->+ let scores = map blockRefScore (sort ts)+ in sort scores == reverse scores+ prop "respects identity" $+ forAll arbitraryBlockRef $ \b ->+ let score = blockRefScore b+ ref = scoreBlockRef score+ in ref == b arbitraryBlockRefs :: Gen [BlockRef] arbitraryBlockRefs = listOf arbitraryBlockRef@@ -27,9 +27,9 @@ arbitraryBlockRef = oneof [b, m] where b = do- h <- choose (0, 0x07ffffff)- p <- choose (0, 0x03ffffff)- return BlockRef{blockRefHeight = h, blockRefPos = p}+ h <- choose (0, 0x07ffffff)+ p <- choose (0, 0x03ffffff)+ return BlockRef {blockRefHeight = h, blockRefPos = p} m = do- t <- choose (0, 0x001fffffffffffff)- return MemRef{memRefTime = t}+ t <- choose (0, 0x001fffffffffffff)+ return MemRef {memRefTime = t}
test/Haskoin/StoreSpec.hs view
@@ -30,186 +30,186 @@ import UnliftIO data TestStore = TestStore- { testStoreDB :: !DatabaseReader- , testStoreBlockStore :: !BlockStore- , testStoreChain :: !Chain- , testStoreEvents :: !(Inbox StoreEvent)- }+ { testStoreDB :: !DatabaseReader,+ testStoreBlockStore :: !BlockStore,+ testStoreChain :: !Chain,+ testStoreEvents :: !(Inbox StoreEvent)+ } spec :: Spec spec = do- describe "Download" $ do- it "gets 8 blocks" $- withTestStore bchRegTest "eight-blocks" $ \TestStore{..} -> do- bs <- replicateM 8 . receiveMatch testStoreEvents $ \case- StoreBestBlock b -> Just b- _ -> Nothing- let bestHash = last bs- bestNodeM <- chainGetBlock bestHash testStoreChain- bestNodeM `shouldSatisfy` isJust- let bestNode = fromJust bestNodeM- bestHeight = nodeHeight bestNode- bestHeight `shouldBe` 8- it "get a block and its transactions" $- withTestStore bchRegTest "get-block-txs" $ \TestStore{..} ->- flip runReaderT testStoreDB $ do- let h1 = "5369ef2386c72acdf513ffd80aeba2a1774e2f004d120761e54a8bf614173f3e"- get_the_block h =- receive testStoreEvents >>= \case- StoreBestBlock b- | h <= 1 -> return b- | otherwise ->- get_the_block ((h :: Int) - 1)- _ -> get_the_block h- bh <- get_the_block 15- m <- getBlock bh- let bd = fromMaybe (error "Could not get block") m- t1 <- getTransaction h1- lift $ do- blockDataHeight bd `shouldBe` 15- length (blockDataTxs bd) `shouldBe` 1- head (blockDataTxs bd) `shouldBe` h1- t1 `shouldSatisfy` isJust- txHash (transactionData (fromJust t1)) `shouldBe` h1+ describe "Download" $ do+ it "gets 8 blocks" $+ withTestStore bchRegTest "eight-blocks" $ \TestStore {..} -> do+ bs <- replicateM 8 . receiveMatch testStoreEvents $ \case+ StoreBestBlock b -> Just b+ _ -> Nothing+ let bestHash = last bs+ bestNodeM <- chainGetBlock bestHash testStoreChain+ bestNodeM `shouldSatisfy` isJust+ let bestNode = fromJust bestNodeM+ bestHeight = nodeHeight bestNode+ bestHeight `shouldBe` 8+ it "get a block and its transactions" $+ withTestStore bchRegTest "get-block-txs" $ \TestStore {..} ->+ flip runReaderT testStoreDB $ do+ let h1 = "5369ef2386c72acdf513ffd80aeba2a1774e2f004d120761e54a8bf614173f3e"+ get_the_block h =+ receive testStoreEvents >>= \case+ StoreBestBlock b+ | h <= 1 -> return b+ | otherwise ->+ get_the_block ((h :: Int) - 1)+ _ -> get_the_block h+ bh <- get_the_block 15+ m <- getBlock bh+ let bd = fromMaybe (error "Could not get block") m+ t1 <- getTransaction h1+ lift $ do+ blockDataHeight bd `shouldBe` 15+ length (blockDataTxs bd) `shouldBe` 1+ head (blockDataTxs bd) `shouldBe` h1+ t1 `shouldSatisfy` isJust+ txHash (transactionData (fromJust t1)) `shouldBe` h1 withTestStore ::- MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a+ MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a withTestStore net t f =- withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w ->- runNoLoggingT $ do- let ad =- NetworkAddress- nodeNetwork- (sockToHostAddress (SockAddrInet 0 0))- cfg =- StoreConfig- { storeConfMaxPeers = 20- , storeConfInitPeers = []- , storeConfDiscover = True- , storeConfDB = w- , storeConfNetwork = net- , storeConfCache = Nothing- , storeConfGap = gap- , storeConfInitialGap = 20- , storeConfCacheMin = 100- , storeConfMaxKeys = 100 * 1000 * 1000- , storeConfNoMempool = False- , storeConfWipeMempool = False- , storeConfSyncMempool = False- , storeConfPeerTimeout = 60- , storeConfPeerMaxLife = 48 * 3600- , storeConfConnect = dummyPeerConnect net ad- , storeConfCacheRetryDelay = 100000- , storeConfStats = Nothing- }- withStore cfg $ \Store{..} ->- withSubscription storePublisher $ \sub ->- lift $- f- TestStore- { testStoreDB = storeDB- , testStoreBlockStore = storeBlock- , testStoreChain = storeChain- , testStoreEvents = sub- }+ withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w ->+ runNoLoggingT $ do+ let ad =+ NetworkAddress+ nodeNetwork+ (sockToHostAddress (SockAddrInet 0 0))+ cfg =+ StoreConfig+ { storeConfMaxPeers = 20,+ storeConfInitPeers = [],+ storeConfDiscover = True,+ storeConfDB = w,+ storeConfNetwork = net,+ storeConfCache = Nothing,+ storeConfGap = gap,+ storeConfInitialGap = 20,+ storeConfCacheMin = 100,+ storeConfMaxKeys = 100 * 1000 * 1000,+ storeConfNoMempool = False,+ storeConfWipeMempool = False,+ storeConfSyncMempool = False,+ storeConfPeerTimeout = 60,+ storeConfPeerMaxLife = 48 * 3600,+ storeConfConnect = dummyPeerConnect net ad,+ storeConfCacheRetryDelay = 100000,+ storeConfStats = Nothing+ }+ withStore cfg $ \Store {..} ->+ withSubscription storePublisher $ \sub ->+ lift $+ f+ TestStore+ { testStoreDB = storeDB,+ testStoreBlockStore = storeBlock,+ testStoreChain = storeChain,+ testStoreEvents = sub+ } gap :: Word32 gap = 32 allBlocks :: [Block] allBlocks =- fromRight (error "Could not decode blocks") $- runGet f (decodeBase64Lenient allBlocksBase64)+ fromRight (error "Could not decode blocks") $+ runGet f (decodeBase64Lenient allBlocksBase64) where f = mapM (const get) [(1 :: Int) .. 15] allBlocksBase64 :: ByteString allBlocksBase64 =- "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\- \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\- \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\- \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\- \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\- \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\- \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\- \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\- \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\- \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\- \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\- \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\- \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\- \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\- \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\- \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\- \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\- \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\- \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\- \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\- \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\- \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\- \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\- \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\- \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\- \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\- \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\- \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\- \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\- \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\- \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\- \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\- \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\- \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\- \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\- \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\- \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\- \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\- \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\- \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\- \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\- \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\- \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\- \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\- \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\- \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\- \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\- \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\- \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\- \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA"+ "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\+ \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\+ \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\+ \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\+ \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\+ \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\+ \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\+ \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\+ \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\+ \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\+ \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\+ \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\+ \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\+ \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\+ \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\+ \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\+ \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\+ \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\+ \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\+ \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\+ \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\+ \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\+ \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\+ \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\+ \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\+ \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\+ \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\+ \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\+ \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\+ \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\+ \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\+ \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\+ \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\+ \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\+ \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\+ \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\+ \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\+ \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\+ \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\+ \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\+ \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA" dummyPeerConnect :: Network -> NetworkAddress -> SockAddr -> WithConnection dummyPeerConnect net ad sa f = do- r <- newInbox- s <- newInbox- let s' = inboxToMailbox s- withAsync (go r s') $ \_ -> do- let o = awaitForever (`send` r)- i = forever (receive s >>= yield)- f (Conduits i o) :: IO ()+ r <- newInbox+ s <- newInbox+ let s' = inboxToMailbox s+ withAsync (go r s') $ \_ -> do+ let o = awaitForever (`send` r)+ i = forever (receive s >>= yield)+ f (Conduits i o) :: IO () where go :: Inbox ByteString -> Mailbox ByteString -> IO () go r s = do- nonce <- randomIO- now <- round <$> liftIO getPOSIXTime- let rmt = NetworkAddress 0 (sockToHostAddress sa)- ver = buildVersion net nonce 0 ad rmt now- runPut (putMessage net (MVersion ver)) `send` s- runConduit $- forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact- .| outc- .| awaitForever (`send` s)+ nonce <- randomIO+ now <- round <$> liftIO getPOSIXTime+ let rmt = NetworkAddress 0 (sockToHostAddress sa)+ ver = buildVersion net nonce 0 ad rmt now+ runPut (putMessage net (MVersion ver)) `send` s+ runConduit $+ forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact+ .| outc+ .| awaitForever (`send` s) outc = mapMC $ \msg' -> return $ runPut (putMessage net msg') inc = forever $ do- x <- takeCE 24 .| foldC- case decode x of- Left _ ->- error "Dummy peer not decode message header"- Right (MessageHeader _ _ len _) -> do- y <- takeCE (fromIntegral len) .| foldC- case runGet (getMessage net) $ x `B.append` y of- Right msg' -> yield msg'- Left e ->- error $- "Dummy peer could not decode payload: " <> show e+ x <- takeCE 24 .| foldC+ case decode x of+ Left _ ->+ error "Dummy peer not decode message header"+ Right (MessageHeader _ _ len _) -> do+ y <- takeCE (fromIntegral len) .| foldC+ case runGet (getMessage net) $ x `B.append` y of+ Right msg' -> yield msg'+ Left e ->+ error $+ "Dummy peer could not decode payload: " <> show e mockPeerReact :: Message -> [Message] mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]