diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 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 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -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 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -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 diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -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 () diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -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{..} diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -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) + } diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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)} diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -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) diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -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 () diff --git a/src/Haskoin/Store/Stats.hs b/src/Haskoin/Store/Stats.hs --- a/src/Haskoin/Store/Stats.hs +++ b/src/Haskoin/Store/Stats.hs @@ -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 diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -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) diff --git a/test/Haskoin/Store/CacheSpec.hs b/test/Haskoin/Store/CacheSpec.hs --- a/test/Haskoin/Store/CacheSpec.hs +++ b/test/Haskoin/Store/CacheSpec.hs @@ -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} diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -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 _ = [] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs