haskoin-store 0.64.0 → 0.64.1
raw patch · 16 files changed
+7477/−6630 lines, 16 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 +8/−0
- haskoin-store.cabal +4/−4
- src/Haskoin/Store.hs +43/−39
- src/Haskoin/Store/BlockStore.hs +1225/−1086
- src/Haskoin/Store/Cache.hs +1513/−1349
- src/Haskoin/Store/Common.hs +246/−199
- src/Haskoin/Store/Database/Reader.hs +197/−166
- src/Haskoin/Store/Database/Types.hs +209/−152
- src/Haskoin/Store/Database/Writer.hs +204/−172
- src/Haskoin/Store/Logic.hs +293/−210
- src/Haskoin/Store/Manager.hs +234/−195
- src/Haskoin/Store/Stats.hs +129/−87
- src/Haskoin/Store/Web.hs +3057/−2862
- test/Haskoin/Store/CacheSpec.hs +8/−8
- test/Haskoin/StoreSpec.hs +107/−101
- test/Spec.hs +0/−0
CHANGELOG.md view
@@ -4,6 +4,14 @@ 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.1+### Changed+- Automatic formatting.+- Improve cache debug logging.++### Fixed+- Add item count to 'all' query metrics.+ ## 0.64.0 ### Changed - Improve metrics.
haskoin-store.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store-version: 0.64.0+version: 0.64.1 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.0+ , haskoin-store-data ==0.64.1 , 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.0+ , haskoin-store-data ==0.64.1 , 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.0+ , haskoin-store-data ==0.64.1 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store.hs view
@@ -1,40 +1,44 @@-module Haskoin.Store- ( Store(..)- , StoreConfig(..)- , StoreEvent(..)- , withStore- , module Haskoin.Store.BlockStore- , module Haskoin.Store.Web- , module Haskoin.Store.Database.Reader- , module Haskoin.Store.Database.Types- , module Haskoin.Store.Data- -- * Cache- , CacheConfig(..)- , CacheT- , CacheError(..)- , withCache- , connectRedis- , isInCache- -- * Store Reader- , StoreReadBase(..)- , StoreReadExtra(..)- , Limits(..)- , Start(..)- -- * Useful Fuctions- , getTransaction- , getDefaultBalance- , getSpenders- , getActiveTxData- , blockAtOrBefore- -- * Other Data- , PubExcept(..)- ) where+module Haskoin.Store (+ Store (..),+ StoreConfig (..),+ StoreEvent (..),+ withStore,+ module Haskoin.Store.BlockStore,+ module Haskoin.Store.Web,+ module Haskoin.Store.Database.Reader,+ module Haskoin.Store.Database.Types,+ module Haskoin.Store.Data, -import Haskoin.Store.BlockStore-import Haskoin.Store.Cache-import Haskoin.Store.Common-import Haskoin.Store.Data-import Haskoin.Store.Database.Reader-import Haskoin.Store.Database.Types-import Haskoin.Store.Manager-import Haskoin.Store.Web+ -- * Cache+ CacheConfig (..),+ CacheT,+ CacheError (..),+ withCache,+ connectRedis,+ isInCache,++ -- * Store Reader+ StoreReadBase (..),+ StoreReadExtra (..),+ Limits (..),+ Start (..),++ -- * Useful Fuctions+ getTransaction,+ getDefaultBalance,+ getSpenders,+ getActiveTxData,+ blockAtOrBefore,++ -- * Other Data+ PubExcept (..),+) where++import Haskoin.Store.BlockStore+import Haskoin.Store.Cache+import Haskoin.Store.Common+import Haskoin.Store.Data+import Haskoin.Store.Database.Reader+import Haskoin.Store.Database.Types+import Haskoin.Store.Manager+import Haskoin.Store.Web
src/Haskoin/Store/BlockStore.hs view
@@ -1,1089 +1,1228 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# 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 "height"- headersHeight <- g "headers"- storePendingTxs <- g "pending_txs"- storePeersConnected <- g "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- { blockConfManager :: !PeerManager- -- ^ peer manager from running node- , blockConfChain :: !Chain- -- ^ chain from a running node- , blockConfListener :: !(Publisher StoreEvent)- -- ^ listener for store events- , blockConfDB :: !DatabaseReader- -- ^ RocksDB database handle- , blockConfNet :: !Network- -- ^ network constants- , blockConfNoMempool :: !Bool- -- ^ do not index new mempool transactions- , blockConfWipeMempool :: !Bool- -- ^ wipe mempool at start- , blockConfSyncMempool :: !Bool- -- ^ sync mempool from peers- , blockConfPeerTimeout :: !NominalDiffTime- -- ^ disconnect syncing peer if inactive for this long- , 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+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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 "height"+ headersHeight <- g "headers"+ storePendingTxs <- g "pending_txs"+ storePeersConnected <- g "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
src/Haskoin/Store/Cache.hs view
@@ -1,1352 +1,1516 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# 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- , cacheBlockSyncTime :: !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"- cacheBlockSyncTime <- d "cache.block_sync"- cacheXPubBals <- c "cache.xpub_bals"- cacheXPubUnspents <- c "cache.xpub_unspents"- cacheXPubTxs <- c "cache.xpub_txs"- cacheXPubTxCount <- c "cache.xpub_tx_count"- 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) = go- where- f = cacheIsInMempool txid >>= \x ->- unless x $- lift (getTxData txid) >>= \mtx ->- forM_ mtx $ \tx -> do- $(logDebugS) "Cache" $- "Importing mempool transaction: " <> txHashToHex txid- importMultiTxC [tx]- go = withLock f >>= \case- Just () -> return ()- Nothing -> smallDelay >> go--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 $ withMetrics cacheIndexTime index- where- op XPubUnspent {xPubUnspent = u} = (unspentPoint u, unspentBlock u)- should_index =- asks cacheMin >>= \x ->- if x <= lenNotNull xbals then inSync else return False- index =- bracket set_index unset_index $ \y -> when y $- 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- 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"+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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+ , cacheBlockSyncTime :: !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"+ cacheBlockSyncTime <- d "cache.block_sync"+ cacheXPubBals <- c "cache.xpub_bals"+ cacheXPubUnspents <- c "cache.xpub_unspents"+ cacheXPubTxs <- c "cache.xpub_txs"+ cacheXPubTxCount <- c "cache.xpub_tx_count"+ 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 $ withMetrics cacheIndexTime index+ where+ op XPubUnspent{xPubUnspent = u} = (unspentPoint u, unspentBlock u)+ should_index =+ asks cacheMin >>= \x ->+ if x <= lenNotNull xbals then inSync else return False+ index =+ bracket set_index unset_index $ \y -> when y $+ 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+ 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 ()
src/Haskoin/Store/Common.hs view
@@ -1,113 +1,147 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-module Haskoin.Store.Common- ( Limits(..)- , Start(..)- , StoreReadBase(..)- , StoreReadExtra(..)- , StoreWrite(..)- , StoreEvent(..)- , PubExcept(..)- , DataMetrics(..)- , getActiveBlock- , getActiveTxData- , getDefaultBalance- , getSpenders- , getTransaction- , getNumTransaction- , blockAtOrAfter- , blockAtOrBefore- , blockAtOrAfterMTP- , xPubSummary- , deriveAddresses- , deriveFunction- , deOffset- , applyLimits- , applyLimitsC- , applyLimit- , applyLimitC- , sortTxs- , nub'- , microseconds- , streamThings- , joinDescStreams- , createDataMetrics- ) where+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} -import Conduit (ConduitT, await, dropC, mapC,- sealConduitT, takeC, yield, ($$++))-import Control.DeepSeq (NFData)-import Control.Exception (Exception)-import Control.Monad (forM)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Control.Monad.Trans.Reader (runReaderT)-import Data.ByteString (ByteString)-import Data.Default (Default (..))-import qualified Data.HashSet as H-import Data.Hashable (Hashable)-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as I-import Data.List (sortOn)-import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes, mapMaybe)-import Data.Ord (Down (..))-import Data.Serialize (Serialize (..))-import Data.Time.Clock.System (getSystemTime, systemNanoseconds,- systemSeconds)-import Data.Word (Word32, Word64)-import GHC.Generics (Generic)-import Haskoin (Address, BlockHash,- BlockHeader (..), BlockHeight,- BlockNode (..), KeyIndex,- Network (..), OutPoint (..),- RejectCode (..), Tx (..),- TxHash (..), TxIn (..),- XPubKey (..), deriveAddr,- deriveCompatWitnessAddr,- deriveWitnessAddr,- firstGreaterOrEqual, headerHash,- lastSmallerOrEqual, mtp, pubSubKey,- txHash)-import Haskoin.Node (Chain, Peer)-import Haskoin.Store.Data (Balance (..), BlockData (..),- DeriveType (..), Spender,- Transaction (..), TxData (..),- TxRef (..), UnixTime, Unspent (..),- XPubBal (..), XPubSpec (..),- XPubSummary (..), XPubUnspent (..),- nullBalance, toTransaction,- zeroBalance)-import qualified System.Metrics as Metrics-import System.Metrics.Counter (Counter)-import qualified System.Metrics.Counter as Counter-import UnliftIO (MonadIO, liftIO)+module Haskoin.Store.Common (+ Limits (..),+ Start (..),+ StoreReadBase (..),+ StoreReadExtra (..),+ StoreWrite (..),+ StoreEvent (..),+ PubExcept (..),+ DataMetrics (..),+ getActiveBlock,+ getActiveTxData,+ getDefaultBalance,+ getSpenders,+ getTransaction,+ getNumTransaction,+ blockAtOrAfter,+ blockAtOrBefore,+ blockAtOrAfterMTP,+ xPubSummary,+ deriveAddresses,+ deriveFunction,+ deOffset,+ applyLimits,+ applyLimitsC,+ applyLimit,+ applyLimitC,+ sortTxs,+ nub',+ microseconds,+ streamThings,+ joinDescStreams,+ createDataMetrics,+) where +import Conduit (+ ConduitT,+ await,+ dropC,+ mapC,+ sealConduitT,+ takeC,+ yield,+ ($$++),+ )+import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad (forM)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Control.Monad.Trans.Reader (runReaderT)+import Data.ByteString (ByteString)+import Data.Default (Default (..))+import qualified Data.HashSet as H+import Data.Hashable (Hashable)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as I+import Data.List (sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, mapMaybe)+import Data.Ord (Down (..))+import Data.Serialize (Serialize (..))+import Data.Time.Clock.System (+ getSystemTime,+ systemNanoseconds,+ systemSeconds,+ )+import Data.Word (Word32, Word64)+import GHC.Generics (Generic)+import Haskoin (+ Address,+ BlockHash,+ BlockHeader (..),+ BlockHeight,+ BlockNode (..),+ KeyIndex,+ Network (..),+ OutPoint (..),+ RejectCode (..),+ Tx (..),+ TxHash (..),+ TxIn (..),+ XPubKey (..),+ deriveAddr,+ deriveCompatWitnessAddr,+ deriveWitnessAddr,+ firstGreaterOrEqual,+ headerHash,+ lastSmallerOrEqual,+ mtp,+ pubSubKey,+ txHash,+ )+import Haskoin.Node (Chain, Peer)+import Haskoin.Store.Data (+ Balance (..),+ BlockData (..),+ DeriveType (..),+ Spender,+ Transaction (..),+ TxData (..),+ TxRef (..),+ UnixTime,+ Unspent (..),+ XPubBal (..),+ XPubSpec (..),+ XPubSummary (..),+ XPubUnspent (..),+ nullBalance,+ toTransaction,+ zeroBalance,+ )+import qualified System.Metrics as Metrics+import System.Metrics.Counter (Counter)+import qualified System.Metrics.Counter as Counter+import UnliftIO (MonadIO, liftIO)+ type DeriveAddr = XPubKey -> KeyIndex -> Address type Offset = Word32 type Limit = Word32 data Start- = AtTx{atTxHash :: !TxHash}- | AtBlock{atBlockHeight :: !BlockHeight}+ = AtTx {atTxHash :: !TxHash}+ | AtBlock {atBlockHeight :: !BlockHeight} deriving (Eq, Show) data Limits = Limits- { limit :: !Word32+ { limit :: !Word32 , offset :: !Word32- , start :: !(Maybe Start)+ , 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@@ -158,54 +192,58 @@ getSpenders th = getActiveTxData th >>= \case Nothing -> return I.empty- Just td -> I.fromList . catMaybes <$>- mapM get_spender [0 .. length (txOut (txData td)) - 1]+ 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+getActiveBlock bh =+ 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+getActiveTxData th =+ 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+getDefaultBalance a =+ 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 ..] deriveFunction :: DeriveType -> DeriveAddr deriveFunction DeriveNormal i = fst . deriveAddr i-deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i+deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i 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- }+ { 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@@ -219,34 +257,39 @@ sm <- getSpenders (txHash (txData d)) return $ toTransaction d sm -blockAtOrAfter :: (MonadIO m, StoreReadExtra m)- => Chain- -> UnixTime- -> m (Maybe BlockData)+blockAtOrAfter ::+ (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)) where- f x = let t = fromIntegral (blockTimestamp (nodeHeader x))- in return $ t `compare` q+ f x =+ let t = fromIntegral (blockTimestamp (nodeHeader x))+ in return $ t `compare` q -blockAtOrBefore :: (MonadIO m, StoreReadExtra m)- => Chain- -> UnixTime- -> m (Maybe BlockData)+blockAtOrBefore ::+ (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)) where- f x = let t = fromIntegral (blockTimestamp (nodeHeader x))- in return $ t `compare` q+ f x =+ let t = fromIntegral (blockTimestamp (nodeHeader x))+ in return $ t `compare` q -blockAtOrAfterMTP :: (MonadIO m, StoreReadExtra m)- => Chain- -> UnixTime- -> m (Maybe BlockData)+blockAtOrAfterMTP ::+ (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@@ -256,7 +299,6 @@ t <- fromIntegral <$> mtp x return $ t `compare` q - -- | Events that the store can generate. data StoreEvent = StoreBestBlock !BlockHash@@ -268,7 +310,8 @@ | StoreTxAnnounce !Peer ![TxHash] | StoreTxReject !Peer !TxHash !RejectCode !ByteString -data PubExcept = PubNoPeers+data PubExcept+ = PubNoPeers | PubReject RejectCode | PubTimeout | PubPeerDisconnected@@ -277,23 +320,23 @@ 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"+ "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@@ -308,7 +351,7 @@ _ -> 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@@ -323,31 +366,33 @@ thset = H.fromList (map txHash txs) 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+ 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 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 ()+streamThings ::+ 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)+ [] -> 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))}@@ -356,61 +401,63 @@ _ -> 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)+ 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 ()+joinDescStreams ::+ (Monad m, Ord a) =>+ [ConduitT () a m ()] ->+ ConduitT () a m () joinDescStreams xs = do 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+ j (x, y) = (,[x]) <$> y+ g ss =+ 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+ | 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- }+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+ } 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+ 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
@@ -1,110 +1,136 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-module Haskoin.Store.Database.Reader- ( -- * RocksDB Database Access- DatabaseReader (..)- , DatabaseReaderT- , withDatabaseReader- , addrTxCF- , addrOutCF- , txCF- , spenderCF- , unspentCF- , blockCF- , heightCF- , balanceCF- ) where+{-# LANGUAGE RecordWildCards #-} -import Conduit (ConduitT, dropWhileC, lift, mapC,- runConduit, sinkList, (.|))-import Control.Monad.Except (runExceptT, throwError)-import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)-import Data.Bits ((.&.))-import qualified Data.ByteString as BS-import Data.Default (def)-import Data.Function (on)-import Data.List (sortOn)-import Data.Maybe (fromMaybe)-import Data.Ord (Down (..))-import Data.Serialize (encode)-import Data.Word (Word32, Word64)-import Database.RocksDB (ColumnFamily, Config (..),- DB (..), Iterator, withDBCF,- withIterCF)-import Database.RocksDB.Query (insert, matching,- matchingAsListCF, matchingSkip,- retrieve, retrieveCF)-import Haskoin (Address, BlockHash, BlockHeight,- Network, OutPoint (..), TxHash,- pubSubKey, txHash)-import Haskoin.Store.Common-import Haskoin.Store.Data-import Haskoin.Store.Database.Types-import qualified System.Metrics as Metrics-import System.Metrics.Counter (Counter)-import qualified System.Metrics.Counter as Counter-import UnliftIO (MonadIO, MonadUnliftIO, liftIO)+module Haskoin.Store.Database.Reader (+ -- * RocksDB Database Access+ DatabaseReader (..),+ DatabaseReaderT,+ withDatabaseReader,+ addrTxCF,+ addrOutCF,+ txCF,+ spenderCF,+ unspentCF,+ blockCF,+ heightCF,+ balanceCF,+) where +import Conduit (+ ConduitT,+ dropWhileC,+ lift,+ mapC,+ runConduit,+ sinkList,+ (.|),+ )+import Control.Monad.Except (runExceptT, throwError)+import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)+import Data.Bits ((.&.))+import qualified Data.ByteString as BS+import Data.Default (def)+import Data.Function (on)+import Data.List (sortOn)+import Data.Maybe (fromMaybe)+import Data.Ord (Down (..))+import Data.Serialize (encode)+import Data.Word (Word32, Word64)+import Database.RocksDB (+ ColumnFamily,+ Config (..),+ DB (..),+ Iterator,+ withDBCF,+ withIterCF,+ )+import Database.RocksDB.Query (+ insert,+ matching,+ matchingAsListCF,+ matchingSkip,+ retrieve,+ retrieveCF,+ )+import Haskoin (+ Address,+ BlockHash,+ BlockHeight,+ Network,+ OutPoint (..),+ TxHash,+ pubSubKey,+ txHash,+ )+import Haskoin.Store.Common+import Haskoin.Store.Data+import Haskoin.Store.Database.Types+import qualified System.Metrics as Metrics+import System.Metrics.Counter (Counter)+import qualified System.Metrics.Counter as Counter+import UnliftIO (MonadIO, MonadUnliftIO, liftIO)+ type DatabaseReaderT = ReaderT DatabaseReader -data DatabaseReader =- DatabaseReader- { databaseHandle :: !DB- , databaseMaxGap :: !Word32- , databaseInitialGap :: !Word32- , databaseNetwork :: !Network- , databaseMetrics :: !(Maybe DataMetrics)- }+data DatabaseReader = DatabaseReader+ { databaseHandle :: !DB+ , databaseMaxGap :: !Word32+ , databaseInitialGap :: !Word32+ , databaseNetwork :: !Network+ , databaseMetrics :: !(Maybe DataMetrics)+ } -incrementCounter :: MonadIO m- => (DataMetrics -> Counter)- -> Int- -> ReaderT DatabaseReader m ()+incrementCounter ::+ MonadIO m =>+ (DataMetrics -> Counter) ->+ Int ->+ ReaderT DatabaseReader m () incrementCounter f i = asks databaseMetrics >>= \case- Just s -> liftIO $ Counter.add (f s) (fromIntegral i)+ 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+withDatabaseReader ::+ 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+ 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)} 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@@ -134,28 +160,29 @@ 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+ 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+ 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) ()-addressConduit a s it =+addressConduit ::+ MonadUnliftIO m =>+ Address ->+ Maybe Start ->+ Iterator ->+ ConduitT i TxRef (DatabaseReaderT m) ()+addressConduit a s it = x .| mapC (uncurry f) where f (AddrTxKey _ t) () = t- f _ _ = undefined+ f _ _ = undefined x = case s of Nothing -> matching it (AddrTxKeyA a)@@ -166,22 +193,23 @@ (AddrTxKeyB a (BlockRef bh maxBound)) Just (AtTx txh) -> lift (getTxData txh) >>= \case- Just TxData {txDataBlock = b@BlockRef{}} ->+ Just TxData{txDataBlock = b@BlockRef{}} -> matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b)- Just TxData {txDataBlock = MemRef{}} ->+ 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)+ in matching it (AddrTxKeyA a)+ .| (dropWhileC (cond . fst) >> mapC id) Nothing -> return () -unspentConduit :: MonadUnliftIO m- => Address- -> Maybe Start- -> Iterator- -> ConduitT i Unspent (DatabaseReaderT m) ()+unspentConduit ::+ MonadUnliftIO m =>+ Address ->+ Maybe Start ->+ Iterator ->+ ConduitT i Unspent (DatabaseReaderT m) () unspentConduit a s it = x .| mapC (uncurry toUnspent) where@@ -195,15 +223,15 @@ (AddrOutKeyB a (BlockRef h maxBound)) Just (AtTx txh) -> lift (getTxData txh) >>= \case- Just TxData {txDataBlock = b@BlockRef{}} ->+ Just TxData{txDataBlock = b@BlockRef{}} -> matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)- Just TxData {txDataBlock = MemRef{}} ->+ 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)+ in matching it (AddrOutKeyA a)+ .| (dropWhileC (cond . fst) >> mapC id) Nothing -> return () instance MonadIO m => StoreReadBase (DatabaseReaderT m) where@@ -213,9 +241,9 @@ db <- asks databaseHandle retrieveCF db (txCF db) (TxKey th) >>= \case Nothing -> return Nothing- Just t -> do- incrementCounter dataTxCount 1- return (Just t)+ Just t -> do+ incrementCounter dataTxCount 1+ return (Just t) getSpender op = do db <- asks databaseHandle@@ -229,7 +257,7 @@ db <- asks databaseHandle fmap (valToUnspent p) <$> retrieveCF db (unspentCF db) (UnspentKey p) >>= \case Nothing -> return Nothing- Just u -> do+ Just u -> do incrementCounter dataUnspentCount 1 return (Just u) @@ -252,16 +280,16 @@ retrieveCF db (heightCF db) (HeightKey h) >>= \case Nothing -> return [] Just ls -> do- incrementCounter dataBlockCount (length ls)- return ls+ 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)+ Just b -> do+ incrementCounter dataBlockCount 1+ return (Just b) instance MonadUnliftIO m => StoreReadExtra (DatabaseReaderT m) where getAddressesTxs addrs limits = do@@ -274,9 +302,9 @@ db <- asks databaseHandle withIterCF db (addrTxCF db) $ \it -> runConduit $- addressConduit a (start l) it .|- applyLimitC (limit l) .|- sinkList+ addressConduit a (start l) it+ .| applyLimitC (limit l)+ .| sinkList getAddressesUnspents addrs limits = do us <- applyLimits limits . sortOn Down . concat <$> mapM f addrs@@ -288,45 +316,46 @@ db <- asks databaseHandle withIterCF db (addrOutCF db) $ \it -> runConduit $- unspentConduit a (start l) it .|- applyLimitC (limit l) .|- sinkList+ unspentConduit a (start l) it+ .| applyLimitC (limit l)+ .| sinkList 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)+ 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) getAddressTxs a limits = do db <- asks databaseHandle txs <- withIterCF db (addrTxCF db) $ \it -> runConduit $- addressConduit a (start limits) it .|- applyLimitsC limits .|- sinkList+ addressConduit a (start limits) it+ .| applyLimitsC limits+ .| sinkList incrementCounter dataAddrTxCount (length txs) return txs @@ -338,10 +367,11 @@ 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'+ 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@@ -349,7 +379,7 @@ getBalances as = do zipWith f as <$> mapM getBalance as where- f a Nothing = zeroBalance a+ f a Nothing = zeroBalance a f _ (Just b) = b xPubBals xpub = do@@ -371,7 +401,7 @@ deriveAddresses (deriveFunction (xPubDeriveType xpub)) (pubSubKey (xPubSpecKey xpub) m)- xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+ 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@@ -391,13 +421,14 @@ i b = do us <- getAddressUnspents (balanceAddress (xPubBal b)) l return us- f b t = XPubUnspent {xPubUnspentPath = xPubBalPath b, xPubUnspent = t}+ 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+ let as =+ map balanceAddress $+ filter (not . nullBalance) $+ map xPubBal xbals txs <- getAddressesTxs as limits incrementCounter dataXPubTxs (length txs) return txs
src/Haskoin/Store/Database/Types.hs view
@@ -1,82 +1,116 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-module Haskoin.Store.Database.Types- ( AddrTxKey(..)- , AddrOutKey(..)- , BestKey(..)- , BlockKey(..)- , BalKey(..)- , HeightKey(..)- , MemKey(..)- , SpenderKey(..)- , TxKey(..)- , decodeTxKey- , UnspentKey(..)- , VersionKey(..)- , BalVal(..)- , valToBalance- , balanceToVal- , UnspentVal(..)- , toUnspent- , unspentToVal- , valToUnspent- , OutVal(..)- ) where -import Control.DeepSeq (NFData)-import Control.Monad (guard)-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 (..), decode, encode,- getBytes, getWord16be, getWord32be,- getWord8, putWord32be, putWord64be,- putWord8, runGet, runPut)-import Data.Word (Word16, Word32, Word64, Word8)-import Database.RocksDB.Query (Key, KeyValue)-import GHC.Generics (Generic)-import Haskoin (Address, BlockHash, BlockHeight,- OutPoint (..), TxHash, eitherToMaybe,- scriptToAddressBS)-import Haskoin.Store.Data (Balance (..), BlockData, BlockRef,- Spender, TxData, TxRef (..), UnixTime,- Unspent (..))+module Haskoin.Store.Database.Types (+ AddrTxKey (..),+ AddrOutKey (..),+ BestKey (..),+ BlockKey (..),+ BalKey (..),+ HeightKey (..),+ MemKey (..),+ SpenderKey (..),+ TxKey (..),+ decodeTxKey,+ UnspentKey (..),+ VersionKey (..),+ BalVal (..),+ valToBalance,+ balanceToVal,+ UnspentVal (..),+ toUnspent,+ unspentToVal,+ valToUnspent,+ OutVal (..),+) where +import Control.DeepSeq (NFData)+import Control.Monad (guard)+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 (..),+ decode,+ encode,+ getBytes,+ getWord16be,+ getWord32be,+ getWord8,+ putWord32be,+ putWord64be,+ putWord8,+ runGet,+ runPut,+ )+import Data.Word (Word16, Word32, Word64, Word8)+import Database.RocksDB.Query (Key, KeyValue)+import GHC.Generics (Generic)+import Haskoin (+ Address,+ BlockHash,+ BlockHeight,+ OutPoint (..),+ TxHash,+ eitherToMaybe,+ scriptToAddressBS,+ )+import Haskoin.Store.Data (+ Balance (..),+ BlockData,+ BlockRef,+ Spender,+ TxData,+ TxRef (..),+ UnixTime,+ Unspent (..),+ )+ -- | Database key for an address transaction. data AddrTxKey- = AddrTxKey { addrTxKeyA :: !Address- , addrTxKeyT :: !TxRef- }- -- ^ key for a transaction affecting an address- | AddrTxKeyA { addrTxKeyA :: !Address }- -- ^ short key that matches all entries- | AddrTxKeyB { addrTxKeyA :: !Address- , addrTxKeyB :: !BlockRef- }+ = -- | 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+instance Serialize AddrTxKey where -- 0x05 · Address · BlockRef · TxHash- where- put AddrTxKey { addrTxKeyA = a- , addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t}- } = do- put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b}- put 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 AddrTxKeyA{addrTxKeyA = a} = do put AddrTxKeyS put a -- 0x05 · Address · BlockRef- put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do- put AddrTxKeyA {addrTxKeyA = a}+ put AddrTxKeyB{addrTxKeyA = a, addrTxKeyB = b} = do+ put AddrTxKeyA{addrTxKeyA = a} put b -- 0x05 put AddrTxKeyS = putWord8 0x05@@ -88,7 +122,7 @@ return AddrTxKey { addrTxKeyA = a- , addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t}+ , addrTxKeyT = TxRef{txRefBlock = b, txRefHash = t} } instance Key AddrTxKey@@ -96,30 +130,33 @@ -- | Database key for an address output. data AddrOutKey- = AddrOutKey { addrOutKeyA :: !Address- , addrOutKeyB :: !BlockRef- , addrOutKeyP :: !OutPoint }- -- ^ full key- | AddrOutKeyA { addrOutKeyA :: !Address }- -- ^ short key for all spent or unspent outputs- | AddrOutKeyB { addrOutKeyA :: !Address- , addrOutKeyB :: !BlockRef- }+ = -- | 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+instance Serialize AddrOutKey where -- 0x06 · StoreAddr · BlockRef · OutPoint- where- put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do- put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b}++ 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 AddrOutKeyB{addrOutKeyA = a, addrOutKeyB = b} = do+ put AddrOutKeyA{addrOutKeyA = a} put b -- 0x06 · StoreAddr- put AddrOutKeyA {addrOutKeyA = a} = do+ put AddrOutKeyA{addrOutKeyA = a} = do put AddrOutKeyS put a -- 0x06@@ -133,13 +170,15 @@ data OutVal = OutVal { outValAmount :: !Word64 , outValScript :: !ByteString- } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize)+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) instance KeyValue AddrOutKey OutVal -- | Transaction database key.-data TxKey = TxKey { txKey :: TxHash }- | TxKeyS { txKeyShort :: (Word32, Word16) }+data TxKey+ = TxKey {txKey :: TxHash}+ | TxKeyS {txKeyShort :: (Word32, Word16)} deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize TxKey where@@ -165,19 +204,19 @@ w3 <- getWord8 return (w1, w2, w3) Right (w1, w2, w3) = runGet g bs- in ((w1, w2), w3)+ in ((w1, w2), w3) instance Key TxKey instance KeyValue TxKey TxData data SpenderKey- = SpenderKey { outputPoint :: !OutPoint }- | SpenderKeyS { outputKeyS :: !TxHash }+ = 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 (SpenderKey OutPoint{outPointHash = h, outPointIndex = i}) = do put (SpenderKeyS h) put i -- 0x10 · TxHash@@ -194,19 +233,19 @@ -- | Unspent output database key. data UnspentKey- = UnspentKey { unspentKey :: !OutPoint }- | UnspentKeyS { unspentKeyS :: !TxHash }+ = 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+ put UnspentKey{unspentKey = OutPoint{outPointHash = h, outPointIndex = i}} = do putWord8 0x09 put h put i -- 0x09 · TxHash- put UnspentKeyS {unspentKeyS = t} = do+ put UnspentKeyS{unspentKeyS = t} = do putWord8 0x09 put t -- 0x09@@ -215,7 +254,7 @@ guard . (== 0x09) =<< getWord8 h <- get i <- get- return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i}+ return $ UnspentKey OutPoint{outPointHash = h, outPointIndex = i} instance Key UnspentKey instance KeyValue UnspentKey UnspentVal@@ -231,8 +270,8 @@ } -- | Mempool transaction database key.-data MemKey =- MemKey+data MemKey+ = MemKey deriving (Show, Read) instance Serialize MemKey where@@ -248,7 +287,8 @@ -- | Block entry database key. newtype BlockKey = BlockKey { blockKey :: BlockHash- } deriving (Show, Read, Eq, Ord, Generic, Hashable)+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BlockKey where -- 0x01 · BlockHash@@ -265,7 +305,8 @@ -- | Block height database key. newtype HeightKey = HeightKey { heightKey :: BlockHeight- } deriving (Show, Read, Eq, Ord, Generic, Hashable)+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize HeightKey where -- 0x03 · BlockHeight@@ -282,14 +323,14 @@ -- | Address balance database key. data BalKey = BalKey- { balanceKey :: !Address- }+ { balanceKey :: !Address+ } | BalKeyS deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BalKey where -- 0x04 · Address- put BalKey {balanceKey = a} = do+ put BalKey{balanceKey = a} = do putWord8 0x04 put a -- 0x04@@ -302,8 +343,8 @@ instance KeyValue BalKey BalVal -- | Key for best block in database.-data BestKey =- BestKey+data BestKey+ = BestKey deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BestKey where@@ -317,8 +358,8 @@ instance KeyValue BestKey BlockHash -- | Key for database version.-data VersionKey =- VersionKey+data VersionKey+ = VersionKey deriving (Eq, Show, Read, Ord, Generic, Hashable) instance Serialize VersionKey where@@ -332,44 +373,50 @@ instance KeyValue VersionKey Word32 data BalVal = BalVal- { balValAmount :: !Word64- , balValZero :: !Word64- , balValUnspentCount :: !Word64- , balValTxCount :: !Word64+ { balValAmount :: !Word64+ , balValZero :: !Word64+ , balValUnspentCount :: !Word64+ , balValTxCount :: !Word64 , balValTotalReceived :: !Word64- } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)+ }+ 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- }--balanceToVal :: Balance -> BalVal-balanceToVal Balance { balanceAmount = v- , balanceZero = z- , balanceUnspentCount = u- , balanceTxCount = t- , balanceTotalReceived = r- } =+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+ } +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+ }+ -- | Default balance for an address. instance Default BalVal where def =@@ -382,30 +429,40 @@ } data UnspentVal = UnspentVal- { unspentValBlock :: !BlockRef+ { unspentValBlock :: !BlockRef , unspentValAmount :: !Word64 , unspentValScript :: !ByteString- } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)+ }+ 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})--valToUnspent :: OutPoint -> UnspentVal -> Unspent-valToUnspent p UnspentVal { unspentValBlock = b- , unspentValAmount = v- , unspentValScript = s- } =+unspentToVal Unspent { unspentBlock = b , unspentPoint = p , unspentAmount = v , unspentScript = s- , unspentAddress = eitherToMaybe (scriptToAddressBS 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)+ }
src/Haskoin/Store/Database/Writer.hs view
@@ -1,33 +1,54 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-module Haskoin.Store.Database.Writer (WriterT , runWriter) where -import Control.Monad.Reader (ReaderT (..))-import qualified Control.Monad.Reader as R-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import Data.List (sortOn)-import Data.Ord (Down (..))-import Data.Tuple (swap)-import Database.RocksDB (BatchOp, DB)-import Database.RocksDB.Query (deleteOp, deleteOpCF, insertOp,- insertOpCF, writeBatch)-import Haskoin (Address, BlockHash, BlockHeight,- Network, OutPoint (..), TxHash,- headerHash, txHash)-import Haskoin.Store.Common-import Haskoin.Store.Data-import Haskoin.Store.Database.Reader-import Haskoin.Store.Database.Types-import UnliftIO (MonadIO, TVar, atomically,- liftIO, modifyTVar, newTVarIO,- readTVarIO)+module Haskoin.Store.Database.Writer (WriterT, runWriter) where -data Writer = Writer { getReader :: !DatabaseReader- , getState :: !(TVar Memory) }+import Control.Monad.Reader (ReaderT (..))+import qualified Control.Monad.Reader as R+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import Data.List (sortOn)+import Data.Ord (Down (..))+import Data.Tuple (swap)+import Database.RocksDB (BatchOp, DB)+import Database.RocksDB.Query (+ deleteOp,+ deleteOpCF,+ insertOp,+ insertOpCF,+ writeBatch,+ )+import Haskoin (+ Address,+ BlockHash,+ BlockHeight,+ Network,+ OutPoint (..),+ TxHash,+ headerHash,+ txHash,+ )+import Haskoin.Store.Common+import Haskoin.Store.Data+import Haskoin.Store.Database.Reader+import Haskoin.Store.Database.Types+import UnliftIO (+ MonadIO,+ TVar,+ atomically,+ liftIO,+ modifyTVar,+ newTVarIO,+ readTVarIO,+ ) +data Writer = Writer+ { getReader :: !DatabaseReader+ , getState :: !(TVar Memory)+ }+ type WriterT = ReaderT Writer instance MonadIO m => StoreReadBase (WriterT m) where@@ -42,110 +63,113 @@ 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+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ setBestH h insertBlock b =- ReaderT $ \Writer { getState = s } ->- liftIO . atomically . modifyTVar s $- insertBlockH 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+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ setBlocksAtHeightH h g insertTx t =- ReaderT $ \Writer { getState = s } ->- liftIO . atomically . modifyTVar s $- insertTxH 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'+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertSpenderH p s' deleteSpender p =- ReaderT $ \Writer { getState = s } ->- liftIO . atomically . modifyTVar s $- deleteSpenderH 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+ 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+ 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+ 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+ 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+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ addToMempoolH x t deleteFromMempool x =- ReaderT $ \Writer { getState = s } ->- liftIO . atomically . modifyTVar s $- deleteFromMempoolH x+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ deleteFromMempoolH x setBalance b =- ReaderT $ \Writer { getState = s } ->- liftIO . atomically . modifyTVar s $- setBalanceH b+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ setBalanceH b insertUnspent h =- ReaderT $ \Writer { getState = s } ->- liftIO . atomically . modifyTVar s $- insertUnspentH h+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ insertUnspentH h deleteUnspent p =- ReaderT $ \Writer { getState = s } ->- liftIO . atomically . modifyTVar s $- deleteUnspentH p+ ReaderT $ \Writer{getState = s} ->+ liftIO . atomically . modifyTVar s $+ deleteUnspentH p -getLayered :: MonadIO m- => (Memory -> Maybe a)- -> DatabaseReaderT m a- -> WriterT m a+getLayered ::+ MonadIO m =>+ (Memory -> Maybe a) ->+ DatabaseReaderT m a ->+ WriterT m a getLayered f g =- ReaderT $ \Writer { getReader = db, getState = tmem } ->+ 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+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 }+ x <- R.runReaderT f Writer{getReader = bdb, getState = hm} mem' <- readTVarIO hm let ops = hashMapOps db mem' writeBatch db ops@@ -153,27 +177,27 @@ 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 = []-bestBlockOp (Just Nothing) = [deleteOp BestKey]+bestBlockOp Nothing = []+bestBlockOp (Just Nothing) = [deleteOp BestKey] bestBlockOp (Just (Just b)) = [insertOp BestKey b] blockHashOps :: DB -> HashMap BlockHash (Maybe BlockData) -> [BatchOp] blockHashOps db = map (uncurry f) . M.toList where f k (Just d) = insertOpCF (blockCF db) (BlockKey k) d- f k Nothing = deleteOpCF (blockCF db) (BlockKey k)+ f k Nothing = deleteOpCF (blockCF db) (BlockKey k) blockHeightOps :: DB -> HashMap BlockHeight [BlockHash] -> [BatchOp] blockHeightOps db = map (uncurry f) . M.toList@@ -184,47 +208,50 @@ txOps db = map (uncurry f) . M.toList where f k (Just t) = insertOpCF (txCF db) (TxKey k) t- f k Nothing = deleteOpCF (txCF db) (TxKey k)+ f k Nothing = deleteOpCF (txCF db) (TxKey k) spenderOps :: DB -> HashMap OutPoint (Maybe Spender) -> [BatchOp] spenderOps db = map (uncurry f) . M.toList where f o (Just s) = insertOpCF (spenderCF db) (SpenderKey o) s- f o Nothing = deleteOpCF (spenderCF db) (SpenderKey o)+ f o Nothing = deleteOpCF (spenderCF db) (SpenderKey o) balOps :: DB -> HashMap Address (Maybe Balance) -> [BatchOp] balOps db = map (uncurry f) . M.toList where f a (Just b) = insertOpCF (balanceCF db) (BalKey a) (balanceToVal b)- f a Nothing = deleteOpCF (balanceCF db) (BalKey a)+ f a Nothing = deleteOpCF (balanceCF db) (BalKey a) addrTxOps :: DB -> HashMap (Address, TxRef) (Maybe ()) -> [BatchOp] addrTxOps db = map (uncurry f) . M.toList where f (a, t) (Just ()) = insertOpCF (addrTxCF db) (AddrTxKey a t) ()- f (a, t) Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t)+ f (a, t) Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t) -addrOutOps :: DB- -> HashMap (Address, BlockRef, OutPoint) (Maybe OutVal)- -> [BatchOp]+addrOutOps ::+ 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+ (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- }+ (addrOutCF db)+ AddrOutKey+ { addrOutKeyA = a+ , addrOutKeyB = b+ , addrOutKeyP = p+ } mempoolOp :: HashMap TxHash UnixTime -> [BatchOp] mempoolOp = return . insertOp MemKey . sortOn Down . map swap . M.toList@@ -234,7 +261,7 @@ where f p (Just u) = insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u))- f p Nothing =+ f p Nothing = deleteOpCF (unspentCF db) (UnspentKey p) getNetworkI :: MonadIO m => WriterT m Network@@ -264,23 +291,24 @@ getMempoolI :: MonadIO m => WriterT m [(UnixTime, TxHash)] getMempoolI =- ReaderT $ \Writer { getState = 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@@ -304,64 +332,68 @@ 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) }+ 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) }+ 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)@@ -369,8 +401,8 @@ insertUnspentH :: Unspent -> Memory -> Memory insertUnspentH u db = let k = fst (unspentToVal u)- in db { hUnspent = M.insert k (Just u) (hUnspent db) }+ 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
@@ -1,52 +1,91 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-module Haskoin.Store.Logic- ( ImportException (..)- , MonadImport- , initBest- , revertBlock- , importBlock- , newMempoolTx- , deleteUnconfirmedTx- ) where+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} -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)+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@@ -69,17 +108,17 @@ 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 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"+ show TxSpent = "Transaction is spent" initBest :: MonadImport m => m () initBest = do@@ -104,11 +143,12 @@ bestBlockData :: MonadImport m => m BlockData bestBlockData = do- h <- getBestBlock >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "Best block unknown"- throwError BestBlockNotFound- Just h -> return h+ 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"@@ -117,13 +157,14 @@ 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+ 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)@@ -131,9 +172,9 @@ "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}+ "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@@ -151,14 +192,14 @@ | otherwise -> do $(logErrorS) "BlockStore" $ "Cannot import non-genesis block: "- <> blockHashToHex (headerHash (blockHeader b))+ <> 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))+ <> blockHashToHex (headerHash (blockHeader b)) throwError PrevBlockNotBest importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m ()@@ -167,24 +208,24 @@ mapM_ (uncurry action) txs where txs = sortTxs txns- br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i}+ 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+ True -> confirm_it i tx confirm_it i tx = getActiveTxData (txHash tx) >>= \case Just t -> do $(logDebugS) "BlockStore" $ "Confirming tx: "- <> txHashToHex (txHash tx)+ <> txHashToHex (txHash tx) confirmTx t (br i) return Nothing Nothing -> do $(logErrorS) "BlockStore" $ "Cannot find tx to confirm: "- <> txHashToHex (txHash tx)+ <> txHashToHex (txHash tx) throwError TxNotFound import_it i tx = do $(logDebugS) "BlockStore" $@@ -196,7 +237,7 @@ importBlock b n = do $(logDebugS) "BlockStore" $ "Checking new block: "- <> blockHashToHex (headerHash (nodeHeader n))+ <> blockHashToHex (headerHash (nodeHeader n)) checkNewBlock b n $(logDebugS) "BlockStore" "Passed check" net <- getNetwork@@ -204,7 +245,7 @@ bs <- getBlocksAtHeight (nodeHeight n) $(logDebugS) "BlockStore" $ "Inserting block entries for: "- <> blockHashToHex (headerHash (nodeHeader n))+ <> blockHashToHex (headerHash (nodeHeader n)) insertBlock BlockData { blockDataHeight = nodeHeight n@@ -225,15 +266,15 @@ importOrConfirm n (blockTxns b) $(logDebugS) "BlockStore" $ "Finished importing transactions for: "- <> blockHashToHex (headerHash (nodeHeader n))+ <> 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)}+ 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@@ -243,7 +284,7 @@ when (unique_inputs < length (txIn tx)) $ do $(logErrorS) "BlockStore" $ "Transaction spends same output twice: "- <> txHashToHex (txHash tx)+ <> txHashToHex (txHash tx) throwError DuplicatePrevOutput us <- getUnspentOutputs tx when (any isNothing us) $ do@@ -253,7 +294,7 @@ when (isCoinbase tx) $ do $(logErrorS) "BlockStore" $ "Coinbase cannot be imported into mempool: "- <> txHashToHex (txHash tx)+ <> txHashToHex (txHash tx) throwError UnexpectedCoinbase when (length (prevOuts tx) > length us) $ do $(logErrorS) "BlockStore" $@@ -273,31 +314,34 @@ 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- }+ 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- -> Word64 -- ^ unix time- -> Bool -- ^ RBF- -> Tx- -> m ()+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)+ <> txHashToHex (txHash tx) throwError Orphan Just u -> return u let td = prepareTxData rbf br tt tx us@@ -313,15 +357,24 @@ replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do deleteAddrTx a- TxRef { txRefBlock = txDataBlock t- , txRefHash = txHash (txData t) }+ TxRef+ { txRefBlock = txDataBlock t+ , txRefHash = txHash (txData t)+ } insertAddrTx a- TxRef { txRefBlock = new- , txRefHash = txHash (txData t) }+ TxRef+ { txRefBlock = new+ , txRefHash = txHash (txData t)+ } -adjustAddressOutput :: MonadImport m- => OutPoint -> TxOut -> BlockRef -> BlockRef -> m ()+adjustAddressOutput ::+ MonadImport m =>+ OutPoint ->+ TxOut ->+ BlockRef ->+ BlockRef ->+ m () adjustAddressOutput op o old new = do let pk = scriptOutput o getUnspent op >>= \case@@ -372,23 +425,25 @@ let op = OutPoint (txHash (txData t)) n adjustAddressOutput op o old new rbf <- isRBF new (txData t)- let td = t { txDataBlock = new, txDataRBF = rbf }+ let td = t{txDataBlock = new, txDataRBF = rbf} insertTx td updateMempool td where new = fromMaybe (MemRef (txDataTime t)) mbr old = txDataBlock t -freeOutputs- :: MonadImport m- => Bool -- ^ only delete transaction if unconfirmed- -> Bool -- ^ only delete RBF- -> Tx- -> m ()+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 ]+ 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@@ -401,26 +456,33 @@ getActiveTxData th >>= \case Just _ -> deleteTx True rbfcheck th Nothing ->- $(logDebugS) "BlockStore" $- "Not found or already deleted: " <> txHashToHex th+ $(logDebugS) "BlockStore" $+ "Not found or already deleted: " <> txHashToHex th -deleteTx :: MonadImport m- => Bool -- ^ only delete transaction if unconfirmed- -> Bool -- ^ only delete RBF- -> TxHash- -> m ()+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+ "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)- => Bool -- ^ only delete transaction if unconfirmed- -> Bool -- ^ only delete RBF- -> TxHash- -> m [Tx]+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'@@ -434,24 +496,25 @@ "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: "+ | memonly && confirmed (txDataBlock td) -> do+ $(logErrorS) "BlockStore" $+ "Transaction already confirmed: " <> txHashToHex th- throwError DoubleSpend- | otherwise -> return $ Just $ txData td+ 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)+ 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'@@ -469,11 +532,12 @@ $(logDebugS) "BlockStore" $ "Deleting tx: " <> txHashToHex th getSpenders th >>= \case- m | I.null m -> commitDelTx td- | otherwise -> do+ m+ | I.null m -> commitDelTx td+ | otherwise -> do $(logErrorS) "BlockStore" $ "Tried to delete spent tx: "- <> txHashToHex th+ <> txHashToHex th throwError TxSpent commitDelTx :: MonadImport m => TxData -> m ()@@ -492,21 +556,21 @@ where tx = txData td br = txDataBlock td- td = tx_data { txDataDeleted = not add }+ td = tx_data{txDataDeleted = not add} tx_ref = TxRef br (txHash tx) mod_addr_tx a- | add = do+ | add = do insertAddrTx a tx_ref modAddressCount add a- | otherwise = do+ | otherwise = do deleteAddrTx a tx_ref modAddressCount add a mod_unspent- | add = spendOutputs tx- | otherwise = unspendOutputs tx+ | add = spendOutputs tx+ | otherwise = unspendOutputs tx mod_outputs- | add = addOutputs br tx- | otherwise = delOutputs br tx+ | add = addOutputs br tx+ | otherwise = delOutputs br tx updateMempool :: MonadImport m => TxData -> m () updateMempool td@TxData{txDataDeleted = True} =@@ -524,29 +588,32 @@ addOutputs br tx = zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx) -isRBF :: StoreReadBase m- => BlockRef- -> Tx- -> m Bool+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+ | 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+ 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'+ Just t+ | confirmed (txDataBlock t) -> ck hs'+ | txDataRBF t -> return True+ | otherwise -> ck hs' in ck hs addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()@@ -563,23 +630,28 @@ modBalance (confirmed br) add a (outValue o) modifyReceived a v where- v | add = (+ outValue o)- | otherwise = subtract (outValue o)+ 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+ 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+ forM_ (zip [0 ..] (txOut tx)) $ \(i, o) -> do let op = OutPoint (txHash tx) i delOutput br op o @@ -598,9 +670,10 @@ 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+ 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@@ -616,19 +689,23 @@ 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))+ 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- }+ u =+ Unspent+ { unspentAmount = outValue o+ , unspentBlock = txDataBlock t+ , unspentScript = scriptOutput o+ , unspentPoint = op+ , unspentAddress = m+ } deleteSpender op insertUnspent u forM_ m $ \a -> do@@ -638,7 +715,7 @@ modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m () modifyReceived a f = do b <- getDefaultBalance a- setBalance b { balanceTotalReceived = f (balanceTotalReceived b) }+ setBalance b{balanceTotalReceived = f (balanceTotalReceived b)} decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () decreaseBalance conf = modBalance conf False@@ -646,29 +723,35 @@ increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () increaseBalance conf = modBalance conf True -modBalance :: MonadImport m- => Bool -- ^ confirmed- -> Bool -- ^ add- -> Address- -> Word64- -> m ()+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+ 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)}+ setBalance b{balanceTxCount = f (balanceTxCount b)} where- f | add = (+ 1)- | otherwise = subtract 1+ f+ | add = (+ 1)+ | otherwise = subtract 1 txOutAddrs :: [TxOut] -> [Address] txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput)
src/Haskoin/Store/Manager.hs view
@@ -1,147 +1,192 @@ {-# LANGUAGE FlexibleContexts #-}-module Haskoin.Store.Manager- ( StoreConfig(..)- , Store(..)- , withStore- ) where -import Control.Monad (forever, unless, when)-import Control.Monad.Logger (MonadLoggerIO)-import Control.Monad.Reader (ReaderT (ReaderT), runReaderT)-import Data.Serialize (decode)-import Data.Time.Clock (NominalDiffTime)-import Data.Word (Word32)-import Haskoin (BlockHash (..), Inv (..),- InvType (..), InvVector (..),- Message (..),- MessageCommand (..), Network,- NetworkAddress (..),- NotFound (..), Pong (..),- Reject (..), TxHash (..),- VarString (..),- sockToHostAddress)-import Haskoin.Node (Chain, ChainEvent (..),- HostPort, Node (..),- NodeConfig (..), NodeEvent (..),- PeerEvent (..), PeerManager,- WithConnection, withNode)-import Haskoin.Store.BlockStore (BlockStore,- BlockStoreConfig (..),- blockStoreBlockSTM,- blockStoreHeadSTM,- blockStoreNotFoundSTM,- blockStorePeerConnectSTM,- blockStorePeerDisconnectSTM,- blockStoreTxHashSTM,- blockStoreTxSTM, withBlockStore)-import Haskoin.Store.Cache (CacheConfig (..), CacheWriter,- cacheNewBlock, cacheNewTx,- cacheWriter, connectRedis,- newCacheMetrics)-import Haskoin.Store.Common (StoreEvent (..),- createDataMetrics)-import Haskoin.Store.Database.Reader (DatabaseReader (..),- DatabaseReaderT,- withDatabaseReader)-import NQE (Inbox, Process (..), Publisher,- publishSTM, receive,- withProcess, withPublisher,- withSubscription)-import Network.Socket (SockAddr (..))-import qualified System.Metrics as Metrics (Store)-import UnliftIO (MonadIO, MonadUnliftIO, STM,- atomically, link, withAsync)-import UnliftIO.Concurrent (threadDelay)+module Haskoin.Store.Manager (+ StoreConfig (..),+ Store (..),+ withStore,+) where +import Control.Monad (forever, unless, when)+import Control.Monad.Logger (MonadLoggerIO)+import Control.Monad.Reader (ReaderT (ReaderT), runReaderT)+import Data.Serialize (decode)+import Data.Time.Clock (NominalDiffTime)+import Data.Word (Word32)+import Haskoin (+ BlockHash (..),+ Inv (..),+ InvType (..),+ InvVector (..),+ Message (..),+ MessageCommand (..),+ Network,+ NetworkAddress (..),+ NotFound (..),+ Pong (..),+ Reject (..),+ TxHash (..),+ VarString (..),+ sockToHostAddress,+ )+import Haskoin.Node (+ Chain,+ ChainEvent (..),+ HostPort,+ Node (..),+ NodeConfig (..),+ NodeEvent (..),+ PeerEvent (..),+ PeerManager,+ WithConnection,+ withNode,+ )+import Haskoin.Store.BlockStore (+ BlockStore,+ BlockStoreConfig (..),+ blockStoreBlockSTM,+ blockStoreHeadSTM,+ blockStoreNotFoundSTM,+ blockStorePeerConnectSTM,+ blockStorePeerDisconnectSTM,+ blockStoreTxHashSTM,+ blockStoreTxSTM,+ withBlockStore,+ )+import Haskoin.Store.Cache (+ CacheConfig (..),+ CacheWriter,+ cacheNewBlock,+ cacheNewTx,+ cacheWriter,+ connectRedis,+ newCacheMetrics,+ )+import Haskoin.Store.Common (+ StoreEvent (..),+ createDataMetrics,+ )+import Haskoin.Store.Database.Reader (+ DatabaseReader (..),+ DatabaseReaderT,+ withDatabaseReader,+ )+import NQE (+ Inbox,+ Process (..),+ Publisher,+ publishSTM,+ receive,+ withProcess,+ withPublisher,+ withSubscription,+ )+import Network.Socket (SockAddr (..))+import qualified System.Metrics as Metrics (Store)+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- }+data Store = Store+ { storeManager :: !PeerManager+ , storeChain :: !Chain+ , storeBlock :: !BlockStore+ , storeDB :: !DatabaseReader+ , storeCache :: !(Maybe CacheConfig)+ , storePublisher :: !(Publisher StoreEvent)+ , storeNetwork :: !Network+ } -- | Configuration for a 'Store'.-data StoreConfig =- StoreConfig- { storeConfMaxPeers :: !Int- -- ^ max peers to connect to- , storeConfInitPeers :: ![HostPort]- -- ^ static set of peers to connect to- , storeConfDiscover :: !Bool- -- ^ discover new peers- , storeConfDB :: !FilePath- -- ^ RocksDB database path- , storeConfNetwork :: !Network- -- ^ network constants- , storeConfCache :: !(Maybe String)- -- ^ Redis cache configuration- , storeConfInitialGap :: !Word32- -- ^ gap on extended public key with no transactions- , storeConfGap :: !Word32- -- ^ gap for extended public keys- , storeConfCacheMin :: !Int- -- ^ cache xpubs with more than this many used addresses- , storeConfMaxKeys :: !Integer- -- ^ maximum number of keys in Redis cache- , storeConfNoMempool :: !Bool- -- ^ do not index new mempool transactions- , storeConfWipeMempool :: !Bool- -- ^ wipe mempool when starting- , storeConfSyncMempool :: !Bool- -- ^ sync mempool from peers- , storeConfPeerTimeout :: !NominalDiffTime- -- ^ disconnect peer if message not received for this many seconds- , storeConfPeerMaxLife :: !NominalDiffTime- -- ^ disconnect peer if it has been connected this long- , storeConfConnect :: !(SockAddr -> WithConnection)- -- ^ connect to peers using the function 'withConnection'- , storeConfCacheRetryDelay :: !Int- -- ^ delay in microseconds to retry getting cache lock- , storeConfStats :: !(Maybe Metrics.Store)- -- ^ stats 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)+ } -withStore :: (MonadLoggerIO m, MonadUnliftIO m)- => StoreConfig -> (Store -> m a) -> m a+withStore ::+ (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+ (storeConfNetwork cfg)+ (storeConfInitialGap cfg)+ (storeConfGap cfg)+ (storeConfDB cfg)+ stats+ f -blockStoreCfg :: StoreConfig- -> Node- -> Publisher StoreEvent- -> DatabaseReader- -> BlockStoreConfig+blockStoreCfg ::+ StoreConfig ->+ Node ->+ Publisher StoreEvent ->+ DatabaseReader ->+ BlockStoreConfig blockStoreCfg cfg node pub db = BlockStoreConfig { blockConfChain = nodeChain node@@ -156,10 +201,11 @@ , blockConfStats = storeConfStats cfg } -nodeCfg :: StoreConfig- -> DatabaseReader- -> Publisher NodeEvent- -> NodeConfig+nodeCfg ::+ StoreConfig ->+ DatabaseReader ->+ Publisher NodeEvent ->+ NodeConfig nodeCfg cfg db pub = NodeConfig { nodeConfMaxPeers = storeConfMaxPeers cfg@@ -169,7 +215,7 @@ , nodeConfDiscover = storeConfDiscover cfg , nodeConfEvents = pub , nodeConfNetAddr =- NetworkAddress+ NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0)) , nodeConfNet = storeConfNetwork cfg@@ -178,42 +224,44 @@ , nodeConfConnect = storeConfConnect cfg } -withCache :: (MonadUnliftIO m, MonadLoggerIO m)- => StoreConfig- -> Chain- -> DatabaseReader- -> Publisher StoreEvent- -> (Maybe CacheConfig -> m a)- -> m a+withCache ::+ (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)+ 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- }+ { 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+cacheWriterProcesses ::+ MonadUnliftIO m =>+ Inbox StoreEvent ->+ CacheWriter ->+ m a ->+ m a cacheWriterProcesses evts cwm action = withAsync events $ \a1 -> link a1 >> action where@@ -222,52 +270,46 @@ cacheWriterEvents :: MonadIO m => Inbox StoreEvent -> CacheWriter -> m () cacheWriterEvents evts cwm = forever $- receive evts >>= \e ->- e `cacheWriterDispatch` cwm+ receive evts >>= \e ->+ e `cacheWriterDispatch` cwm cacheWriterDispatch :: MonadIO m => StoreEvent -> CacheWriter -> m ()-cacheWriterDispatch (StoreBestBlock _) = cacheNewBlock-cacheWriterDispatch (StoreMempoolNew t) = cacheNewTx t+cacheWriterDispatch (StoreBestBlock _) = cacheNewBlock+cacheWriterDispatch (StoreMempoolNew t) = cacheNewTx t cacheWriterDispatch (StoreMempoolDelete t) = cacheNewTx t-cacheWriterDispatch _ = const (return ())+cacheWriterDispatch _ = const (return ()) -nodeForwarder :: MonadIO m- => BlockStore- -> Publisher StoreEvent- -> Inbox NodeEvent- -> m ()+nodeForwarder ::+ MonadIO m =>+ BlockStore ->+ Publisher StoreEvent ->+ Inbox NodeEvent ->+ m () nodeForwarder b pub sub = forever $ receive sub >>= atomically . storeDispatch b pub -- | Dispatcher of node events.-storeDispatch :: BlockStore- -> Publisher StoreEvent- -> NodeEvent- -> STM ()-+storeDispatch ::+ BlockStore ->+ Publisher StoreEvent ->+ NodeEvent ->+ STM () storeDispatch b pub (PeerEvent (PeerConnected p)) = do publishSTM (StorePeerConnected p) pub blockStorePeerConnectSTM p b- storeDispatch b pub (PeerEvent (PeerDisconnected p)) = do publishSTM (StorePeerDisconnected p) pub blockStorePeerDisconnectSTM p b- storeDispatch b _ (ChainEvent (ChainBestBlock bn)) = blockStoreHeadSTM bn b- storeDispatch _ _ (ChainEvent _) = return ()- storeDispatch _ pub (PeerMessage p (MPong (Pong n))) = publishSTM (StorePeerPong p n) pub- storeDispatch b _ (PeerMessage p (MBlock block)) = blockStoreBlockSTM p block b- storeDispatch b _ (PeerMessage p (MTx tx)) = blockStoreTxSTM p tx b- storeDispatch b _ (PeerMessage p (MNotFound (NotFound is))) = do let blocks = [ BlockHash h@@ -275,24 +317,21 @@ , 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- 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-+ 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 ()
src/Haskoin/Store/Stats.hs view
@@ -1,72 +1,91 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-module Haskoin.Store.Stats- ( StatDist- , withStats- , createStatDist- , addStatTime- , addClientError- , addServerError- , addStatQuery- , addStatItems- ) where+{-# LANGUAGE RecordWildCards #-} -import Control.Concurrent.STM.TQueue (TQueue, flushTQueue,- writeTQueue)-import qualified Control.Foldl as L-import Control.Monad (forever)-import Data.Function (on)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Int (Int64)-import Data.List (sort, sortBy)-import Data.Maybe (fromMaybe)-import Data.Ord (Down (..), comparing)-import Data.String.Conversions (cs)-import Data.Text (Text)-import System.Metrics (Store, Value (..), newStore,- registerGcMetrics,- registerGroup, sampleAll)-import System.Remote.Monitoring.Statsd (defaultStatsdOptions,- flushInterval, forkStatsd,- host, port, prefix)-import UnliftIO (MonadIO, TVar, atomically,- liftIO, modifyTVar,- newTQueueIO, newTVarIO,- readTVar, withAsync)-import UnliftIO.Concurrent (threadDelay)+module Haskoin.Store.Stats (+ StatDist,+ withStats,+ createStatDist,+ addStatTime,+ addClientError,+ addServerError,+ addStatQuery,+ addStatItems,+) where +import Control.Concurrent.STM.TQueue (+ TQueue,+ flushTQueue,+ writeTQueue,+ )+import qualified Control.Foldl as L+import Control.Monad (forever)+import Data.Function (on)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Int (Int64)+import Data.List (sort, sortBy)+import Data.Maybe (fromMaybe)+import Data.Ord (Down (..), comparing)+import Data.String.Conversions (cs)+import Data.Text (Text)+import System.Metrics (+ Store,+ Value (..),+ newStore,+ registerGcMetrics,+ registerGroup,+ sampleAll,+ )+import System.Remote.Monitoring.Statsd (+ defaultStatsdOptions,+ flushInterval,+ forkStatsd,+ host,+ port,+ prefix,+ )+import UnliftIO (+ MonadIO,+ TVar,+ atomically,+ liftIO,+ modifyTVar,+ newTQueueIO,+ 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+ _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+data StatData = StatData+ { 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)+data StatDist = StatDist+ { distQueue :: !(TQueue Int64)+ , distQueries :: !(TVar Int64)+ , distItems :: !(TVar Int64)+ , distClientErrors :: !(TVar Int64)+ , distServerErrors :: !(TVar Int64) } createStatDist :: MonadIO m => Text -> Store -> m StatDist@@ -76,30 +95,53 @@ distItems <- newTVarIO 0 distClientErrors <- newTVarIO 0 distServerErrors <- newTVarIO 0- let metrics = HashMap.fromList- [ (t <> ".query_count",- Counter . statQueries)- , (t <> ".item_count",- Counter . statItems)- , (t <> ".errors.client",- Counter . statClientErrors)- , (t <> ".errors.server",- 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 metrics =+ HashMap.fromList+ [+ ( t <> ".query_count"+ , Counter . statQueries+ )+ ,+ ( t <> ".item_count"+ , Counter . statItems+ )+ ,+ ( t <> ".errors.client"+ , Counter . statClientErrors+ )+ ,+ ( t <> ".errors.server"+ , 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@@ -113,7 +155,7 @@ 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 =@@ -121,11 +163,11 @@ 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@@ -157,8 +199,8 @@ p90max :: [Int64] -> Int64 p90max ls = case chopped of- [] -> 0- h:_ -> h+ [] -> 0+ h : _ -> h where sorted = sortBy (comparing Down) ls len = length sorted
src/Haskoin/Store/Web.hs view
@@ -1,2862 +1,3057 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# 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 >>= \mm -> forM_ mm $ \m ->- S.request >>= \req ->- forM_ (V.lookup (statKey m) (vault req)) $ \t ->- readTVarIO t >>= \ms -> forM_ ms $ \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- 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- 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)- 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- 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- 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 (length ths)- 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- txs <- lift . runNoCache nocache $ xPubTxs xspec xbals limits- addItemCount (length txs)- return txs--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- 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 (HashMap XPubKey XPubSpec, HashSet Address)-getBinfoActive = do- active <- getBinfoAddrsParam "active"- p2sh <- getBinfoAddrsParam "activeP2SH"- bech32 <- getBinfoAddrsParam "activeBech32"- let xspec d b = (\x -> (x, XPubSpec x d)) <$> xpub b- xspecs = HashMap.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 =- setMetrics statBlockchainUnspent >>- getBinfoActive >>= \(xspecs, addrs) ->- getNumTxId >>= \numtxid ->- get_limit >>= \limit ->- get_min_conf >>= \min_conf -> do- let len = HashSet.size addrs + HashMap.size xspecs- net <- lift $ asks (storeNetwork . webStore . webConfig)- height <- getChainHeight- let mn BinfoUnspent{..} = min_conf > getBinfoUnspentConfirmations- xspecs' = HashSet.fromList $ HashMap.elems xspecs- bus <- lift . runConduit $- getBinfoUnspents numtxid height xspecs' addrs .|- (dropWhileC mn >> takeC limit .| sinkList)- setHeaders- addItemCount (length bus)- 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- -> HashSet XPubSpec- -> HashSet Address- -> ConduitT () BinfoUnspent m ()-getBinfoUnspents numtxid height 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- bs <- xPubBals x- return $- streamThings- (xPubUnspents x bs)- 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)--getBinfoTxs :: (StoreReadExtra m, MonadIO m)- => 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 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 $ do- bs <- xPubBals x- return $ streamThings (xPubTxs x bs) (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 =- setMetrics statBlockchainExportHistory >>- getBinfoActive >>= \(xspecs, addrs) ->- get_dates >>= \(startM, endM) -> do- (code, price') <- getPrice- xpubs <- mapM (\x -> (,) x <$> xPubBals x) (HashMap.elems xspecs)- let xaddrs = HashSet.fromList $ concatMap (map get_addr . snd) xpubs- aaddrs = xaddrs <> addrs- cur = binfoTicker15m price'- cs' = conduits xpubs addrs endM- txs <- lift . runConduit $- joinDescStreams cs'- .| takeWhileC (is_newer startM)- .| concatMapMC get_transaction- .| sinkList- 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)- let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0)- setHeaders- addItemCount (length hs)- 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 <- get_xbals xspecs- xtxns <- get_xpub_tx_count xbals xspecs- let sxbals = subset sxpubs xbals- xabals = compute_xabals xbals- addrs = addrs' `HashSet.difference` HashMap.keysSet xabals- abals <- get_abals addrs- let sxspecs = compute_sxspecs sxpubs xspecs- sxabals = compute_xabals sxbals- sabals = subset 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 abook sxspecs saddrs salladdrs fltr numtxid prune ibal .|- (dropC offset >> takeC n .| sinkList)- best <- get_best_block- peers <- get_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- addItemCount (length abook + length ftxs)- streamEncoding $ binfoMultiAddrToEncoding net- BinfoMultiAddr- { getBinfoMultiAddrAddresses = baddrs- , getBinfoMultiAddrWallet = wallet- , getBinfoMultiAddrTxs = ftxs- , getBinfoMultiAddrInfo = info- , getBinfoMultiAddrRecommendFee = True- , getBinfoMultiAddrCashAddr = cashaddr- }- where- get_xpub_tx_count xbals =- let f (k, s) =- case HashMap.lookup k xbals of- Nothing -> return (k, 0)- Just bs -> do- n <- xPubTxCount s bs- return (k, fromIntegral n)- in fmap HashMap.fromList . mapM f . HashMap.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)- subset ks =- HashMap.filterWithKey (\k _ -> k `HashSet.member` ks)- compute_sxspecs sxpubs =- HashSet.fromList . HashMap.elems . subset sxpubs- 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 = HashMap.keysSet 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_xbals =- let f = not . nullBalance . xPubBal- g = HashMap.fromList . map (second (filter f))- h (k, s) = (,) k <$> xPubBals s- in fmap g . mapM h . HashMap.toList- 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 k XPubBal{..} =- let a = balanceAddress xPubBal- e = error "lions and tigers and bears"- s = toSoft (listToPath xPubBalPath)- m = fromMaybe e s- in (a, Just (BinfoXPubPath k m))- g k = map (f k)- amap = HashMap.map (const Nothing) $- HashSet.toMap addrs- xmap = HashMap.fromList .- concatMap (uncurry g) $- 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 <- xPubBals xspec- net <- lift $ asks (storeNetwork . webStore . webConfig)- let summary = xPubSummary xspec xbals- abook = compute_abook xpub xbals- xspecs = HashSet.singleton xspec- saddrs = HashSet.empty- baddrs = HashMap.keysSet abook- bfilter = BinfoFilterAll- amnt = xPubSummaryConfirmed summary +- xPubSummaryZero summary- txs <- lift . runConduit $- getBinfoTxs- 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- addItemCount (length abook + length txs)- 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- 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- 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- addItemCount (1 + length txs)- 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)- xbals <- mapM (get_xspec_balance net) (HashMap.elems xspecs)- let res = HashMap.fromList (abals <> xbals)- setHeaders- addItemCount (length abals)- 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- 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- }- addItemCount (length xbals)- 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 =- getNumTxId >>= \numtxid ->- S.param "height" >>= \height ->- setMetrics statBlockchainBlockHeight >>- getBlocksAtHeight height >>= \block_hashes -> do- block_headers <- catMaybes <$> mapM getBlock block_hashes- next_block_hashes <- getBlocksAtHeight (height + 1)- next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes- binfo_blocks <-- mapM (get_binfo_blocks numtxid next_block_headers) block_headers- setHeaders- net <- lift $ asks (storeNetwork . webStore . webConfig)- addItemCount (length binfo_blocks)- 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- let 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 =- getNumTxId >>= \numtxid ->- getBinfoHex >>= \hex ->- 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- txs <- lift $ mapM get_tx (blockDataTxs b)- 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)- 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)- addItemCount (length btxs + 1)- 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--fmtStatus :: Status -> Text-fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)-+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# 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+ 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+ 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)+ 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+ 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+ 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 (length ths)+ 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+ txs <- lift . runNoCache nocache $ xPubTxs xspec xbals limits+ addItemCount (length txs)+ return txs++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+ 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 (HashMap XPubKey XPubSpec, HashSet Address)+getBinfoActive = do+ active <- getBinfoAddrsParam "active"+ p2sh <- getBinfoAddrsParam "activeP2SH"+ bech32 <- getBinfoAddrsParam "activeBech32"+ let xspec d b = (\x -> (x, XPubSpec x d)) <$> xpub b+ xspecs =+ HashMap.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 =+ setMetrics statBlockchainUnspent+ >> getBinfoActive >>= \(xspecs, addrs) ->+ getNumTxId >>= \numtxid ->+ get_limit >>= \limit ->+ get_min_conf >>= \min_conf -> do+ let len = HashSet.size addrs + HashMap.size xspecs+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ height <- getChainHeight+ let mn BinfoUnspent{..} = min_conf > getBinfoUnspentConfirmations+ xspecs' = HashSet.fromList $ HashMap.elems xspecs+ bus <-+ lift . runConduit $+ getBinfoUnspents numtxid height xspecs' addrs+ .| (dropWhileC mn >> takeC limit .| sinkList)+ setHeaders+ addItemCount (length bus)+ 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 ->+ HashSet XPubSpec ->+ HashSet Address ->+ ConduitT () BinfoUnspent m ()+getBinfoUnspents numtxid height 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+ bs <- xPubBals x+ return $+ streamThings+ (xPubUnspents x bs)+ 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)++getBinfoTxs ::+ (StoreReadExtra m, MonadIO m) =>+ 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 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 $ do+ bs <- xPubBals x+ return $ streamThings (xPubTxs x bs) (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 =+ setMetrics statBlockchainExportHistory+ >> getBinfoActive >>= \(xspecs, addrs) ->+ get_dates >>= \(startM, endM) -> do+ (code, price') <- getPrice+ xpubs <- mapM (\x -> (,) x <$> xPubBals x) (HashMap.elems xspecs)+ let xaddrs = HashSet.fromList $ concatMap (map get_addr . snd) xpubs+ aaddrs = xaddrs <> addrs+ cur = binfoTicker15m price'+ cs' = conduits xpubs addrs endM+ txs <-+ lift . runConduit $+ joinDescStreams cs'+ .| takeWhileC (is_newer startM)+ .| concatMapMC get_transaction+ .| sinkList+ 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)+ let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0)+ setHeaders+ addItemCount (length hs)+ 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 <- get_xbals xspecs+ xtxns <- get_xpub_tx_count xbals xspecs+ let sxbals = subset sxpubs xbals+ xabals = compute_xabals xbals+ addrs = addrs' `HashSet.difference` HashMap.keysSet xabals+ abals <- get_abals addrs+ let sxspecs = compute_sxspecs sxpubs xspecs+ sxabals = compute_xabals sxbals+ sabals = subset 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 abook sxspecs saddrs salladdrs fltr numtxid prune ibal+ .| (dropC offset >> takeC n .| sinkList)+ best <- get_best_block+ peers <- get_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+ addItemCount (length abook + length ftxs)+ streamEncoding $+ binfoMultiAddrToEncoding+ net+ BinfoMultiAddr+ { getBinfoMultiAddrAddresses = baddrs+ , getBinfoMultiAddrWallet = wallet+ , getBinfoMultiAddrTxs = ftxs+ , getBinfoMultiAddrInfo = info+ , getBinfoMultiAddrRecommendFee = True+ , getBinfoMultiAddrCashAddr = cashaddr+ }+ where+ get_xpub_tx_count xbals =+ let f (k, s) =+ case HashMap.lookup k xbals of+ Nothing -> return (k, 0)+ Just bs -> do+ n <- xPubTxCount s bs+ return (k, fromIntegral n)+ in fmap HashMap.fromList . mapM f . HashMap.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)+ subset ks =+ HashMap.filterWithKey (\k _ -> k `HashSet.member` ks)+ compute_sxspecs sxpubs =+ HashSet.fromList . HashMap.elems . subset sxpubs+ 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 = HashMap.keysSet 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_xbals =+ let f = not . nullBalance . xPubBal+ g = HashMap.fromList . map (second (filter f))+ h (k, s) = (,) k <$> xPubBals s+ in fmap g . mapM h . HashMap.toList+ 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 k XPubBal{..} =+ let a = balanceAddress xPubBal+ e = error "lions and tigers and bears"+ s = toSoft (listToPath xPubBalPath)+ m = fromMaybe e s+ in (a, Just (BinfoXPubPath k m))+ g k = map (f k)+ amap =+ HashMap.map (const Nothing) $+ HashSet.toMap addrs+ xmap =+ HashMap.fromList+ . concatMap (uncurry g)+ $ 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 <- xPubBals xspec+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ let summary = xPubSummary xspec xbals+ abook = compute_abook xpub xbals+ xspecs = HashSet.singleton xspec+ saddrs = HashSet.empty+ baddrs = HashMap.keysSet abook+ bfilter = BinfoFilterAll+ amnt =+ xPubSummaryConfirmed summary+ + xPubSummaryZero summary+ txs <-+ lift . runConduit $+ getBinfoTxs+ 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+ addItemCount (length abook + length txs)+ 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+ 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+ 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+ addItemCount (1 + length txs)+ 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)+ xbals <- mapM (get_xspec_balance net) (HashMap.elems xspecs)+ let res = HashMap.fromList (abals <> xbals)+ setHeaders+ addItemCount (length abals)+ 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+ 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+ }+ addItemCount (length xbals)+ 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 =+ getNumTxId >>= \numtxid ->+ S.param "height" >>= \height ->+ setMetrics statBlockchainBlockHeight+ >> getBlocksAtHeight height >>= \block_hashes -> do+ block_headers <- catMaybes <$> mapM getBlock block_hashes+ next_block_hashes <- getBlocksAtHeight (height + 1)+ next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes+ binfo_blocks <-+ mapM (get_binfo_blocks numtxid next_block_headers) block_headers+ setHeaders+ net <- lift $ asks (storeNetwork . webStore . webConfig)+ addItemCount (length binfo_blocks)+ 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+ let 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 =+ getNumTxId >>= \numtxid ->+ getBinfoHex >>= \hex ->+ 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+ txs <- lift $ mapM get_tx (blockDataTxs b)+ 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)+ 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)+ addItemCount (length btxs + 1)+ 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++fmtStatus :: Status -> Text+fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)
test/Haskoin/Store/CacheSpec.hs view
@@ -1,11 +1,11 @@ module Haskoin.Store.CacheSpec (spec) where -import Data.List (sort)-import Haskoin.Store.Cache (blockRefScore, scoreBlockRef)-import Haskoin.Store.Data (BlockRef (..))-import Test.Hspec (Spec, describe)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Gen, choose, forAll, listOf, oneof)+import Data.List (sort)+import Haskoin.Store.Cache (blockRefScore, scoreBlockRef)+import Haskoin.Store.Data (BlockRef (..))+import Test.Hspec (Spec, describe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Gen, choose, forAll, listOf, oneof) spec :: Spec spec = do@@ -29,7 +29,7 @@ b = do h <- choose (0, 0x07ffffff) p <- choose (0, 0x03ffffff)- return BlockRef {blockRefHeight = h, blockRefPos = p}+ return BlockRef{blockRefHeight = h, blockRefPos = p} m = do t <- choose (0, 0x001fffffffffffff)- return MemRef {memRefTime = t}+ return MemRef{memRefTime = t}
test/Haskoin/StoreSpec.hs view
@@ -1,112 +1,117 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} module Haskoin.StoreSpec (spec) where -import Conduit-import Control.Monad-import Control.Monad.Logger-import Control.Monad.Reader-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Base64-import Data.Either-import Data.List-import Data.Maybe-import Data.Serialize-import Data.Time.Clock.POSIX-import Data.Word-import Haskoin-import Haskoin.Node-import Haskoin.Store-import Haskoin.Util.Arbitrary-import Network.Socket-import NQE-import System.Random-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck-import UnliftIO+import Conduit+import Control.Monad+import Control.Monad.Logger+import Control.Monad.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Base64+import Data.Either+import Data.List+import Data.Maybe+import Data.Serialize+import Data.Time.Clock.POSIX+import Data.Word+import Haskoin+import Haskoin.Node+import Haskoin.Store+import Haskoin.Util.Arbitrary+import NQE+import Network.Socket+import System.Random+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import UnliftIO data TestStore = TestStore- { testStoreDB :: !DatabaseReader+ { testStoreDB :: !DatabaseReader , testStoreBlockStore :: !BlockStore- , testStoreChain :: !Chain- , testStoreEvents :: !(Inbox StoreEvent)+ , 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- }+ 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@@ -114,7 +119,7 @@ allBlocks :: [Block] allBlocks = fromRight (error "Could not decode blocks") $- runGet f (decodeBase64Lenient allBlocksBase64)+ runGet f (decodeBase64Lenient allBlocksBase64) where f = mapM (const get) [(1 :: Int) .. 15] @@ -189,9 +194,9 @@ 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)+ 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@@ -202,8 +207,9 @@ 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+ Left e ->+ error $+ "Dummy peer could not decode payload: " <> show e mockPeerReact :: Message -> [Message] mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]@@ -215,6 +221,6 @@ mockPeerReact (MGetData (GetData ivs)) = mapMaybe f ivs where f (InvVector InvBlock h) = MBlock <$> find (l h) allBlocks- f _ = Nothing+ f _ = Nothing l h b = headerHash (blockHeader b) == BlockHash h mockPeerReact _ = []
test/Spec.hs view