diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,15 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html) +## 0.64.8 +### Changed +- Use better Fourmolu format. +- Be more precise when counting retrieved items. + +### Fixed +- Avoid transactions duplicated in xpub data. +- Refactor some functions to make them more robust. + ## 0.64.7 ### Fixed - Optimisations for various Blockchain endpoints. 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.7 +version: 0.64.8 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.7 + , haskoin-store-data ==0.64.8 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -116,7 +116,7 @@ , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.64.7 + , haskoin-store-data ==0.64.8 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -177,7 +177,7 @@ , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.64.7 + , haskoin-store-data ==0.64.8 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -1,5 +1,5 @@ -module Haskoin.Store ( - Store (..), +module Haskoin.Store + ( Store (..), StoreConfig (..), StoreEvent (..), withStore, @@ -32,7 +32,8 @@ -- * Other Data PubExcept (..), -) where + ) +where import Haskoin.Store.BlockStore import Haskoin.Store.Cache 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 @@ -7,1225 +7,1226 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.BlockStore ( - -- * Block Store - BlockStore, - BlockStoreConfig (..), - withBlockStore, - blockStorePeerConnect, - blockStorePeerConnectSTM, - blockStorePeerDisconnect, - blockStorePeerDisconnectSTM, - blockStoreHead, - blockStoreHeadSTM, - blockStoreBlock, - blockStoreBlockSTM, - blockStoreNotFound, - blockStoreNotFoundSTM, - blockStoreTx, - blockStoreTxSTM, - blockStoreTxHash, - blockStoreTxHashSTM, - blockStorePendingTxs, - blockStorePendingTxsSTM, -) where - -import Control.Monad ( - forM, - forM_, - forever, - mzero, - unless, - void, - when, - ) -import Control.Monad.Except ( - ExceptT (..), - MonadError, - catchError, - runExceptT, - ) -import Control.Monad.Logger ( - MonadLoggerIO, - logDebugS, - logErrorS, - logInfoS, - logWarnS, - ) -import Control.Monad.Reader ( - MonadReader, - ReaderT (..), - ask, - asks, - ) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (runMaybeT) -import qualified Data.ByteString as B -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.List (delete) -import Data.Maybe ( - catMaybes, - fromJust, - isJust, - mapMaybe, - ) -import Data.Serialize (encode) -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Time.Clock ( - NominalDiffTime, - UTCTime, - diffUTCTime, - getCurrentTime, - ) -import Data.Time.Clock.POSIX ( - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.Format ( - defaultTimeLocale, - formatTime, - iso8601DateFormat, - ) -import Haskoin ( - Block (..), - BlockHash (..), - BlockHeader (..), - BlockHeight, - BlockNode (..), - GetData (..), - InvType (..), - InvVector (..), - Message (..), - Network (..), - OutPoint (..), - Tx (..), - TxHash (..), - TxIn (..), - blockHashToHex, - headerHash, - txHash, - txHashToHex, - ) -import Haskoin.Node ( - Chain, - OnlinePeer (..), - Peer, - PeerException (..), - PeerManager, - chainBlockMain, - chainGetAncestor, - chainGetBest, - chainGetBlock, - chainGetParents, - getPeers, - killPeer, - peerText, - sendMessage, - setBusy, - setFree, - ) -import Haskoin.Store.Common -import Haskoin.Store.Data -import Haskoin.Store.Database.Reader -import Haskoin.Store.Database.Writer -import Haskoin.Store.Logic ( - ImportException (Orphan), - deleteUnconfirmedTx, - importBlock, - initBest, - newMempoolTx, - revertBlock, - ) -import Haskoin.Store.Stats -import NQE ( - Listen, - Mailbox, - Publisher, - inboxToMailbox, - newInbox, - publish, - query, - receive, - send, - sendSTM, - ) -import qualified System.Metrics as Metrics -import qualified System.Metrics.Gauge as Metrics (Gauge) -import qualified System.Metrics.Gauge as Metrics.Gauge -import System.Random (randomRIO) -import UnliftIO ( - Exception, - MonadIO, - MonadUnliftIO, - STM, - TVar, - async, - atomically, - liftIO, - link, - modifyTVar, - newTVarIO, - readTVar, - readTVarIO, - throwIO, - withAsync, - writeTVar, - ) -import UnliftIO.Concurrent (threadDelay) - -data BlockStoreMessage - = BlockNewBest !BlockNode - | BlockPeerConnect !Peer - | BlockPeerDisconnect !Peer - | BlockReceived !Peer !Block - | BlockNotFound !Peer ![BlockHash] - | TxRefReceived !Peer !Tx - | TxRefAvailable !Peer ![TxHash] - | BlockPing !(Listen ()) - -data BlockException - = BlockNotInChain !BlockHash - | Uninitialized - | CorruptDatabase - | AncestorNotInChain !BlockHeight !BlockHash - | MempoolImportFailed - deriving (Show, Eq, Ord, Exception) - -data Syncing = Syncing - { syncingPeer :: !Peer - , syncingTime :: !UTCTime - , syncingBlocks :: ![BlockHash] - } - -data PendingTx = PendingTx - { pendingTxTime :: !UTCTime - , pendingTx :: !Tx - , pendingDeps :: !(HashSet TxHash) - } - deriving (Show, Eq, Ord) - --- | Block store process state. -data BlockStore = BlockStore - { myMailbox :: !(Mailbox BlockStoreMessage) - , myConfig :: !BlockStoreConfig - , myPeer :: !(TVar (Maybe Syncing)) - , myTxs :: !(TVar (HashMap TxHash PendingTx)) - , requested :: !(TVar (HashSet TxHash)) - , myMetrics :: !(Maybe StoreMetrics) - } - -data StoreMetrics = StoreMetrics - { storeHeight :: !Metrics.Gauge - , headersHeight :: !Metrics.Gauge - , storePendingTxs :: !Metrics.Gauge - , storePeersConnected :: !Metrics.Gauge - , storeMempoolSize :: !Metrics.Gauge - } - -newStoreMetrics :: MonadIO m => Metrics.Store -> m StoreMetrics -newStoreMetrics s = liftIO $ do - storeHeight <- g "blockchain.height" - headersHeight <- g "blockchain.headers" - storePendingTxs <- g "mempool.pending_txs" - storePeersConnected <- g "network.peers_connected" - storeMempoolSize <- g "mempool.size" - return StoreMetrics{..} - where - g x = Metrics.createGauge ("store." <> x) s - -setStoreHeight :: MonadIO m => BlockT m () -setStoreHeight = - asks myMetrics >>= \case - Nothing -> return () - Just m -> - getBestBlock >>= \case - Nothing -> setit m 0 - Just bb -> - getBlock bb >>= \case - Nothing -> setit m 0 - Just b -> setit m (blockDataHeight b) - where - setit m i = liftIO $ storeHeight m `Metrics.Gauge.set` fromIntegral i - -setHeadersHeight :: MonadIO m => BlockT m () -setHeadersHeight = - asks myMetrics >>= \case - Nothing -> return () - Just m -> do - h <- fmap nodeHeight $ chainGetBest =<< asks (blockConfChain . myConfig) - liftIO $ headersHeight m `Metrics.Gauge.set` fromIntegral h - -setPendingTxs :: MonadIO m => BlockT m () -setPendingTxs = - asks myMetrics >>= \case - Nothing -> return () - Just m -> do - s <- asks myTxs >>= \t -> atomically (HashMap.size <$> readTVar t) - liftIO $ storePendingTxs m `Metrics.Gauge.set` fromIntegral s - -setPeersConnected :: MonadIO m => BlockT m () -setPeersConnected = - asks myMetrics >>= \case - Nothing -> return () - Just m -> do - ps <- fmap length $ getPeers =<< asks (blockConfManager . myConfig) - liftIO $ storePeersConnected m `Metrics.Gauge.set` fromIntegral ps - -setMempoolSize :: MonadIO m => BlockT m () -setMempoolSize = - asks myMetrics >>= \case - Nothing -> return () - Just m -> do - s <- length <$> getMempool - liftIO $ storeMempoolSize m `Metrics.Gauge.set` fromIntegral s - --- | Configuration for a block store. -data BlockStoreConfig = BlockStoreConfig - { -- | peer manager from running node - blockConfManager :: !PeerManager - , -- | chain from a running node - blockConfChain :: !Chain - , -- | listener for store events - blockConfListener :: !(Publisher StoreEvent) - , -- | RocksDB database handle - blockConfDB :: !DatabaseReader - , -- | network constants - blockConfNet :: !Network - , -- | do not index new mempool transactions - blockConfNoMempool :: !Bool - , -- | wipe mempool at start - blockConfWipeMempool :: !Bool - , -- | sync mempool from peers - blockConfSyncMempool :: !Bool - , -- | disconnect syncing peer if inactive for this long - blockConfPeerTimeout :: !NominalDiffTime - , blockConfStats :: !(Maybe Metrics.Store) - } - -type BlockT m = ReaderT BlockStore m - -runImport :: - MonadLoggerIO m => - WriterT (ExceptT ImportException m) a -> - BlockT m (Either ImportException a) -runImport f = - ReaderT $ \r -> runExceptT $ runWriter (blockConfDB (myConfig r)) f - -runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a -runRocksDB f = - ReaderT $ runReaderT f . blockConfDB . myConfig - -instance MonadIO m => StoreReadBase (BlockT m) where - getNetwork = - runRocksDB getNetwork - getBestBlock = - runRocksDB getBestBlock - getBlocksAtHeight = - runRocksDB . getBlocksAtHeight - getBlock = - runRocksDB . getBlock - getTxData = - runRocksDB . getTxData - getSpender = - runRocksDB . getSpender - getUnspent = - runRocksDB . getUnspent - getBalance = - runRocksDB . getBalance - getMempool = - runRocksDB getMempool - -instance MonadUnliftIO m => StoreReadExtra (BlockT m) where - getMaxGap = - runRocksDB getMaxGap - getInitialGap = - runRocksDB getInitialGap - getAddressesTxs as = - runRocksDB . getAddressesTxs as - getAddressesUnspents as = - runRocksDB . getAddressesUnspents as - getAddressUnspents a = - runRocksDB . getAddressUnspents a - getAddressTxs a = - runRocksDB . getAddressTxs a - getNumTxData = - runRocksDB . getNumTxData - getBalances = - runRocksDB . getBalances - xPubBals = - runRocksDB . xPubBals - xPubUnspents x l = - runRocksDB . xPubUnspents x l - xPubTxs x l = - runRocksDB . xPubTxs x l - xPubTxCount x = - runRocksDB . xPubTxCount x - --- | Run block store process. -withBlockStore :: - (MonadUnliftIO m, MonadLoggerIO m) => - BlockStoreConfig -> - (BlockStore -> m a) -> - m a -withBlockStore cfg action = do - pb <- newTVarIO Nothing - ts <- newTVarIO HashMap.empty - rq <- newTVarIO HashSet.empty - inbox <- newInbox - metrics <- mapM newStoreMetrics (blockConfStats cfg) - let r = - BlockStore - { myMailbox = inboxToMailbox inbox - , myConfig = cfg - , myPeer = pb - , myTxs = ts - , requested = rq - , myMetrics = metrics - } - withAsync (runReaderT (go inbox) r) $ \a -> do - link a - action r - where - go inbox = do - ini - wipe - run inbox - del txs = do - $(logInfoS) "BlockStore" $ - "Deleting " <> cs (show (length txs)) <> " transactions" - forM_ txs $ \(_, th) -> deleteUnconfirmedTx False th - wipe_it txs = do - let (txs1, txs2) = splitAt 1000 txs - unless (null txs1) $ - runImport (del txs1) >>= \case - Left e -> do - $(logErrorS) "BlockStore" $ - "Could not wipe mempool: " <> cs (show e) - throwIO e - Right () -> wipe_it txs2 - wipe - | blockConfWipeMempool cfg = - getMempool >>= wipe_it - | otherwise = - return () - ini = - runImport initBest >>= \case - Left e -> do - $(logErrorS) "BlockStore" $ - "Could not initialize: " <> cs (show e) - throwIO e - Right () -> return () - run inbox = - withAsync (pingMe (inboxToMailbox inbox)) $ - const $ - forever $ - receive inbox - >>= ReaderT . runReaderT . processBlockStoreMessage - -isInSync :: MonadLoggerIO m => BlockT m Bool -isInSync = - getBestBlock >>= \case - Nothing -> do - $(logErrorS) "BlockStore" "Block database uninitialized" - throwIO Uninitialized - Just bb -> do - cb <- asks (blockConfChain . myConfig) >>= chainGetBest - if headerHash (nodeHeader cb) == bb - then clearSyncingState >> return True - else return False - -guardMempool :: Monad m => BlockT m () -> BlockT m () -guardMempool f = do - n <- asks (blockConfNoMempool . myConfig) - unless n f - -syncMempool :: Monad m => BlockT m () -> BlockT m () -syncMempool f = do - s <- asks (blockConfSyncMempool . myConfig) - when s f - -mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m () -mempool p = guardMempool $ - syncMempool $ - void $ - async $ do - isInSync >>= \s -> when s $ do - $(logDebugS) "BlockStore" $ - "Requesting mempool from peer: " <> peerText p - MMempool `sendMessage` p - -processBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => - Peer -> - Block -> - BlockT m () -processBlock peer block = void . runMaybeT $ do - checkPeer peer >>= \case - True -> return () - False -> do - $(logErrorS) "BlockStore" $ - "Non-syncing peer " <> peerText peer - <> " sent me a block: " - <> blockHashToHex blockhash - PeerMisbehaving "Sent unexpected block" `killPeer` peer - mzero - node <- - getBlockNode blockhash >>= \case - Just b -> return b - Nothing -> do - $(logErrorS) "BlockStore" $ - "Peer " <> peerText peer - <> " sent unknown block: " - <> blockHashToHex blockhash - PeerMisbehaving "Sent unknown block" `killPeer` peer - mzero - $(logDebugS) "BlockStore" $ - "Processing block: " <> blockText node Nothing - <> " from peer: " - <> peerText peer - lift . notify (Just block) $ - runImport (importBlock block node) >>= \case - Left e -> failure e - Right () -> success node - where - header = blockHeader block - blockhash = headerHash header - hexhash = blockHashToHex blockhash - success node = do - $(logInfoS) "BlockStore" $ - "Best block: " <> blockText node (Just block) - removeSyncingBlock $ headerHash $ nodeHeader node - touchPeer - isInSync >>= \case - False -> syncMe - True -> do - updateOrphans - mempool peer - failure e = do - $(logErrorS) "BlockStore" $ - "Error importing block " <> hexhash - <> " from peer: " - <> peerText peer - <> ": " - <> cs (show e) - killPeer (PeerMisbehaving (show e)) peer - -setSyncingBlocks :: - (MonadReader BlockStore m, MonadIO m) => - [BlockHash] -> - m () -setSyncingBlocks hs = - asks myPeer >>= \box -> - atomically $ - modifyTVar box $ \case - Nothing -> Nothing - Just x -> Just x{syncingBlocks = hs} - -getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash] -getSyncingBlocks = - asks myPeer >>= readTVarIO >>= \case - Nothing -> return [] - Just x -> return $ syncingBlocks x - -addSyncingBlocks :: - (MonadReader BlockStore m, MonadIO m) => - [BlockHash] -> - m () -addSyncingBlocks hs = - asks myPeer >>= \box -> - atomically $ - modifyTVar box $ \case - Nothing -> Nothing - Just x -> Just x{syncingBlocks = syncingBlocks x <> hs} - -removeSyncingBlock :: - (MonadReader BlockStore m, MonadIO m) => - BlockHash -> - m () -removeSyncingBlock h = do - box <- asks myPeer - atomically $ - modifyTVar box $ \case - Nothing -> Nothing - Just x -> Just x{syncingBlocks = delete h (syncingBlocks x)} - -checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool -checkPeer p = - fmap syncingPeer <$> getSyncingState >>= \case - Nothing -> return False - Just p' -> return $ p == p' - -getBlockNode :: - (MonadLoggerIO m, MonadReader BlockStore m) => - BlockHash -> - m (Maybe BlockNode) -getBlockNode blockhash = - chainGetBlock blockhash =<< asks (blockConfChain . myConfig) - -processNoBlocks :: - MonadLoggerIO m => - Peer -> - [BlockHash] -> - BlockT m () -processNoBlocks p hs = do - forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) -> - $(logErrorS) "BlockStore" $ - "Block " - <> cs (show i) - <> "/" - <> cs (show (length hs)) - <> " " - <> blockHashToHex h - <> " not found by peer: " - <> peerText p - killPeer (PeerMisbehaving "Did not find requested block(s)") p - -processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m () -processTx p tx = guardMempool $ do - t <- liftIO getCurrentTime - $(logDebugS) "BlockManager" $ - "Received tx " <> txHashToHex (txHash tx) - <> " by peer: " - <> peerText p - addPendingTx $ PendingTx t tx HashSet.empty - -pruneOrphans :: MonadIO m => BlockT m () -pruneOrphans = guardMempool $ do - ts <- asks myTxs - now <- liftIO getCurrentTime - atomically . modifyTVar ts . HashMap.filter $ \p -> - now `diffUTCTime` pendingTxTime p > 600 - -addPendingTx :: MonadIO m => PendingTx -> BlockT m () -addPendingTx p = do - ts <- asks myTxs - rq <- asks requested - atomically $ do - modifyTVar ts $ HashMap.insert th p - modifyTVar rq $ HashSet.delete th - HashMap.size <$> readTVar ts - setPendingTxs - where - th = txHash (pendingTx p) - -addRequestedTx :: MonadIO m => TxHash -> BlockT m () -addRequestedTx th = do - qbox <- asks requested - atomically $ modifyTVar qbox $ HashSet.insert th - liftIO $ - void $ - async $ do - threadDelay 20000000 - atomically $ modifyTVar qbox $ HashSet.delete th - -isPending :: MonadIO m => TxHash -> BlockT m Bool -isPending th = do - tbox <- asks myTxs - qbox <- asks requested - atomically $ do - ts <- readTVar tbox - rs <- readTVar qbox - return $ - th `HashMap.member` ts - || th `HashSet.member` rs - -pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx] -pendingTxs i = do - selected <- - asks myTxs >>= \box -> atomically $ do - pending <- readTVar box - let (selected, rest) = select pending - writeTVar box rest - return (selected) - setPendingTxs - return selected - where - select pend = - let eligible = HashMap.filter (null . pendingDeps) pend - orphans = HashMap.difference pend eligible - selected = take i $ sortit eligible - remaining = HashMap.filter (`notElem` selected) eligible - in (selected, remaining <> orphans) - sortit m = - let sorted = sortTxs $ map pendingTx $ HashMap.elems m - txids = map (txHash . snd) sorted - in mapMaybe (`HashMap.lookup` m) txids - -fulfillOrphans :: MonadIO m => BlockStore -> TxHash -> m () -fulfillOrphans block_read th = - atomically $ modifyTVar box (HashMap.map fulfill) - where - box = myTxs block_read - fulfill p = p{pendingDeps = HashSet.delete th (pendingDeps p)} - -updateOrphans :: - ( StoreReadBase m - , MonadLoggerIO m - , MonadReader BlockStore m - ) => - m () -updateOrphans = do - box <- asks myTxs - pending <- readTVarIO box - let orphans = HashMap.filter (not . null . pendingDeps) pending - updated <- forM orphans $ \p -> do - let tx = pendingTx p - exists (txHash tx) >>= \case - True -> return Nothing - False -> Just <$> fill_deps p - let pruned = HashMap.map fromJust $ HashMap.filter isJust updated - atomically $ writeTVar box pruned - where - exists th = - getTxData th >>= \case - Nothing -> return False - Just TxData{txDataDeleted = True} -> return False - Just TxData{txDataDeleted = False} -> return True - prev_utxos tx = catMaybes <$> mapM (getUnspent . prevOutput) (txIn tx) - fulfill p unspent = - let unspent_hash = outPointHash (unspentPoint unspent) - new_deps = HashSet.delete unspent_hash (pendingDeps p) - in p{pendingDeps = new_deps} - fill_deps p = do - let tx = pendingTx p - unspents <- prev_utxos tx - return $ foldl fulfill p unspents - -newOrphanTx :: - MonadLoggerIO m => - BlockStore -> - UTCTime -> - Tx -> - WriterT m () -newOrphanTx block_read time tx = do - $(logDebugS) "BlockStore" $ - "Import tx " - <> txHashToHex (txHash tx) - <> ": Orphan" - let box = myTxs block_read - unspents <- catMaybes <$> mapM getUnspent prevs - let unspent_set = HashSet.fromList (map unspentPoint unspents) - missing_set = HashSet.difference prev_set unspent_set - missing_txs = HashSet.map outPointHash missing_set - atomically . modifyTVar box $ - HashMap.insert - (txHash tx) - PendingTx - { pendingTxTime = time - , pendingTx = tx - , pendingDeps = missing_txs - } - where - prev_set = HashSet.fromList prevs - prevs = map prevOutput (txIn tx) - -importMempoolTx :: - (MonadLoggerIO m, MonadError ImportException m) => - BlockStore -> - UTCTime -> - Tx -> - WriterT m Bool -importMempoolTx block_read time tx = - catchError new_mempool_tx handle_error - where - tx_hash = txHash tx - handle_error Orphan = do - newOrphanTx block_read time tx - return False - handle_error _ = return False - seconds = floor (utcTimeToPOSIXSeconds time) - new_mempool_tx = - newMempoolTx tx seconds >>= \case - True -> do - $(logInfoS) "BlockStore" $ - "Import tx " <> txHashToHex (txHash tx) - <> ": OK" - fulfillOrphans block_read tx_hash - return True - False -> do - $(logDebugS) "BlockStore" $ - "Import tx " <> txHashToHex (txHash tx) - <> ": Already imported" - return False - -notify :: MonadIO m => Maybe Block -> BlockT m a -> BlockT m a -notify block go = do - old <- HashSet.union e . HashSet.fromList . map snd <$> getMempool - x <- go - new <- HashSet.fromList . map snd <$> getMempool - l <- asks (blockConfListener . myConfig) - forM_ (old `HashSet.difference` new) $ \h -> - publish (StoreMempoolDelete h) l - forM_ (new `HashSet.difference` old) $ \h -> - publish (StoreMempoolNew h) l - case block of - Just b -> publish (StoreBestBlock (headerHash (blockHeader b))) l - Nothing -> return () - return x - where - e = case block of - Just b -> HashSet.fromList (map txHash (blockTxns b)) - Nothing -> HashSet.empty - -processMempool :: MonadLoggerIO m => BlockT m () -processMempool = guardMempool . notify Nothing $ do - txs <- pendingTxs 2000 - block_read <- ask - unless (null txs) (import_txs block_read txs) - where - run_import block_read p = - let t = pendingTx p - h = txHash t - in importMempoolTx block_read (pendingTxTime p) (pendingTx p) - import_txs block_read txs = - let r = mapM (run_import block_read) txs - in runImport r >>= \case - Left e -> report_error e - Right _ -> return () - report_error e = do - $(logErrorS) "BlockImport" $ - "Error processing mempool: " <> cs (show e) - throwIO e - -processTxs :: - MonadLoggerIO m => - Peer -> - [TxHash] -> - BlockT m () -processTxs p hs = guardMempool $ do - s <- isInSync - when s $ do - $(logDebugS) "BlockStore" $ - "Received inventory with " - <> cs (show (length hs)) - <> " transactions from peer: " - <> peerText p - xs <- catMaybes <$> zip_counter process_tx - unless (null xs) $ go xs - where - len = length hs - zip_counter = forM (zip [(1 :: Int) ..] hs) . uncurry - process_tx i h = - isPending h >>= \case - True -> do - $(logDebugS) "BlockStore" $ - "Tx " <> cs (show i) <> "/" <> cs (show len) - <> " " - <> txHashToHex h - <> ": " - <> "Pending" - return Nothing - False -> - getActiveTxData h >>= \case - Just _ -> do - $(logDebugS) "BlockStore" $ - "Tx " <> cs (show i) <> "/" <> cs (show len) - <> " " - <> txHashToHex h - <> ": " - <> "Already Imported" - return Nothing - Nothing -> do - $(logDebugS) "BlockStore" $ - "Tx " <> cs (show i) <> "/" <> cs (show len) - <> " " - <> txHashToHex h - <> ": " - <> "Requesting" - return (Just h) - go xs = do - mapM_ addRequestedTx xs - net <- asks (blockConfNet . myConfig) - let inv = if getSegWit net then InvWitnessTx else InvTx - vec = map (InvVector inv . getTxHash) xs - msg = MGetData (GetData vec) - msg `sendMessage` p - -touchPeer :: - ( MonadIO m - , MonadReader BlockStore m - ) => - m () -touchPeer = - getSyncingState >>= \case - Nothing -> return () - Just _ -> do - box <- asks myPeer - now <- liftIO getCurrentTime - atomically $ - modifyTVar box $ - fmap $ \x -> x{syncingTime = now} - -checkTime :: MonadLoggerIO m => BlockT m () -checkTime = - asks myPeer >>= readTVarIO >>= \case - Nothing -> return () - Just - Syncing - { syncingTime = t - , syncingPeer = p - } -> do - now <- liftIO getCurrentTime - peer_time_out <- asks (blockConfPeerTimeout . myConfig) - when (now `diffUTCTime` t > peer_time_out) $ do - $(logErrorS) "BlockStore" $ - "Syncing peer timeout: " <> peerText p - killPeer PeerTimeout p - -revertToMainChain :: MonadLoggerIO m => BlockT m () -revertToMainChain = do - h <- headerHash . nodeHeader <$> getBest - ch <- asks (blockConfChain . myConfig) - chainBlockMain h ch >>= \x -> unless x $ do - $(logWarnS) "BlockStore" $ - "Reverting best block: " - <> blockHashToHex h - runImport (revertBlock h) >>= \case - Left e -> do - $(logErrorS) "BlockStore" $ - "Could not revert block " - <> blockHashToHex h - <> ": " - <> cs (show e) - throwIO e - Right () -> setSyncingBlocks [] - revertToMainChain - -getBest :: MonadLoggerIO m => BlockT m BlockNode -getBest = do - bb <- - getBestBlock >>= \case - Just b -> return b - Nothing -> do - $(logErrorS) "BlockStore" "No best block set" - throwIO Uninitialized - ch <- asks (blockConfChain . myConfig) - chainGetBlock bb ch >>= \case - Just x -> return x - Nothing -> do - $(logErrorS) "BlockStore" $ - "Header not found for best block: " - <> blockHashToHex bb - throwIO (BlockNotInChain bb) - -getSyncBest :: MonadLoggerIO m => BlockT m BlockNode -getSyncBest = do - bb <- - getSyncingBlocks >>= \case - [] -> - getBestBlock >>= \case - Just b -> return b - Nothing -> do - $(logErrorS) "BlockStore" "No best block set" - throwIO Uninitialized - hs -> return $ last hs - ch <- asks (blockConfChain . myConfig) - chainGetBlock bb ch >>= \case - Just x -> return x - Nothing -> do - $(logErrorS) "BlockStore" $ - "Header not found for block: " - <> blockHashToHex bb - throwIO (BlockNotInChain bb) - -shouldSync :: MonadLoggerIO m => BlockT m (Maybe Peer) -shouldSync = - isInSync >>= \case - True -> return Nothing - False -> - getSyncingState >>= \case - Nothing -> return Nothing - Just Syncing{syncingPeer = p, syncingBlocks = bs} - | 100 > length bs -> return (Just p) - | otherwise -> return Nothing - -syncMe :: MonadLoggerIO m => BlockT m () -syncMe = do - revertToMainChain - shouldSync >>= \case - Nothing -> return () - Just p -> do - bb <- getSyncBest - bh <- getbh - when (bb /= bh) $ do - bns <- sel bb bh - iv <- getiv bns - $(logDebugS) "BlockStore" $ - "Requesting " - <> fromString (show (length iv)) - <> " blocks from peer: " - <> peerText p - addSyncingBlocks $ map (headerHash . nodeHeader) bns - MGetData (GetData iv) `sendMessage` p - where - getiv bns = do - w <- getSegWit <$> asks (blockConfNet . myConfig) - let i = if w then InvWitnessBlock else InvBlock - f = InvVector i . getBlockHash . headerHash . nodeHeader - return $ map f bns - getbh = - chainGetBest =<< asks (blockConfChain . myConfig) - sel bb bh = do - let sh = geth bb bh - t <- top sh bh - ch <- asks (blockConfChain . myConfig) - ps <- chainGetParents (nodeHeight bb + 1) t ch - return $ - if 500 > length ps - then ps <> [bh] - else ps - geth bb bh = - min - (nodeHeight bb + 501) - (nodeHeight bh) - top sh bh = - if sh == nodeHeight bh - then return bh - else findAncestor sh bh - -findAncestor :: - (MonadLoggerIO m, MonadReader BlockStore m) => - BlockHeight -> - BlockNode -> - m BlockNode -findAncestor height target = do - ch <- asks (blockConfChain . myConfig) - chainGetAncestor height target ch >>= \case - Just ancestor -> return ancestor - Nothing -> do - let h = headerHash $ nodeHeader target - $(logErrorS) "BlockStore" $ - "Could not find header for ancestor of block " - <> blockHashToHex h - <> " at height " - <> cs (show (nodeHeight target)) - throwIO $ AncestorNotInChain height h - -finishPeer :: - (MonadLoggerIO m, MonadReader BlockStore m) => - Peer -> - m () -finishPeer p = do - box <- asks myPeer - readTVarIO box >>= \case - Just Syncing{syncingPeer = p'} | p == p' -> reset_it box - _ -> return () - where - reset_it box = do - atomically $ writeTVar box Nothing - $(logDebugS) "BlockStore" $ "Releasing peer: " <> peerText p - setFree p - -trySetPeer :: MonadLoggerIO m => Peer -> BlockT m Bool -trySetPeer p = - getSyncingState >>= \case - Just _ -> return False - Nothing -> set_it - where - set_it = - setBusy p >>= \case - False -> return False - True -> do - $(logDebugS) "BlockStore" $ - "Locked peer: " <> peerText p - box <- asks myPeer - now <- liftIO getCurrentTime - atomically . writeTVar box $ - Just - Syncing - { syncingPeer = p - , syncingTime = now - , syncingBlocks = [] - } - return True - -trySyncing :: MonadLoggerIO m => BlockT m () -trySyncing = - isInSync >>= \case - True -> return () - False -> - getSyncingState >>= \case - Just _ -> return () - Nothing -> online_peer - where - recurse [] = return () - recurse (p : ps) = - trySetPeer p >>= \case - False -> recurse ps - True -> syncMe - online_peer = do - ops <- getPeers =<< asks (blockConfManager . myConfig) - let ps = map onlinePeerMailbox ops - recurse ps - -trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m () -trySyncingPeer p = - isInSync >>= \case - True -> mempool p - False -> - trySetPeer p >>= \case - False -> return () - True -> syncMe - -getSyncingState :: - (MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing) -getSyncingState = - readTVarIO =<< asks myPeer - -clearSyncingState :: - (MonadLoggerIO m, MonadReader BlockStore m) => m () -clearSyncingState = - asks myPeer >>= readTVarIO >>= \case - Nothing -> return () - Just Syncing{syncingPeer = p} -> finishPeer p - -processBlockStoreMessage :: - (MonadUnliftIO m, MonadLoggerIO m) => - BlockStoreMessage -> - BlockT m () -processBlockStoreMessage (BlockNewBest _) = - trySyncing -processBlockStoreMessage (BlockPeerConnect p) = - trySyncingPeer p -processBlockStoreMessage (BlockPeerDisconnect p) = - finishPeer p -processBlockStoreMessage (BlockReceived p b) = - processBlock p b -processBlockStoreMessage (BlockNotFound p bs) = - processNoBlocks p bs -processBlockStoreMessage (TxRefReceived p tx) = - processTx p tx -processBlockStoreMessage (TxRefAvailable p ts) = - processTxs p ts -processBlockStoreMessage (BlockPing r) = do - setStoreHeight - setHeadersHeight - setPendingTxs - setPeersConnected - setMempoolSize - trySyncing - processMempool - pruneOrphans - checkTime - atomically (r ()) - -pingMe :: MonadLoggerIO m => Mailbox BlockStoreMessage -> m () -pingMe mbox = - forever $ do - BlockPing `query` mbox - delay <- - liftIO $ - randomRIO - ( 100 * 1000 - , 1000 * 1000 - ) - threadDelay delay - -blockStorePeerConnect :: MonadIO m => Peer -> BlockStore -> m () -blockStorePeerConnect peer store = - BlockPeerConnect peer `send` myMailbox store - -blockStorePeerDisconnect :: - MonadIO m => Peer -> BlockStore -> m () -blockStorePeerDisconnect peer store = - BlockPeerDisconnect peer `send` myMailbox store - -blockStoreHead :: - MonadIO m => BlockNode -> BlockStore -> m () -blockStoreHead node store = - BlockNewBest node `send` myMailbox store - -blockStoreBlock :: - MonadIO m => Peer -> Block -> BlockStore -> m () -blockStoreBlock peer block store = - BlockReceived peer block `send` myMailbox store - -blockStoreNotFound :: - MonadIO m => Peer -> [BlockHash] -> BlockStore -> m () -blockStoreNotFound peer blocks store = - BlockNotFound peer blocks `send` myMailbox store - -blockStoreTx :: - MonadIO m => Peer -> Tx -> BlockStore -> m () -blockStoreTx peer tx store = - TxRefReceived peer tx `send` myMailbox store - -blockStoreTxHash :: - MonadIO m => Peer -> [TxHash] -> BlockStore -> m () -blockStoreTxHash peer txhashes store = - TxRefAvailable peer txhashes `send` myMailbox store - -blockStorePeerConnectSTM :: - Peer -> BlockStore -> STM () -blockStorePeerConnectSTM peer store = - BlockPeerConnect peer `sendSTM` myMailbox store - -blockStorePeerDisconnectSTM :: - Peer -> BlockStore -> STM () -blockStorePeerDisconnectSTM peer store = - BlockPeerDisconnect peer `sendSTM` myMailbox store - -blockStoreHeadSTM :: - BlockNode -> BlockStore -> STM () -blockStoreHeadSTM node store = - BlockNewBest node `sendSTM` myMailbox store - -blockStoreBlockSTM :: - Peer -> Block -> BlockStore -> STM () -blockStoreBlockSTM peer block store = - BlockReceived peer block `sendSTM` myMailbox store - -blockStoreNotFoundSTM :: - Peer -> [BlockHash] -> BlockStore -> STM () -blockStoreNotFoundSTM peer blocks store = - BlockNotFound peer blocks `sendSTM` myMailbox store - -blockStoreTxSTM :: - Peer -> Tx -> BlockStore -> STM () -blockStoreTxSTM peer tx store = - TxRefReceived peer tx `sendSTM` myMailbox store - -blockStoreTxHashSTM :: - Peer -> [TxHash] -> BlockStore -> STM () -blockStoreTxHashSTM peer txhashes store = - TxRefAvailable peer txhashes `sendSTM` myMailbox store - -blockStorePendingTxs :: - MonadIO m => BlockStore -> m Int -blockStorePendingTxs = - atomically . blockStorePendingTxsSTM - -blockStorePendingTxsSTM :: - BlockStore -> STM Int -blockStorePendingTxsSTM BlockStore{..} = do - x <- HashMap.keysSet <$> readTVar myTxs - y <- readTVar requested - return $ HashSet.size $ x `HashSet.union` y - -blockText :: BlockNode -> Maybe Block -> Text -blockText bn mblock = case mblock of - Nothing -> - height <> sep <> time <> sep <> hash - Just block -> - height <> sep <> time <> sep <> hash <> sep <> size block - where - height = cs $ show (nodeHeight bn) - systime = - posixSecondsToUTCTime $ - fromIntegral $ - blockTimestamp $ - nodeHeader bn - time = - cs $ - formatTime - defaultTimeLocale - (iso8601DateFormat (Just "%H:%M")) - systime +module Haskoin.Store.BlockStore + ( -- * Block Store + BlockStore, + BlockStoreConfig (..), + withBlockStore, + blockStorePeerConnect, + blockStorePeerConnectSTM, + blockStorePeerDisconnect, + blockStorePeerDisconnectSTM, + blockStoreHead, + blockStoreHeadSTM, + blockStoreBlock, + blockStoreBlockSTM, + blockStoreNotFound, + blockStoreNotFoundSTM, + blockStoreTx, + blockStoreTxSTM, + blockStoreTxHash, + blockStoreTxHashSTM, + blockStorePendingTxs, + blockStorePendingTxsSTM, + ) +where + +import Control.Monad + ( forM, + forM_, + forever, + mzero, + unless, + void, + when, + ) +import Control.Monad.Except + ( ExceptT (..), + MonadError, + catchError, + runExceptT, + ) +import Control.Monad.Logger + ( MonadLoggerIO, + logDebugS, + logErrorS, + logInfoS, + logWarnS, + ) +import Control.Monad.Reader + ( MonadReader, + ReaderT (..), + ask, + asks, + ) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.ByteString as B +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.List (delete) +import Data.Maybe + ( catMaybes, + fromJust, + isJust, + mapMaybe, + ) +import Data.Serialize (encode) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time.Clock + ( NominalDiffTime, + UTCTime, + diffUTCTime, + getCurrentTime, + ) +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.Format + ( defaultTimeLocale, + formatTime, + iso8601DateFormat, + ) +import Haskoin + ( Block (..), + BlockHash (..), + BlockHeader (..), + BlockHeight, + BlockNode (..), + GetData (..), + InvType (..), + InvVector (..), + Message (..), + Network (..), + OutPoint (..), + Tx (..), + TxHash (..), + TxIn (..), + blockHashToHex, + headerHash, + txHash, + txHashToHex, + ) +import Haskoin.Node + ( Chain, + OnlinePeer (..), + Peer, + PeerException (..), + PeerManager, + chainBlockMain, + chainGetAncestor, + chainGetBest, + chainGetBlock, + chainGetParents, + getPeers, + killPeer, + peerText, + sendMessage, + setBusy, + setFree, + ) +import Haskoin.Store.Common +import Haskoin.Store.Data +import Haskoin.Store.Database.Reader +import Haskoin.Store.Database.Writer +import Haskoin.Store.Logic + ( ImportException (Orphan), + deleteUnconfirmedTx, + importBlock, + initBest, + newMempoolTx, + revertBlock, + ) +import Haskoin.Store.Stats +import NQE + ( Listen, + Mailbox, + Publisher, + inboxToMailbox, + newInbox, + publish, + query, + receive, + send, + sendSTM, + ) +import qualified System.Metrics as Metrics +import qualified System.Metrics.Gauge as Metrics (Gauge) +import qualified System.Metrics.Gauge as Metrics.Gauge +import System.Random (randomRIO) +import UnliftIO + ( Exception, + MonadIO, + MonadUnliftIO, + STM, + TVar, + async, + atomically, + liftIO, + link, + modifyTVar, + newTVarIO, + readTVar, + readTVarIO, + throwIO, + withAsync, + writeTVar, + ) +import UnliftIO.Concurrent (threadDelay) + +data BlockStoreMessage + = BlockNewBest !BlockNode + | BlockPeerConnect !Peer + | BlockPeerDisconnect !Peer + | BlockReceived !Peer !Block + | BlockNotFound !Peer ![BlockHash] + | TxRefReceived !Peer !Tx + | TxRefAvailable !Peer ![TxHash] + | BlockPing !(Listen ()) + +data BlockException + = BlockNotInChain !BlockHash + | Uninitialized + | CorruptDatabase + | AncestorNotInChain !BlockHeight !BlockHash + | MempoolImportFailed + deriving (Show, Eq, Ord, Exception) + +data Syncing = Syncing + { syncingPeer :: !Peer, + syncingTime :: !UTCTime, + syncingBlocks :: ![BlockHash] + } + +data PendingTx = PendingTx + { pendingTxTime :: !UTCTime, + pendingTx :: !Tx, + pendingDeps :: !(HashSet TxHash) + } + deriving (Show, Eq, Ord) + +-- | Block store process state. +data BlockStore = BlockStore + { myMailbox :: !(Mailbox BlockStoreMessage), + myConfig :: !BlockStoreConfig, + myPeer :: !(TVar (Maybe Syncing)), + myTxs :: !(TVar (HashMap TxHash PendingTx)), + requested :: !(TVar (HashSet TxHash)), + myMetrics :: !(Maybe StoreMetrics) + } + +data StoreMetrics = StoreMetrics + { storeHeight :: !Metrics.Gauge, + headersHeight :: !Metrics.Gauge, + storePendingTxs :: !Metrics.Gauge, + storePeersConnected :: !Metrics.Gauge, + storeMempoolSize :: !Metrics.Gauge + } + +newStoreMetrics :: MonadIO m => Metrics.Store -> m StoreMetrics +newStoreMetrics s = liftIO $ do + storeHeight <- g "blockchain.height" + headersHeight <- g "blockchain.headers" + storePendingTxs <- g "mempool.pending_txs" + storePeersConnected <- g "network.peers_connected" + storeMempoolSize <- g "mempool.size" + return StoreMetrics {..} + where + g x = Metrics.createGauge ("store." <> x) s + +setStoreHeight :: MonadIO m => BlockT m () +setStoreHeight = + asks myMetrics >>= \case + Nothing -> return () + Just m -> + getBestBlock >>= \case + Nothing -> setit m 0 + Just bb -> + getBlock bb >>= \case + Nothing -> setit m 0 + Just b -> setit m (blockDataHeight b) + where + setit m i = liftIO $ storeHeight m `Metrics.Gauge.set` fromIntegral i + +setHeadersHeight :: MonadIO m => BlockT m () +setHeadersHeight = + asks myMetrics >>= \case + Nothing -> return () + Just m -> do + h <- fmap nodeHeight $ chainGetBest =<< asks (blockConfChain . myConfig) + liftIO $ headersHeight m `Metrics.Gauge.set` fromIntegral h + +setPendingTxs :: MonadIO m => BlockT m () +setPendingTxs = + asks myMetrics >>= \case + Nothing -> return () + Just m -> do + s <- asks myTxs >>= \t -> atomically (HashMap.size <$> readTVar t) + liftIO $ storePendingTxs m `Metrics.Gauge.set` fromIntegral s + +setPeersConnected :: MonadIO m => BlockT m () +setPeersConnected = + asks myMetrics >>= \case + Nothing -> return () + Just m -> do + ps <- fmap length $ getPeers =<< asks (blockConfManager . myConfig) + liftIO $ storePeersConnected m `Metrics.Gauge.set` fromIntegral ps + +setMempoolSize :: MonadIO m => BlockT m () +setMempoolSize = + asks myMetrics >>= \case + Nothing -> return () + Just m -> do + s <- length <$> getMempool + liftIO $ storeMempoolSize m `Metrics.Gauge.set` fromIntegral s + +-- | Configuration for a block store. +data BlockStoreConfig = BlockStoreConfig + { -- | peer manager from running node + blockConfManager :: !PeerManager, + -- | chain from a running node + blockConfChain :: !Chain, + -- | listener for store events + blockConfListener :: !(Publisher StoreEvent), + -- | RocksDB database handle + blockConfDB :: !DatabaseReader, + -- | network constants + blockConfNet :: !Network, + -- | do not index new mempool transactions + blockConfNoMempool :: !Bool, + -- | wipe mempool at start + blockConfWipeMempool :: !Bool, + -- | sync mempool from peers + blockConfSyncMempool :: !Bool, + -- | disconnect syncing peer if inactive for this long + blockConfPeerTimeout :: !NominalDiffTime, + blockConfStats :: !(Maybe Metrics.Store) + } + +type BlockT m = ReaderT BlockStore m + +runImport :: + MonadLoggerIO m => + WriterT (ExceptT ImportException m) a -> + BlockT m (Either ImportException a) +runImport f = + ReaderT $ \r -> runExceptT $ runWriter (blockConfDB (myConfig r)) f + +runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a +runRocksDB f = + ReaderT $ runReaderT f . blockConfDB . myConfig + +instance MonadIO m => StoreReadBase (BlockT m) where + getNetwork = + runRocksDB getNetwork + getBestBlock = + runRocksDB getBestBlock + getBlocksAtHeight = + runRocksDB . getBlocksAtHeight + getBlock = + runRocksDB . getBlock + getTxData = + runRocksDB . getTxData + getSpender = + runRocksDB . getSpender + getUnspent = + runRocksDB . getUnspent + getBalance = + runRocksDB . getBalance + getMempool = + runRocksDB getMempool + +instance MonadUnliftIO m => StoreReadExtra (BlockT m) where + getMaxGap = + runRocksDB getMaxGap + getInitialGap = + runRocksDB getInitialGap + getAddressesTxs as = + runRocksDB . getAddressesTxs as + getAddressesUnspents as = + runRocksDB . getAddressesUnspents as + getAddressUnspents a = + runRocksDB . getAddressUnspents a + getAddressTxs a = + runRocksDB . getAddressTxs a + getNumTxData = + runRocksDB . getNumTxData + getBalances = + runRocksDB . getBalances + xPubBals = + runRocksDB . xPubBals + xPubUnspents x l = + runRocksDB . xPubUnspents x l + xPubTxs x l = + runRocksDB . xPubTxs x l + xPubTxCount x = + runRocksDB . xPubTxCount x + +-- | Run block store process. +withBlockStore :: + (MonadUnliftIO m, MonadLoggerIO m) => + BlockStoreConfig -> + (BlockStore -> m a) -> + m a +withBlockStore cfg action = do + pb <- newTVarIO Nothing + ts <- newTVarIO HashMap.empty + rq <- newTVarIO HashSet.empty + inbox <- newInbox + metrics <- mapM newStoreMetrics (blockConfStats cfg) + let r = + BlockStore + { myMailbox = inboxToMailbox inbox, + myConfig = cfg, + myPeer = pb, + myTxs = ts, + requested = rq, + myMetrics = metrics + } + withAsync (runReaderT (go inbox) r) $ \a -> do + link a + action r + where + go inbox = do + ini + wipe + run inbox + del txs = do + $(logInfoS) "BlockStore" $ + "Deleting " <> cs (show (length txs)) <> " transactions" + forM_ txs $ \(_, th) -> deleteUnconfirmedTx False th + wipe_it txs = do + let (txs1, txs2) = splitAt 1000 txs + unless (null txs1) $ + runImport (del txs1) >>= \case + Left e -> do + $(logErrorS) "BlockStore" $ + "Could not wipe mempool: " <> cs (show e) + throwIO e + Right () -> wipe_it txs2 + wipe + | blockConfWipeMempool cfg = + getMempool >>= wipe_it + | otherwise = + return () + ini = + runImport initBest >>= \case + Left e -> do + $(logErrorS) "BlockStore" $ + "Could not initialize: " <> cs (show e) + throwIO e + Right () -> return () + run inbox = + withAsync (pingMe (inboxToMailbox inbox)) $ + const $ + forever $ + receive inbox + >>= ReaderT . runReaderT . processBlockStoreMessage + +isInSync :: MonadLoggerIO m => BlockT m Bool +isInSync = + getBestBlock >>= \case + Nothing -> do + $(logErrorS) "BlockStore" "Block database uninitialized" + throwIO Uninitialized + Just bb -> do + cb <- asks (blockConfChain . myConfig) >>= chainGetBest + if headerHash (nodeHeader cb) == bb + then clearSyncingState >> return True + else return False + +guardMempool :: Monad m => BlockT m () -> BlockT m () +guardMempool f = do + n <- asks (blockConfNoMempool . myConfig) + unless n f + +syncMempool :: Monad m => BlockT m () -> BlockT m () +syncMempool f = do + s <- asks (blockConfSyncMempool . myConfig) + when s f + +mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m () +mempool p = guardMempool $ + syncMempool $ + void $ + async $ do + isInSync >>= \s -> when s $ do + $(logDebugS) "BlockStore" $ + "Requesting mempool from peer: " <> peerText p + MMempool `sendMessage` p + +processBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => + Peer -> + Block -> + BlockT m () +processBlock peer block = void . runMaybeT $ do + checkPeer peer >>= \case + True -> return () + False -> do + $(logErrorS) "BlockStore" $ + "Non-syncing peer " <> peerText peer + <> " sent me a block: " + <> blockHashToHex blockhash + PeerMisbehaving "Sent unexpected block" `killPeer` peer + mzero + node <- + getBlockNode blockhash >>= \case + Just b -> return b + Nothing -> do + $(logErrorS) "BlockStore" $ + "Peer " <> peerText peer + <> " sent unknown block: " + <> blockHashToHex blockhash + PeerMisbehaving "Sent unknown block" `killPeer` peer + mzero + $(logDebugS) "BlockStore" $ + "Processing block: " <> blockText node Nothing + <> " from peer: " + <> peerText peer + lift . notify (Just block) $ + runImport (importBlock block node) >>= \case + Left e -> failure e + Right () -> success node + where + header = blockHeader block + blockhash = headerHash header + hexhash = blockHashToHex blockhash + success node = do + $(logInfoS) "BlockStore" $ + "Best block: " <> blockText node (Just block) + removeSyncingBlock $ headerHash $ nodeHeader node + touchPeer + isInSync >>= \case + False -> syncMe + True -> do + updateOrphans + mempool peer + failure e = do + $(logErrorS) "BlockStore" $ + "Error importing block " <> hexhash + <> " from peer: " + <> peerText peer + <> ": " + <> cs (show e) + killPeer (PeerMisbehaving (show e)) peer + +setSyncingBlocks :: + (MonadReader BlockStore m, MonadIO m) => + [BlockHash] -> + m () +setSyncingBlocks hs = + asks myPeer >>= \box -> + atomically $ + modifyTVar box $ \case + Nothing -> Nothing + Just x -> Just x {syncingBlocks = hs} + +getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash] +getSyncingBlocks = + asks myPeer >>= readTVarIO >>= \case + Nothing -> return [] + Just x -> return $ syncingBlocks x + +addSyncingBlocks :: + (MonadReader BlockStore m, MonadIO m) => + [BlockHash] -> + m () +addSyncingBlocks hs = + asks myPeer >>= \box -> + atomically $ + modifyTVar box $ \case + Nothing -> Nothing + Just x -> Just x {syncingBlocks = syncingBlocks x <> hs} + +removeSyncingBlock :: + (MonadReader BlockStore m, MonadIO m) => + BlockHash -> + m () +removeSyncingBlock h = do + box <- asks myPeer + atomically $ + modifyTVar box $ \case + Nothing -> Nothing + Just x -> Just x {syncingBlocks = delete h (syncingBlocks x)} + +checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool +checkPeer p = + fmap syncingPeer <$> getSyncingState >>= \case + Nothing -> return False + Just p' -> return $ p == p' + +getBlockNode :: + (MonadLoggerIO m, MonadReader BlockStore m) => + BlockHash -> + m (Maybe BlockNode) +getBlockNode blockhash = + chainGetBlock blockhash =<< asks (blockConfChain . myConfig) + +processNoBlocks :: + MonadLoggerIO m => + Peer -> + [BlockHash] -> + BlockT m () +processNoBlocks p hs = do + forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) -> + $(logErrorS) "BlockStore" $ + "Block " + <> cs (show i) + <> "/" + <> cs (show (length hs)) + <> " " + <> blockHashToHex h + <> " not found by peer: " + <> peerText p + killPeer (PeerMisbehaving "Did not find requested block(s)") p + +processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m () +processTx p tx = guardMempool $ do + t <- liftIO getCurrentTime + $(logDebugS) "BlockManager" $ + "Received tx " <> txHashToHex (txHash tx) + <> " by peer: " + <> peerText p + addPendingTx $ PendingTx t tx HashSet.empty + +pruneOrphans :: MonadIO m => BlockT m () +pruneOrphans = guardMempool $ do + ts <- asks myTxs + now <- liftIO getCurrentTime + atomically . modifyTVar ts . HashMap.filter $ \p -> + now `diffUTCTime` pendingTxTime p > 600 + +addPendingTx :: MonadIO m => PendingTx -> BlockT m () +addPendingTx p = do + ts <- asks myTxs + rq <- asks requested + atomically $ do + modifyTVar ts $ HashMap.insert th p + modifyTVar rq $ HashSet.delete th + HashMap.size <$> readTVar ts + setPendingTxs + where + th = txHash (pendingTx p) + +addRequestedTx :: MonadIO m => TxHash -> BlockT m () +addRequestedTx th = do + qbox <- asks requested + atomically $ modifyTVar qbox $ HashSet.insert th + liftIO $ + void $ + async $ do + threadDelay 20000000 + atomically $ modifyTVar qbox $ HashSet.delete th + +isPending :: MonadIO m => TxHash -> BlockT m Bool +isPending th = do + tbox <- asks myTxs + qbox <- asks requested + atomically $ do + ts <- readTVar tbox + rs <- readTVar qbox + return $ + th `HashMap.member` ts + || th `HashSet.member` rs + +pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx] +pendingTxs i = do + selected <- + asks myTxs >>= \box -> atomically $ do + pending <- readTVar box + let (selected, rest) = select pending + writeTVar box rest + return (selected) + setPendingTxs + return selected + where + select pend = + let eligible = HashMap.filter (null . pendingDeps) pend + orphans = HashMap.difference pend eligible + selected = take i $ sortit eligible + remaining = HashMap.filter (`notElem` selected) eligible + in (selected, remaining <> orphans) + sortit m = + let sorted = sortTxs $ map pendingTx $ HashMap.elems m + txids = map (txHash . snd) sorted + in mapMaybe (`HashMap.lookup` m) txids + +fulfillOrphans :: MonadIO m => BlockStore -> TxHash -> m () +fulfillOrphans block_read th = + atomically $ modifyTVar box (HashMap.map fulfill) + where + box = myTxs block_read + fulfill p = p {pendingDeps = HashSet.delete th (pendingDeps p)} + +updateOrphans :: + ( StoreReadBase m, + MonadLoggerIO m, + MonadReader BlockStore m + ) => + m () +updateOrphans = do + box <- asks myTxs + pending <- readTVarIO box + let orphans = HashMap.filter (not . null . pendingDeps) pending + updated <- forM orphans $ \p -> do + let tx = pendingTx p + exists (txHash tx) >>= \case + True -> return Nothing + False -> Just <$> fill_deps p + let pruned = HashMap.map fromJust $ HashMap.filter isJust updated + atomically $ writeTVar box pruned + where + exists th = + getTxData th >>= \case + Nothing -> return False + Just TxData {txDataDeleted = True} -> return False + Just TxData {txDataDeleted = False} -> return True + prev_utxos tx = catMaybes <$> mapM (getUnspent . prevOutput) (txIn tx) + fulfill p unspent = + let unspent_hash = outPointHash (unspentPoint unspent) + new_deps = HashSet.delete unspent_hash (pendingDeps p) + in p {pendingDeps = new_deps} + fill_deps p = do + let tx = pendingTx p + unspents <- prev_utxos tx + return $ foldl fulfill p unspents + +newOrphanTx :: + MonadLoggerIO m => + BlockStore -> + UTCTime -> + Tx -> + WriterT m () +newOrphanTx block_read time tx = do + $(logDebugS) "BlockStore" $ + "Import tx " + <> txHashToHex (txHash tx) + <> ": Orphan" + let box = myTxs block_read + unspents <- catMaybes <$> mapM getUnspent prevs + let unspent_set = HashSet.fromList (map unspentPoint unspents) + missing_set = HashSet.difference prev_set unspent_set + missing_txs = HashSet.map outPointHash missing_set + atomically . modifyTVar box $ + HashMap.insert + (txHash tx) + PendingTx + { pendingTxTime = time, + pendingTx = tx, + pendingDeps = missing_txs + } + where + prev_set = HashSet.fromList prevs + prevs = map prevOutput (txIn tx) + +importMempoolTx :: + (MonadLoggerIO m, MonadError ImportException m) => + BlockStore -> + UTCTime -> + Tx -> + WriterT m Bool +importMempoolTx block_read time tx = + catchError new_mempool_tx handle_error + where + tx_hash = txHash tx + handle_error Orphan = do + newOrphanTx block_read time tx + return False + handle_error _ = return False + seconds = floor (utcTimeToPOSIXSeconds time) + new_mempool_tx = + newMempoolTx tx seconds >>= \case + True -> do + $(logInfoS) "BlockStore" $ + "Import tx " <> txHashToHex (txHash tx) + <> ": OK" + fulfillOrphans block_read tx_hash + return True + False -> do + $(logDebugS) "BlockStore" $ + "Import tx " <> txHashToHex (txHash tx) + <> ": Already imported" + return False + +notify :: MonadIO m => Maybe Block -> BlockT m a -> BlockT m a +notify block go = do + old <- HashSet.union e . HashSet.fromList . map snd <$> getMempool + x <- go + new <- HashSet.fromList . map snd <$> getMempool + l <- asks (blockConfListener . myConfig) + forM_ (old `HashSet.difference` new) $ \h -> + publish (StoreMempoolDelete h) l + forM_ (new `HashSet.difference` old) $ \h -> + publish (StoreMempoolNew h) l + case block of + Just b -> publish (StoreBestBlock (headerHash (blockHeader b))) l + Nothing -> return () + return x + where + e = case block of + Just b -> HashSet.fromList (map txHash (blockTxns b)) + Nothing -> HashSet.empty + +processMempool :: MonadLoggerIO m => BlockT m () +processMempool = guardMempool . notify Nothing $ do + txs <- pendingTxs 2000 + block_read <- ask + unless (null txs) (import_txs block_read txs) + where + run_import block_read p = + let t = pendingTx p + h = txHash t + in importMempoolTx block_read (pendingTxTime p) (pendingTx p) + import_txs block_read txs = + let r = mapM (run_import block_read) txs + in runImport r >>= \case + Left e -> report_error e + Right _ -> return () + report_error e = do + $(logErrorS) "BlockImport" $ + "Error processing mempool: " <> cs (show e) + throwIO e + +processTxs :: + MonadLoggerIO m => + Peer -> + [TxHash] -> + BlockT m () +processTxs p hs = guardMempool $ do + s <- isInSync + when s $ do + $(logDebugS) "BlockStore" $ + "Received inventory with " + <> cs (show (length hs)) + <> " transactions from peer: " + <> peerText p + xs <- catMaybes <$> zip_counter process_tx + unless (null xs) $ go xs + where + len = length hs + zip_counter = forM (zip [(1 :: Int) ..] hs) . uncurry + process_tx i h = + isPending h >>= \case + True -> do + $(logDebugS) "BlockStore" $ + "Tx " <> cs (show i) <> "/" <> cs (show len) + <> " " + <> txHashToHex h + <> ": " + <> "Pending" + return Nothing + False -> + getActiveTxData h >>= \case + Just _ -> do + $(logDebugS) "BlockStore" $ + "Tx " <> cs (show i) <> "/" <> cs (show len) + <> " " + <> txHashToHex h + <> ": " + <> "Already Imported" + return Nothing + Nothing -> do + $(logDebugS) "BlockStore" $ + "Tx " <> cs (show i) <> "/" <> cs (show len) + <> " " + <> txHashToHex h + <> ": " + <> "Requesting" + return (Just h) + go xs = do + mapM_ addRequestedTx xs + net <- asks (blockConfNet . myConfig) + let inv = if getSegWit net then InvWitnessTx else InvTx + vec = map (InvVector inv . getTxHash) xs + msg = MGetData (GetData vec) + msg `sendMessage` p + +touchPeer :: + ( MonadIO m, + MonadReader BlockStore m + ) => + m () +touchPeer = + getSyncingState >>= \case + Nothing -> return () + Just _ -> do + box <- asks myPeer + now <- liftIO getCurrentTime + atomically $ + modifyTVar box $ + fmap $ \x -> x {syncingTime = now} + +checkTime :: MonadLoggerIO m => BlockT m () +checkTime = + asks myPeer >>= readTVarIO >>= \case + Nothing -> return () + Just + Syncing + { syncingTime = t, + syncingPeer = p + } -> do + now <- liftIO getCurrentTime + peer_time_out <- asks (blockConfPeerTimeout . myConfig) + when (now `diffUTCTime` t > peer_time_out) $ do + $(logErrorS) "BlockStore" $ + "Syncing peer timeout: " <> peerText p + killPeer PeerTimeout p + +revertToMainChain :: MonadLoggerIO m => BlockT m () +revertToMainChain = do + h <- headerHash . nodeHeader <$> getBest + ch <- asks (blockConfChain . myConfig) + chainBlockMain h ch >>= \x -> unless x $ do + $(logWarnS) "BlockStore" $ + "Reverting best block: " + <> blockHashToHex h + runImport (revertBlock h) >>= \case + Left e -> do + $(logErrorS) "BlockStore" $ + "Could not revert block " + <> blockHashToHex h + <> ": " + <> cs (show e) + throwIO e + Right () -> setSyncingBlocks [] + revertToMainChain + +getBest :: MonadLoggerIO m => BlockT m BlockNode +getBest = do + bb <- + getBestBlock >>= \case + Just b -> return b + Nothing -> do + $(logErrorS) "BlockStore" "No best block set" + throwIO Uninitialized + ch <- asks (blockConfChain . myConfig) + chainGetBlock bb ch >>= \case + Just x -> return x + Nothing -> do + $(logErrorS) "BlockStore" $ + "Header not found for best block: " + <> blockHashToHex bb + throwIO (BlockNotInChain bb) + +getSyncBest :: MonadLoggerIO m => BlockT m BlockNode +getSyncBest = do + bb <- + getSyncingBlocks >>= \case + [] -> + getBestBlock >>= \case + Just b -> return b + Nothing -> do + $(logErrorS) "BlockStore" "No best block set" + throwIO Uninitialized + hs -> return $ last hs + ch <- asks (blockConfChain . myConfig) + chainGetBlock bb ch >>= \case + Just x -> return x + Nothing -> do + $(logErrorS) "BlockStore" $ + "Header not found for block: " + <> blockHashToHex bb + throwIO (BlockNotInChain bb) + +shouldSync :: MonadLoggerIO m => BlockT m (Maybe Peer) +shouldSync = + isInSync >>= \case + True -> return Nothing + False -> + getSyncingState >>= \case + Nothing -> return Nothing + Just Syncing {syncingPeer = p, syncingBlocks = bs} + | 100 > length bs -> return (Just p) + | otherwise -> return Nothing + +syncMe :: MonadLoggerIO m => BlockT m () +syncMe = do + revertToMainChain + shouldSync >>= \case + Nothing -> return () + Just p -> do + bb <- getSyncBest + bh <- getbh + when (bb /= bh) $ do + bns <- sel bb bh + iv <- getiv bns + $(logDebugS) "BlockStore" $ + "Requesting " + <> fromString (show (length iv)) + <> " blocks from peer: " + <> peerText p + addSyncingBlocks $ map (headerHash . nodeHeader) bns + MGetData (GetData iv) `sendMessage` p + where + getiv bns = do + w <- getSegWit <$> asks (blockConfNet . myConfig) + let i = if w then InvWitnessBlock else InvBlock + f = InvVector i . getBlockHash . headerHash . nodeHeader + return $ map f bns + getbh = + chainGetBest =<< asks (blockConfChain . myConfig) + sel bb bh = do + let sh = geth bb bh + t <- top sh bh + ch <- asks (blockConfChain . myConfig) + ps <- chainGetParents (nodeHeight bb + 1) t ch + return $ + if 500 > length ps + then ps <> [bh] + else ps + geth bb bh = + min + (nodeHeight bb + 501) + (nodeHeight bh) + top sh bh = + if sh == nodeHeight bh + then return bh + else findAncestor sh bh + +findAncestor :: + (MonadLoggerIO m, MonadReader BlockStore m) => + BlockHeight -> + BlockNode -> + m BlockNode +findAncestor height target = do + ch <- asks (blockConfChain . myConfig) + chainGetAncestor height target ch >>= \case + Just ancestor -> return ancestor + Nothing -> do + let h = headerHash $ nodeHeader target + $(logErrorS) "BlockStore" $ + "Could not find header for ancestor of block " + <> blockHashToHex h + <> " at height " + <> cs (show (nodeHeight target)) + throwIO $ AncestorNotInChain height h + +finishPeer :: + (MonadLoggerIO m, MonadReader BlockStore m) => + Peer -> + m () +finishPeer p = do + box <- asks myPeer + readTVarIO box >>= \case + Just Syncing {syncingPeer = p'} | p == p' -> reset_it box + _ -> return () + where + reset_it box = do + atomically $ writeTVar box Nothing + $(logDebugS) "BlockStore" $ "Releasing peer: " <> peerText p + setFree p + +trySetPeer :: MonadLoggerIO m => Peer -> BlockT m Bool +trySetPeer p = + getSyncingState >>= \case + Just _ -> return False + Nothing -> set_it + where + set_it = + setBusy p >>= \case + False -> return False + True -> do + $(logDebugS) "BlockStore" $ + "Locked peer: " <> peerText p + box <- asks myPeer + now <- liftIO getCurrentTime + atomically . writeTVar box $ + Just + Syncing + { syncingPeer = p, + syncingTime = now, + syncingBlocks = [] + } + return True + +trySyncing :: MonadLoggerIO m => BlockT m () +trySyncing = + isInSync >>= \case + True -> return () + False -> + getSyncingState >>= \case + Just _ -> return () + Nothing -> online_peer + where + recurse [] = return () + recurse (p : ps) = + trySetPeer p >>= \case + False -> recurse ps + True -> syncMe + online_peer = do + ops <- getPeers =<< asks (blockConfManager . myConfig) + let ps = map onlinePeerMailbox ops + recurse ps + +trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m () +trySyncingPeer p = + isInSync >>= \case + True -> mempool p + False -> + trySetPeer p >>= \case + False -> return () + True -> syncMe + +getSyncingState :: + (MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing) +getSyncingState = + readTVarIO =<< asks myPeer + +clearSyncingState :: + (MonadLoggerIO m, MonadReader BlockStore m) => m () +clearSyncingState = + asks myPeer >>= readTVarIO >>= \case + Nothing -> return () + Just Syncing {syncingPeer = p} -> finishPeer p + +processBlockStoreMessage :: + (MonadUnliftIO m, MonadLoggerIO m) => + BlockStoreMessage -> + BlockT m () +processBlockStoreMessage (BlockNewBest _) = + trySyncing +processBlockStoreMessage (BlockPeerConnect p) = + trySyncingPeer p +processBlockStoreMessage (BlockPeerDisconnect p) = + finishPeer p +processBlockStoreMessage (BlockReceived p b) = + processBlock p b +processBlockStoreMessage (BlockNotFound p bs) = + processNoBlocks p bs +processBlockStoreMessage (TxRefReceived p tx) = + processTx p tx +processBlockStoreMessage (TxRefAvailable p ts) = + processTxs p ts +processBlockStoreMessage (BlockPing r) = do + setStoreHeight + setHeadersHeight + setPendingTxs + setPeersConnected + setMempoolSize + trySyncing + processMempool + pruneOrphans + checkTime + atomically (r ()) + +pingMe :: MonadLoggerIO m => Mailbox BlockStoreMessage -> m () +pingMe mbox = + forever $ do + BlockPing `query` mbox + delay <- + liftIO $ + randomRIO + ( 100 * 1000, + 1000 * 1000 + ) + threadDelay delay + +blockStorePeerConnect :: MonadIO m => Peer -> BlockStore -> m () +blockStorePeerConnect peer store = + BlockPeerConnect peer `send` myMailbox store + +blockStorePeerDisconnect :: + MonadIO m => Peer -> BlockStore -> m () +blockStorePeerDisconnect peer store = + BlockPeerDisconnect peer `send` myMailbox store + +blockStoreHead :: + MonadIO m => BlockNode -> BlockStore -> m () +blockStoreHead node store = + BlockNewBest node `send` myMailbox store + +blockStoreBlock :: + MonadIO m => Peer -> Block -> BlockStore -> m () +blockStoreBlock peer block store = + BlockReceived peer block `send` myMailbox store + +blockStoreNotFound :: + MonadIO m => Peer -> [BlockHash] -> BlockStore -> m () +blockStoreNotFound peer blocks store = + BlockNotFound peer blocks `send` myMailbox store + +blockStoreTx :: + MonadIO m => Peer -> Tx -> BlockStore -> m () +blockStoreTx peer tx store = + TxRefReceived peer tx `send` myMailbox store + +blockStoreTxHash :: + MonadIO m => Peer -> [TxHash] -> BlockStore -> m () +blockStoreTxHash peer txhashes store = + TxRefAvailable peer txhashes `send` myMailbox store + +blockStorePeerConnectSTM :: + Peer -> BlockStore -> STM () +blockStorePeerConnectSTM peer store = + BlockPeerConnect peer `sendSTM` myMailbox store + +blockStorePeerDisconnectSTM :: + Peer -> BlockStore -> STM () +blockStorePeerDisconnectSTM peer store = + BlockPeerDisconnect peer `sendSTM` myMailbox store + +blockStoreHeadSTM :: + BlockNode -> BlockStore -> STM () +blockStoreHeadSTM node store = + BlockNewBest node `sendSTM` myMailbox store + +blockStoreBlockSTM :: + Peer -> Block -> BlockStore -> STM () +blockStoreBlockSTM peer block store = + BlockReceived peer block `sendSTM` myMailbox store + +blockStoreNotFoundSTM :: + Peer -> [BlockHash] -> BlockStore -> STM () +blockStoreNotFoundSTM peer blocks store = + BlockNotFound peer blocks `sendSTM` myMailbox store + +blockStoreTxSTM :: + Peer -> Tx -> BlockStore -> STM () +blockStoreTxSTM peer tx store = + TxRefReceived peer tx `sendSTM` myMailbox store + +blockStoreTxHashSTM :: + Peer -> [TxHash] -> BlockStore -> STM () +blockStoreTxHashSTM peer txhashes store = + TxRefAvailable peer txhashes `sendSTM` myMailbox store + +blockStorePendingTxs :: + MonadIO m => BlockStore -> m Int +blockStorePendingTxs = + atomically . blockStorePendingTxsSTM + +blockStorePendingTxsSTM :: + BlockStore -> STM Int +blockStorePendingTxsSTM BlockStore {..} = do + x <- HashMap.keysSet <$> readTVar myTxs + y <- readTVar requested + return $ HashSet.size $ x `HashSet.union` y + +blockText :: BlockNode -> Maybe Block -> Text +blockText bn mblock = case mblock of + Nothing -> + height <> sep <> time <> sep <> hash + Just block -> + height <> sep <> time <> sep <> hash <> sep <> size block + where + height = cs $ show (nodeHeight bn) + systime = + posixSecondsToUTCTime $ + fromIntegral $ + blockTimestamp $ + nodeHeader bn + time = + cs $ + formatTime + defaultTimeLocale + (iso8601DateFormat (Just "%H:%M")) + systime hash = blockHashToHex (headerHash (nodeHeader bn)) sep = " | " size = (<> " bytes") . cs . show . B.length . encode 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 @@ -11,1495 +11,1498 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.Cache ( - CacheConfig (..), - CacheMetrics, - CacheT, - CacheError (..), - newCacheMetrics, - withCache, - connectRedis, - blockRefScore, - scoreBlockRef, - CacheWriter, - CacheWriterInbox, - cacheNewBlock, - cacheNewTx, - cacheWriter, - cacheDelXPubs, - isInCache, -) where - -import Control.DeepSeq (NFData) -import Control.Monad (forM, forM_, forever, guard, unless, void, when, (>=>)) -import Control.Monad.Logger ( - MonadLoggerIO, - logDebugS, - logErrorS, - logInfoS, - logWarnS, - ) -import Control.Monad.Reader (ReaderT (..), ask, asks) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Bits (complement, shift, (.&.), (.|.)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Default (def) -import Data.Either (fromRight, isRight, rights) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import qualified Data.IntMap.Strict as I -import Data.List (sort) -import qualified Data.Map.Strict as Map -import Data.Maybe ( - catMaybes, - fromMaybe, - isJust, - isNothing, - mapMaybe, - ) -import Data.Serialize (Serialize, decode, encode) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Time.Clock (NominalDiffTime, diffUTCTime) -import Data.Time.Clock.System ( - getSystemTime, - systemSeconds, - systemToUTCTime, - ) -import Data.Word (Word32, Word64) -import Database.Redis ( - Connection, - Redis, - RedisCtx, - Reply, - checkedConnect, - defaultConnectInfo, - hgetall, - parseConnectInfo, - zadd, - zrangeWithscores, - zrangebyscoreWithscoresLimit, - zrem, - ) -import qualified Database.Redis as Redis -import GHC.Generics (Generic) -import Haskoin ( - Address, - BlockHash, - BlockHeader (..), - BlockNode (..), - DerivPathI (..), - KeyIndex, - OutPoint (..), - Tx (..), - TxHash, - TxIn (..), - TxOut (..), - XPubKey, - blockHashToHex, - derivePubPath, - eitherToMaybe, - headerHash, - pathToList, - scriptToAddressBS, - txHash, - txHashToHex, - xPubAddr, - xPubCompatWitnessAddr, - xPubExport, - xPubWitnessAddr, - ) -import Haskoin.Node ( - Chain, - chainBlockMain, - chainGetAncestor, - chainGetBest, - chainGetBlock, - ) -import Haskoin.Store.Common -import Haskoin.Store.Data -import Haskoin.Store.Stats -import NQE ( - Inbox, - Listen, - Mailbox, - inboxToMailbox, - query, - receive, - send, - ) -import qualified System.Metrics as Metrics -import qualified System.Metrics.Counter as Metrics (Counter) -import qualified System.Metrics.Counter as Metrics.Counter -import qualified System.Metrics.Distribution as Metrics (Distribution) -import qualified System.Metrics.Distribution as Metrics.Distribution -import qualified System.Metrics.Gauge as Metrics (Gauge) -import qualified System.Metrics.Gauge as Metrics.Gauge -import System.Random (randomIO, randomRIO) -import UnliftIO ( - Exception, - MonadIO, - MonadUnliftIO, - TQueue, - TVar, - async, - atomically, - bracket, - liftIO, - link, - modifyTVar, - newTVarIO, - readTQueue, - readTVar, - throwIO, - wait, - withAsync, - writeTQueue, - writeTVar, - ) -import UnliftIO.Concurrent (threadDelay) - -runRedis :: MonadLoggerIO m => Redis (Either Reply a) -> CacheX m a -runRedis action = - asks cacheConn >>= \conn -> - liftIO (Redis.runRedis conn action) >>= \case - Right x -> return x - Left e -> do - $(logErrorS) "Cache" $ "Got error from Redis: " <> cs (show e) - throwIO (RedisError e) - -data CacheConfig = CacheConfig - { cacheConn :: !Connection - , cacheMin :: !Int - , cacheMax :: !Integer - , cacheChain :: !Chain - , cacheRetryDelay :: !Int -- microseconds - , cacheMetrics :: !(Maybe CacheMetrics) - } - -data CacheMetrics = CacheMetrics - { cacheHits :: !Metrics.Counter - , cacheMisses :: !Metrics.Counter - , cacheLockAcquired :: !Metrics.Counter - , cacheLockReleased :: !Metrics.Counter - , cacheLockFailed :: !Metrics.Counter - , cacheXPubBals :: !Metrics.Counter - , cacheXPubUnspents :: !Metrics.Counter - , cacheXPubTxs :: !Metrics.Counter - , cacheXPubTxCount :: !Metrics.Counter - , cacheIndexTime :: !StatDist - } - -newCacheMetrics :: MonadIO m => Metrics.Store -> m CacheMetrics -newCacheMetrics s = liftIO $ do - cacheHits <- c "cache.hits" - cacheMisses <- c "cache.misses" - cacheLockAcquired <- c "cache.lock_acquired" - cacheLockReleased <- c "cache.lock_released" - cacheLockFailed <- c "cache.lock_failed" - cacheIndexTime <- d "cache.index" - cacheXPubBals <- c "cache.xpub_balances_cached" - cacheXPubUnspents <- c "cache.xpub_unspents_cached" - cacheXPubTxs <- c "cache.xpub_txs_cached" - cacheXPubTxCount <- c "cache.xpub_tx_count_cached" - return CacheMetrics{..} - where - c x = Metrics.createCounter x s - d x = createStatDist x s - -withMetrics :: - MonadUnliftIO m => - (CacheMetrics -> StatDist) -> - CacheX m a -> - CacheX m a -withMetrics df go = - asks cacheMetrics >>= \case - Nothing -> go - Just m -> - bracket - (systemToUTCTime <$> liftIO getSystemTime) - (end m) - (const go) - where - end metrics t1 = do - t2 <- systemToUTCTime <$> liftIO getSystemTime - let diff = round $ diffUTCTime t2 t1 * 1000 - df metrics `addStatTime` diff - addStatQuery (df metrics) - -incrementCounter :: - MonadIO m => - (CacheMetrics -> Metrics.Counter) -> - Int -> - CacheX m () -incrementCounter f i = - asks cacheMetrics >>= \case - Just s -> liftIO $ Metrics.Counter.add (f s) (fromIntegral i) - Nothing -> return () - -type CacheT = ReaderT (Maybe CacheConfig) -type CacheX = ReaderT CacheConfig - -data CacheError - = RedisError Reply - | RedisTxError !String - | LogicError !String - deriving (Show, Eq, Generic, NFData, Exception) - -connectRedis :: MonadIO m => String -> m Connection -connectRedis redisurl = do - conninfo <- - if null redisurl - then return defaultConnectInfo - else case parseConnectInfo redisurl of - Left e -> error e - Right r -> return r - liftIO (checkedConnect conninfo) - -instance - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - StoreReadBase (CacheT m) - where - getNetwork = lift getNetwork - getBestBlock = lift getBestBlock - getBlocksAtHeight = lift . getBlocksAtHeight - getBlock = lift . getBlock - getTxData = lift . getTxData - getSpender = lift . getSpender - getBalance = lift . getBalance - getUnspent = lift . getUnspent - getMempool = lift getMempool - -instance - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - StoreReadExtra (CacheT m) - where - getBalances = lift . getBalances - getAddressesTxs addrs = lift . getAddressesTxs addrs - getAddressTxs addr = lift . getAddressTxs addr - getAddressUnspents addr = lift . getAddressUnspents addr - getAddressesUnspents addrs = lift . getAddressesUnspents addrs - getMaxGap = lift getMaxGap - getInitialGap = lift getInitialGap - getNumTxData = lift . getNumTxData - xPubBals xpub = - ask >>= \case - Nothing -> - lift $ - xPubBals xpub - Just cfg -> - lift $ - runReaderT (getXPubBalances xpub) cfg - xPubUnspents xpub xbals limits = - ask >>= \case - Nothing -> - lift $ - xPubUnspents xpub xbals limits - Just cfg -> - lift $ - runReaderT (getXPubUnspents xpub xbals limits) cfg - xPubTxs xpub xbals limits = - ask >>= \case - Nothing -> - lift $ - xPubTxs xpub xbals limits - Just cfg -> - lift $ - runReaderT (getXPubTxs xpub xbals limits) cfg - xPubTxCount xpub xbals = - ask >>= \case - Nothing -> - lift $ - xPubTxCount xpub xbals - Just cfg -> - lift $ - runReaderT (getXPubTxCount xpub xbals) cfg - -withCache :: StoreReadBase m => Maybe CacheConfig -> CacheT m a -> m a -withCache s f = runReaderT f s - -balancesPfx :: ByteString -balancesPfx = "b" - -txSetPfx :: ByteString -txSetPfx = "t" - -utxoPfx :: ByteString -utxoPfx = "u" - -idxPfx :: ByteString -idxPfx = "i" - -getXPubTxs :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - Limits -> - CacheX m [TxRef] -getXPubTxs xpub xbals limits = go False - where - go m = - isXPubCached xpub >>= \case - True -> do - txs <- cacheGetXPubTxs xpub limits - incrementCounter cacheXPubTxs (length txs) - return txs - False -> - case m of - True -> lift $ xPubTxs xpub xbals limits - False -> do - newXPubC xpub xbals - go True - -getXPubTxCount :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - CacheX m Word32 -getXPubTxCount xpub xbals = - go False - where - go t = - isXPubCached xpub >>= \case - True -> do - incrementCounter cacheXPubTxCount 1 - cacheGetXPubTxCount xpub - False -> - if t - then lift $ xPubTxCount xpub xbals - else do - newXPubC xpub xbals - go True - -getXPubUnspents :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - Limits -> - CacheX m [XPubUnspent] -getXPubUnspents xpub xbals limits = - go False - where - xm = - let f x = (balanceAddress (xPubBal x), x) - g = (> 0) . balanceUnspentCount . xPubBal - in HashMap.fromList $ map f $ filter g xbals - go m = - isXPubCached xpub >>= \case - True -> do - process - False -> case m of - True -> do - us <- lift $ xPubUnspents xpub xbals limits - return us - False -> do - newXPubC xpub xbals - go True - process = do - ops <- map snd <$> cacheGetXPubUnspents xpub limits - uns <- catMaybes <$> lift (mapM getUnspent ops) - let f u = - either - (const Nothing) - (\a -> Just (a, u)) - (scriptToAddressBS (unspentScript u)) - g a = HashMap.lookup a xm - h u x = - XPubUnspent - { xPubUnspent = u - , xPubUnspentPath = xPubBalPath x - } - us = mapMaybe f uns - i a u = h u <$> g a - incrementCounter cacheXPubUnspents (length us) - return $ mapMaybe (uncurry i) us - -getXPubBalances :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - XPubSpec -> - CacheX m [XPubBal] -getXPubBalances xpub = - isXPubCached xpub >>= \case - True -> do - xbals <- cacheGetXPubBalances xpub - incrementCounter cacheXPubBals (length xbals) - return xbals - False -> do - bals <- lift $ xPubBals xpub - newXPubC xpub bals - return bals - -isInCache :: MonadLoggerIO m => XPubSpec -> CacheT m Bool -isInCache xpub = - ask >>= \case - Nothing -> return False - Just cfg -> runReaderT (isXPubCached xpub) cfg - -isXPubCached :: MonadLoggerIO m => XPubSpec -> CacheX m Bool -isXPubCached xpub = do - cached <- runRedis (redisIsXPubCached xpub) - if cached - then incrementCounter cacheHits 1 - else incrementCounter cacheMisses 1 - return cached - -redisIsXPubCached :: RedisCtx m f => XPubSpec -> m (f Bool) -redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub) - -cacheGetXPubBalances :: MonadLoggerIO m => XPubSpec -> CacheX m [XPubBal] -cacheGetXPubBalances xpub = do - bals <- runRedis $ redisGetXPubBalances xpub - touchKeys [xpub] - return bals - -cacheGetXPubTxCount :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - XPubSpec -> - CacheX m Word32 -cacheGetXPubTxCount xpub = do - count <- fromInteger <$> runRedis (redisGetXPubTxCount xpub) - touchKeys [xpub] - return count - -redisGetXPubTxCount :: RedisCtx m f => XPubSpec -> m (f Integer) -redisGetXPubTxCount xpub = Redis.zcard (txSetPfx <> encode xpub) - -cacheGetXPubTxs :: - (StoreReadBase m, MonadLoggerIO m) => - XPubSpec -> - Limits -> - CacheX m [TxRef] -cacheGetXPubTxs xpub limits = - case start limits of - Nothing -> - go1 Nothing - Just (AtTx th) -> - lift (getTxData th) >>= \case - Just TxData{txDataBlock = b@BlockRef{}} -> - go1 $ Just (blockRefScore b) - _ -> - go2 th - Just (AtBlock h) -> - go1 (Just (blockRefScore (BlockRef h maxBound))) - where - go1 score = do - xs <- - runRedis $ - getFromSortedSet - (txSetPfx <> encode xpub) - score - (offset limits) - (limit limits) - touchKeys [xpub] - return $ map (uncurry f) xs - go2 hash = do - xs <- - runRedis $ - getFromSortedSet - (txSetPfx <> encode xpub) - Nothing - 0 - 0 - touchKeys [xpub] - let xs' = - if any ((== hash) . fst) xs - then dropWhile ((/= hash) . fst) xs - else [] - return $ - map (uncurry f) $ - l $ - drop (fromIntegral (offset limits)) xs' - l = - if limit limits > 0 - then take (fromIntegral (limit limits)) - else id - f t s = TxRef{txRefHash = t, txRefBlock = scoreBlockRef s} - -cacheGetXPubUnspents :: - (StoreReadBase m, MonadLoggerIO m) => - XPubSpec -> - Limits -> - CacheX m [(BlockRef, OutPoint)] -cacheGetXPubUnspents xpub limits = - case start limits of - Nothing -> - go1 Nothing - Just (AtTx th) -> - lift (getTxData th) >>= \case - Just TxData{txDataBlock = b@BlockRef{}} -> - go1 (Just (blockRefScore b)) - _ -> - go2 th - Just (AtBlock h) -> - go1 (Just (blockRefScore (BlockRef h maxBound))) - where - go1 score = do - xs <- - runRedis $ - getFromSortedSet - (utxoPfx <> encode xpub) - score - (offset limits) - (limit limits) - touchKeys [xpub] - return $ map (uncurry f) xs - go2 hash = do - xs <- - runRedis $ - getFromSortedSet - (utxoPfx <> encode xpub) - Nothing - 0 - 0 - touchKeys [xpub] - let xs' = - if any ((== hash) . outPointHash . fst) xs - then dropWhile ((/= hash) . outPointHash . fst) xs - else [] - return $ - map (uncurry f) $ - l $ - drop (fromIntegral (offset limits)) xs' - l = - if limit limits > 0 - then take (fromIntegral (limit limits)) - else id - f o s = (scoreBlockRef s, o) - -redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal]) -redisGetXPubBalances xpub = - fmap (sort . map (uncurry f)) <$> getAllFromMap (balancesPfx <> encode xpub) - where - f p b = XPubBal{xPubBalPath = p, xPubBal = b} - -blockRefScore :: BlockRef -> Double -blockRefScore BlockRef{blockRefHeight = h, blockRefPos = p} = - fromIntegral (0x001fffffffffffff - (h' .|. p')) - where - h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64 - p' = (fromIntegral p .&. 0x03ffffff) :: Word64 -blockRefScore MemRef{memRefTime = t} = negate t' - where - t' = fromIntegral (t .&. 0x001fffffffffffff) - -scoreBlockRef :: Double -> BlockRef -scoreBlockRef s - | s < 0 = MemRef{memRefTime = n} - | otherwise = BlockRef{blockRefHeight = h, blockRefPos = p} - where - n = truncate (abs s) :: Word64 - m = 0x001fffffffffffff - n - h = fromIntegral (m `shift` (-26)) - p = fromIntegral (m .&. 0x03ffffff) - -getFromSortedSet :: - (Applicative f, RedisCtx m f, Serialize a) => - ByteString -> - Maybe Double -> - Word32 -> - Word32 -> - m (f [(a, Double)]) -getFromSortedSet key Nothing off 0 = do - xs <- zrangeWithscores key (fromIntegral off) (-1) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) -getFromSortedSet key Nothing off count = do - xs <- - zrangeWithscores - key - (fromIntegral off) - (fromIntegral off + fromIntegral count - 1) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) -getFromSortedSet key (Just score) off 0 = do - xs <- - zrangebyscoreWithscoresLimit - key - score - (1 / 0) - (fromIntegral off) - (-1) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) -getFromSortedSet key (Just score) off count = do - xs <- - zrangebyscoreWithscoresLimit - key - score - (1 / 0) - (fromIntegral off) - (fromIntegral count) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) - -getAllFromMap :: - (Functor f, RedisCtx m f, Serialize k, Serialize v) => - ByteString -> - m (f [(k, v)]) -getAllFromMap n = do - fxs <- hgetall n - return $ do - xs <- fxs - return - [ (k, v) - | (k', v') <- xs - , let Right k = decode k' - , let Right v = decode v' - ] - -data CacheWriterMessage - = CacheNewBlock - | CacheNewTx TxHash - -type CacheWriterInbox = Inbox CacheWriterMessage -type CacheWriter = Mailbox CacheWriterMessage - -data AddressXPub = AddressXPub - { addressXPubSpec :: !XPubSpec - , addressXPubPath :: ![KeyIndex] - } - deriving (Show, Eq, Generic, NFData, Serialize) - -mempoolSetKey :: ByteString -mempoolSetKey = "mempool" - -addrPfx :: ByteString -addrPfx = "a" - -bestBlockKey :: ByteString -bestBlockKey = "head" - -maxKey :: ByteString -maxKey = "max" - -xPubAddrFunction :: DeriveType -> XPubKey -> Address -xPubAddrFunction DeriveNormal = xPubAddr -xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr -xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr - -cacheWriter :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - CacheConfig -> - CacheWriterInbox -> - m () -cacheWriter cfg inbox = - runReaderT go cfg - where - go = do - newBlockC - syncMempoolC - forever $ do - x <- receive inbox - cacheWriterReact x - -lockIt :: MonadLoggerIO m => CacheX m (Maybe Word32) -lockIt = do - rnd <- liftIO randomIO - go rnd >>= \case - Right Redis.Ok -> do - $(logDebugS) "Cache" $ - "Acquired lock with value " <> cs (show rnd) - incrementCounter cacheLockAcquired 1 - return (Just rnd) - Right Redis.Pong -> do - $(logErrorS) - "Cache" - "Unexpected pong when acquiring lock" - incrementCounter cacheLockFailed 1 - return Nothing - Right (Redis.Status s) -> do - $(logErrorS) "Cache" $ - "Unexpected status acquiring lock: " <> cs s - incrementCounter cacheLockFailed 1 - return Nothing - Left (Redis.Bulk Nothing) -> do - $(logDebugS) "Cache" "Lock already taken" - incrementCounter cacheLockFailed 1 - return Nothing - Left e -> do - $(logErrorS) - "Cache" - "Error when trying to acquire lock" - incrementCounter cacheLockFailed 1 - throwIO (RedisError e) - where - go rnd = do - conn <- asks cacheConn - liftIO . Redis.runRedis conn $ do - let opts = - Redis.SetOpts - { Redis.setSeconds = Just 300 - , Redis.setMilliseconds = Nothing - , Redis.setCondition = Just Redis.Nx - } - Redis.setOpts "lock" (cs (show rnd)) opts - -unlockIt :: MonadLoggerIO m => Maybe Word32 -> CacheX m () -unlockIt Nothing = return () -unlockIt (Just i) = - runRedis (Redis.get "lock") >>= \case - Nothing -> - $(logErrorS) "Cache" $ - "Not releasing lock with value " <> cs (show i) - <> ": not locked" - Just bs -> - if read (cs bs) == i - then do - void $ runRedis (Redis.del ["lock"]) - $(logDebugS) "Cache" $ - "Released lock with value " - <> cs (show i) - incrementCounter cacheLockReleased 1 - else - $(logErrorS) "Cache" $ - "Could not release lock: value is not " - <> cs (show i) - -withLock :: - (MonadLoggerIO m, MonadUnliftIO m) => - CacheX m a -> - CacheX m (Maybe a) -withLock f = - bracket lockIt unlockIt $ \case - Just _ -> Just <$> f - Nothing -> return Nothing - -smallDelay :: MonadUnliftIO m => CacheX m () -smallDelay = do - delay <- asks cacheRetryDelay - let delayMin = delay `div` 2 - let delayMax = delay * 3 `div` 2 - threadDelay =<< liftIO (randomRIO (delayMin, delayMax)) - -withLockForever :: - (MonadLoggerIO m, MonadUnliftIO m) => - CacheX m a -> - CacheX m a -withLockForever go = - withLock go >>= \case - Nothing -> do - smallDelay - $(logDebugS) "Cache" "Retrying lock aquisition without limits" - withLockForever go - Just x -> return x - -withLockRetry :: - (MonadLoggerIO m, MonadUnliftIO m) => - Int -> - CacheX m a -> - CacheX m (Maybe a) -withLockRetry i f - | i <= 0 = return Nothing - | otherwise = - withLock f >>= \case - Nothing -> do - smallDelay - $(logDebugS) "Cache" $ - "Retrying lock acquisition: " - <> cs (show i) - <> " tries remaining" - withLockRetry (i - 1) f - x -> return x - -pruneDB :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - CacheX m Integer -pruneDB = do - x <- asks cacheMax - s <- runRedis Redis.dbsize - if s > x then flush (s - x) else return 0 - where - flush n = - case n `div` 64 of - 0 -> return 0 - x -> fmap (fromMaybe 0) $ - withLock $ do - ks <- - fmap (map fst) . runRedis $ - getFromSortedSet maxKey Nothing 0 (fromIntegral x) - $(logDebugS) "Cache" $ - "Pruning " <> cs (show (length ks)) <> " old xpubs" - delXPubKeys ks - -touchKeys :: MonadLoggerIO m => [XPubSpec] -> CacheX m () -touchKeys xpubs = do - now <- systemSeconds <$> liftIO getSystemTime - runRedis $ redisTouchKeys now xpubs - -redisTouchKeys :: (Monad f, RedisCtx m f, Real a) => a -> [XPubSpec] -> m (f ()) -redisTouchKeys _ [] = return $ return () -redisTouchKeys now xpubs = - void <$> Redis.zadd maxKey (map ((realToFrac now,) . encode) xpubs) - -cacheWriterReact :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - CacheWriterMessage -> - CacheX m () -cacheWriterReact CacheNewBlock = - doSync -cacheWriterReact (CacheNewTx txid) = - withLock go >>= \case - Just () -> return () - Nothing -> smallDelay >> cacheWriterReact (CacheNewTx txid) - where - hex = txHashToHex txid - go = - $(logDebugS) "Cache" ("Locking to import tx: " <> hex) - >> cacheIsInMempool txid >>= \case - True -> - $(logDebugS) "Cache" $ "Already imported tx: " <> hex - False -> - lift (getTxData txid) >>= mapM_ \tx -> do - $(logDebugS) "Cache" $ "Importing mempool tx: " <> hex - importMultiTxC [tx] - -doSync :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - CacheX m () -doSync = newBlockC >> void pruneDB - -lenNotNull :: [XPubBal] -> Int -lenNotNull = length . filter (not . nullBalance . xPubBal) - -newXPubC :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - CacheX m () -newXPubC xpub xbals = - should_index >>= \i -> when i $ - bracket set_index unset_index $ \j -> when j $ - withMetrics cacheIndexTime $ do - xpubtxt <- xpubText xpub - $(logDebugS) "Cache" $ - "Caching " <> xpubtxt <> ": " - <> cs (show (length xbals)) - <> " addresses / " - <> cs (show (lenNotNull xbals)) - <> " used" - utxo <- lift $ xPubUnspents xpub xbals def - $(logDebugS) "Cache" $ - "Caching " <> xpubtxt <> ": " <> cs (show (length utxo)) - <> " utxos" - xtxs <- lift $ xPubTxs xpub xbals def - $(logDebugS) "Cache" $ - "Caching " <> xpubtxt <> ": " <> cs (show (length xtxs)) - <> " txs" - now <- systemSeconds <$> liftIO getSystemTime - runRedis $ do - b <- redisTouchKeys now [xpub] - c <- redisAddXPubBalances xpub xbals - d <- redisAddXPubUnspents xpub (map op utxo) - e <- redisAddXPubTxs xpub xtxs - return $ b >> c >> d >> e >> return () - $(logDebugS) "Cache" $ "Cached " <> xpubtxt - where - op XPubUnspent{xPubUnspent = u} = (unspentPoint u, unspentBlock u) - should_index = - asks cacheMin >>= \x -> - if x <= lenNotNull xbals then inSync else return False - key = idxPfx <> encode xpub - opts = - Redis.SetOpts - { Redis.setSeconds = Just 600 - , Redis.setMilliseconds = Nothing - , Redis.setCondition = Just Redis.Nx - } - red = Redis.setOpts key "1" opts - unset_index y = when y . void . runRedis $ Redis.del [key] - set_index = - asks cacheConn >>= \conn -> - liftIO (Redis.runRedis conn red) >>= return . isRight - -inSync :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - CacheX m Bool -inSync = - lift getBestBlock >>= \case - Nothing -> return False - Just bb -> - asks cacheChain >>= \ch -> - chainGetBest ch >>= \cb -> - return $ headerHash (nodeHeader cb) == bb - -newBlockC :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - CacheX m () -newBlockC = - inSync >>= \s -> - when s $ - asks cacheChain >>= \ch -> - chainGetBest ch >>= \bn -> - cacheGetHead >>= \case - Nothing -> - $(logInfoS) "Cache" "Initializing best cache block" - >> withLock (do_import bn) >>= \case - Nothing -> smallDelay >> newBlockC - Just () -> return () - Just hb -> - if hb == headerHash (nodeHeader bn) - then $(logDebugS) "Cache" "Cache in sync" - else - withLock (sync ch hb bn) >>= \case - Nothing -> smallDelay >> newBlockC - Just () -> return () - where - sync ch hb bn = - chainGetBlock hb ch >>= \case - Nothing -> do - $(logErrorS) "Cache" $ - "Cache head block node not found: " - <> blockHashToHex hb - throwIO $ - LogicError $ - "Cache head block node not found: " - <> cs (blockHashToHex hb) - Just hn -> - chainBlockMain hb ch >>= \m -> - if m - then next ch bn hn - else do - $(logDebugS) "Cache" $ - "Reverting cache head not in main chain: " - <> blockHashToHex hb - removeHeadC hb - cacheGetHead >>= \case - Nothing -> do_import bn - Just hb' -> sync ch hb' bn - next ch bn hn = - if - | prevBlock (nodeHeader bn) == headerHash (nodeHeader hn) -> - do_import bn - | nodeHeight bn > nodeHeight hn -> - chainGetAncestor (nodeHeight hn + 1) bn ch >>= \case - Nothing -> do - $(logErrorS) "Cache" $ - "Ancestor not found at height " - <> cs (show (nodeHeight hn + 1)) - <> " for block: " - <> blockHashToHex (headerHash (nodeHeader bn)) - throwIO $ - LogicError $ - "Ancestor not found at height " - <> show (nodeHeight hn + 1) - <> " for block: " - <> cs (blockHashToHex (headerHash (nodeHeader bn))) - Just hn' -> do - do_import hn' - next ch bn hn' - | otherwise -> - $(logInfoS) "Cache" "Cache best block higher than this node's" - do_import = importBlockC . headerHash . nodeHeader - -importBlockC :: - (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) => - BlockHash -> - CacheX m () -importBlockC bh = - lift (getBlock bh) >>= \case - Just bd -> do - let ths = blockDataTxs bd - tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths - $(logDebugS) "Cache" $ - "Importing " <> cs (show (length tds)) - <> " transactions from block " - <> blockHashToHex bh - importMultiTxC tds - $(logDebugS) "Cache" $ - "Done importing " <> cs (show (length tds)) - <> " transactions from block " - <> blockHashToHex bh - cacheSetHead bh - Nothing -> do - $(logErrorS) "Cache" $ - "Could not get block: " - <> blockHashToHex bh - throwIO . LogicError . cs $ - "Could not get block: " - <> blockHashToHex bh - -removeHeadC :: - (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) => - BlockHash -> - CacheX m () -removeHeadC cb = - void . runMaybeT $ do - bh <- MaybeT cacheGetHead - guard (cb == bh) - bd <- MaybeT (lift (getBlock bh)) - lift $ do - tds <- - sortTxData . catMaybes - <$> mapM (lift . getTxData) (blockDataTxs bd) - $(logDebugS) "Cache" $ "Reverting head: " <> blockHashToHex bh - importMultiTxC tds - $(logWarnS) "Cache" $ - "Reverted block head " - <> blockHashToHex bh - <> " to parent " - <> blockHashToHex (prevBlock (blockDataHeader bd)) - cacheSetHead (prevBlock (blockDataHeader bd)) - -importMultiTxC :: - (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) => - [TxData] -> - CacheX m () -importMultiTxC txs = do - $(logDebugS) "Cache" $ "Processing " <> cs (show (length txs)) <> " txs" - $(logDebugS) "Cache" $ - "Getting address information for " - <> cs (show (length alladdrs)) - <> " addresses" - addrmap <- getaddrmap - let addrs = HashMap.keys addrmap - $(logDebugS) "Cache" $ - "Getting balances for " - <> cs (show (HashMap.size addrmap)) - <> " addresses" - balmap <- getbalances addrs - $(logDebugS) "Cache" $ - "Getting unspent data for " - <> cs (show (length allops)) - <> " outputs" - unspentmap <- getunspents - gap <- lift getMaxGap - now <- systemSeconds <$> liftIO getSystemTime - let xpubs = allxpubsls addrmap - forM_ (zip [(1 :: Int) ..] xpubs) $ \(i, xpub) -> do - xpubtxt <- xpubText xpub - $(logDebugS) "Cache" $ - "Affected xpub " - <> cs (show i) - <> "/" - <> cs (show (length xpubs)) - <> ": " - <> xpubtxt - addrs' <- do - $(logDebugS) "Cache" $ - "Getting xpub balances for " - <> cs (show (length xpubs)) - <> " xpubs" - xmap <- getxbals xpubs - let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap - $(logDebugS) "Cache" "Starting Redis import pipeline" - runRedis $ do - x <- redisImportMultiTx addrmap' unspentmap txs - y <- redisUpdateBalances addrmap' balmap - z <- redisTouchKeys now (HashMap.keys xmap) - return $ x >> y >> z >> return () - $(logDebugS) "Cache" "Completed Redis pipeline" - return $ getNewAddrs gap xmap (HashMap.elems addrmap') - cacheAddAddresses addrs' - where - alladdrsls = HashSet.toList alladdrs - faddrmap xmap = HashMap.filter (\a -> addressXPubSpec a `elem` xmap) - getaddrmap = - HashMap.fromList . catMaybes . zipWith (\a -> fmap (a,)) alladdrsls - <$> cacheGetAddrsInfo alladdrsls - getunspents = - HashMap.fromList . catMaybes . zipWith (\p -> fmap (p,)) allops - <$> lift (mapM getUnspent allops) - getbalances addrs = - HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs - getxbals xpubs = do - bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do - bs <- redisGetXPubBalances xpub - return $ (,) xpub <$> bs - return $ HashMap.filter (not . null) (HashMap.fromList bals) - allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs - alladdrs = - HashSet.fromList . map fst $ - concatMap txInputs txs <> concatMap txOutputs txs - allxpubsls addrmap = HashSet.toList (allxpubs addrmap) - allxpubs addrmap = - HashSet.fromList . map addressXPubSpec $ HashMap.elems addrmap - -redisImportMultiTx :: - (Monad f, RedisCtx m f) => - HashMap Address AddressXPub -> - HashMap OutPoint Unspent -> - [TxData] -> - m (f ()) -redisImportMultiTx addrmap unspentmap txs = do - xs <- mapM importtxentries txs - return $ sequence_ xs - where - uns p i = - case HashMap.lookup p unspentmap of - Just u -> - redisAddXPubUnspents (addressXPubSpec i) [(p, unspentBlock u)] - Nothing -> redisRemXPubUnspents (addressXPubSpec i) [p] - addtx tx a p = - case HashMap.lookup a addrmap of - Just i -> do - let tr = - TxRef - { txRefHash = txHash (txData tx) - , txRefBlock = txDataBlock tx - } - x <- redisAddXPubTxs (addressXPubSpec i) [tr] - y <- uns p i - return $ x >> y >> return () - Nothing -> return (pure ()) - remtx tx a p = - case HashMap.lookup a addrmap of - Just i -> do - x <- redisRemXPubTxs (addressXPubSpec i) [txHash (txData tx)] - y <- uns p i - return $ x >> y >> return () - Nothing -> return (pure ()) - importtxentries tx = - if txDataDeleted tx - then do - x <- mapM (uncurry (remtx tx)) (txaddrops tx) - y <- redisRemFromMempool [txHash (txData tx)] - return $ sequence_ x >> void y - else do - a <- sequence <$> mapM (uncurry (addtx tx)) (txaddrops tx) - b <- - case txDataBlock tx of - b@MemRef{} -> - let tr = - TxRef - { txRefHash = txHash (txData tx) - , txRefBlock = b - } - in redisAddToMempool [tr] - _ -> redisRemFromMempool [txHash (txData tx)] - return $ a >> b >> return () - txaddrops td = txInputs td <> txOutputs td - -redisUpdateBalances :: - (Monad f, RedisCtx m f) => - HashMap Address AddressXPub -> - HashMap Address Balance -> - m (f ()) -redisUpdateBalances addrmap balmap = - fmap (fmap mconcat . sequence) . forM (HashMap.keys addrmap) $ \a -> - case (HashMap.lookup a addrmap, HashMap.lookup a balmap) of - (Just ainfo, Just bal) -> - redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal] - _ -> return (pure ()) - where - xpubbal ainfo bal = - XPubBal{xPubBalPath = addressXPubPath ainfo, xPubBal = bal} - -cacheAddAddresses :: - (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) => - [(Address, AddressXPub)] -> - CacheX m () -cacheAddAddresses [] = $(logDebugS) "Cache" "No further addresses to add" -cacheAddAddresses addrs = do - $(logDebugS) "Cache" $ - "Adding " <> cs (show (length addrs)) <> " new generated addresses" - $(logDebugS) "Cache" "Getting balances" - balmap <- HashMap.fromListWith (<>) <$> mapM (uncurry getbal) addrs - $(logDebugS) "Cache" "Getting unspent outputs" - utxomap <- HashMap.fromListWith (<>) <$> mapM (uncurry getutxo) addrs - $(logDebugS) "Cache" "Getting transactions" - txmap <- HashMap.fromListWith (<>) <$> mapM (uncurry gettxmap) addrs - $(logDebugS) "Cache" "Running Redis pipeline" - runRedis $ do - a <- forM (HashMap.toList balmap) (uncurry redisAddXPubBalances) - b <- forM (HashMap.toList utxomap) (uncurry redisAddXPubUnspents) - c <- forM (HashMap.toList txmap) (uncurry redisAddXPubTxs) - return $ sequence_ a >> sequence_ b >> sequence_ c - $(logDebugS) "Cache" "Completed Redis pipeline" - let xpubs = - HashSet.toList - . HashSet.fromList - . map addressXPubSpec - $ Map.elems amap - $(logDebugS) "Cache" "Getting xpub balances" - xmap <- getbals xpubs - gap <- lift getMaxGap - let notnulls = getnotnull balmap - addrs' = getNewAddrs gap xmap notnulls - cacheAddAddresses addrs' - where - getbals xpubs = runRedis $ do - bs <- sequence <$> forM xpubs redisGetXPubBalances - return $ - HashMap.filter (not . null) . HashMap.fromList . zip xpubs <$> bs - amap = Map.fromList addrs - getnotnull = - let f xpub = - map $ \bal -> - AddressXPub - { addressXPubSpec = xpub - , addressXPubPath = xPubBalPath bal - } - g = filter (not . nullBalance . xPubBal) - in concatMap (uncurry f) . HashMap.toList . HashMap.map g - getbal a i = - let f b = - ( addressXPubSpec i - , [XPubBal{xPubBal = b, xPubBalPath = addressXPubPath i}] - ) - in f <$> lift (getDefaultBalance a) - getutxo a i = - let f us = - ( addressXPubSpec i - , map (\u -> (unspentPoint u, unspentBlock u)) us - ) - in f <$> lift (getAddressUnspents a def) - gettxmap a i = - let f ts = (addressXPubSpec i, ts) - in f <$> lift (getAddressTxs a def) - -getNewAddrs :: - KeyIndex -> - HashMap XPubSpec [XPubBal] -> - [AddressXPub] -> - [(Address, AddressXPub)] -getNewAddrs gap xpubs = - concatMap $ \a -> - case HashMap.lookup (addressXPubSpec a) xpubs of - Nothing -> [] - Just bals -> addrsToAdd gap bals a - -syncMempoolC :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => - CacheX m () -syncMempoolC = void . withLockForever $ do - nodepool <- HashSet.fromList . map snd <$> lift getMempool - cachepool <- HashSet.fromList . map snd <$> cacheGetMempool - getem (HashSet.difference nodepool cachepool) - getem (HashSet.difference cachepool nodepool) - where - getem tset = do - let tids = HashSet.toList tset - txs <- catMaybes <$> mapM (lift . getTxData) tids - unless (null txs) $ do - $(logDebugS) "Cache" $ - "Importing mempool transactions: " <> cs (show (length txs)) - importMultiTxC txs - -cacheGetMempool :: MonadLoggerIO m => CacheX m [(UnixTime, TxHash)] -cacheGetMempool = runRedis redisGetMempool - -cacheIsInMempool :: MonadLoggerIO m => TxHash -> CacheX m Bool -cacheIsInMempool = runRedis . redisIsInMempool - -cacheGetHead :: MonadLoggerIO m => CacheX m (Maybe BlockHash) -cacheGetHead = runRedis redisGetHead - -cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockHash -> CacheX m () -cacheSetHead bh = do - $(logDebugS) "Cache" $ "Cache head set to: " <> blockHashToHex bh - void $ runRedis (redisSetHead bh) - -cacheGetAddrsInfo :: - MonadLoggerIO m => [Address] -> CacheX m [Maybe AddressXPub] -cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as) - -redisAddToMempool :: (Applicative f, RedisCtx m f) => [TxRef] -> m (f Integer) -redisAddToMempool [] = return (pure 0) -redisAddToMempool btxs = - zadd mempoolSetKey $ - map - (\btx -> (blockRefScore (txRefBlock btx), encode (txRefHash btx))) - btxs - -redisIsInMempool :: (Applicative f, RedisCtx m f) => TxHash -> m (f Bool) -redisIsInMempool txid = - fmap isJust <$> Redis.zrank mempoolSetKey (encode txid) - -redisRemFromMempool :: - (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer) -redisRemFromMempool [] = return (pure 0) -redisRemFromMempool xs = zrem mempoolSetKey $ map encode xs - -redisSetAddrInfo :: - (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ()) -redisSetAddrInfo a i = void <$> Redis.set (addrPfx <> encode a) (encode i) - -cacheDelXPubs :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - [XPubSpec] -> - CacheT m Integer -cacheDelXPubs xpubs = ReaderT $ \case - Just cache -> runReaderT (delXPubKeys xpubs) cache - Nothing -> return 0 - -delXPubKeys :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - [XPubSpec] -> - CacheX m Integer -delXPubKeys [] = return 0 -delXPubKeys xpubs = do - forM_ xpubs $ \x -> do - xtxt <- xpubText x - $(logDebugS) "Cache" $ "Deleting xpub: " <> xtxt - xbals <- - runRedis . fmap sequence . forM xpubs $ \xpub -> do - bs <- redisGetXPubBalances xpub - return $ (xpub,) <$> bs - runRedis $ fmap sum . sequence <$> forM xbals (uncurry redisDelXPubKeys) - -redisDelXPubKeys :: - (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f Integer) -redisDelXPubKeys xpub bals = go (map (balanceAddress . xPubBal) bals) - where - go addrs = do - addrcount <- - case addrs of - [] -> return (pure 0) - _ -> Redis.del (map ((addrPfx <>) . encode) addrs) - txsetcount <- Redis.del [txSetPfx <> encode xpub] - utxocount <- Redis.del [utxoPfx <> encode xpub] - balcount <- Redis.del [balancesPfx <> encode xpub] - x <- Redis.zrem maxKey [encode xpub] - return $ do - _ <- x - addrs' <- addrcount - txset' <- txsetcount - utxo' <- utxocount - bal' <- balcount - return $ addrs' + txset' + utxo' + bal' - -redisAddXPubTxs :: - (Applicative f, RedisCtx m f) => XPubSpec -> [TxRef] -> m (f Integer) -redisAddXPubTxs _ [] = return (pure 0) -redisAddXPubTxs xpub btxs = - zadd (txSetPfx <> encode xpub) $ - map (\t -> (blockRefScore (txRefBlock t), encode (txRefHash t))) btxs - -redisRemXPubTxs :: - (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer) -redisRemXPubTxs _ [] = return (pure 0) -redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs) - -redisAddXPubUnspents :: - (Applicative f, RedisCtx m f) => - XPubSpec -> - [(OutPoint, BlockRef)] -> - m (f Integer) -redisAddXPubUnspents _ [] = - return (pure 0) -redisAddXPubUnspents xpub utxo = - zadd (utxoPfx <> encode xpub) $ - map (\(p, r) -> (blockRefScore r, encode p)) utxo - -redisRemXPubUnspents :: - (Applicative f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f Integer) -redisRemXPubUnspents _ [] = - return (pure 0) -redisRemXPubUnspents xpub ops = - zrem (utxoPfx <> encode xpub) (map encode ops) - -redisAddXPubBalances :: - (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ()) -redisAddXPubBalances _ [] = return (pure ()) -redisAddXPubBalances xpub bals = do - xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries - ys <- forM bals $ \b -> - redisSetAddrInfo - (balanceAddress (xPubBal b)) - AddressXPub - { addressXPubSpec = xpub - , addressXPubPath = xPubBalPath b - } - return $ sequence_ xs >> sequence_ ys - where - entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals - -redisSetHead :: RedisCtx m f => BlockHash -> m (f Redis.Status) -redisSetHead bh = Redis.set bestBlockKey (encode bh) - -redisGetAddrsInfo :: - (Monad f, RedisCtx m f) => [Address] -> m (f [Maybe AddressXPub]) -redisGetAddrsInfo [] = return (pure []) -redisGetAddrsInfo as = do - is <- mapM (\a -> Redis.get (addrPfx <> encode a)) as - return $ do - is' <- sequence is - return $ map (eitherToMaybe . decode =<<) is' - -addrsToAdd :: KeyIndex -> [XPubBal] -> AddressXPub -> [(Address, AddressXPub)] -addrsToAdd gap xbals addrinfo - | null fbals = [] - | otherwise = zipWith f addrs list - where - f a p = (a, AddressXPub{addressXPubSpec = xpub, addressXPubPath = p}) - dchain = head (addressXPubPath addrinfo) - fbals = filter ((== dchain) . head . xPubBalPath) xbals - maxidx = maximum (map (head . tail . xPubBalPath) fbals) - xpub = addressXPubSpec addrinfo - aidx = (head . tail) (addressXPubPath addrinfo) - ixs = - if gap > maxidx - aidx - then [maxidx + 1 .. aidx + gap] - else [] - paths = map (Deriv :/ dchain :/) ixs - keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths - list = map pathToList paths - xpubf = xPubAddrFunction (xPubDeriveType xpub) - addrs = map xpubf keys - -sortTxData :: [TxData] -> [TxData] -sortTxData tds = - let txm = Map.fromList (map (\d -> (txHash (txData d), d)) tds) - ths = map (txHash . snd) (sortTxs (map txData tds)) - in mapMaybe (`Map.lookup` txm) ths - -txInputs :: TxData -> [(Address, OutPoint)] -txInputs td = - let is = txIn (txData td) - ps = I.toAscList (txDataPrevs td) - as = map (scriptToAddressBS . prevScript . snd) ps - f (Right a) i = Just (a, prevOutput i) - f (Left _) _ = Nothing - in catMaybes (zipWith f as is) - -txOutputs :: TxData -> [(Address, OutPoint)] -txOutputs td = - let ps = - zipWith - ( \i _ -> - OutPoint - { outPointHash = txHash (txData td) - , outPointIndex = i - } - ) - [0 ..] - (txOut (txData td)) - as = map (scriptToAddressBS . scriptOutput) (txOut (txData td)) - f (Right a) p = Just (a, p) - f (Left _) _ = Nothing - in catMaybes (zipWith f as ps) - -redisGetHead :: (Functor f, RedisCtx m f) => m (f (Maybe BlockHash)) -redisGetHead = do - x <- Redis.get bestBlockKey - return $ (eitherToMaybe . decode =<<) <$> x - -redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [(UnixTime, TxHash)]) -redisGetMempool = do - xs <- getFromSortedSet mempoolSetKey Nothing 0 0 - return $ map (uncurry f) <$> xs - where - f t s = (memRefTime (scoreBlockRef s), t) - -xpubText :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - XPubSpec -> - CacheX m Text -xpubText xpub = do - net <- lift getNetwork - let suffix = case xPubDeriveType xpub of - DeriveNormal -> "" - DeriveP2SH -> "/p2sh" - DeriveP2WPKH -> "/p2wpkh" - return . cs $ suffix <> xPubExport net (xPubSpecKey xpub) +module Haskoin.Store.Cache + ( CacheConfig (..), + CacheMetrics, + CacheT, + CacheError (..), + newCacheMetrics, + withCache, + connectRedis, + blockRefScore, + scoreBlockRef, + CacheWriter, + CacheWriterInbox, + cacheNewBlock, + cacheNewTx, + cacheWriter, + cacheDelXPubs, + isInCache, + ) +where + +import Control.DeepSeq (NFData) +import Control.Monad (forM, forM_, forever, guard, unless, void, when, (>=>)) +import Control.Monad.Logger + ( MonadLoggerIO, + logDebugS, + logErrorS, + logInfoS, + logWarnS, + ) +import Control.Monad.Reader (ReaderT (..), ask, asks) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Bits (complement, shift, (.&.), (.|.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Default (def) +import Data.Either (fromRight, isRight, rights) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import qualified Data.IntMap.Strict as I +import Data.List (sort) +import qualified Data.Map.Strict as Map +import Data.Maybe + ( catMaybes, + fromMaybe, + isJust, + isNothing, + mapMaybe, + ) +import Data.Serialize (Serialize, decode, encode) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime, diffUTCTime) +import Data.Time.Clock.System + ( getSystemTime, + systemSeconds, + systemToUTCTime, + ) +import Data.Word (Word32, Word64) +import Database.Redis + ( Connection, + Redis, + RedisCtx, + Reply, + checkedConnect, + defaultConnectInfo, + hgetall, + parseConnectInfo, + zadd, + zrangeWithscores, + zrangebyscoreWithscoresLimit, + zrem, + ) +import qualified Database.Redis as Redis +import GHC.Generics (Generic) +import Haskoin + ( Address, + BlockHash, + BlockHeader (..), + BlockNode (..), + DerivPathI (..), + KeyIndex, + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + XPubKey, + blockHashToHex, + derivePubPath, + eitherToMaybe, + headerHash, + pathToList, + scriptToAddressBS, + txHash, + txHashToHex, + xPubAddr, + xPubCompatWitnessAddr, + xPubExport, + xPubWitnessAddr, + ) +import Haskoin.Node + ( Chain, + chainBlockMain, + chainGetAncestor, + chainGetBest, + chainGetBlock, + ) +import Haskoin.Store.Common +import Haskoin.Store.Data +import Haskoin.Store.Stats +import NQE + ( Inbox, + Listen, + Mailbox, + inboxToMailbox, + query, + receive, + send, + ) +import qualified System.Metrics as Metrics +import qualified System.Metrics.Counter as Metrics (Counter) +import qualified System.Metrics.Counter as Metrics.Counter +import qualified System.Metrics.Distribution as Metrics (Distribution) +import qualified System.Metrics.Distribution as Metrics.Distribution +import qualified System.Metrics.Gauge as Metrics (Gauge) +import qualified System.Metrics.Gauge as Metrics.Gauge +import System.Random (randomIO, randomRIO) +import UnliftIO + ( Exception, + MonadIO, + MonadUnliftIO, + TQueue, + TVar, + async, + atomically, + bracket, + liftIO, + link, + modifyTVar, + newTVarIO, + readTQueue, + readTVar, + throwIO, + wait, + withAsync, + writeTQueue, + writeTVar, + ) +import UnliftIO.Concurrent (threadDelay) + +runRedis :: MonadLoggerIO m => Redis (Either Reply a) -> CacheX m a +runRedis action = + asks cacheConn >>= \conn -> + liftIO (Redis.runRedis conn action) >>= \case + Right x -> return x + Left e -> do + $(logErrorS) "Cache" $ "Got error from Redis: " <> cs (show e) + throwIO (RedisError e) + +data CacheConfig = CacheConfig + { cacheConn :: !Connection, + cacheMin :: !Int, + cacheMax :: !Integer, + cacheChain :: !Chain, + cacheRetryDelay :: !Int, -- microseconds + cacheMetrics :: !(Maybe CacheMetrics) + } + +data CacheMetrics = CacheMetrics + { cacheHits :: !Metrics.Counter, + cacheMisses :: !Metrics.Counter, + cacheLockAcquired :: !Metrics.Counter, + cacheLockReleased :: !Metrics.Counter, + cacheLockFailed :: !Metrics.Counter, + cacheXPubBals :: !Metrics.Counter, + cacheXPubUnspents :: !Metrics.Counter, + cacheXPubTxs :: !Metrics.Counter, + cacheXPubTxCount :: !Metrics.Counter, + cacheIndexTime :: !StatDist + } + +newCacheMetrics :: MonadIO m => Metrics.Store -> m CacheMetrics +newCacheMetrics s = liftIO $ do + cacheHits <- c "cache.hits" + cacheMisses <- c "cache.misses" + cacheLockAcquired <- c "cache.lock_acquired" + cacheLockReleased <- c "cache.lock_released" + cacheLockFailed <- c "cache.lock_failed" + cacheIndexTime <- d "cache.index" + cacheXPubBals <- c "cache.xpub_balances_cached" + cacheXPubUnspents <- c "cache.xpub_unspents_cached" + cacheXPubTxs <- c "cache.xpub_txs_cached" + cacheXPubTxCount <- c "cache.xpub_tx_count_cached" + return CacheMetrics {..} + where + c x = Metrics.createCounter x s + d x = createStatDist x s + +withMetrics :: + MonadUnliftIO m => + (CacheMetrics -> StatDist) -> + CacheX m a -> + CacheX m a +withMetrics df go = + asks cacheMetrics >>= \case + Nothing -> go + Just m -> + bracket + (systemToUTCTime <$> liftIO getSystemTime) + (end m) + (const go) + where + end metrics t1 = do + t2 <- systemToUTCTime <$> liftIO getSystemTime + let diff = round $ diffUTCTime t2 t1 * 1000 + df metrics `addStatTime` diff + addStatQuery (df metrics) + +incrementCounter :: + MonadIO m => + (CacheMetrics -> Metrics.Counter) -> + Int -> + CacheX m () +incrementCounter f i = + asks cacheMetrics >>= \case + Just s -> liftIO $ Metrics.Counter.add (f s) (fromIntegral i) + Nothing -> return () + +type CacheT = ReaderT (Maybe CacheConfig) + +type CacheX = ReaderT CacheConfig + +data CacheError + = RedisError Reply + | RedisTxError !String + | LogicError !String + deriving (Show, Eq, Generic, NFData, Exception) + +connectRedis :: MonadIO m => String -> m Connection +connectRedis redisurl = do + conninfo <- + if null redisurl + then return defaultConnectInfo + else case parseConnectInfo redisurl of + Left e -> error e + Right r -> return r + liftIO (checkedConnect conninfo) + +instance + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + StoreReadBase (CacheT m) + where + getNetwork = lift getNetwork + getBestBlock = lift getBestBlock + getBlocksAtHeight = lift . getBlocksAtHeight + getBlock = lift . getBlock + getTxData = lift . getTxData + getSpender = lift . getSpender + getBalance = lift . getBalance + getUnspent = lift . getUnspent + getMempool = lift getMempool + +instance + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + StoreReadExtra (CacheT m) + where + getBalances = lift . getBalances + getAddressesTxs addrs = lift . getAddressesTxs addrs + getAddressTxs addr = lift . getAddressTxs addr + getAddressUnspents addr = lift . getAddressUnspents addr + getAddressesUnspents addrs = lift . getAddressesUnspents addrs + getMaxGap = lift getMaxGap + getInitialGap = lift getInitialGap + getNumTxData = lift . getNumTxData + xPubBals xpub = + ask >>= \case + Nothing -> + lift $ + xPubBals xpub + Just cfg -> + lift $ + runReaderT (getXPubBalances xpub) cfg + xPubUnspents xpub xbals limits = + ask >>= \case + Nothing -> + lift $ + xPubUnspents xpub xbals limits + Just cfg -> + lift $ + runReaderT (getXPubUnspents xpub xbals limits) cfg + xPubTxs xpub xbals limits = + ask >>= \case + Nothing -> + lift $ + xPubTxs xpub xbals limits + Just cfg -> + lift $ + runReaderT (getXPubTxs xpub xbals limits) cfg + xPubTxCount xpub xbals = + ask >>= \case + Nothing -> + lift $ + xPubTxCount xpub xbals + Just cfg -> + lift $ + runReaderT (getXPubTxCount xpub xbals) cfg + +withCache :: StoreReadBase m => Maybe CacheConfig -> CacheT m a -> m a +withCache s f = runReaderT f s + +balancesPfx :: ByteString +balancesPfx = "b" + +txSetPfx :: ByteString +txSetPfx = "t" + +utxoPfx :: ByteString +utxoPfx = "u" + +idxPfx :: ByteString +idxPfx = "i" + +getXPubTxs :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + XPubSpec -> + [XPubBal] -> + Limits -> + CacheX m [TxRef] +getXPubTxs xpub xbals limits = go False + where + go m = + isXPubCached xpub >>= \case + True -> do + txs <- cacheGetXPubTxs xpub limits + incrementCounter cacheXPubTxs (length txs) + return txs + False -> + case m of + True -> lift $ xPubTxs xpub xbals limits + False -> do + newXPubC xpub xbals + go True + +getXPubTxCount :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + XPubSpec -> + [XPubBal] -> + CacheX m Word32 +getXPubTxCount xpub xbals = + go False + where + go t = + isXPubCached xpub >>= \case + True -> do + incrementCounter cacheXPubTxCount 1 + cacheGetXPubTxCount xpub + False -> + if t + then lift $ xPubTxCount xpub xbals + else do + newXPubC xpub xbals + go True + +getXPubUnspents :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + XPubSpec -> + [XPubBal] -> + Limits -> + CacheX m [XPubUnspent] +getXPubUnspents xpub xbals limits = + go False + where + xm = + let f x = (balanceAddress (xPubBal x), x) + g = (> 0) . balanceUnspentCount . xPubBal + in HashMap.fromList $ map f $ filter g xbals + go m = + isXPubCached xpub >>= \case + True -> do + process + False -> case m of + True -> do + us <- lift $ xPubUnspents xpub xbals limits + return us + False -> do + newXPubC xpub xbals + go True + process = do + ops <- map snd <$> cacheGetXPubUnspents xpub limits + uns <- catMaybes <$> lift (mapM getUnspent ops) + let f u = + either + (const Nothing) + (\a -> Just (a, u)) + (scriptToAddressBS (unspentScript u)) + g a = HashMap.lookup a xm + h u x = + XPubUnspent + { xPubUnspent = u, + xPubUnspentPath = xPubBalPath x + } + us = mapMaybe f uns + i a u = h u <$> g a + incrementCounter cacheXPubUnspents (length us) + return $ mapMaybe (uncurry i) us + +getXPubBalances :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + XPubSpec -> + CacheX m [XPubBal] +getXPubBalances xpub = + isXPubCached xpub >>= \case + True -> do + xbals <- cacheGetXPubBalances xpub + incrementCounter cacheXPubBals (length xbals) + return xbals + False -> do + bals <- lift $ xPubBals xpub + newXPubC xpub bals + return bals + +isInCache :: MonadLoggerIO m => XPubSpec -> CacheT m Bool +isInCache xpub = + ask >>= \case + Nothing -> return False + Just cfg -> runReaderT (isXPubCached xpub) cfg + +isXPubCached :: MonadLoggerIO m => XPubSpec -> CacheX m Bool +isXPubCached xpub = do + cached <- runRedis (redisIsXPubCached xpub) + if cached + then incrementCounter cacheHits 1 + else incrementCounter cacheMisses 1 + return cached + +redisIsXPubCached :: RedisCtx m f => XPubSpec -> m (f Bool) +redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub) + +cacheGetXPubBalances :: MonadLoggerIO m => XPubSpec -> CacheX m [XPubBal] +cacheGetXPubBalances xpub = do + bals <- runRedis $ redisGetXPubBalances xpub + touchKeys [xpub] + return bals + +cacheGetXPubTxCount :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + XPubSpec -> + CacheX m Word32 +cacheGetXPubTxCount xpub = do + count <- fromInteger <$> runRedis (redisGetXPubTxCount xpub) + touchKeys [xpub] + return count + +redisGetXPubTxCount :: RedisCtx m f => XPubSpec -> m (f Integer) +redisGetXPubTxCount xpub = Redis.zcard (txSetPfx <> encode xpub) + +cacheGetXPubTxs :: + (StoreReadBase m, MonadLoggerIO m) => + XPubSpec -> + Limits -> + CacheX m [TxRef] +cacheGetXPubTxs xpub limits = + case start limits of + Nothing -> + go1 Nothing + Just (AtTx th) -> + lift (getTxData th) >>= \case + Just TxData {txDataBlock = b@BlockRef {}} -> + go1 $ Just (blockRefScore b) + _ -> + go2 th + Just (AtBlock h) -> + go1 (Just (blockRefScore (BlockRef h maxBound))) + where + go1 score = do + xs <- + runRedis $ + getFromSortedSet + (txSetPfx <> encode xpub) + score + (offset limits) + (limit limits) + touchKeys [xpub] + return $ map (uncurry f) xs + go2 hash = do + xs <- + runRedis $ + getFromSortedSet + (txSetPfx <> encode xpub) + Nothing + 0 + 0 + touchKeys [xpub] + let xs' = + if any ((== hash) . fst) xs + then dropWhile ((/= hash) . fst) xs + else [] + return $ + map (uncurry f) $ + l $ + drop (fromIntegral (offset limits)) xs' + l = + if limit limits > 0 + then take (fromIntegral (limit limits)) + else id + f t s = TxRef {txRefHash = t, txRefBlock = scoreBlockRef s} + +cacheGetXPubUnspents :: + (StoreReadBase m, MonadLoggerIO m) => + XPubSpec -> + Limits -> + CacheX m [(BlockRef, OutPoint)] +cacheGetXPubUnspents xpub limits = + case start limits of + Nothing -> + go1 Nothing + Just (AtTx th) -> + lift (getTxData th) >>= \case + Just TxData {txDataBlock = b@BlockRef {}} -> + go1 (Just (blockRefScore b)) + _ -> + go2 th + Just (AtBlock h) -> + go1 (Just (blockRefScore (BlockRef h maxBound))) + where + go1 score = do + xs <- + runRedis $ + getFromSortedSet + (utxoPfx <> encode xpub) + score + (offset limits) + (limit limits) + touchKeys [xpub] + return $ map (uncurry f) xs + go2 hash = do + xs <- + runRedis $ + getFromSortedSet + (utxoPfx <> encode xpub) + Nothing + 0 + 0 + touchKeys [xpub] + let xs' = + if any ((== hash) . outPointHash . fst) xs + then dropWhile ((/= hash) . outPointHash . fst) xs + else [] + return $ + map (uncurry f) $ + l $ + drop (fromIntegral (offset limits)) xs' + l = + if limit limits > 0 + then take (fromIntegral (limit limits)) + else id + f o s = (scoreBlockRef s, o) + +redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal]) +redisGetXPubBalances xpub = + fmap (sort . map (uncurry f)) <$> getAllFromMap (balancesPfx <> encode xpub) + where + f p b = XPubBal {xPubBalPath = p, xPubBal = b} + +blockRefScore :: BlockRef -> Double +blockRefScore BlockRef {blockRefHeight = h, blockRefPos = p} = + fromIntegral (0x001fffffffffffff - (h' .|. p')) + where + h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64 + p' = (fromIntegral p .&. 0x03ffffff) :: Word64 +blockRefScore MemRef {memRefTime = t} = negate t' + where + t' = fromIntegral (t .&. 0x001fffffffffffff) + +scoreBlockRef :: Double -> BlockRef +scoreBlockRef s + | s < 0 = MemRef {memRefTime = n} + | otherwise = BlockRef {blockRefHeight = h, blockRefPos = p} + where + n = truncate (abs s) :: Word64 + m = 0x001fffffffffffff - n + h = fromIntegral (m `shift` (-26)) + p = fromIntegral (m .&. 0x03ffffff) + +getFromSortedSet :: + (Applicative f, RedisCtx m f, Serialize a) => + ByteString -> + Maybe Double -> + Word32 -> + Word32 -> + m (f [(a, Double)]) +getFromSortedSet key Nothing off 0 = do + xs <- zrangeWithscores key (fromIntegral off) (-1) + return $ do + ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs + return (rights ys) +getFromSortedSet key Nothing off count = do + xs <- + zrangeWithscores + key + (fromIntegral off) + (fromIntegral off + fromIntegral count - 1) + return $ do + ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs + return (rights ys) +getFromSortedSet key (Just score) off 0 = do + xs <- + zrangebyscoreWithscoresLimit + key + score + (1 / 0) + (fromIntegral off) + (-1) + return $ do + ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs + return (rights ys) +getFromSortedSet key (Just score) off count = do + xs <- + zrangebyscoreWithscoresLimit + key + score + (1 / 0) + (fromIntegral off) + (fromIntegral count) + return $ do + ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs + return (rights ys) + +getAllFromMap :: + (Functor f, RedisCtx m f, Serialize k, Serialize v) => + ByteString -> + m (f [(k, v)]) +getAllFromMap n = do + fxs <- hgetall n + return $ do + xs <- fxs + return + [ (k, v) + | (k', v') <- xs, + let Right k = decode k', + let Right v = decode v' + ] + +data CacheWriterMessage + = CacheNewBlock + | CacheNewTx TxHash + +type CacheWriterInbox = Inbox CacheWriterMessage + +type CacheWriter = Mailbox CacheWriterMessage + +data AddressXPub = AddressXPub + { addressXPubSpec :: !XPubSpec, + addressXPubPath :: ![KeyIndex] + } + deriving (Show, Eq, Generic, NFData, Serialize) + +mempoolSetKey :: ByteString +mempoolSetKey = "mempool" + +addrPfx :: ByteString +addrPfx = "a" + +bestBlockKey :: ByteString +bestBlockKey = "head" + +maxKey :: ByteString +maxKey = "max" + +xPubAddrFunction :: DeriveType -> XPubKey -> Address +xPubAddrFunction DeriveNormal = xPubAddr +xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr +xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr + +cacheWriter :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + CacheConfig -> + CacheWriterInbox -> + m () +cacheWriter cfg inbox = + runReaderT go cfg + where + go = do + newBlockC + syncMempoolC + forever $ do + x <- receive inbox + cacheWriterReact x + +lockIt :: MonadLoggerIO m => CacheX m (Maybe Word32) +lockIt = do + rnd <- liftIO randomIO + go rnd >>= \case + Right Redis.Ok -> do + $(logDebugS) "Cache" $ + "Acquired lock with value " <> cs (show rnd) + incrementCounter cacheLockAcquired 1 + return (Just rnd) + Right Redis.Pong -> do + $(logErrorS) + "Cache" + "Unexpected pong when acquiring lock" + incrementCounter cacheLockFailed 1 + return Nothing + Right (Redis.Status s) -> do + $(logErrorS) "Cache" $ + "Unexpected status acquiring lock: " <> cs s + incrementCounter cacheLockFailed 1 + return Nothing + Left (Redis.Bulk Nothing) -> do + $(logDebugS) "Cache" "Lock already taken" + incrementCounter cacheLockFailed 1 + return Nothing + Left e -> do + $(logErrorS) + "Cache" + "Error when trying to acquire lock" + incrementCounter cacheLockFailed 1 + throwIO (RedisError e) + where + go rnd = do + conn <- asks cacheConn + liftIO . Redis.runRedis conn $ do + let opts = + Redis.SetOpts + { Redis.setSeconds = Just 300, + Redis.setMilliseconds = Nothing, + Redis.setCondition = Just Redis.Nx + } + Redis.setOpts "lock" (cs (show rnd)) opts + +unlockIt :: MonadLoggerIO m => Maybe Word32 -> CacheX m () +unlockIt Nothing = return () +unlockIt (Just i) = + runRedis (Redis.get "lock") >>= \case + Nothing -> + $(logErrorS) "Cache" $ + "Not releasing lock with value " <> cs (show i) + <> ": not locked" + Just bs -> + if read (cs bs) == i + then do + void $ runRedis (Redis.del ["lock"]) + $(logDebugS) "Cache" $ + "Released lock with value " + <> cs (show i) + incrementCounter cacheLockReleased 1 + else + $(logErrorS) "Cache" $ + "Could not release lock: value is not " + <> cs (show i) + +withLock :: + (MonadLoggerIO m, MonadUnliftIO m) => + CacheX m a -> + CacheX m (Maybe a) +withLock f = + bracket lockIt unlockIt $ \case + Just _ -> Just <$> f + Nothing -> return Nothing + +smallDelay :: MonadUnliftIO m => CacheX m () +smallDelay = do + delay <- asks cacheRetryDelay + let delayMin = delay `div` 2 + let delayMax = delay * 3 `div` 2 + threadDelay =<< liftIO (randomRIO (delayMin, delayMax)) + +withLockForever :: + (MonadLoggerIO m, MonadUnliftIO m) => + CacheX m a -> + CacheX m a +withLockForever go = + withLock go >>= \case + Nothing -> do + smallDelay + $(logDebugS) "Cache" "Retrying lock aquisition without limits" + withLockForever go + Just x -> return x + +withLockRetry :: + (MonadLoggerIO m, MonadUnliftIO m) => + Int -> + CacheX m a -> + CacheX m (Maybe a) +withLockRetry i f + | i <= 0 = return Nothing + | otherwise = + withLock f >>= \case + Nothing -> do + smallDelay + $(logDebugS) "Cache" $ + "Retrying lock acquisition: " + <> cs (show i) + <> " tries remaining" + withLockRetry (i - 1) f + x -> return x + +pruneDB :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + CacheX m Integer +pruneDB = do + x <- asks cacheMax + s <- runRedis Redis.dbsize + if s > x then flush (s - x) else return 0 + where + flush n = + case n `div` 64 of + 0 -> return 0 + x -> fmap (fromMaybe 0) $ + withLock $ do + ks <- + fmap (map fst) . runRedis $ + getFromSortedSet maxKey Nothing 0 (fromIntegral x) + $(logDebugS) "Cache" $ + "Pruning " <> cs (show (length ks)) <> " old xpubs" + delXPubKeys ks + +touchKeys :: MonadLoggerIO m => [XPubSpec] -> CacheX m () +touchKeys xpubs = do + now <- systemSeconds <$> liftIO getSystemTime + runRedis $ redisTouchKeys now xpubs + +redisTouchKeys :: (Monad f, RedisCtx m f, Real a) => a -> [XPubSpec] -> m (f ()) +redisTouchKeys _ [] = return $ return () +redisTouchKeys now xpubs = + void <$> Redis.zadd maxKey (map ((realToFrac now,) . encode) xpubs) + +cacheWriterReact :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + CacheWriterMessage -> + CacheX m () +cacheWriterReact CacheNewBlock = + doSync +cacheWriterReact (CacheNewTx txid) = + withLock go >>= \case + Just () -> return () + Nothing -> smallDelay >> cacheWriterReact (CacheNewTx txid) + where + hex = txHashToHex txid + go = + $(logDebugS) "Cache" ("Locking to import tx: " <> hex) + >> cacheIsInMempool txid >>= \case + True -> + $(logDebugS) "Cache" $ "Already imported tx: " <> hex + False -> + lift (getTxData txid) >>= mapM_ \tx -> do + $(logDebugS) "Cache" $ "Importing mempool tx: " <> hex + importMultiTxC [tx] + +doSync :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + CacheX m () +doSync = newBlockC >> void pruneDB + +lenNotNull :: [XPubBal] -> Int +lenNotNull = length . filter (not . nullBalance . xPubBal) + +newXPubC :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + XPubSpec -> + [XPubBal] -> + CacheX m () +newXPubC xpub xbals = + should_index >>= \i -> when i $ + bracket set_index unset_index $ \j -> when j $ + withMetrics cacheIndexTime $ do + xpubtxt <- xpubText xpub + $(logDebugS) "Cache" $ + "Caching " <> xpubtxt <> ": " + <> cs (show (length xbals)) + <> " addresses / " + <> cs (show (lenNotNull xbals)) + <> " used" + utxo <- lift $ xPubUnspents xpub xbals def + $(logDebugS) "Cache" $ + "Caching " <> xpubtxt <> ": " <> cs (show (length utxo)) + <> " utxos" + xtxs <- lift $ xPubTxs xpub xbals def + $(logDebugS) "Cache" $ + "Caching " <> xpubtxt <> ": " <> cs (show (length xtxs)) + <> " txs" + now <- systemSeconds <$> liftIO getSystemTime + runRedis $ do + b <- redisTouchKeys now [xpub] + c <- redisAddXPubBalances xpub xbals + d <- redisAddXPubUnspents xpub (map op utxo) + e <- redisAddXPubTxs xpub xtxs + return $ b >> c >> d >> e >> return () + $(logDebugS) "Cache" $ "Cached " <> xpubtxt + where + op XPubUnspent {xPubUnspent = u} = (unspentPoint u, unspentBlock u) + should_index = + asks cacheMin >>= \x -> + if x <= lenNotNull xbals then inSync else return False + key = idxPfx <> encode xpub + opts = + Redis.SetOpts + { Redis.setSeconds = Just 600, + Redis.setMilliseconds = Nothing, + Redis.setCondition = Just Redis.Nx + } + red = Redis.setOpts key "1" opts + unset_index y = when y . void . runRedis $ Redis.del [key] + set_index = + asks cacheConn >>= \conn -> + liftIO (Redis.runRedis conn red) >>= return . isRight + +inSync :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + CacheX m Bool +inSync = + lift getBestBlock >>= \case + Nothing -> return False + Just bb -> + asks cacheChain >>= \ch -> + chainGetBest ch >>= \cb -> + return $ headerHash (nodeHeader cb) == bb + +newBlockC :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + CacheX m () +newBlockC = + inSync >>= \s -> + when s $ + asks cacheChain >>= \ch -> + chainGetBest ch >>= \bn -> + cacheGetHead >>= \case + Nothing -> + $(logInfoS) "Cache" "Initializing best cache block" + >> withLock (do_import bn) >>= \case + Nothing -> smallDelay >> newBlockC + Just () -> return () + Just hb -> + if hb == headerHash (nodeHeader bn) + then $(logDebugS) "Cache" "Cache in sync" + else + withLock (sync ch hb bn) >>= \case + Nothing -> smallDelay >> newBlockC + Just () -> return () + where + sync ch hb bn = + chainGetBlock hb ch >>= \case + Nothing -> do + $(logErrorS) "Cache" $ + "Cache head block node not found: " + <> blockHashToHex hb + throwIO $ + LogicError $ + "Cache head block node not found: " + <> cs (blockHashToHex hb) + Just hn -> + chainBlockMain hb ch >>= \m -> + if m + then next ch bn hn + else do + $(logDebugS) "Cache" $ + "Reverting cache head not in main chain: " + <> blockHashToHex hb + removeHeadC hb + cacheGetHead >>= \case + Nothing -> do_import bn + Just hb' -> sync ch hb' bn + next ch bn hn = + if + | prevBlock (nodeHeader bn) == headerHash (nodeHeader hn) -> + do_import bn + | nodeHeight bn > nodeHeight hn -> + chainGetAncestor (nodeHeight hn + 1) bn ch >>= \case + Nothing -> do + $(logErrorS) "Cache" $ + "Ancestor not found at height " + <> cs (show (nodeHeight hn + 1)) + <> " for block: " + <> blockHashToHex (headerHash (nodeHeader bn)) + throwIO $ + LogicError $ + "Ancestor not found at height " + <> show (nodeHeight hn + 1) + <> " for block: " + <> cs (blockHashToHex (headerHash (nodeHeader bn))) + Just hn' -> do + do_import hn' + next ch bn hn' + | otherwise -> + $(logInfoS) "Cache" "Cache best block higher than this node's" + do_import = importBlockC . headerHash . nodeHeader + +importBlockC :: + (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) => + BlockHash -> + CacheX m () +importBlockC bh = + lift (getBlock bh) >>= \case + Just bd -> do + let ths = blockDataTxs bd + tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths + $(logDebugS) "Cache" $ + "Importing " <> cs (show (length tds)) + <> " transactions from block " + <> blockHashToHex bh + importMultiTxC tds + $(logDebugS) "Cache" $ + "Done importing " <> cs (show (length tds)) + <> " transactions from block " + <> blockHashToHex bh + cacheSetHead bh + Nothing -> do + $(logErrorS) "Cache" $ + "Could not get block: " + <> blockHashToHex bh + throwIO . LogicError . cs $ + "Could not get block: " + <> blockHashToHex bh + +removeHeadC :: + (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) => + BlockHash -> + CacheX m () +removeHeadC cb = + void . runMaybeT $ do + bh <- MaybeT cacheGetHead + guard (cb == bh) + bd <- MaybeT (lift (getBlock bh)) + lift $ do + tds <- + sortTxData . catMaybes + <$> mapM (lift . getTxData) (blockDataTxs bd) + $(logDebugS) "Cache" $ "Reverting head: " <> blockHashToHex bh + importMultiTxC tds + $(logWarnS) "Cache" $ + "Reverted block head " + <> blockHashToHex bh + <> " to parent " + <> blockHashToHex (prevBlock (blockDataHeader bd)) + cacheSetHead (prevBlock (blockDataHeader bd)) + +importMultiTxC :: + (MonadUnliftIO m, StoreReadExtra m, MonadLoggerIO m) => + [TxData] -> + CacheX m () +importMultiTxC txs = do + $(logDebugS) "Cache" $ "Processing " <> cs (show (length txs)) <> " txs" + $(logDebugS) "Cache" $ + "Getting address information for " + <> cs (show (length alladdrs)) + <> " addresses" + addrmap <- getaddrmap + let addrs = HashMap.keys addrmap + $(logDebugS) "Cache" $ + "Getting balances for " + <> cs (show (HashMap.size addrmap)) + <> " addresses" + balmap <- getbalances addrs + $(logDebugS) "Cache" $ + "Getting unspent data for " + <> cs (show (length allops)) + <> " outputs" + unspentmap <- getunspents + gap <- lift getMaxGap + now <- systemSeconds <$> liftIO getSystemTime + let xpubs = allxpubsls addrmap + forM_ (zip [(1 :: Int) ..] xpubs) $ \(i, xpub) -> do + xpubtxt <- xpubText xpub + $(logDebugS) "Cache" $ + "Affected xpub " + <> cs (show i) + <> "/" + <> cs (show (length xpubs)) + <> ": " + <> xpubtxt + addrs' <- do + $(logDebugS) "Cache" $ + "Getting xpub balances for " + <> cs (show (length xpubs)) + <> " xpubs" + xmap <- getxbals xpubs + let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap + $(logDebugS) "Cache" "Starting Redis import pipeline" + runRedis $ do + x <- redisImportMultiTx addrmap' unspentmap txs + y <- redisUpdateBalances addrmap' balmap + z <- redisTouchKeys now (HashMap.keys xmap) + return $ x >> y >> z >> return () + $(logDebugS) "Cache" "Completed Redis pipeline" + return $ getNewAddrs gap xmap (HashMap.elems addrmap') + cacheAddAddresses addrs' + where + alladdrsls = HashSet.toList alladdrs + faddrmap xmap = HashMap.filter (\a -> addressXPubSpec a `elem` xmap) + getaddrmap = + HashMap.fromList . catMaybes . zipWith (\a -> fmap (a,)) alladdrsls + <$> cacheGetAddrsInfo alladdrsls + getunspents = + HashMap.fromList . catMaybes . zipWith (\p -> fmap (p,)) allops + <$> lift (mapM getUnspent allops) + getbalances addrs = + HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs + getxbals xpubs = do + bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do + bs <- redisGetXPubBalances xpub + return $ (,) xpub <$> bs + return $ HashMap.filter (not . null) (HashMap.fromList bals) + allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs + alladdrs = + HashSet.fromList . map fst $ + concatMap txInputs txs <> concatMap txOutputs txs + allxpubsls addrmap = HashSet.toList (allxpubs addrmap) + allxpubs addrmap = + HashSet.fromList . map addressXPubSpec $ HashMap.elems addrmap + +redisImportMultiTx :: + (Monad f, RedisCtx m f) => + HashMap Address AddressXPub -> + HashMap OutPoint Unspent -> + [TxData] -> + m (f ()) +redisImportMultiTx addrmap unspentmap txs = do + xs <- mapM importtxentries txs + return $ sequence_ xs + where + uns p i = + case HashMap.lookup p unspentmap of + Just u -> + redisAddXPubUnspents (addressXPubSpec i) [(p, unspentBlock u)] + Nothing -> redisRemXPubUnspents (addressXPubSpec i) [p] + addtx tx a p = + case HashMap.lookup a addrmap of + Just i -> do + let tr = + TxRef + { txRefHash = txHash (txData tx), + txRefBlock = txDataBlock tx + } + x <- redisAddXPubTxs (addressXPubSpec i) [tr] + y <- uns p i + return $ x >> y >> return () + Nothing -> return (pure ()) + remtx tx a p = + case HashMap.lookup a addrmap of + Just i -> do + x <- redisRemXPubTxs (addressXPubSpec i) [txHash (txData tx)] + y <- uns p i + return $ x >> y >> return () + Nothing -> return (pure ()) + importtxentries tx = + if txDataDeleted tx + then do + x <- mapM (uncurry (remtx tx)) (txaddrops tx) + y <- redisRemFromMempool [txHash (txData tx)] + return $ sequence_ x >> void y + else do + a <- sequence <$> mapM (uncurry (addtx tx)) (txaddrops tx) + b <- + case txDataBlock tx of + b@MemRef {} -> + let tr = + TxRef + { txRefHash = txHash (txData tx), + txRefBlock = b + } + in redisAddToMempool [tr] + _ -> redisRemFromMempool [txHash (txData tx)] + return $ a >> b >> return () + txaddrops td = txInputs td <> txOutputs td + +redisUpdateBalances :: + (Monad f, RedisCtx m f) => + HashMap Address AddressXPub -> + HashMap Address Balance -> + m (f ()) +redisUpdateBalances addrmap balmap = + fmap (fmap mconcat . sequence) . forM (HashMap.keys addrmap) $ \a -> + case (HashMap.lookup a addrmap, HashMap.lookup a balmap) of + (Just ainfo, Just bal) -> + redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal] + _ -> return (pure ()) + where + xpubbal ainfo bal = + XPubBal {xPubBalPath = addressXPubPath ainfo, xPubBal = bal} + +cacheAddAddresses :: + (StoreReadExtra m, MonadUnliftIO m, MonadLoggerIO m) => + [(Address, AddressXPub)] -> + CacheX m () +cacheAddAddresses [] = $(logDebugS) "Cache" "No further addresses to add" +cacheAddAddresses addrs = do + $(logDebugS) "Cache" $ + "Adding " <> cs (show (length addrs)) <> " new generated addresses" + $(logDebugS) "Cache" "Getting balances" + balmap <- HashMap.fromListWith (<>) <$> mapM (uncurry getbal) addrs + $(logDebugS) "Cache" "Getting unspent outputs" + utxomap <- HashMap.fromListWith (<>) <$> mapM (uncurry getutxo) addrs + $(logDebugS) "Cache" "Getting transactions" + txmap <- HashMap.fromListWith (<>) <$> mapM (uncurry gettxmap) addrs + $(logDebugS) "Cache" "Running Redis pipeline" + runRedis $ do + a <- forM (HashMap.toList balmap) (uncurry redisAddXPubBalances) + b <- forM (HashMap.toList utxomap) (uncurry redisAddXPubUnspents) + c <- forM (HashMap.toList txmap) (uncurry redisAddXPubTxs) + return $ sequence_ a >> sequence_ b >> sequence_ c + $(logDebugS) "Cache" "Completed Redis pipeline" + let xpubs = + HashSet.toList + . HashSet.fromList + . map addressXPubSpec + $ Map.elems amap + $(logDebugS) "Cache" "Getting xpub balances" + xmap <- getbals xpubs + gap <- lift getMaxGap + let notnulls = getnotnull balmap + addrs' = getNewAddrs gap xmap notnulls + cacheAddAddresses addrs' + where + getbals xpubs = runRedis $ do + bs <- sequence <$> forM xpubs redisGetXPubBalances + return $ + HashMap.filter (not . null) . HashMap.fromList . zip xpubs <$> bs + amap = Map.fromList addrs + getnotnull = + let f xpub = + map $ \bal -> + AddressXPub + { addressXPubSpec = xpub, + addressXPubPath = xPubBalPath bal + } + g = filter (not . nullBalance . xPubBal) + in concatMap (uncurry f) . HashMap.toList . HashMap.map g + getbal a i = + let f b = + ( addressXPubSpec i, + [XPubBal {xPubBal = b, xPubBalPath = addressXPubPath i}] + ) + in f <$> lift (getDefaultBalance a) + getutxo a i = + let f us = + ( addressXPubSpec i, + map (\u -> (unspentPoint u, unspentBlock u)) us + ) + in f <$> lift (getAddressUnspents a def) + gettxmap a i = + let f ts = (addressXPubSpec i, ts) + in f <$> lift (getAddressTxs a def) + +getNewAddrs :: + KeyIndex -> + HashMap XPubSpec [XPubBal] -> + [AddressXPub] -> + [(Address, AddressXPub)] +getNewAddrs gap xpubs = + concatMap $ \a -> + case HashMap.lookup (addressXPubSpec a) xpubs of + Nothing -> [] + Just bals -> addrsToAdd gap bals a + +syncMempoolC :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => + CacheX m () +syncMempoolC = void . withLockForever $ do + nodepool <- HashSet.fromList . map snd <$> lift getMempool + cachepool <- HashSet.fromList . map snd <$> cacheGetMempool + getem (HashSet.difference nodepool cachepool) + getem (HashSet.difference cachepool nodepool) + where + getem tset = do + let tids = HashSet.toList tset + txs <- catMaybes <$> mapM (lift . getTxData) tids + unless (null txs) $ do + $(logDebugS) "Cache" $ + "Importing mempool transactions: " <> cs (show (length txs)) + importMultiTxC txs + +cacheGetMempool :: MonadLoggerIO m => CacheX m [(UnixTime, TxHash)] +cacheGetMempool = runRedis redisGetMempool + +cacheIsInMempool :: MonadLoggerIO m => TxHash -> CacheX m Bool +cacheIsInMempool = runRedis . redisIsInMempool + +cacheGetHead :: MonadLoggerIO m => CacheX m (Maybe BlockHash) +cacheGetHead = runRedis redisGetHead + +cacheSetHead :: (MonadLoggerIO m, StoreReadBase m) => BlockHash -> CacheX m () +cacheSetHead bh = do + $(logDebugS) "Cache" $ "Cache head set to: " <> blockHashToHex bh + void $ runRedis (redisSetHead bh) + +cacheGetAddrsInfo :: + MonadLoggerIO m => [Address] -> CacheX m [Maybe AddressXPub] +cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as) + +redisAddToMempool :: (Applicative f, RedisCtx m f) => [TxRef] -> m (f Integer) +redisAddToMempool [] = return (pure 0) +redisAddToMempool btxs = + zadd mempoolSetKey $ + map + (\btx -> (blockRefScore (txRefBlock btx), encode (txRefHash btx))) + btxs + +redisIsInMempool :: (Applicative f, RedisCtx m f) => TxHash -> m (f Bool) +redisIsInMempool txid = + fmap isJust <$> Redis.zrank mempoolSetKey (encode txid) + +redisRemFromMempool :: + (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer) +redisRemFromMempool [] = return (pure 0) +redisRemFromMempool xs = zrem mempoolSetKey $ map encode xs + +redisSetAddrInfo :: + (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ()) +redisSetAddrInfo a i = void <$> Redis.set (addrPfx <> encode a) (encode i) + +cacheDelXPubs :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + [XPubSpec] -> + CacheT m Integer +cacheDelXPubs xpubs = ReaderT $ \case + Just cache -> runReaderT (delXPubKeys xpubs) cache + Nothing -> return 0 + +delXPubKeys :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + [XPubSpec] -> + CacheX m Integer +delXPubKeys [] = return 0 +delXPubKeys xpubs = do + forM_ xpubs $ \x -> do + xtxt <- xpubText x + $(logDebugS) "Cache" $ "Deleting xpub: " <> xtxt + xbals <- + runRedis . fmap sequence . forM xpubs $ \xpub -> do + bs <- redisGetXPubBalances xpub + return $ (xpub,) <$> bs + runRedis $ fmap sum . sequence <$> forM xbals (uncurry redisDelXPubKeys) + +redisDelXPubKeys :: + (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f Integer) +redisDelXPubKeys xpub bals = go (map (balanceAddress . xPubBal) bals) + where + go addrs = do + addrcount <- + case addrs of + [] -> return (pure 0) + _ -> Redis.del (map ((addrPfx <>) . encode) addrs) + txsetcount <- Redis.del [txSetPfx <> encode xpub] + utxocount <- Redis.del [utxoPfx <> encode xpub] + balcount <- Redis.del [balancesPfx <> encode xpub] + x <- Redis.zrem maxKey [encode xpub] + return $ do + _ <- x + addrs' <- addrcount + txset' <- txsetcount + utxo' <- utxocount + bal' <- balcount + return $ addrs' + txset' + utxo' + bal' + +redisAddXPubTxs :: + (Applicative f, RedisCtx m f) => XPubSpec -> [TxRef] -> m (f Integer) +redisAddXPubTxs _ [] = return (pure 0) +redisAddXPubTxs xpub btxs = + zadd (txSetPfx <> encode xpub) $ + map (\t -> (blockRefScore (txRefBlock t), encode (txRefHash t))) btxs + +redisRemXPubTxs :: + (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer) +redisRemXPubTxs _ [] = return (pure 0) +redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs) + +redisAddXPubUnspents :: + (Applicative f, RedisCtx m f) => + XPubSpec -> + [(OutPoint, BlockRef)] -> + m (f Integer) +redisAddXPubUnspents _ [] = + return (pure 0) +redisAddXPubUnspents xpub utxo = + zadd (utxoPfx <> encode xpub) $ + map (\(p, r) -> (blockRefScore r, encode p)) utxo + +redisRemXPubUnspents :: + (Applicative f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f Integer) +redisRemXPubUnspents _ [] = + return (pure 0) +redisRemXPubUnspents xpub ops = + zrem (utxoPfx <> encode xpub) (map encode ops) + +redisAddXPubBalances :: + (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ()) +redisAddXPubBalances _ [] = return (pure ()) +redisAddXPubBalances xpub bals = do + xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries + ys <- forM bals $ \b -> + redisSetAddrInfo + (balanceAddress (xPubBal b)) + AddressXPub + { addressXPubSpec = xpub, + addressXPubPath = xPubBalPath b + } + return $ sequence_ xs >> sequence_ ys + where + entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals + +redisSetHead :: RedisCtx m f => BlockHash -> m (f Redis.Status) +redisSetHead bh = Redis.set bestBlockKey (encode bh) + +redisGetAddrsInfo :: + (Monad f, RedisCtx m f) => [Address] -> m (f [Maybe AddressXPub]) +redisGetAddrsInfo [] = return (pure []) +redisGetAddrsInfo as = do + is <- mapM (\a -> Redis.get (addrPfx <> encode a)) as + return $ do + is' <- sequence is + return $ map (eitherToMaybe . decode =<<) is' + +addrsToAdd :: KeyIndex -> [XPubBal] -> AddressXPub -> [(Address, AddressXPub)] +addrsToAdd gap xbals addrinfo + | null fbals = [] + | otherwise = zipWith f addrs list + where + f a p = (a, AddressXPub {addressXPubSpec = xpub, addressXPubPath = p}) + dchain = head (addressXPubPath addrinfo) + fbals = filter ((== dchain) . head . xPubBalPath) xbals + maxidx = maximum (map (head . tail . xPubBalPath) fbals) + xpub = addressXPubSpec addrinfo + aidx = (head . tail) (addressXPubPath addrinfo) + ixs = + if gap > maxidx - aidx + then [maxidx + 1 .. aidx + gap] + else [] + paths = map (Deriv :/ dchain :/) ixs + keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths + list = map pathToList paths + xpubf = xPubAddrFunction (xPubDeriveType xpub) + addrs = map xpubf keys + +sortTxData :: [TxData] -> [TxData] +sortTxData tds = + let txm = Map.fromList (map (\d -> (txHash (txData d), d)) tds) + ths = map (txHash . snd) (sortTxs (map txData tds)) + in mapMaybe (`Map.lookup` txm) ths + +txInputs :: TxData -> [(Address, OutPoint)] +txInputs td = + let is = txIn (txData td) + ps = I.toAscList (txDataPrevs td) + as = map (scriptToAddressBS . prevScript . snd) ps + f (Right a) i = Just (a, prevOutput i) + f (Left _) _ = Nothing + in catMaybes (zipWith f as is) + +txOutputs :: TxData -> [(Address, OutPoint)] +txOutputs td = + let ps = + zipWith + ( \i _ -> + OutPoint + { outPointHash = txHash (txData td), + outPointIndex = i + } + ) + [0 ..] + (txOut (txData td)) + as = map (scriptToAddressBS . scriptOutput) (txOut (txData td)) + f (Right a) p = Just (a, p) + f (Left _) _ = Nothing + in catMaybes (zipWith f as ps) + +redisGetHead :: (Functor f, RedisCtx m f) => m (f (Maybe BlockHash)) +redisGetHead = do + x <- Redis.get bestBlockKey + return $ (eitherToMaybe . decode =<<) <$> x + +redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [(UnixTime, TxHash)]) +redisGetMempool = do + xs <- getFromSortedSet mempoolSetKey Nothing 0 0 + return $ map (uncurry f) <$> xs + where + f t s = (memRefTime (scoreBlockRef s), t) + +xpubText :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + XPubSpec -> + CacheX m Text +xpubText xpub = do + net <- lift getNetwork + let suffix = case xPubDeriveType xpub of + DeriveNormal -> "" + DeriveP2SH -> "/p2sh" + DeriveP2WPKH -> "/p2wpkh" + return . cs $ suffix <> xPubExport net (xPubSpecKey xpub) cacheNewBlock :: MonadIO m => CacheWriter -> m () cacheNewBlock = send CacheNewBlock 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 @@ -7,8 +7,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.Common ( - Limits (..), +module Haskoin.Store.Common + ( Limits (..), Start (..), StoreReadBase (..), StoreReadExtra (..), @@ -39,10 +39,11 @@ streamThings, joinDescStreams, createDataMetrics, -) where + ) +where -import Conduit ( - ConduitT, +import Conduit + ( ConduitT, await, dropC, mapC, @@ -50,7 +51,7 @@ takeC, yield, ($$++), - ) + ) import Control.DeepSeq (NFData) import Control.Exception (Exception) import Control.Monad (forM) @@ -68,15 +69,15 @@ import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..)) import Data.Serialize (Serialize (..)) -import Data.Time.Clock.System ( - getSystemTime, +import Data.Time.Clock.System + ( getSystemTime, systemNanoseconds, systemSeconds, - ) + ) import Data.Word (Word32, Word64) import GHC.Generics (Generic) -import Haskoin ( - Address, +import Haskoin + ( Address, BlockHash, BlockHeader (..), BlockHeight, @@ -98,10 +99,10 @@ mtp, pubSubKey, txHash, - ) + ) import Haskoin.Node (Chain, Peer) -import Haskoin.Store.Data ( - Balance (..), +import Haskoin.Store.Data + ( Balance (..), BlockData (..), DeriveType (..), Spender, @@ -117,7 +118,7 @@ nullBalance, toTransaction, zeroBalance, - ) + ) import qualified System.Metrics as Metrics import System.Metrics.Counter (Counter) import qualified System.Metrics.Counter as Counter @@ -126,95 +127,96 @@ type DeriveAddr = XPubKey -> KeyIndex -> Address type Offset = Word32 + type Limit = Word32 data Start - = AtTx {atTxHash :: !TxHash} - | AtBlock {atBlockHeight :: !BlockHeight} - deriving (Eq, Show) + = AtTx {atTxHash :: !TxHash} + | AtBlock {atBlockHeight :: !BlockHeight} + deriving (Eq, Show) data Limits = Limits - { limit :: !Word32 - , offset :: !Word32 - , start :: !(Maybe Start) - } - deriving (Eq, Show) + { limit :: !Word32, + offset :: !Word32, + start :: !(Maybe Start) + } + deriving (Eq, Show) defaultLimits :: Limits -defaultLimits = Limits{limit = 0, offset = 0, start = Nothing} +defaultLimits = Limits {limit = 0, offset = 0, start = Nothing} instance Default Limits where - def = defaultLimits + def = defaultLimits class Monad m => StoreReadBase m where - getNetwork :: m Network - getBestBlock :: m (Maybe BlockHash) - getBlocksAtHeight :: BlockHeight -> m [BlockHash] - getBlock :: BlockHash -> m (Maybe BlockData) - getTxData :: TxHash -> m (Maybe TxData) - getSpender :: OutPoint -> m (Maybe Spender) - getBalance :: Address -> m (Maybe Balance) - getUnspent :: OutPoint -> m (Maybe Unspent) - getMempool :: m [(UnixTime, TxHash)] + getNetwork :: m Network + getBestBlock :: m (Maybe BlockHash) + getBlocksAtHeight :: BlockHeight -> m [BlockHash] + getBlock :: BlockHash -> m (Maybe BlockData) + getTxData :: TxHash -> m (Maybe TxData) + getSpender :: OutPoint -> m (Maybe Spender) + getBalance :: Address -> m (Maybe Balance) + getUnspent :: OutPoint -> m (Maybe Unspent) + getMempool :: m [(UnixTime, TxHash)] class StoreReadBase m => StoreReadExtra m where - getAddressesTxs :: [Address] -> Limits -> m [TxRef] - getAddressesUnspents :: [Address] -> Limits -> m [Unspent] - getInitialGap :: m Word32 - getMaxGap :: m Word32 - getNumTxData :: Word64 -> m [TxData] - getBalances :: [Address] -> m [Balance] - getAddressTxs :: Address -> Limits -> m [TxRef] - getAddressUnspents :: Address -> Limits -> m [Unspent] - xPubBals :: XPubSpec -> m [XPubBal] - xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent] - xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> m [TxRef] - xPubTxCount :: XPubSpec -> [XPubBal] -> m Word32 + getAddressesTxs :: [Address] -> Limits -> m [TxRef] + getAddressesUnspents :: [Address] -> Limits -> m [Unspent] + getInitialGap :: m Word32 + getMaxGap :: m Word32 + getNumTxData :: Word64 -> m [TxData] + getBalances :: [Address] -> m [Balance] + getAddressTxs :: Address -> Limits -> m [TxRef] + getAddressUnspents :: Address -> Limits -> m [Unspent] + xPubBals :: XPubSpec -> m [XPubBal] + xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent] + xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> m [TxRef] + xPubTxCount :: XPubSpec -> [XPubBal] -> m Word32 class StoreWrite m where - setBest :: BlockHash -> m () - insertBlock :: BlockData -> m () - setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m () - insertTx :: TxData -> m () - insertSpender :: OutPoint -> Spender -> m () - deleteSpender :: OutPoint -> m () - insertAddrTx :: Address -> TxRef -> m () - deleteAddrTx :: Address -> TxRef -> m () - insertAddrUnspent :: Address -> Unspent -> m () - deleteAddrUnspent :: Address -> Unspent -> m () - addToMempool :: TxHash -> UnixTime -> m () - deleteFromMempool :: TxHash -> m () - setBalance :: Balance -> m () - insertUnspent :: Unspent -> m () - deleteUnspent :: OutPoint -> m () + setBest :: BlockHash -> m () + insertBlock :: BlockData -> m () + setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m () + insertTx :: TxData -> m () + insertSpender :: OutPoint -> Spender -> m () + deleteSpender :: OutPoint -> m () + insertAddrTx :: Address -> TxRef -> m () + deleteAddrTx :: Address -> TxRef -> m () + insertAddrUnspent :: Address -> Unspent -> m () + deleteAddrUnspent :: Address -> Unspent -> m () + addToMempool :: TxHash -> UnixTime -> m () + deleteFromMempool :: TxHash -> m () + setBalance :: Balance -> m () + insertUnspent :: Unspent -> m () + deleteUnspent :: OutPoint -> m () getSpenders :: StoreReadBase m => TxHash -> m (IntMap Spender) getSpenders th = - getActiveTxData th >>= \case - Nothing -> return I.empty - Just td -> - I.fromList . catMaybes - <$> mapM get_spender [0 .. length (txOut (txData td)) - 1] + getActiveTxData th >>= \case + Nothing -> return I.empty + Just td -> + I.fromList . catMaybes + <$> mapM get_spender [0 .. length (txOut (txData td)) - 1] where get_spender i = fmap (i,) <$> getSpender (OutPoint th (fromIntegral i)) getActiveBlock :: StoreReadExtra m => BlockHash -> m (Maybe BlockData) getActiveBlock bh = - getBlock bh >>= \case - Just b | blockDataMainChain b -> return (Just b) - _ -> return Nothing + getBlock bh >>= \case + Just b | blockDataMainChain b -> return (Just b) + _ -> return Nothing getActiveTxData :: StoreReadBase m => TxHash -> m (Maybe TxData) getActiveTxData th = - getTxData th >>= \case - Just td | not (txDataDeleted td) -> return (Just td) - _ -> return Nothing + getTxData th >>= \case + Just td | not (txDataDeleted td) -> return (Just td) + _ -> return Nothing getDefaultBalance :: StoreReadBase m => Address -> m Balance getDefaultBalance a = - getBalance a >>= \case - Nothing -> return $ zeroBalance a - Just b -> return b + getBalance a >>= \case + Nothing -> return $ zeroBalance a + Just b -> return b deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)] deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..] @@ -226,117 +228,117 @@ xPubSummary :: XPubSpec -> [XPubBal] -> XPubSummary xPubSummary _xspec xbals = - XPubSummary - { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs) - , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs) - , xPubSummaryReceived = rx - , xPubUnspentCount = uc - , xPubChangeIndex = ch - , xPubExternalIndex = ex - } + XPubSummary + { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs), + xPubSummaryZero = sum (map (balanceZero . xPubBal) bs), + xPubSummaryReceived = rx, + xPubUnspentCount = uc, + xPubChangeIndex = ch, + xPubExternalIndex = ex + } where bs = filter (not . nullBalance . xPubBal) xbals - ex = foldl max 0 [i | XPubBal{xPubBalPath = [0, i]} <- bs] - ch = foldl max 0 [i | XPubBal{xPubBalPath = [1, i]} <- bs] + ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs] + ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs] uc = sum [balanceUnspentCount (xPubBal b) | b <- bs] - xt = [b | b@XPubBal{xPubBalPath = [0, _]} <- bs] + xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs] rx = sum [balanceTotalReceived (xPubBal b) | b <- xt] getTransaction :: - (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction) + (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction) getTransaction h = runMaybeT $ do - d <- MaybeT $ getTxData h - sm <- lift $ getSpenders h - return $ toTransaction d sm + d <- MaybeT $ getTxData h + sm <- lift $ getSpenders h + return $ toTransaction d sm getNumTransaction :: - (Monad m, StoreReadExtra m) => Word64 -> m [Transaction] + (Monad m, StoreReadExtra m) => Word64 -> m [Transaction] getNumTransaction i = do - ds <- getNumTxData i - forM ds $ \d -> do - sm <- getSpenders (txHash (txData d)) - return $ toTransaction d sm + ds <- getNumTxData i + forM ds $ \d -> do + sm <- getSpenders (txHash (txData d)) + return $ toTransaction d sm blockAtOrAfter :: - (MonadIO m, StoreReadExtra m) => - Chain -> - UnixTime -> - m (Maybe BlockData) + (MonadIO m, StoreReadExtra m) => + Chain -> + UnixTime -> + m (Maybe BlockData) blockAtOrAfter ch q = runMaybeT $ do - net <- lift getNetwork - x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch - MaybeT $ getBlock (headerHash (nodeHeader x)) + net <- lift getNetwork + x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch + MaybeT $ getBlock (headerHash (nodeHeader x)) where f x = - let t = fromIntegral (blockTimestamp (nodeHeader x)) - in return $ t `compare` q + let t = fromIntegral (blockTimestamp (nodeHeader x)) + in return $ t `compare` q blockAtOrBefore :: - (MonadIO m, StoreReadExtra m) => - Chain -> - UnixTime -> - m (Maybe BlockData) + (MonadIO m, StoreReadExtra m) => + Chain -> + UnixTime -> + m (Maybe BlockData) blockAtOrBefore ch q = runMaybeT $ do - net <- lift getNetwork - x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch - MaybeT $ getBlock (headerHash (nodeHeader x)) + net <- lift getNetwork + x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch + MaybeT $ getBlock (headerHash (nodeHeader x)) where f x = - let t = fromIntegral (blockTimestamp (nodeHeader x)) - in return $ t `compare` q + let t = fromIntegral (blockTimestamp (nodeHeader x)) + in return $ t `compare` q blockAtOrAfterMTP :: - (MonadIO m, StoreReadExtra m) => - Chain -> - UnixTime -> - m (Maybe BlockData) + (MonadIO m, StoreReadExtra m) => + Chain -> + UnixTime -> + m (Maybe BlockData) blockAtOrAfterMTP ch q = runMaybeT $ do - net <- lift getNetwork - x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch - MaybeT $ getBlock (headerHash (nodeHeader x)) + net <- lift getNetwork + x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch + MaybeT $ getBlock (headerHash (nodeHeader x)) where f x = do - t <- fromIntegral <$> mtp x - return $ t `compare` q + t <- fromIntegral <$> mtp x + return $ t `compare` q -- | Events that the store can generate. data StoreEvent - = StoreBestBlock !BlockHash - | StoreMempoolNew !TxHash - | StoreMempoolDelete !TxHash - | StorePeerConnected !Peer - | StorePeerDisconnected !Peer - | StorePeerPong !Peer !Word64 - | StoreTxAnnounce !Peer ![TxHash] - | StoreTxReject !Peer !TxHash !RejectCode !ByteString + = StoreBestBlock !BlockHash + | StoreMempoolNew !TxHash + | StoreMempoolDelete !TxHash + | StorePeerConnected !Peer + | StorePeerDisconnected !Peer + | StorePeerPong !Peer !Word64 + | StoreTxAnnounce !Peer ![TxHash] + | StoreTxReject !Peer !TxHash !RejectCode !ByteString data PubExcept - = PubNoPeers - | PubReject RejectCode - | PubTimeout - | PubPeerDisconnected - deriving (Eq, NFData, Generic, Serialize) + = PubNoPeers + | PubReject RejectCode + | PubTimeout + | PubPeerDisconnected + deriving (Eq, NFData, Generic, Serialize) instance Show PubExcept where - show PubNoPeers = "no peers" - show (PubReject c) = - "rejected: " - <> case c of - RejectMalformed -> "malformed" - RejectInvalid -> "invalid" - RejectObsolete -> "obsolete" - RejectDuplicate -> "duplicate" - RejectNonStandard -> "not standard" - RejectDust -> "dust" - RejectInsufficientFee -> "insufficient fee" - RejectCheckpoint -> "checkpoint" - show PubTimeout = "peer timeout or silent rejection" - show PubPeerDisconnected = "peer disconnected" + show PubNoPeers = "no peers" + show (PubReject c) = + "rejected: " + <> case c of + RejectMalformed -> "malformed" + RejectInvalid -> "invalid" + RejectObsolete -> "obsolete" + RejectDuplicate -> "duplicate" + RejectNonStandard -> "not standard" + RejectDust -> "dust" + RejectInsufficientFee -> "insufficient fee" + RejectCheckpoint -> "checkpoint" + show PubTimeout = "peer timeout or silent rejection" + show PubPeerDisconnected = "peer disconnected" instance Exception PubExcept applyLimits :: Limits -> [a] -> [a] -applyLimits Limits{..} = applyLimit limit . applyOffset offset +applyLimits Limits {..} = applyLimit limit . applyOffset offset applyOffset :: Offset -> [a] -> [a] applyOffset = drop . fromIntegral @@ -347,11 +349,11 @@ deOffset :: Limits -> Limits deOffset l = case limit l of - 0 -> l{offset = 0} - _ -> l{limit = limit l + offset l, offset = 0} + 0 -> l {offset = 0} + _ -> l {limit = limit l + offset l, offset = 0} applyLimitsC :: Monad m => Limits -> ConduitT i i m () -applyLimitsC Limits{..} = applyOffsetC offset >> applyLimitC limit +applyLimitsC Limits {..} = applyOffsetC offset >> applyLimitC limit applyOffsetC :: Monad m => Offset -> ConduitT i i m () applyOffsetC = dropC . fromIntegral @@ -367,97 +369,97 @@ go [] _ [] = [] go orphans ths [] = go [] ths orphans go orphans ths ((i, tx) : xs) = - let ops = map (outPointHash . prevOutput) (txIn tx) - orp = any (`H.member` ths) ops - in if orp - then go ((i, tx) : orphans) ths xs - else (i, tx) : go orphans (txHash tx `H.delete` ths) xs + let ops = map (outPointHash . prevOutput) (txIn tx) + orp = any (`H.member` ths) ops + in if orp + then go ((i, tx) : orphans) ths xs + else (i, tx) : go orphans (txHash tx `H.delete` ths) xs nub' :: (Eq a, Hashable a) => [a] -> [a] nub' = H.toList . H.fromList microseconds :: MonadIO m => m Integer microseconds = - let f t = - toInteger (systemSeconds t) * 1000000 - + toInteger (systemNanoseconds t) `div` 1000 - in liftIO $ f <$> getSystemTime + let f t = + toInteger (systemSeconds t) * 1000000 + + toInteger (systemNanoseconds t) `div` 1000 + in liftIO $ f <$> getSystemTime streamThings :: - Monad m => - (Limits -> m [a]) -> - Maybe (a -> TxHash) -> - Limits -> - ConduitT () a m () + Monad m => + (Limits -> m [a]) -> + Maybe (a -> TxHash) -> + Limits -> + ConduitT () a m () streamThings getit gettx limits = - lift (getit limits) >>= \case - [] -> return () - ls -> mapM_ yield ls >> go limits (last ls) + lift (getit limits) >>= \case + [] -> return () + ls -> mapM_ yield ls >> go limits (last ls) where h l x = case gettx of - Just g -> Just l{offset = 1, start = Just (AtTx (g x))} - Nothing -> case limit l of - 0 -> Nothing - _ -> Just l{offset = offset l + limit l} + Just g -> Just l {offset = 1, start = Just (AtTx (g x))} + Nothing -> case limit l of + 0 -> Nothing + _ -> Just l {offset = offset l + limit l} go l x = case h l x of - Nothing -> return () - Just l' -> - lift (getit l') >>= \case - [] -> return () - ls -> mapM_ yield ls >> go l' (last ls) + Nothing -> return () + Just l' -> + lift (getit l') >>= \case + [] -> return () + ls -> mapM_ yield ls >> go l' (last ls) joinDescStreams :: - (Monad m, Ord a) => - [ConduitT () a m ()] -> - ConduitT () a m () + (Monad m, Ord a) => + [ConduitT () a m ()] -> + ConduitT () a m () joinDescStreams xs = do - let ss = map sealConduitT xs - go Nothing =<< g ss + let ss = map sealConduitT xs + go Nothing =<< g ss where j (x, y) = (,[x]) <$> y g ss = - let l = mapMaybe j <$> lift (traverse ($$++ await) ss) - in Map.fromListWith (++) <$> l + let l = mapMaybe j <$> lift (traverse ($$++ await) ss) + in Map.fromListWith (++) <$> l go m mp = case Map.lookupMax mp of - Nothing -> return () - Just (x, ss) -> do - case m of - Nothing -> yield x - Just x' - | x == x' -> return () - | otherwise -> yield x - mp1 <- g ss - let mp2 = Map.deleteMax mp - mp' = Map.unionWith (++) mp1 mp2 - go (Just x) mp' + Nothing -> return () + Just (x, ss) -> do + case m of + Nothing -> yield x + Just x' + | x == x' -> return () + | otherwise -> yield x + mp1 <- g ss + let mp2 = Map.deleteMax mp + mp' = Map.unionWith (++) mp1 mp2 + go (Just x) mp' data DataMetrics = DataMetrics - { dataBestCount :: !Counter - , dataBlockCount :: !Counter - , dataTxCount :: !Counter - , dataSpenderCount :: !Counter - , dataMempoolCount :: !Counter - , dataBalanceCount :: !Counter - , dataUnspentCount :: !Counter - , dataAddrTxCount :: !Counter - , dataXPubBals :: !Counter - , dataXPubUnspents :: !Counter - , dataXPubTxs :: !Counter - , dataXPubTxCount :: !Counter - } + { dataBestCount :: !Counter, + dataBlockCount :: !Counter, + dataTxCount :: !Counter, + dataSpenderCount :: !Counter, + dataMempoolCount :: !Counter, + dataBalanceCount :: !Counter, + dataUnspentCount :: !Counter, + dataAddrTxCount :: !Counter, + dataXPubBals :: !Counter, + dataXPubUnspents :: !Counter, + dataXPubTxs :: !Counter, + dataXPubTxCount :: !Counter + } createDataMetrics :: MonadIO m => Metrics.Store -> m DataMetrics createDataMetrics s = liftIO $ do - dataBestCount <- Metrics.createCounter "data.best_block" s - dataBlockCount <- Metrics.createCounter "data.blocks" s - dataTxCount <- Metrics.createCounter "data.txs" s - dataSpenderCount <- Metrics.createCounter "data.spenders" s - dataMempoolCount <- Metrics.createCounter "data.mempool" s - dataBalanceCount <- Metrics.createCounter "data.balances" s - dataUnspentCount <- Metrics.createCounter "data.unspents" s - dataAddrTxCount <- Metrics.createCounter "data.address_txs" s - dataXPubBals <- Metrics.createCounter "data.xpub_balances" s - dataXPubUnspents <- Metrics.createCounter "data.xpub_unspents" s - dataXPubTxs <- Metrics.createCounter "data.xpub_txs" s - dataXPubTxCount <- Metrics.createCounter "data.xpub_tx_count" s - return DataMetrics{..} + dataBestCount <- Metrics.createCounter "data.best_block" s + dataBlockCount <- Metrics.createCounter "data.blocks" s + dataTxCount <- Metrics.createCounter "data.txs" s + dataSpenderCount <- Metrics.createCounter "data.spenders" s + dataMempoolCount <- Metrics.createCounter "data.mempool" s + dataBalanceCount <- Metrics.createCounter "data.balances" s + dataUnspentCount <- Metrics.createCounter "data.unspents" s + dataAddrTxCount <- Metrics.createCounter "data.address_txs" s + dataXPubBals <- Metrics.createCounter "data.xpub_balances" s + dataXPubUnspents <- Metrics.createCounter "data.xpub_unspents" s + dataXPubTxs <- Metrics.createCounter "data.xpub_txs" s + dataXPubTxCount <- Metrics.createCounter "data.xpub_tx_count" s + return DataMetrics {..} 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 @@ -4,8 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Haskoin.Store.Database.Reader ( - -- * RocksDB Database Access +module Haskoin.Store.Database.Reader + ( -- * RocksDB Database Access DatabaseReader (..), DatabaseReaderT, withDatabaseReader, @@ -17,17 +17,20 @@ blockCF, heightCF, balanceCF, -) where + ) +where -import Conduit ( - ConduitT, +import Conduit + ( ConduitT, + dropC, dropWhileC, lift, mapC, runConduit, sinkList, + takeC, (.|), - ) + ) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) import Data.Bits ((.&.)) @@ -39,24 +42,24 @@ import Data.Ord (Down (..)) import Data.Serialize (encode) import Data.Word (Word32, Word64) -import Database.RocksDB ( - ColumnFamily, +import Database.RocksDB + ( ColumnFamily, Config (..), DB (..), Iterator, withDBCF, withIterCF, - ) -import Database.RocksDB.Query ( - insert, + ) +import Database.RocksDB.Query + ( insert, matching, matchingAsListCF, matchingSkip, retrieve, retrieveCF, - ) -import Haskoin ( - Address, + ) +import Haskoin + ( Address, BlockHash, BlockHeight, Network, @@ -64,7 +67,7 @@ TxHash, pubSubKey, txHash, - ) + ) import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types @@ -76,61 +79,61 @@ type DatabaseReaderT = ReaderT DatabaseReader data DatabaseReader = DatabaseReader - { databaseHandle :: !DB - , databaseMaxGap :: !Word32 - , databaseInitialGap :: !Word32 - , databaseNetwork :: !Network - , databaseMetrics :: !(Maybe DataMetrics) - } + { databaseHandle :: !DB, + databaseMaxGap :: !Word32, + databaseInitialGap :: !Word32, + databaseNetwork :: !Network, + databaseMetrics :: !(Maybe DataMetrics) + } incrementCounter :: - MonadIO m => - (DataMetrics -> Counter) -> - Int -> - ReaderT DatabaseReader m () + MonadIO m => + (DataMetrics -> Counter) -> + Int -> + ReaderT DatabaseReader m () incrementCounter f i = - asks databaseMetrics >>= \case - Just s -> liftIO $ Counter.add (f s) (fromIntegral i) - Nothing -> return () + asks databaseMetrics >>= \case + Just s -> liftIO $ Counter.add (f s) (fromIntegral i) + Nothing -> return () dataVersion :: Word32 dataVersion = 17 withDatabaseReader :: - MonadUnliftIO m => - Network -> - Word32 -> - Word32 -> - FilePath -> - Maybe DataMetrics -> - DatabaseReaderT m a -> - m a + MonadUnliftIO m => + Network -> + Word32 -> + Word32 -> + FilePath -> + Maybe DataMetrics -> + DatabaseReaderT m a -> + m a withDatabaseReader net igap gap dir stats f = - withDBCF dir cfg columnFamilyConfig $ \db -> do - let bdb = - DatabaseReader - { databaseHandle = db - , databaseMaxGap = gap - , databaseNetwork = net - , databaseInitialGap = igap - , databaseMetrics = stats - } - initRocksDB bdb - runReaderT f bdb + withDBCF dir cfg columnFamilyConfig $ \db -> do + let bdb = + DatabaseReader + { databaseHandle = db, + databaseMaxGap = gap, + databaseNetwork = net, + databaseInitialGap = igap, + databaseMetrics = stats + } + initRocksDB bdb + runReaderT f bdb where - cfg = def{createIfMissing = True, maxFiles = Just (-1)} + cfg = def {createIfMissing = True, maxFiles = Just (-1)} columnFamilyConfig :: [(String, Config)] columnFamilyConfig = - [ ("addr-tx", def{prefixLength = Just 22, bloomFilter = True}) - , ("addr-out", def{prefixLength = Just 22, bloomFilter = True}) - , ("tx", def{prefixLength = Just 33, bloomFilter = True}) - , ("spender", def{prefixLength = Just 33, bloomFilter = True}) - , ("unspent", def{prefixLength = Just 37, bloomFilter = True}) - , ("block", def{prefixLength = Just 33, bloomFilter = True}) - , ("height", def{prefixLength = Nothing, bloomFilter = True}) - , ("balance", def{prefixLength = Just 22, bloomFilter = True}) - ] + [ ("addr-tx", def {prefixLength = Just 22, bloomFilter = True}), + ("addr-out", def {prefixLength = Just 22, bloomFilter = True}), + ("tx", def {prefixLength = Just 33, bloomFilter = True}), + ("spender", def {prefixLength = Just 33, bloomFilter = True}), + ("unspent", def {prefixLength = Just 37, bloomFilter = True}), + ("block", def {prefixLength = Just 33, bloomFilter = True}), + ("height", def {prefixLength = Nothing, bloomFilter = True}), + ("balance", def {prefixLength = Just 22, bloomFilter = True}) + ] addrTxCF :: DB -> ColumnFamily addrTxCF = head . columnFamilies @@ -157,282 +160,276 @@ balanceCF db = columnFamilies db !! 7 initRocksDB :: MonadIO m => DatabaseReader -> m () -initRocksDB DatabaseReader{databaseHandle = db} = do - e <- - runExceptT $ - retrieve db VersionKey >>= \case - Just v - | v == dataVersion -> return () - | otherwise -> throwError "Incorrect RocksDB database version" - Nothing -> setInitRocksDB db - case e of - Left s -> error s - Right () -> return () +initRocksDB DatabaseReader {databaseHandle = db} = do + e <- + runExceptT $ + retrieve db VersionKey >>= \case + Just v + | v == dataVersion -> return () + | otherwise -> throwError "Incorrect RocksDB database version" + Nothing -> setInitRocksDB db + case e of + Left s -> error s + Right () -> return () setInitRocksDB :: MonadIO m => DB -> m () setInitRocksDB db = insert db VersionKey dataVersion addressConduit :: - MonadUnliftIO m => - Address -> - Maybe Start -> - Iterator -> - ConduitT i TxRef (DatabaseReaderT m) () + MonadUnliftIO m => + Address -> + Maybe Start -> + Iterator -> + ConduitT i TxRef (DatabaseReaderT m) () addressConduit a s it = - x .| mapC (uncurry f) + x .| mapC (uncurry f) where f (AddrTxKey _ t) () = t f _ _ = undefined x = case s of - Nothing -> - matching it (AddrTxKeyA a) - Just (AtBlock bh) -> - matchingSkip - it - (AddrTxKeyA a) - (AddrTxKeyB a (BlockRef bh maxBound)) - Just (AtTx txh) -> - lift (getTxData txh) >>= \case - Just TxData{txDataBlock = b@BlockRef{}} -> - matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b) - Just TxData{txDataBlock = MemRef{}} -> - let cond (AddrTxKey _a (TxRef MemRef{} th)) = - th /= txh - cond (AddrTxKey _a (TxRef BlockRef{} _th)) = - False - in matching it (AddrTxKeyA a) - .| (dropWhileC (cond . fst) >> mapC id) - Nothing -> return () + Nothing -> + matching it (AddrTxKeyA a) + Just (AtBlock bh) -> + matchingSkip + it + (AddrTxKeyA a) + (AddrTxKeyB a (BlockRef bh maxBound)) + Just (AtTx txh) -> + lift (getTxData txh) >>= \case + Just TxData {txDataBlock = b@BlockRef {}} -> + matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b) + Just TxData {txDataBlock = MemRef {}} -> + let cond (AddrTxKey _a (TxRef MemRef {} th)) = + th /= txh + cond (AddrTxKey _a (TxRef BlockRef {} _th)) = + False + in matching it (AddrTxKeyA a) + .| (dropWhileC (cond . fst) >> mapC id) + Nothing -> return () unspentConduit :: - MonadUnliftIO m => - Address -> - Maybe Start -> - Iterator -> - ConduitT i Unspent (DatabaseReaderT m) () + MonadUnliftIO m => + Address -> + Maybe Start -> + Iterator -> + ConduitT i Unspent (DatabaseReaderT m) () unspentConduit a s it = - x .| mapC (uncurry toUnspent) + x .| mapC (uncurry toUnspent) where x = case s of - Nothing -> - matching it (AddrOutKeyA a) - Just (AtBlock h) -> - matchingSkip - it - (AddrOutKeyA a) - (AddrOutKeyB a (BlockRef h maxBound)) - Just (AtTx txh) -> - lift (getTxData txh) >>= \case - Just TxData{txDataBlock = b@BlockRef{}} -> - matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) - Just TxData{txDataBlock = MemRef{}} -> - let cond (AddrOutKey _a MemRef{} p) = - outPointHash p /= txh - cond (AddrOutKey _a BlockRef{} _p) = - False - in matching it (AddrOutKeyA a) - .| (dropWhileC (cond . fst) >> mapC id) - Nothing -> return () + Nothing -> + matching it (AddrOutKeyA a) + Just (AtBlock h) -> + matchingSkip + it + (AddrOutKeyA a) + (AddrOutKeyB a (BlockRef h maxBound)) + Just (AtTx txh) -> + lift (getTxData txh) >>= \case + Just TxData {txDataBlock = b@BlockRef {}} -> + matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) + Just TxData {txDataBlock = MemRef {}} -> + let cond (AddrOutKey _a MemRef {} p) = + outPointHash p /= txh + cond (AddrOutKey _a BlockRef {} _p) = + False + in matching it (AddrOutKeyA a) + .| (dropWhileC (cond . fst) >> mapC id) + Nothing -> return () +withManyIters :: + MonadUnliftIO m => + DB -> + ColumnFamily -> + Int -> + ([Iterator] -> m a) -> + m a +withManyIters db cf i f = go [] i + where + go acc 0 = f acc + go acc n = withIterCF db cf $ \it -> go (it : acc) (n - 1) + +joinConduits :: + (Monad m, Ord o) => + [ConduitT () o m ()] -> + Limits -> + m [o] +joinConduits cs l = + runConduit $ joinDescStreams cs .| applyLimitsC l .| sinkList + instance MonadIO m => StoreReadBase (DatabaseReaderT m) where - getNetwork = asks databaseNetwork + getNetwork = asks databaseNetwork - getTxData th = do - db <- asks databaseHandle - retrieveCF db (txCF db) (TxKey th) >>= \case - Nothing -> return Nothing - Just t -> do - incrementCounter dataTxCount 1 - return (Just t) + getTxData th = do + db <- asks databaseHandle + retrieveCF db (txCF db) (TxKey th) >>= \case + Nothing -> return Nothing + Just t -> do + incrementCounter dataTxCount 1 + return (Just t) - getSpender op = do - db <- asks databaseHandle - retrieveCF db (spenderCF db) (SpenderKey op) >>= \case - Nothing -> return Nothing - Just s -> do - incrementCounter dataSpenderCount 1 - return (Just s) + getSpender op = do + db <- asks databaseHandle + retrieveCF db (spenderCF db) (SpenderKey op) >>= \case + Nothing -> return Nothing + Just s -> do + incrementCounter dataSpenderCount 1 + return (Just s) - getUnspent p = do - db <- asks databaseHandle - fmap (valToUnspent p) <$> retrieveCF db (unspentCF db) (UnspentKey p) >>= \case - Nothing -> return Nothing - Just u -> do - incrementCounter dataUnspentCount 1 - return (Just u) + getUnspent p = do + db <- asks databaseHandle + val <- retrieveCF db (unspentCF db) (UnspentKey p) + case fmap (valToUnspent p) val of + Nothing -> return Nothing + Just u -> do + incrementCounter dataUnspentCount 1 + return (Just u) - getBalance a = do - db <- asks databaseHandle - incrementCounter dataBalanceCount 1 - fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) + getBalance a = do + db <- asks databaseHandle + incrementCounter dataBalanceCount 1 + fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) - getMempool = do - db <- asks databaseHandle - incrementCounter dataMempoolCount 1 - fromMaybe [] <$> retrieve db MemKey + getMempool = do + db <- asks databaseHandle + incrementCounter dataMempoolCount 1 + fromMaybe [] <$> retrieve db MemKey - getBestBlock = do - incrementCounter dataBestCount 1 - asks databaseHandle >>= (`retrieve` BestKey) + getBestBlock = do + incrementCounter dataBestCount 1 + asks databaseHandle >>= (`retrieve` BestKey) - getBlocksAtHeight h = do - db <- asks databaseHandle - retrieveCF db (heightCF db) (HeightKey h) >>= \case - Nothing -> return [] - Just ls -> do - incrementCounter dataBlockCount (length ls) - return ls + getBlocksAtHeight h = do + db <- asks databaseHandle + retrieveCF db (heightCF db) (HeightKey h) >>= \case + Nothing -> return [] + Just ls -> do + incrementCounter dataBlockCount (length ls) + return ls - getBlock h = do - db <- asks databaseHandle - retrieveCF db (blockCF db) (BlockKey h) >>= \case - Nothing -> return Nothing - Just b -> do - incrementCounter dataBlockCount 1 - return (Just b) + getBlock h = do + db <- asks databaseHandle + retrieveCF db (blockCF db) (BlockKey h) >>= \case + Nothing -> return Nothing + Just b -> do + incrementCounter dataBlockCount 1 + return (Just b) instance MonadUnliftIO m => StoreReadExtra (DatabaseReaderT m) where - getAddressesTxs addrs limits = do - txs <- applyLimits limits . sortOn Down . concat <$> mapM f addrs - incrementCounter dataAddrTxCount (length txs) - return txs - where - l = deOffset limits - f a = do - db <- asks databaseHandle - withIterCF db (addrTxCF db) $ \it -> - runConduit $ - addressConduit a (start l) it - .| applyLimitC (limit l) - .| sinkList + getAddressesTxs addrs limits = do + db <- asks databaseHandle + withManyIters db (addrTxCF db) (length addrs) $ \its -> do + txs <- joinConduits (cs its) limits + incrementCounter dataAddrTxCount (length txs) + return txs + where + cs = map (uncurry c) . zip addrs + c a = addressConduit a (start limits) - getAddressesUnspents addrs limits = do - us <- applyLimits limits . sortOn Down . concat <$> mapM f addrs - incrementCounter dataUnspentCount (length us) - return us - where - l = deOffset limits - f a = do - db <- asks databaseHandle - withIterCF db (addrOutCF db) $ \it -> - runConduit $ - unspentConduit a (start l) it - .| applyLimitC (limit l) - .| sinkList + getAddressesUnspents addrs limits = do + db <- asks databaseHandle + withManyIters db (addrOutCF db) (length addrs) $ \its -> do + uns <- joinConduits (cs its) limits + incrementCounter dataUnspentCount (length uns) + return uns + where + cs = map (uncurry c) . zip addrs + c a = unspentConduit a (start limits) - getAddressUnspents a limits = do - db <- asks databaseHandle - us <- withIterCF db (addrOutCF db) $ \it -> - runConduit $ - x it .| applyLimitsC limits .| mapC (uncurry toUnspent) .| sinkList - incrementCounter dataUnspentCount (length us) - return us - where - x it = case start limits of - Nothing -> - matching it (AddrOutKeyA a) - Just (AtBlock h) -> - matchingSkip - it - (AddrOutKeyA a) - (AddrOutKeyB a (BlockRef h maxBound)) - Just (AtTx txh) -> - lift (getTxData txh) >>= \case - Just TxData{txDataBlock = b@BlockRef{}} -> - matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) - Just TxData{txDataBlock = MemRef{}} -> - let cond (AddrOutKey _a MemRef{} p) = - outPointHash p /= txh - cond (AddrOutKey _a BlockRef{} _p) = - False - in matching it (AddrOutKeyA a) - .| (dropWhileC (cond . fst) >> mapC id) - _ -> matching it (AddrOutKeyA a) + getAddressUnspents a limits = do + db <- asks databaseHandle + us <- withIterCF db (addrOutCF db) $ \it -> + runConduit $ + unspentConduit a (start limits) it + .| applyLimitsC limits + .| sinkList + incrementCounter dataUnspentCount (length us) + return us - getAddressTxs a limits = do - db <- asks databaseHandle - txs <- withIterCF db (addrTxCF db) $ \it -> - runConduit $ - addressConduit a (start limits) it - .| applyLimitsC limits - .| sinkList - incrementCounter dataAddrTxCount (length txs) - return txs + getAddressTxs a limits = do + db <- asks databaseHandle + txs <- withIterCF db (addrTxCF db) $ \it -> + runConduit $ + addressConduit a (start limits) it + .| applyLimitsC limits + .| sinkList + incrementCounter dataAddrTxCount (length txs) + return txs - getMaxGap = asks databaseMaxGap + getMaxGap = asks databaseMaxGap - getInitialGap = asks databaseInitialGap + getInitialGap = asks databaseInitialGap - getNumTxData i = do - db <- asks databaseHandle - let (sk, w) = decodeTxKey i - ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk) - let f t = - let bs = encode $ txHash (txData t) - b = BS.head (BS.drop 6 bs) - w' = b .&. 0xf8 - in w == w' - txs = filter f $ map snd ls - incrementCounter dataTxCount (length txs) - return txs + getNumTxData i = do + db <- asks databaseHandle + let (sk, w) = decodeTxKey i + ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk) + let f t = + let bs = encode $ txHash (txData t) + b = BS.head (BS.drop 6 bs) + w' = b .&. 0xf8 + in w == w' + txs = filter f $ map snd ls + incrementCounter dataTxCount (length txs) + return txs - getBalances as = do - zipWith f as <$> mapM getBalance as - where - f a Nothing = zeroBalance a - f _ (Just b) = b + getBalances as = do + zipWith f as <$> mapM getBalance as + where + f a Nothing = zeroBalance a + f _ (Just b) = b - xPubBals xpub = do - igap <- getInitialGap - gap <- getMaxGap - ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0)) - if all (nullBalance . xPubBal) ext1 - then do - incrementCounter dataXPubBals (length ext1) - return ext1 - else do - ext2 <- derive_until_gap gap 0 (aderiv 0 igap) - chg <- derive_until_gap gap 1 (aderiv 1 0) - let bals = ext1 <> ext2 <> chg - incrementCounter dataXPubBals (length bals) - return bals - where - aderiv m = - deriveAddresses - (deriveFunction (xPubDeriveType xpub)) - (pubSubKey (xPubSpecKey xpub) m) - xbalance m b n = XPubBal{xPubBalPath = [m, n], xPubBal = b} - derive_until_gap _ _ [] = return [] - derive_until_gap gap m as = do - let (as1, as2) = splitAt (fromIntegral gap) as - bs <- getBalances (map snd as1) - let xbs = zipWith (xbalance m) bs (map fst as1) - if all nullBalance bs - then return xbs - else (xbs <>) <$> derive_until_gap gap m as2 + xPubBals xpub = do + igap <- getInitialGap + gap <- getMaxGap + ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0)) + if all (nullBalance . xPubBal) ext1 + then do + incrementCounter dataXPubBals (length ext1) + return ext1 + else do + ext2 <- derive_until_gap gap 0 (aderiv 0 igap) + chg <- derive_until_gap gap 1 (aderiv 1 0) + let bals = ext1 <> ext2 <> chg + incrementCounter dataXPubBals (length bals) + return bals + where + aderiv m = + deriveAddresses + (deriveFunction (xPubDeriveType xpub)) + (pubSubKey (xPubSpecKey xpub) m) + xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b} + derive_until_gap _ _ [] = return [] + derive_until_gap gap m as = do + let (as1, as2) = splitAt (fromIntegral gap) as + bs <- getBalances (map snd as1) + let xbs = zipWith (xbalance m) bs (map fst as1) + if all nullBalance bs + then return xbs + else (xbs <>) <$> derive_until_gap gap m as2 - xPubUnspents _xspec xbals limits = do - us <- concat <$> mapM h cs - incrementCounter dataXPubUnspents (length us) - return . applyLimits limits $ sortOn Down us - where - l = deOffset limits - cs = filter ((> 0) . balanceUnspentCount . xPubBal) xbals - i b = do - us <- getAddressUnspents (balanceAddress (xPubBal b)) l - return us - f b t = XPubUnspent{xPubUnspentPath = xPubBalPath b, xPubUnspent = t} - h b = map (f b) <$> i b + xPubUnspents _xspec xbals limits = do + us <- concat <$> mapM h cs + incrementCounter dataXPubUnspents (length us) + return . applyLimits limits $ sortOn Down us + where + l = deOffset limits + cs = filter ((> 0) . balanceUnspentCount . xPubBal) xbals + i b = do + us <- getAddressUnspents (balanceAddress (xPubBal b)) l + return us + f b t = XPubUnspent {xPubUnspentPath = xPubBalPath b, xPubUnspent = t} + h b = map (f b) <$> i b - xPubTxs _xspec xbals limits = do - let as = - map balanceAddress $ - filter (not . nullBalance) $ - map xPubBal xbals - txs <- getAddressesTxs as limits - incrementCounter dataXPubTxs (length txs) - return txs + xPubTxs _xspec xbals limits = do + let as = + map balanceAddress $ + filter (not . nullBalance) $ + map xPubBal xbals + txs <- getAddressesTxs as limits + incrementCounter dataXPubTxs (length txs) + return txs - xPubTxCount xspec xbals = do - incrementCounter dataXPubTxCount 1 - fromIntegral . length <$> xPubTxs xspec xbals def + xPubTxCount xspec xbals = do + incrementCounter dataXPubTxCount 1 + fromIntegral . length <$> xPubTxs xspec xbals def 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 @@ -3,8 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Haskoin.Store.Database.Types ( - AddrTxKey (..), +module Haskoin.Store.Database.Types + ( AddrTxKey (..), AddrOutKey (..), BestKey (..), BlockKey (..), @@ -24,25 +24,26 @@ unspentToVal, valToUnspent, OutVal (..), -) where + ) +where import Control.DeepSeq (NFData) import Control.Monad (guard) -import Data.Bits ( - Bits, +import Data.Bits + ( Bits, shift, shiftL, shiftR, (.&.), (.|.), - ) + ) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Default (Default (..)) import Data.Either (fromRight) import Data.Hashable (Hashable) -import Data.Serialize ( - Serialize (..), +import Data.Serialize + ( Serialize (..), decode, encode, getBytes, @@ -54,21 +55,21 @@ putWord8, runGet, runPut, - ) + ) import Data.Word (Word16, Word32, Word64, Word8) import Database.RocksDB.Query (Key, KeyValue) import GHC.Generics (Generic) -import Haskoin ( - Address, +import Haskoin + ( Address, BlockHash, BlockHeight, OutPoint (..), TxHash, eitherToMaybe, scriptToAddressBS, - ) -import Haskoin.Store.Data ( - Balance (..), + ) +import Haskoin.Store.Data + ( Balance (..), BlockData, BlockRef, Spender, @@ -76,393 +77,403 @@ TxRef (..), UnixTime, Unspent (..), - ) + ) -- | Database key for an address transaction. data AddrTxKey - = -- | key for a transaction affecting an address - AddrTxKey - { addrTxKeyA :: !Address - , addrTxKeyT :: !TxRef - } - | -- | short key that matches all entries - AddrTxKeyA {addrTxKeyA :: !Address} - | AddrTxKeyB - { addrTxKeyA :: !Address - , addrTxKeyB :: !BlockRef - } - | AddrTxKeyS - deriving (Show, Eq, Ord, Generic, Hashable) + = -- | key for a transaction affecting an address + AddrTxKey + { addrTxKeyA :: !Address, + addrTxKeyT :: !TxRef + } + | -- | short key that matches all entries + AddrTxKeyA {addrTxKeyA :: !Address} + | AddrTxKeyB + { addrTxKeyA :: !Address, + addrTxKeyB :: !BlockRef + } + | AddrTxKeyS + deriving (Show, Eq, Ord, Generic, Hashable) instance Serialize AddrTxKey where - -- 0x05 · Address · BlockRef · TxHash + -- 0x05 · Address · BlockRef · TxHash - put - AddrTxKey - { addrTxKeyA = a - , addrTxKeyT = TxRef{txRefBlock = b, txRefHash = t} - } = do - put AddrTxKeyB{addrTxKeyA = a, addrTxKeyB = b} - put t - -- 0x05 · Address - put AddrTxKeyA{addrTxKeyA = a} = do - put AddrTxKeyS - put a - -- 0x05 · Address · BlockRef - put AddrTxKeyB{addrTxKeyA = a, addrTxKeyB = b} = do - put AddrTxKeyA{addrTxKeyA = a} - put b - -- 0x05 - put AddrTxKeyS = putWord8 0x05 - get = do - guard . (== 0x05) =<< getWord8 - a <- get - b <- get - t <- get - return - AddrTxKey - { addrTxKeyA = a - , addrTxKeyT = TxRef{txRefBlock = b, txRefHash = t} - } + put + AddrTxKey + { addrTxKeyA = a, + addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t} + } = do + put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} + put t + -- 0x05 · Address + put AddrTxKeyA {addrTxKeyA = a} = do + put AddrTxKeyS + put a + -- 0x05 · Address · BlockRef + put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do + put AddrTxKeyA {addrTxKeyA = a} + put b + -- 0x05 + put AddrTxKeyS = putWord8 0x05 + get = do + guard . (== 0x05) =<< getWord8 + a <- get + b <- get + t <- get + return + AddrTxKey + { addrTxKeyA = a, + addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t} + } instance Key AddrTxKey + instance KeyValue AddrTxKey () -- | Database key for an address output. data AddrOutKey - = -- | full key - AddrOutKey - { addrOutKeyA :: !Address - , addrOutKeyB :: !BlockRef - , addrOutKeyP :: !OutPoint - } - | -- | short key for all spent or unspent outputs - AddrOutKeyA {addrOutKeyA :: !Address} - | AddrOutKeyB - { addrOutKeyA :: !Address - , addrOutKeyB :: !BlockRef - } - | AddrOutKeyS - deriving (Show, Read, Eq, Ord, Generic, Hashable) + = -- | full key + AddrOutKey + { addrOutKeyA :: !Address, + addrOutKeyB :: !BlockRef, + addrOutKeyP :: !OutPoint + } + | -- | short key for all spent or unspent outputs + AddrOutKeyA {addrOutKeyA :: !Address} + | AddrOutKeyB + { addrOutKeyA :: !Address, + addrOutKeyB :: !BlockRef + } + | AddrOutKeyS + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize AddrOutKey where - -- 0x06 · StoreAddr · BlockRef · OutPoint + -- 0x06 · StoreAddr · BlockRef · OutPoint - put AddrOutKey{addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do - put AddrOutKeyB{addrOutKeyA = a, addrOutKeyB = b} - put p - -- 0x06 · StoreAddr · BlockRef - put AddrOutKeyB{addrOutKeyA = a, addrOutKeyB = b} = do - put AddrOutKeyA{addrOutKeyA = a} - put b - -- 0x06 · StoreAddr - put AddrOutKeyA{addrOutKeyA = a} = do - put AddrOutKeyS - put a - -- 0x06 - put AddrOutKeyS = putWord8 0x06 - get = do - guard . (== 0x06) =<< getWord8 - AddrOutKey <$> get <*> get <*> get + put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do + put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} + put p + -- 0x06 · StoreAddr · BlockRef + put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} = do + put AddrOutKeyA {addrOutKeyA = a} + put b + -- 0x06 · StoreAddr + put AddrOutKeyA {addrOutKeyA = a} = do + put AddrOutKeyS + put a + -- 0x06 + put AddrOutKeyS = putWord8 0x06 + get = do + guard . (== 0x06) =<< getWord8 + AddrOutKey <$> get <*> get <*> get instance Key AddrOutKey data OutVal = OutVal - { outValAmount :: !Word64 - , outValScript :: !ByteString - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) + { outValAmount :: !Word64, + outValScript :: !ByteString + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) instance KeyValue AddrOutKey OutVal -- | Transaction database key. data TxKey - = TxKey {txKey :: TxHash} - | TxKeyS {txKeyShort :: (Word32, Word16)} - deriving (Show, Read, Eq, Ord, Generic, Hashable) + = TxKey {txKey :: TxHash} + | TxKeyS {txKeyShort :: (Word32, Word16)} + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize TxKey where - -- 0x02 · TxHash - put (TxKey h) = do - putWord8 0x02 - put h - put (TxKeyS h) = do - putWord8 0x02 - put h - get = do - guard . (== 0x02) =<< getWord8 - TxKey <$> get + -- 0x02 · TxHash + put (TxKey h) = do + putWord8 0x02 + put h + put (TxKeyS h) = do + putWord8 0x02 + put h + get = do + guard . (== 0x02) =<< getWord8 + TxKey <$> get decodeTxKey :: Word64 -> ((Word32, Word16), Word8) decodeTxKey i = - let masked = i .&. 0x001fffffffffffff - wb = masked `shift` 11 - bs = runPut (putWord64be wb) - g = do - w1 <- getWord32be - w2 <- getWord16be - w3 <- getWord8 - return (w1, w2, w3) - Right (w1, w2, w3) = runGet g bs - in ((w1, w2), w3) + let masked = i .&. 0x001fffffffffffff + wb = masked `shift` 11 + bs = runPut (putWord64be wb) + g = do + w1 <- getWord32be + w2 <- getWord16be + w3 <- getWord8 + return (w1, w2, w3) + Right (w1, w2, w3) = runGet g bs + in ((w1, w2), w3) instance Key TxKey + instance KeyValue TxKey TxData data SpenderKey - = SpenderKey {outputPoint :: !OutPoint} - | SpenderKeyS {outputKeyS :: !TxHash} - deriving (Show, Read, Eq, Ord, Generic, Hashable) + = SpenderKey {outputPoint :: !OutPoint} + | SpenderKeyS {outputKeyS :: !TxHash} + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize SpenderKey where - -- 0x10 · TxHash · Index - put (SpenderKey OutPoint{outPointHash = h, outPointIndex = i}) = do - put (SpenderKeyS h) - put i - -- 0x10 · TxHash - put (SpenderKeyS h) = do - putWord8 0x10 - put h - get = do - guard . (== 0x10) =<< getWord8 - op <- OutPoint <$> get <*> get - return $ SpenderKey op + -- 0x10 · TxHash · Index + put (SpenderKey OutPoint {outPointHash = h, outPointIndex = i}) = do + put (SpenderKeyS h) + put i + -- 0x10 · TxHash + put (SpenderKeyS h) = do + putWord8 0x10 + put h + get = do + guard . (== 0x10) =<< getWord8 + op <- OutPoint <$> get <*> get + return $ SpenderKey op instance Key SpenderKey + instance KeyValue SpenderKey Spender -- | Unspent output database key. data UnspentKey - = UnspentKey {unspentKey :: !OutPoint} - | UnspentKeyS {unspentKeyS :: !TxHash} - | UnspentKeyB - deriving (Show, Read, Eq, Ord, Generic, Hashable) + = UnspentKey {unspentKey :: !OutPoint} + | UnspentKeyS {unspentKeyS :: !TxHash} + | UnspentKeyB + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize UnspentKey where - -- 0x09 · TxHash · Index - put UnspentKey{unspentKey = OutPoint{outPointHash = h, outPointIndex = i}} = do - putWord8 0x09 - put h - put i - -- 0x09 · TxHash - put UnspentKeyS{unspentKeyS = t} = do - putWord8 0x09 - put t - -- 0x09 - put UnspentKeyB = putWord8 0x09 - get = do - guard . (== 0x09) =<< getWord8 - h <- get - i <- get - return $ UnspentKey OutPoint{outPointHash = h, outPointIndex = i} + -- 0x09 · TxHash · Index + put UnspentKey {unspentKey = OutPoint {outPointHash = h, outPointIndex = i}} = do + putWord8 0x09 + put h + put i + -- 0x09 · TxHash + put UnspentKeyS {unspentKeyS = t} = do + putWord8 0x09 + put t + -- 0x09 + put UnspentKeyB = putWord8 0x09 + get = do + guard . (== 0x09) =<< getWord8 + h <- get + i <- get + return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i} instance Key UnspentKey + instance KeyValue UnspentKey UnspentVal toUnspent :: AddrOutKey -> OutVal -> Unspent toUnspent b v = - Unspent - { unspentBlock = addrOutKeyB b - , unspentAmount = outValAmount v - , unspentScript = outValScript v - , unspentPoint = addrOutKeyP b - , unspentAddress = eitherToMaybe (scriptToAddressBS (outValScript v)) - } + Unspent + { unspentBlock = addrOutKeyB b, + unspentAmount = outValAmount v, + unspentScript = outValScript v, + unspentPoint = addrOutKeyP b, + unspentAddress = eitherToMaybe (scriptToAddressBS (outValScript v)) + } -- | Mempool transaction database key. data MemKey - = MemKey - deriving (Show, Read) + = MemKey + deriving (Show, Read) instance Serialize MemKey where - -- 0x07 - put MemKey = putWord8 0x07 - get = do - guard . (== 0x07) =<< getWord8 - return MemKey + -- 0x07 + put MemKey = putWord8 0x07 + get = do + guard . (== 0x07) =<< getWord8 + return MemKey instance Key MemKey + instance KeyValue MemKey [(UnixTime, TxHash)] -- | Block entry database key. newtype BlockKey = BlockKey - { blockKey :: BlockHash - } - deriving (Show, Read, Eq, Ord, Generic, Hashable) + { blockKey :: BlockHash + } + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BlockKey where - -- 0x01 · BlockHash - put (BlockKey h) = do - putWord8 0x01 - put h - get = do - guard . (== 0x01) =<< getWord8 - BlockKey <$> get + -- 0x01 · BlockHash + put (BlockKey h) = do + putWord8 0x01 + put h + get = do + guard . (== 0x01) =<< getWord8 + BlockKey <$> get instance Key BlockKey + instance KeyValue BlockKey BlockData -- | Block height database key. newtype HeightKey = HeightKey - { heightKey :: BlockHeight - } - deriving (Show, Read, Eq, Ord, Generic, Hashable) + { heightKey :: BlockHeight + } + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize HeightKey where - -- 0x03 · BlockHeight - put (HeightKey height) = do - putWord8 0x03 - put height - get = do - guard . (== 0x03) =<< getWord8 - HeightKey <$> get + -- 0x03 · BlockHeight + put (HeightKey height) = do + putWord8 0x03 + put height + get = do + guard . (== 0x03) =<< getWord8 + HeightKey <$> get instance Key HeightKey + instance KeyValue HeightKey [BlockHash] -- | Address balance database key. data BalKey - = BalKey - { balanceKey :: !Address - } - | BalKeyS - deriving (Show, Read, Eq, Ord, Generic, Hashable) + = BalKey + { balanceKey :: !Address + } + | BalKeyS + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BalKey where - -- 0x04 · Address - put BalKey{balanceKey = a} = do - putWord8 0x04 - put a - -- 0x04 - put BalKeyS = putWord8 0x04 - get = do - guard . (== 0x04) =<< getWord8 - BalKey <$> get + -- 0x04 · Address + put BalKey {balanceKey = a} = do + putWord8 0x04 + put a + -- 0x04 + put BalKeyS = putWord8 0x04 + get = do + guard . (== 0x04) =<< getWord8 + BalKey <$> get instance Key BalKey + instance KeyValue BalKey BalVal -- | Key for best block in database. data BestKey - = BestKey - deriving (Show, Read, Eq, Ord, Generic, Hashable) + = BestKey + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize BestKey where - -- 0x00 × 32 - put BestKey = put (BS.replicate 32 0x00) - get = do - guard . (== BS.replicate 32 0x00) =<< getBytes 32 - return BestKey + -- 0x00 × 32 + put BestKey = put (BS.replicate 32 0x00) + get = do + guard . (== BS.replicate 32 0x00) =<< getBytes 32 + return BestKey instance Key BestKey + instance KeyValue BestKey BlockHash -- | Key for database version. data VersionKey - = VersionKey - deriving (Eq, Show, Read, Ord, Generic, Hashable) + = VersionKey + deriving (Eq, Show, Read, Ord, Generic, Hashable) instance Serialize VersionKey where - -- 0x0a - put VersionKey = putWord8 0x0a - get = do - guard . (== 0x0a) =<< getWord8 - return VersionKey + -- 0x0a + put VersionKey = putWord8 0x0a + get = do + guard . (== 0x0a) =<< getWord8 + return VersionKey instance Key VersionKey + instance KeyValue VersionKey Word32 data BalVal = BalVal - { balValAmount :: !Word64 - , balValZero :: !Word64 - , balValUnspentCount :: !Word64 - , balValTxCount :: !Word64 - , balValTotalReceived :: !Word64 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) + { balValAmount :: !Word64, + balValZero :: !Word64, + balValUnspentCount :: !Word64, + balValTxCount :: !Word64, + balValTotalReceived :: !Word64 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) valToBalance :: Address -> BalVal -> Balance valToBalance - a - BalVal - { balValAmount = v - , balValZero = z - , balValUnspentCount = u - , balValTxCount = t - , balValTotalReceived = r - } = - Balance - { balanceAddress = a - , balanceAmount = v - , balanceZero = z - , balanceUnspentCount = u - , balanceTxCount = t - , balanceTotalReceived = r - } + a + BalVal + { balValAmount = v, + balValZero = z, + balValUnspentCount = u, + balValTxCount = t, + balValTotalReceived = r + } = + Balance + { balanceAddress = a, + balanceAmount = v, + balanceZero = z, + balanceUnspentCount = u, + balanceTxCount = t, + balanceTotalReceived = r + } balanceToVal :: Balance -> BalVal balanceToVal - Balance - { balanceAmount = v - , balanceZero = z - , balanceUnspentCount = u - , balanceTxCount = t - , balanceTotalReceived = r - } = - BalVal - { balValAmount = v - , balValZero = z - , balValUnspentCount = u - , balValTxCount = t - , balValTotalReceived = r - } + Balance + { balanceAmount = v, + balanceZero = z, + balanceUnspentCount = u, + balanceTxCount = t, + balanceTotalReceived = r + } = + BalVal + { balValAmount = v, + balValZero = z, + balValUnspentCount = u, + balValTxCount = t, + balValTotalReceived = r + } -- | Default balance for an address. instance Default BalVal where - def = - BalVal - { balValAmount = 0 - , balValZero = 0 - , balValUnspentCount = 0 - , balValTxCount = 0 - , balValTotalReceived = 0 - } + def = + BalVal + { balValAmount = 0, + balValZero = 0, + balValUnspentCount = 0, + balValTxCount = 0, + balValTotalReceived = 0 + } data UnspentVal = UnspentVal - { unspentValBlock :: !BlockRef - , unspentValAmount :: !Word64 - , unspentValScript :: !ByteString - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) + { unspentValBlock :: !BlockRef, + unspentValAmount :: !Word64, + unspentValScript :: !ByteString + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) unspentToVal :: Unspent -> (OutPoint, UnspentVal) unspentToVal - Unspent - { unspentBlock = b - , unspentPoint = p - , unspentAmount = v - , unspentScript = s - } = - ( p - , UnspentVal - { unspentValBlock = b - , unspentValAmount = v - , unspentValScript = s - } - ) + Unspent + { unspentBlock = b, + unspentPoint = p, + unspentAmount = v, + unspentScript = s + } = + ( p, + UnspentVal + { unspentValBlock = b, + unspentValAmount = v, + unspentValScript = s + } + ) valToUnspent :: OutPoint -> UnspentVal -> Unspent valToUnspent - p - UnspentVal - { unspentValBlock = b - , unspentValAmount = v - , unspentValScript = s - } = - Unspent - { unspentBlock = b - , unspentPoint = p - , unspentAmount = v - , unspentScript = s - , unspentAddress = eitherToMaybe (scriptToAddressBS s) - } + p + UnspentVal + { unspentValBlock = b, + unspentValAmount = v, + unspentValScript = s + } = + Unspent + { unspentBlock = b, + unspentPoint = p, + unspentAmount = v, + unspentScript = s, + unspentAddress = eitherToMaybe (scriptToAddressBS s) + } 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 @@ -13,15 +13,15 @@ import Data.Ord (Down (..)) import Data.Tuple (swap) import Database.RocksDB (BatchOp, DB) -import Database.RocksDB.Query ( - deleteOp, +import Database.RocksDB.Query + ( deleteOp, deleteOpCF, insertOp, insertOpCF, writeBatch, - ) -import Haskoin ( - Address, + ) +import Haskoin + ( Address, BlockHash, BlockHeight, Network, @@ -29,164 +29,164 @@ TxHash, headerHash, txHash, - ) + ) import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Reader import Haskoin.Store.Database.Types -import UnliftIO ( - MonadIO, +import UnliftIO + ( MonadIO, TVar, atomically, liftIO, modifyTVar, newTVarIO, readTVarIO, - ) + ) data Writer = Writer - { getReader :: !DatabaseReader - , getState :: !(TVar Memory) - } + { getReader :: !DatabaseReader, + getState :: !(TVar Memory) + } type WriterT = ReaderT Writer instance MonadIO m => StoreReadBase (WriterT m) where - getNetwork = getNetworkI - getBestBlock = getBestBlockI - getBlocksAtHeight = getBlocksAtHeightI - getBlock = getBlockI - getTxData = getTxDataI - getSpender = getSpenderI - getUnspent = getUnspentI - getBalance = getBalanceI - getMempool = getMempoolI + getNetwork = getNetworkI + getBestBlock = getBestBlockI + getBlocksAtHeight = getBlocksAtHeightI + getBlock = getBlockI + getTxData = getTxDataI + getSpender = getSpenderI + getUnspent = getUnspentI + getBalance = getBalanceI + getMempool = getMempoolI data Memory = Memory - { hNet :: - !(Maybe Network) - , hBest :: - !(Maybe (Maybe BlockHash)) - , hBlock :: - !(HashMap BlockHash (Maybe BlockData)) - , hHeight :: - !(HashMap BlockHeight [BlockHash]) - , hTx :: - !(HashMap TxHash (Maybe TxData)) - , hSpender :: - !(HashMap OutPoint (Maybe Spender)) - , hUnspent :: - !(HashMap OutPoint (Maybe Unspent)) - , hBalance :: - !(HashMap Address (Maybe Balance)) - , hAddrTx :: - !(HashMap (Address, TxRef) (Maybe ())) - , hAddrOut :: - !(HashMap (Address, BlockRef, OutPoint) (Maybe OutVal)) - , hMempool :: - !(HashMap TxHash UnixTime) - } - deriving (Eq, Show) + { hNet :: + !(Maybe Network), + hBest :: + !(Maybe (Maybe BlockHash)), + hBlock :: + !(HashMap BlockHash (Maybe BlockData)), + hHeight :: + !(HashMap BlockHeight [BlockHash]), + hTx :: + !(HashMap TxHash (Maybe TxData)), + hSpender :: + !(HashMap OutPoint (Maybe Spender)), + hUnspent :: + !(HashMap OutPoint (Maybe Unspent)), + hBalance :: + !(HashMap Address (Maybe Balance)), + hAddrTx :: + !(HashMap (Address, TxRef) (Maybe ())), + hAddrOut :: + !(HashMap (Address, BlockRef, OutPoint) (Maybe OutVal)), + hMempool :: + !(HashMap TxHash UnixTime) + } + deriving (Eq, Show) instance MonadIO m => StoreWrite (WriterT m) where - setBest h = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - setBestH h - insertBlock b = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - insertBlockH b - setBlocksAtHeight h g = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - setBlocksAtHeightH h g - insertTx t = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - insertTxH t - insertSpender p s' = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - insertSpenderH p s' - deleteSpender p = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteSpenderH p - insertAddrTx a t = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - insertAddrTxH a t - deleteAddrTx a t = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteAddrTxH a t - insertAddrUnspent a u = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - insertAddrUnspentH a u - deleteAddrUnspent a u = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteAddrUnspentH a u - addToMempool x t = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - addToMempoolH x t - deleteFromMempool x = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteFromMempoolH x - setBalance b = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - setBalanceH b - insertUnspent h = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - insertUnspentH h - deleteUnspent p = - ReaderT $ \Writer{getState = s} -> - liftIO . atomically . modifyTVar s $ - deleteUnspentH p + setBest h = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + setBestH h + insertBlock b = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + insertBlockH b + setBlocksAtHeight h g = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + setBlocksAtHeightH h g + insertTx t = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + insertTxH t + insertSpender p s' = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + insertSpenderH p s' + deleteSpender p = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + deleteSpenderH p + insertAddrTx a t = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + insertAddrTxH a t + deleteAddrTx a t = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + deleteAddrTxH a t + insertAddrUnspent a u = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + insertAddrUnspentH a u + deleteAddrUnspent a u = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + deleteAddrUnspentH a u + addToMempool x t = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + addToMempoolH x t + deleteFromMempool x = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + deleteFromMempoolH x + setBalance b = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + setBalanceH b + insertUnspent h = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + insertUnspentH h + deleteUnspent p = + ReaderT $ \Writer {getState = s} -> + liftIO . atomically . modifyTVar s $ + deleteUnspentH p getLayered :: - MonadIO m => - (Memory -> Maybe a) -> - DatabaseReaderT m a -> - WriterT m a + MonadIO m => + (Memory -> Maybe a) -> + DatabaseReaderT m a -> + WriterT m a getLayered f g = - ReaderT $ \Writer{getReader = db, getState = tmem} -> - f <$> readTVarIO tmem >>= \case - Just x -> return x - Nothing -> runReaderT g db + ReaderT $ \Writer {getReader = db, getState = tmem} -> + f <$> readTVarIO tmem >>= \case + Just x -> return x + Nothing -> runReaderT g db runWriter :: - MonadIO m => - DatabaseReader -> - WriterT m a -> - m a -runWriter bdb@DatabaseReader{databaseHandle = db} f = do - mem <- runReaderT getMempool bdb - hm <- newTVarIO (newMemory mem) - x <- R.runReaderT f Writer{getReader = bdb, getState = hm} - mem' <- readTVarIO hm - let ops = hashMapOps db mem' - writeBatch db ops - return x + MonadIO m => + DatabaseReader -> + WriterT m a -> + m a +runWriter bdb@DatabaseReader {databaseHandle = db} f = do + mem <- runReaderT getMempool bdb + hm <- newTVarIO (newMemory mem) + x <- R.runReaderT f Writer {getReader = bdb, getState = hm} + mem' <- readTVarIO hm + let ops = hashMapOps db mem' + writeBatch db ops + return x hashMapOps :: DB -> Memory -> [BatchOp] hashMapOps db mem = - bestBlockOp (hBest mem) - <> blockHashOps db (hBlock mem) - <> blockHeightOps db (hHeight mem) - <> txOps db (hTx mem) - <> spenderOps db (hSpender mem) - <> balOps db (hBalance mem) - <> addrTxOps db (hAddrTx mem) - <> addrOutOps db (hAddrOut mem) - <> mempoolOp (hMempool mem) - <> unspentOps db (hUnspent mem) + bestBlockOp (hBest mem) + <> blockHashOps db (hBlock mem) + <> blockHeightOps db (hHeight mem) + <> txOps db (hTx mem) + <> spenderOps db (hSpender mem) + <> balOps db (hBalance mem) + <> addrTxOps db (hAddrTx mem) + <> addrOutOps db (hAddrOut mem) + <> mempoolOp (hMempool mem) + <> unspentOps db (hUnspent mem) bestBlockOp :: Maybe (Maybe BlockHash) -> [BatchOp] bestBlockOp Nothing = [] @@ -229,29 +229,29 @@ f (a, t) Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t) addrOutOps :: - DB -> - HashMap (Address, BlockRef, OutPoint) (Maybe OutVal) -> - [BatchOp] + DB -> + HashMap (Address, BlockRef, OutPoint) (Maybe OutVal) -> + [BatchOp] addrOutOps db = map (uncurry f) . M.toList where f (a, b, p) (Just l) = - insertOpCF - (addrOutCF db) - ( AddrOutKey - { addrOutKeyA = a - , addrOutKeyB = b - , addrOutKeyP = p - } - ) - l + insertOpCF + (addrOutCF db) + ( AddrOutKey + { addrOutKeyA = a, + addrOutKeyB = b, + addrOutKeyP = p + } + ) + l f (a, b, p) Nothing = - deleteOpCF - (addrOutCF db) - AddrOutKey - { addrOutKeyA = a - , addrOutKeyB = b - , addrOutKeyP = p - } + deleteOpCF + (addrOutCF db) + AddrOutKey + { addrOutKeyA = a, + addrOutKeyB = b, + addrOutKeyP = p + } mempoolOp :: HashMap TxHash UnixTime -> [BatchOp] mempoolOp = return . insertOp MemKey . sortOn Down . map swap . M.toList @@ -260,9 +260,9 @@ unspentOps db = map (uncurry f) . M.toList where f p (Just u) = - insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u)) + insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u)) f p Nothing = - deleteOpCF (unspentCF db) (UnspentKey p) + deleteOpCF (unspentCF db) (UnspentKey p) getNetworkI :: MonadIO m => WriterT m Network getNetworkI = getLayered hNet getNetwork @@ -272,7 +272,7 @@ getBlocksAtHeightI :: MonadIO m => BlockHeight -> WriterT m [BlockHash] getBlocksAtHeightI bh = - getLayered (getBlocksAtHeightH bh) (getBlocksAtHeight bh) + getLayered (getBlocksAtHeightH bh) (getBlocksAtHeight bh) getBlockI :: MonadIO m => BlockHash -> WriterT m (Maybe BlockData) getBlockI bh = getLayered (getBlockH bh) (getBlock bh) @@ -291,24 +291,24 @@ getMempoolI :: MonadIO m => WriterT m [(UnixTime, TxHash)] getMempoolI = - ReaderT $ \Writer{getState = tmem} -> - getMempoolH <$> readTVarIO tmem + ReaderT $ \Writer {getState = tmem} -> + getMempoolH <$> readTVarIO tmem newMemory :: [(UnixTime, TxHash)] -> Memory newMemory mem = - Memory - { hNet = Nothing - , hBest = Nothing - , hBlock = M.empty - , hHeight = M.empty - , hTx = M.empty - , hSpender = M.empty - , hUnspent = M.empty - , hBalance = M.empty - , hAddrTx = M.empty - , hAddrOut = M.empty - , hMempool = M.fromList (map swap mem) - } + Memory + { hNet = Nothing, + hBest = Nothing, + hBlock = M.empty, + hHeight = M.empty, + hTx = M.empty, + hSpender = M.empty, + hUnspent = M.empty, + hBalance = M.empty, + hAddrTx = M.empty, + hAddrOut = M.empty, + hMempool = M.fromList (map swap mem) + } getBestBlockH :: Memory -> Maybe (Maybe BlockHash) getBestBlockH = hBest @@ -332,77 +332,77 @@ getMempoolH = sortOn Down . map swap . M.toList . hMempool setBestH :: BlockHash -> Memory -> Memory -setBestH h db = db{hBest = Just (Just h)} +setBestH h db = db {hBest = Just (Just h)} insertBlockH :: BlockData -> Memory -> Memory insertBlockH bd db = - db - { hBlock = - M.insert - (headerHash (blockDataHeader bd)) - (Just bd) - (hBlock db) - } + db + { hBlock = + M.insert + (headerHash (blockDataHeader bd)) + (Just bd) + (hBlock db) + } setBlocksAtHeightH :: [BlockHash] -> BlockHeight -> Memory -> Memory setBlocksAtHeightH hs g db = - db{hHeight = M.insert g hs (hHeight db)} + db {hHeight = M.insert g hs (hHeight db)} insertTxH :: TxData -> Memory -> Memory insertTxH tx db = - db{hTx = M.insert (txHash (txData tx)) (Just tx) (hTx db)} + db {hTx = M.insert (txHash (txData tx)) (Just tx) (hTx db)} insertSpenderH :: OutPoint -> Spender -> Memory -> Memory insertSpenderH op s db = - db{hSpender = M.insert op (Just s) (hSpender db)} + db {hSpender = M.insert op (Just s) (hSpender db)} deleteSpenderH :: OutPoint -> Memory -> Memory deleteSpenderH op db = - db{hSpender = M.insert op Nothing (hSpender db)} + db {hSpender = M.insert op Nothing (hSpender db)} setBalanceH :: Balance -> Memory -> Memory setBalanceH bal db = - db{hBalance = M.insert (balanceAddress bal) (Just bal) (hBalance db)} + db {hBalance = M.insert (balanceAddress bal) (Just bal) (hBalance db)} insertAddrTxH :: Address -> TxRef -> Memory -> Memory insertAddrTxH a tr db = - db{hAddrTx = M.insert (a, tr) (Just ()) (hAddrTx db)} + db {hAddrTx = M.insert (a, tr) (Just ()) (hAddrTx db)} deleteAddrTxH :: Address -> TxRef -> Memory -> Memory deleteAddrTxH a tr db = - db{hAddrTx = M.insert (a, tr) Nothing (hAddrTx db)} + db {hAddrTx = M.insert (a, tr) Nothing (hAddrTx db)} insertAddrUnspentH :: Address -> Unspent -> Memory -> Memory insertAddrUnspentH a u db = - let k = (a, unspentBlock u, unspentPoint u) - v = - OutVal - { outValAmount = unspentAmount u - , outValScript = unspentScript u - } - in db{hAddrOut = M.insert k (Just v) (hAddrOut db)} + let k = (a, unspentBlock u, unspentPoint u) + v = + OutVal + { outValAmount = unspentAmount u, + outValScript = unspentScript u + } + in db {hAddrOut = M.insert k (Just v) (hAddrOut db)} deleteAddrUnspentH :: Address -> Unspent -> Memory -> Memory deleteAddrUnspentH a u db = - let k = (a, unspentBlock u, unspentPoint u) - in db{hAddrOut = M.insert k Nothing (hAddrOut db)} + let k = (a, unspentBlock u, unspentPoint u) + in db {hAddrOut = M.insert k Nothing (hAddrOut db)} addToMempoolH :: TxHash -> UnixTime -> Memory -> Memory addToMempoolH h t db = - db{hMempool = M.insert h t (hMempool db)} + db {hMempool = M.insert h t (hMempool db)} deleteFromMempoolH :: TxHash -> Memory -> Memory deleteFromMempoolH h db = - db{hMempool = M.delete h (hMempool db)} + db {hMempool = M.delete h (hMempool db)} getUnspentH :: OutPoint -> Memory -> Maybe (Maybe Unspent) getUnspentH op db = M.lookup op (hUnspent db) insertUnspentH :: Unspent -> Memory -> Memory insertUnspentH u db = - let k = fst (unspentToVal u) - in db{hUnspent = M.insert k (Just u) (hUnspent db)} + let k = fst (unspentToVal u) + in db {hUnspent = M.insert k (Just u) (hUnspent db)} deleteUnspentH :: OutPoint -> Memory -> Memory deleteUnspentH op db = - db{hUnspent = M.insert op Nothing (hUnspent db)} + db {hUnspent = M.insert op Nothing (hUnspent db)} 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 @@ -6,762 +6,763 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Haskoin.Store.Logic ( - ImportException (..), - MonadImport, - initBest, - revertBlock, - importBlock, - newMempoolTx, - deleteUnconfirmedTx, -) where - -import Control.Monad ( - forM, - forM_, - guard, - unless, - void, - when, - zipWithM_, - (<=<), - ) -import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Logger ( - MonadLoggerIO (..), - logDebugS, - logErrorS, - ) -import qualified Data.ByteString as B -import Data.Either (rights) -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import qualified Data.IntMap.Strict as I -import Data.List (nub) -import Data.Maybe ( - catMaybes, - fromMaybe, - isJust, - isNothing, - ) -import Data.Serialize (encode) -import Data.String.Conversions (cs) -import Data.Word (Word32, Word64) -import Haskoin ( - Address, - Block (..), - BlockHash, - BlockHeader (..), - BlockNode (..), - Network (..), - OutPoint (..), - Tx (..), - TxHash, - TxIn (..), - TxOut (..), - blockHashToHex, - computeSubsidy, - eitherToMaybe, - genesisBlock, - genesisNode, - headerHash, - isGenesis, - nullOutPoint, - scriptToAddressBS, - txHash, - txHashToHex, - ) -import Haskoin.Store.Common -import Haskoin.Store.Data ( - Balance (..), - BlockData (..), - BlockRef (..), - Prev (..), - Spender (..), - TxData (..), - TxRef (..), - UnixTime, - Unspent (..), - confirmed, - ) -import UnliftIO (Exception) - -type MonadImport m = - ( MonadError ImportException m - , MonadLoggerIO m - , StoreReadBase m - , StoreWrite m - ) - -data ImportException - = PrevBlockNotBest - | Orphan - | UnexpectedCoinbase - | BestBlockNotFound - | BlockNotBest - | TxNotFound - | DoubleSpend - | TxConfirmed - | InsufficientFunds - | DuplicatePrevOutput - | TxSpent - deriving (Eq, Ord, Exception) - -instance Show ImportException where - show PrevBlockNotBest = "Previous block not best" - show Orphan = "Orphan" - show UnexpectedCoinbase = "Unexpected coinbase" - show BestBlockNotFound = "Best block not found" - show BlockNotBest = "Block not best" - show TxNotFound = "Transaction not found" - show DoubleSpend = "Double spend" - show TxConfirmed = "Transaction confirmed" - show InsufficientFunds = "Insufficient funds" - show DuplicatePrevOutput = "Duplicate previous output" - show TxSpent = "Transaction is spent" - -initBest :: MonadImport m => m () -initBest = do - $(logDebugS) "BlockStore" "Initializing best block" - net <- getNetwork - m <- getBestBlock - when (isNothing m) . void $ do - $(logDebugS) "BlockStore" "Importing Genesis block" - importBlock (genesisBlock net) (genesisNode net) - -newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool -newMempoolTx tx w = - getActiveTxData (txHash tx) >>= \case - Just _ -> - return False - Nothing -> do - freeOutputs True True tx - rbf <- isRBF (MemRef w) tx - checkNewTx tx - importTx (MemRef w) w rbf tx - return True - -bestBlockData :: MonadImport m => m BlockData -bestBlockData = do - h <- - getBestBlock >>= \case - Nothing -> do - $(logErrorS) "BlockStore" "Best block unknown" - throwError BestBlockNotFound - Just h -> return h - getBlock h >>= \case - Nothing -> do - $(logErrorS) "BlockStore" "Best block not found" - throwError BestBlockNotFound - Just b -> return b - -revertBlock :: MonadImport m => BlockHash -> m () -revertBlock bh = do - bd <- - bestBlockData >>= \b -> - if headerHash (blockDataHeader b) == bh - then return b - else do - $(logErrorS) "BlockStore" $ - "Cannot revert non-head block: " <> blockHashToHex bh - throwError BlockNotBest - $(logDebugS) "BlockStore" $ - "Obtained block data for " <> blockHashToHex bh - tds <- mapM getImportTxData (blockDataTxs bd) - $(logDebugS) "BlockStore" $ - "Obtained import tx data for block " <> blockHashToHex bh - setBest (prevBlock (blockDataHeader bd)) - $(logDebugS) "BlockStore" $ - "Set parent as best block " - <> blockHashToHex (prevBlock (blockDataHeader bd)) - insertBlock bd{blockDataMainChain = False} - $(logDebugS) "BlockStore" $ - "Updated as not in main chain: " <> blockHashToHex bh - forM_ (tail tds) unConfirmTx - $(logDebugS) "BlockStore" $ - "Unconfirmed " <> cs (show (length tds)) <> " transactions" - deleteConfirmedTx (txHash (txData (head tds))) - $(logDebugS) "BlockStore" $ - "Deleted coinbase: " <> txHashToHex (txHash (txData (head tds))) - -checkNewBlock :: MonadImport m => Block -> BlockNode -> m () -checkNewBlock b n = - getBestBlock >>= \case - Nothing - | isGenesis n -> return () - | otherwise -> do - $(logErrorS) "BlockStore" $ - "Cannot import non-genesis block: " - <> blockHashToHex (headerHash (blockHeader b)) - throwError BestBlockNotFound - Just h - | prevBlock (blockHeader b) == h -> return () - | otherwise -> do - $(logErrorS) "BlockStore" $ - "Block does not build on head: " - <> blockHashToHex (headerHash (blockHeader b)) - throwError PrevBlockNotBest - -importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m () -importOrConfirm bn txns = do - mapM_ (freeOutputs True False . snd) (reverse txs) - mapM_ (uncurry action) txs - where - txs = sortTxs txns - br i = BlockRef{blockRefHeight = nodeHeight bn, blockRefPos = i} - bn_time = fromIntegral . blockTimestamp $ nodeHeader bn - action i tx = - testPresent tx >>= \case - False -> import_it i tx - True -> confirm_it i tx - confirm_it i tx = - getActiveTxData (txHash tx) >>= \case - Just t -> do - $(logDebugS) "BlockStore" $ - "Confirming tx: " - <> txHashToHex (txHash tx) - confirmTx t (br i) - return Nothing - Nothing -> do - $(logErrorS) "BlockStore" $ - "Cannot find tx to confirm: " - <> txHashToHex (txHash tx) - throwError TxNotFound - import_it i tx = do - $(logDebugS) "BlockStore" $ - "Importing tx: " <> txHashToHex (txHash tx) - importTx (br i) bn_time False tx - return Nothing - -importBlock :: MonadImport m => Block -> BlockNode -> m () -importBlock b n = do - $(logDebugS) "BlockStore" $ - "Checking new block: " - <> blockHashToHex (headerHash (nodeHeader n)) - checkNewBlock b n - $(logDebugS) "BlockStore" "Passed check" - net <- getNetwork - let subsidy = computeSubsidy net (nodeHeight n) - bs <- getBlocksAtHeight (nodeHeight n) - $(logDebugS) "BlockStore" $ - "Inserting block entries for: " - <> blockHashToHex (headerHash (nodeHeader n)) - insertBlock - BlockData - { blockDataHeight = nodeHeight n - , blockDataMainChain = True - , blockDataWork = nodeWork n - , blockDataHeader = nodeHeader n - , blockDataSize = fromIntegral (B.length (encode b)) - , blockDataTxs = map txHash (blockTxns b) - , blockDataWeight = if getSegWit net then w else 0 - , blockDataSubsidy = subsidy - , blockDataFees = cb_out_val - subsidy - , blockDataOutputs = ts_out_val - } - setBlocksAtHeight - (nub (headerHash (nodeHeader n) : bs)) - (nodeHeight n) - setBest (headerHash (nodeHeader n)) - importOrConfirm n (blockTxns b) - $(logDebugS) "BlockStore" $ - "Finished importing transactions for: " - <> blockHashToHex (headerHash (nodeHeader n)) - where - cb_out_val = - sum $ map outValue $ txOut $ head $ blockTxns b - ts_out_val = - sum $ map (sum . map outValue . txOut) $ tail $ blockTxns b - w = - let f t = t{txWitness = []} - b' = b{blockTxns = map f (blockTxns b)} - x = B.length (encode b) - s = B.length (encode b') - in fromIntegral $ s * 3 + x - -checkNewTx :: MonadImport m => Tx -> m () -checkNewTx tx = do - when (unique_inputs < length (txIn tx)) $ do - $(logErrorS) "BlockStore" $ - "Transaction spends same output twice: " - <> txHashToHex (txHash tx) - throwError DuplicatePrevOutput - us <- getUnspentOutputs tx - when (any isNothing us) $ do - $(logErrorS) "BlockStore" $ - "Orphan: " <> txHashToHex (txHash tx) - throwError Orphan - when (isCoinbase tx) $ do - $(logErrorS) "BlockStore" $ - "Coinbase cannot be imported into mempool: " - <> txHashToHex (txHash tx) - throwError UnexpectedCoinbase - when (length (prevOuts tx) > length us) $ do - $(logErrorS) "BlockStore" $ - "Orphan: " <> txHashToHex (txHash tx) - throwError Orphan - when (outputs > unspents us) $ do - $(logErrorS) "BlockStore" $ - "Insufficient funds for tx: " <> txHashToHex (txHash tx) - throwError InsufficientFunds - where - unspents = sum . map unspentAmount . catMaybes - outputs = sum (map outValue (txOut tx)) - unique_inputs = length (nub' (map prevOutput (txIn tx))) - -getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent] -getUnspentOutputs tx = mapM getUnspent (prevOuts tx) - -prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData -prepareTxData rbf br tt tx us = - TxData - { txDataBlock = br - , txData = tx - , txDataPrevs = ps - , txDataDeleted = False - , txDataRBF = rbf - , txDataTime = tt - } - where - mkprv u = Prev (unspentScript u) (unspentAmount u) - ps = I.fromList $ zip [0 ..] $ map mkprv us - -importTx :: - MonadImport m => - BlockRef -> - -- | unix time - Word64 -> - -- | RBF - Bool -> - Tx -> - m () -importTx br tt rbf tx = do - mus <- getUnspentOutputs tx - us <- forM mus $ \case - Nothing -> do - $(logErrorS) "BlockStore" $ - "Attempted to import a tx missing UTXO: " - <> txHashToHex (txHash tx) - throwError Orphan - Just u -> return u - let td = prepareTxData rbf br tt tx us - commitAddTx td - -unConfirmTx :: MonadImport m => TxData -> m () -unConfirmTx t = confTx t Nothing - -confirmTx :: MonadImport m => TxData -> BlockRef -> m () -confirmTx t br = confTx t (Just br) - -replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m () -replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do - deleteAddrTx - a - TxRef - { txRefBlock = txDataBlock t - , txRefHash = txHash (txData t) - } - insertAddrTx - a - TxRef - { txRefBlock = new - , txRefHash = txHash (txData t) - } - -adjustAddressOutput :: - MonadImport m => - OutPoint -> - TxOut -> - BlockRef -> - BlockRef -> - m () -adjustAddressOutput op o old new = do - let pk = scriptOutput o - getUnspent op >>= \case - Nothing -> return () - Just u -> do - unless (unspentBlock u == old) $ - error $ "Existing unspent block bad for output: " <> show op - replace_unspent pk - where - replace_unspent pk = do - let ma = eitherToMaybe (scriptToAddressBS pk) - deleteUnspent op - insertUnspent - Unspent - { unspentBlock = new - , unspentPoint = op - , unspentAmount = outValue o - , unspentScript = pk - , unspentAddress = ma - } - forM_ ma $ replace_addr_unspent pk - replace_addr_unspent pk a = do - deleteAddrUnspent - a - Unspent - { unspentBlock = old - , unspentPoint = op - , unspentAmount = outValue o - , unspentScript = pk - , unspentAddress = Just a - } - insertAddrUnspent - a - Unspent - { unspentBlock = new - , unspentPoint = op - , unspentAmount = outValue o - , unspentScript = pk - , unspentAddress = Just a - } - decreaseBalance (confirmed old) a (outValue o) - increaseBalance (confirmed new) a (outValue o) - -confTx :: MonadImport m => TxData -> Maybe BlockRef -> m () -confTx t mbr = do - replaceAddressTx t new - forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do - let op = OutPoint (txHash (txData t)) n - adjustAddressOutput op o old new - rbf <- isRBF new (txData t) - let td = t{txDataBlock = new, txDataRBF = rbf} - insertTx td - updateMempool td - where - new = fromMaybe (MemRef (txDataTime t)) mbr - old = txDataBlock t - -freeOutputs :: - MonadImport m => - -- | only delete transaction if unconfirmed - Bool -> - -- | only delete RBF - Bool -> - Tx -> - m () -freeOutputs memonly rbfcheck tx = do - let prevs = prevOuts tx - unspents <- mapM getUnspent prevs - let spents = [p | (p, Nothing) <- zip prevs unspents] - spndrs <- catMaybes <$> mapM getSpender spents - let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs - mapM_ (deleteTx memonly rbfcheck) $ HashSet.toList txids - -deleteConfirmedTx :: MonadImport m => TxHash -> m () -deleteConfirmedTx = deleteTx False False - -deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m () -deleteUnconfirmedTx rbfcheck th = - getActiveTxData th >>= \case - Just _ -> deleteTx True rbfcheck th - Nothing -> - $(logDebugS) "BlockStore" $ - "Not found or already deleted: " <> txHashToHex th - -deleteTx :: - MonadImport m => - -- | only delete transaction if unconfirmed - Bool -> - -- | only delete RBF - Bool -> - TxHash -> - m () -deleteTx memonly rbfcheck th = do - chain <- getChain memonly rbfcheck th - $(logDebugS) "BlockStore" $ - "Deleting " <> cs (show (length chain)) - <> " txs from chain leading to " - <> txHashToHex th - mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain - -getChain :: - (MonadImport m, MonadLoggerIO m) => - -- | only delete transaction if unconfirmed - Bool -> - -- | only delete RBF - Bool -> - TxHash -> - m [Tx] -getChain memonly rbfcheck th' = do - $(logDebugS) "BlockStore" $ - "Getting chain for tx " <> txHashToHex th' - sort_clean <$> go HashSet.empty (HashSet.singleton th') - where - sort_clean = reverse . map snd . sortTxs - get_tx th = - getActiveTxData th >>= \case - Nothing -> do - $(logDebugS) "BlockStore" $ - "Transaction not found: " <> txHashToHex th - return Nothing - Just td - | memonly && confirmed (txDataBlock td) -> do - $(logErrorS) "BlockStore" $ - "Transaction already confirmed: " - <> txHashToHex th - throwError TxConfirmed - | rbfcheck -> - isRBF (txDataBlock td) (txData td) >>= \case - True -> return $ Just $ txData td - False -> do - $(logErrorS) "BlockStore" $ - "Double-spending transaction: " - <> txHashToHex th - throwError DoubleSpend - | otherwise -> return $ Just $ txData td - go txs pdg = do - txs1 <- HashSet.fromList . catMaybes <$> mapM get_tx (HashSet.toList pdg) - pdg1 <- - HashSet.fromList . concatMap (map spenderHash . I.elems) - <$> mapM getSpenders (HashSet.toList pdg) - let txs' = txs1 <> txs - pdg' = pdg1 `HashSet.difference` HashSet.map txHash txs' - if HashSet.null pdg' - then return $ HashSet.toList txs' - else go txs' pdg' - -deleteSingleTx :: MonadImport m => TxHash -> m () -deleteSingleTx th = - getActiveTxData th >>= \case - Nothing -> do - $(logErrorS) "BlockStore" $ - "Already deleted: " <> txHashToHex th - throwError TxNotFound - Just td -> do - $(logDebugS) "BlockStore" $ - "Deleting tx: " <> txHashToHex th - getSpenders th >>= \case - m - | I.null m -> commitDelTx td - | otherwise -> do - $(logErrorS) "BlockStore" $ - "Tried to delete spent tx: " - <> txHashToHex th - throwError TxSpent - -commitDelTx :: MonadImport m => TxData -> m () -commitDelTx = commitModTx False - -commitAddTx :: MonadImport m => TxData -> m () -commitAddTx = commitModTx True - -commitModTx :: MonadImport m => Bool -> TxData -> m () -commitModTx add tx_data = do - mapM_ mod_addr_tx (txDataAddresses td) - mod_outputs - mod_unspent - insertTx td - updateMempool td - where - tx = txData td - br = txDataBlock td - td = tx_data{txDataDeleted = not add} - tx_ref = TxRef br (txHash tx) - mod_addr_tx a - | add = do - insertAddrTx a tx_ref - modAddressCount add a - | otherwise = do - deleteAddrTx a tx_ref - modAddressCount add a - mod_unspent - | add = spendOutputs tx - | otherwise = unspendOutputs tx - mod_outputs - | add = addOutputs br tx - | otherwise = delOutputs br tx - -updateMempool :: MonadImport m => TxData -> m () -updateMempool td@TxData{txDataDeleted = True} = - deleteFromMempool (txHash (txData td)) -updateMempool td@TxData{txDataBlock = MemRef t} = - addToMempool (txHash (txData td)) t -updateMempool td@TxData{txDataBlock = BlockRef{}} = - deleteFromMempool (txHash (txData td)) - -spendOutputs :: MonadImport m => Tx -> m () -spendOutputs tx = - zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx) - -addOutputs :: MonadImport m => BlockRef -> Tx -> m () -addOutputs br tx = - zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx) - -isRBF :: - StoreReadBase m => - BlockRef -> - Tx -> - m Bool -isRBF br tx - | confirmed br = return False - | otherwise = - getNetwork >>= \net -> - if getReplaceByFee net - then go - else return False - where - go - | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True - | otherwise = carry_on - carry_on = - let hs = nub' $ map (outPointHash . prevOutput) (txIn tx) - ck [] = return False - ck (h : hs') = - getActiveTxData h >>= \case - Nothing -> return False - Just t - | confirmed (txDataBlock t) -> ck hs' - | txDataRBF t -> return True - | otherwise -> ck hs' - in ck hs - -addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m () -addOutput = modOutput True - -delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m () -delOutput = modOutput False - -modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m () -modOutput add br op o = do - mod_unspent - forM_ ma $ \a -> do - mod_addr_unspent a u - modBalance (confirmed br) add a (outValue o) - modifyReceived a v - where - v - | add = (+ outValue o) - | otherwise = subtract (outValue o) - ma = eitherToMaybe (scriptToAddressBS (scriptOutput o)) - u = - Unspent - { unspentScript = scriptOutput o - , unspentBlock = br - , unspentPoint = op - , unspentAmount = outValue o - , unspentAddress = ma - } - mod_unspent - | add = insertUnspent u - | otherwise = deleteUnspent op - mod_addr_unspent - | add = insertAddrUnspent - | otherwise = deleteAddrUnspent - -delOutputs :: MonadImport m => BlockRef -> Tx -> m () -delOutputs br tx = - forM_ (zip [0 ..] (txOut tx)) $ \(i, o) -> do - let op = OutPoint (txHash tx) i - delOutput br op o - -getImportTxData :: MonadImport m => TxHash -> m TxData -getImportTxData th = - getActiveTxData th >>= \case - Nothing -> do - $(logDebugS) "BlockStore" $ "Tx not found: " <> txHashToHex th - throwError TxNotFound - Just d -> return d - -getTxOut :: Word32 -> Tx -> Maybe TxOut -getTxOut i tx = do - guard (fromIntegral i < length (txOut tx)) - return $ txOut tx !! fromIntegral i - -spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m () -spendOutput th ix op = do - u <- - getUnspent op >>= \case - Just u -> return u - Nothing -> error $ "Could not find UTXO to spend: " <> show op - deleteUnspent op - insertSpender op (Spender th ix) - let pk = unspentScript u - forM_ (scriptToAddressBS pk) $ \a -> do - decreaseBalance - (confirmed (unspentBlock u)) - a - (unspentAmount u) - deleteAddrUnspent a u - -unspendOutputs :: MonadImport m => Tx -> m () -unspendOutputs = mapM_ unspendOutput . prevOuts - -unspendOutput :: MonadImport m => OutPoint -> m () -unspendOutput op = do - t <- - getActiveTxData (outPointHash op) >>= \case - Nothing -> error $ "Could not find tx data: " <> show (outPointHash op) - Just t -> return t - let o = - fromMaybe - (error ("Could not find output: " <> show op)) - (getTxOut (outPointIndex op) (txData t)) - m = eitherToMaybe (scriptToAddressBS (scriptOutput o)) - u = - Unspent - { unspentAmount = outValue o - , unspentBlock = txDataBlock t - , unspentScript = scriptOutput o - , unspentPoint = op - , unspentAddress = m - } - deleteSpender op - insertUnspent u - forM_ m $ \a -> do - insertAddrUnspent a u - increaseBalance (confirmed (unspentBlock u)) a (outValue o) - -modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m () -modifyReceived a f = do - b <- getDefaultBalance a - setBalance b{balanceTotalReceived = f (balanceTotalReceived b)} - -decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () -decreaseBalance conf = modBalance conf False - -increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () -increaseBalance conf = modBalance conf True - -modBalance :: - MonadImport m => - -- | confirmed - Bool -> - -- | add - Bool -> - Address -> - Word64 -> - m () -modBalance conf add a val = do - b <- getDefaultBalance a - setBalance $ (g . f) b - where - g b = b{balanceUnspentCount = m 1 (balanceUnspentCount b)} - f b - | conf = b{balanceAmount = m val (balanceAmount b)} - | otherwise = b{balanceZero = m val (balanceZero b)} - m - | add = (+) - | otherwise = subtract - -modAddressCount :: MonadImport m => Bool -> Address -> m () -modAddressCount add a = do - b <- getDefaultBalance a - setBalance b{balanceTxCount = f (balanceTxCount b)} - where - f - | add = (+ 1) - | otherwise = subtract 1 - -txOutAddrs :: [TxOut] -> [Address] -txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput) - -txInAddrs :: [Prev] -> [Address] -txInAddrs = nub' . rights . map (scriptToAddressBS . prevScript) - -txDataAddresses :: TxData -> [Address] -txDataAddresses t = - nub' $ txInAddrs prevs <> txOutAddrs outs +module Haskoin.Store.Logic + ( ImportException (..), + MonadImport, + initBest, + revertBlock, + importBlock, + newMempoolTx, + deleteUnconfirmedTx, + ) +where + +import Control.Monad + ( forM, + forM_, + guard, + unless, + void, + when, + zipWithM_, + (<=<), + ) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Logger + ( MonadLoggerIO (..), + logDebugS, + logErrorS, + ) +import qualified Data.ByteString as B +import Data.Either (rights) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import qualified Data.IntMap.Strict as I +import Data.List (nub) +import Data.Maybe + ( catMaybes, + fromMaybe, + isJust, + isNothing, + ) +import Data.Serialize (encode) +import Data.String.Conversions (cs) +import Data.Word (Word32, Word64) +import Haskoin + ( Address, + Block (..), + BlockHash, + BlockHeader (..), + BlockNode (..), + Network (..), + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + blockHashToHex, + computeSubsidy, + eitherToMaybe, + genesisBlock, + genesisNode, + headerHash, + isGenesis, + nullOutPoint, + scriptToAddressBS, + txHash, + txHashToHex, + ) +import Haskoin.Store.Common +import Haskoin.Store.Data + ( Balance (..), + BlockData (..), + BlockRef (..), + Prev (..), + Spender (..), + TxData (..), + TxRef (..), + UnixTime, + Unspent (..), + confirmed, + ) +import UnliftIO (Exception) + +type MonadImport m = + ( MonadError ImportException m, + MonadLoggerIO m, + StoreReadBase m, + StoreWrite m + ) + +data ImportException + = PrevBlockNotBest + | Orphan + | UnexpectedCoinbase + | BestBlockNotFound + | BlockNotBest + | TxNotFound + | DoubleSpend + | TxConfirmed + | InsufficientFunds + | DuplicatePrevOutput + | TxSpent + deriving (Eq, Ord, Exception) + +instance Show ImportException where + show PrevBlockNotBest = "Previous block not best" + show Orphan = "Orphan" + show UnexpectedCoinbase = "Unexpected coinbase" + show BestBlockNotFound = "Best block not found" + show BlockNotBest = "Block not best" + show TxNotFound = "Transaction not found" + show DoubleSpend = "Double spend" + show TxConfirmed = "Transaction confirmed" + show InsufficientFunds = "Insufficient funds" + show DuplicatePrevOutput = "Duplicate previous output" + show TxSpent = "Transaction is spent" + +initBest :: MonadImport m => m () +initBest = do + $(logDebugS) "BlockStore" "Initializing best block" + net <- getNetwork + m <- getBestBlock + when (isNothing m) . void $ do + $(logDebugS) "BlockStore" "Importing Genesis block" + importBlock (genesisBlock net) (genesisNode net) + +newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool +newMempoolTx tx w = + getActiveTxData (txHash tx) >>= \case + Just _ -> + return False + Nothing -> do + freeOutputs True True tx + rbf <- isRBF (MemRef w) tx + checkNewTx tx + importTx (MemRef w) w rbf tx + return True + +bestBlockData :: MonadImport m => m BlockData +bestBlockData = do + h <- + getBestBlock >>= \case + Nothing -> do + $(logErrorS) "BlockStore" "Best block unknown" + throwError BestBlockNotFound + Just h -> return h + getBlock h >>= \case + Nothing -> do + $(logErrorS) "BlockStore" "Best block not found" + throwError BestBlockNotFound + Just b -> return b + +revertBlock :: MonadImport m => BlockHash -> m () +revertBlock bh = do + bd <- + bestBlockData >>= \b -> + if headerHash (blockDataHeader b) == bh + then return b + else do + $(logErrorS) "BlockStore" $ + "Cannot revert non-head block: " <> blockHashToHex bh + throwError BlockNotBest + $(logDebugS) "BlockStore" $ + "Obtained block data for " <> blockHashToHex bh + tds <- mapM getImportTxData (blockDataTxs bd) + $(logDebugS) "BlockStore" $ + "Obtained import tx data for block " <> blockHashToHex bh + setBest (prevBlock (blockDataHeader bd)) + $(logDebugS) "BlockStore" $ + "Set parent as best block " + <> blockHashToHex (prevBlock (blockDataHeader bd)) + insertBlock bd {blockDataMainChain = False} + $(logDebugS) "BlockStore" $ + "Updated as not in main chain: " <> blockHashToHex bh + forM_ (tail tds) unConfirmTx + $(logDebugS) "BlockStore" $ + "Unconfirmed " <> cs (show (length tds)) <> " transactions" + deleteConfirmedTx (txHash (txData (head tds))) + $(logDebugS) "BlockStore" $ + "Deleted coinbase: " <> txHashToHex (txHash (txData (head tds))) + +checkNewBlock :: MonadImport m => Block -> BlockNode -> m () +checkNewBlock b n = + getBestBlock >>= \case + Nothing + | isGenesis n -> return () + | otherwise -> do + $(logErrorS) "BlockStore" $ + "Cannot import non-genesis block: " + <> blockHashToHex (headerHash (blockHeader b)) + throwError BestBlockNotFound + Just h + | prevBlock (blockHeader b) == h -> return () + | otherwise -> do + $(logErrorS) "BlockStore" $ + "Block does not build on head: " + <> blockHashToHex (headerHash (blockHeader b)) + throwError PrevBlockNotBest + +importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m () +importOrConfirm bn txns = do + mapM_ (freeOutputs True False . snd) (reverse txs) + mapM_ (uncurry action) txs + where + txs = sortTxs txns + br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i} + bn_time = fromIntegral . blockTimestamp $ nodeHeader bn + action i tx = + testPresent tx >>= \case + False -> import_it i tx + True -> confirm_it i tx + confirm_it i tx = + getActiveTxData (txHash tx) >>= \case + Just t -> do + $(logDebugS) "BlockStore" $ + "Confirming tx: " + <> txHashToHex (txHash tx) + confirmTx t (br i) + return Nothing + Nothing -> do + $(logErrorS) "BlockStore" $ + "Cannot find tx to confirm: " + <> txHashToHex (txHash tx) + throwError TxNotFound + import_it i tx = do + $(logDebugS) "BlockStore" $ + "Importing tx: " <> txHashToHex (txHash tx) + importTx (br i) bn_time False tx + return Nothing + +importBlock :: MonadImport m => Block -> BlockNode -> m () +importBlock b n = do + $(logDebugS) "BlockStore" $ + "Checking new block: " + <> blockHashToHex (headerHash (nodeHeader n)) + checkNewBlock b n + $(logDebugS) "BlockStore" "Passed check" + net <- getNetwork + let subsidy = computeSubsidy net (nodeHeight n) + bs <- getBlocksAtHeight (nodeHeight n) + $(logDebugS) "BlockStore" $ + "Inserting block entries for: " + <> blockHashToHex (headerHash (nodeHeader n)) + insertBlock + BlockData + { blockDataHeight = nodeHeight n, + blockDataMainChain = True, + blockDataWork = nodeWork n, + blockDataHeader = nodeHeader n, + blockDataSize = fromIntegral (B.length (encode b)), + blockDataTxs = map txHash (blockTxns b), + blockDataWeight = if getSegWit net then w else 0, + blockDataSubsidy = subsidy, + blockDataFees = cb_out_val - subsidy, + blockDataOutputs = ts_out_val + } + setBlocksAtHeight + (nub (headerHash (nodeHeader n) : bs)) + (nodeHeight n) + setBest (headerHash (nodeHeader n)) + importOrConfirm n (blockTxns b) + $(logDebugS) "BlockStore" $ + "Finished importing transactions for: " + <> blockHashToHex (headerHash (nodeHeader n)) + where + cb_out_val = + sum $ map outValue $ txOut $ head $ blockTxns b + ts_out_val = + sum $ map (sum . map outValue . txOut) $ tail $ blockTxns b + w = + let f t = t {txWitness = []} + b' = b {blockTxns = map f (blockTxns b)} + x = B.length (encode b) + s = B.length (encode b') + in fromIntegral $ s * 3 + x + +checkNewTx :: MonadImport m => Tx -> m () +checkNewTx tx = do + when (unique_inputs < length (txIn tx)) $ do + $(logErrorS) "BlockStore" $ + "Transaction spends same output twice: " + <> txHashToHex (txHash tx) + throwError DuplicatePrevOutput + us <- getUnspentOutputs tx + when (any isNothing us) $ do + $(logErrorS) "BlockStore" $ + "Orphan: " <> txHashToHex (txHash tx) + throwError Orphan + when (isCoinbase tx) $ do + $(logErrorS) "BlockStore" $ + "Coinbase cannot be imported into mempool: " + <> txHashToHex (txHash tx) + throwError UnexpectedCoinbase + when (length (prevOuts tx) > length us) $ do + $(logErrorS) "BlockStore" $ + "Orphan: " <> txHashToHex (txHash tx) + throwError Orphan + when (outputs > unspents us) $ do + $(logErrorS) "BlockStore" $ + "Insufficient funds for tx: " <> txHashToHex (txHash tx) + throwError InsufficientFunds + where + unspents = sum . map unspentAmount . catMaybes + outputs = sum (map outValue (txOut tx)) + unique_inputs = length (nub' (map prevOutput (txIn tx))) + +getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent] +getUnspentOutputs tx = mapM getUnspent (prevOuts tx) + +prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData +prepareTxData rbf br tt tx us = + TxData + { txDataBlock = br, + txData = tx, + txDataPrevs = ps, + txDataDeleted = False, + txDataRBF = rbf, + txDataTime = tt + } + where + mkprv u = Prev (unspentScript u) (unspentAmount u) + ps = I.fromList $ zip [0 ..] $ map mkprv us + +importTx :: + MonadImport m => + BlockRef -> + -- | unix time + Word64 -> + -- | RBF + Bool -> + Tx -> + m () +importTx br tt rbf tx = do + mus <- getUnspentOutputs tx + us <- forM mus $ \case + Nothing -> do + $(logErrorS) "BlockStore" $ + "Attempted to import a tx missing UTXO: " + <> txHashToHex (txHash tx) + throwError Orphan + Just u -> return u + let td = prepareTxData rbf br tt tx us + commitAddTx td + +unConfirmTx :: MonadImport m => TxData -> m () +unConfirmTx t = confTx t Nothing + +confirmTx :: MonadImport m => TxData -> BlockRef -> m () +confirmTx t br = confTx t (Just br) + +replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m () +replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do + deleteAddrTx + a + TxRef + { txRefBlock = txDataBlock t, + txRefHash = txHash (txData t) + } + insertAddrTx + a + TxRef + { txRefBlock = new, + txRefHash = txHash (txData t) + } + +adjustAddressOutput :: + MonadImport m => + OutPoint -> + TxOut -> + BlockRef -> + BlockRef -> + m () +adjustAddressOutput op o old new = do + let pk = scriptOutput o + getUnspent op >>= \case + Nothing -> return () + Just u -> do + unless (unspentBlock u == old) $ + error $ "Existing unspent block bad for output: " <> show op + replace_unspent pk + where + replace_unspent pk = do + let ma = eitherToMaybe (scriptToAddressBS pk) + deleteUnspent op + insertUnspent + Unspent + { unspentBlock = new, + unspentPoint = op, + unspentAmount = outValue o, + unspentScript = pk, + unspentAddress = ma + } + forM_ ma $ replace_addr_unspent pk + replace_addr_unspent pk a = do + deleteAddrUnspent + a + Unspent + { unspentBlock = old, + unspentPoint = op, + unspentAmount = outValue o, + unspentScript = pk, + unspentAddress = Just a + } + insertAddrUnspent + a + Unspent + { unspentBlock = new, + unspentPoint = op, + unspentAmount = outValue o, + unspentScript = pk, + unspentAddress = Just a + } + decreaseBalance (confirmed old) a (outValue o) + increaseBalance (confirmed new) a (outValue o) + +confTx :: MonadImport m => TxData -> Maybe BlockRef -> m () +confTx t mbr = do + replaceAddressTx t new + forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do + let op = OutPoint (txHash (txData t)) n + adjustAddressOutput op o old new + rbf <- isRBF new (txData t) + let td = t {txDataBlock = new, txDataRBF = rbf} + insertTx td + updateMempool td + where + new = fromMaybe (MemRef (txDataTime t)) mbr + old = txDataBlock t + +freeOutputs :: + MonadImport m => + -- | only delete transaction if unconfirmed + Bool -> + -- | only delete RBF + Bool -> + Tx -> + m () +freeOutputs memonly rbfcheck tx = do + let prevs = prevOuts tx + unspents <- mapM getUnspent prevs + let spents = [p | (p, Nothing) <- zip prevs unspents] + spndrs <- catMaybes <$> mapM getSpender spents + let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs + mapM_ (deleteTx memonly rbfcheck) $ HashSet.toList txids + +deleteConfirmedTx :: MonadImport m => TxHash -> m () +deleteConfirmedTx = deleteTx False False + +deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m () +deleteUnconfirmedTx rbfcheck th = + getActiveTxData th >>= \case + Just _ -> deleteTx True rbfcheck th + Nothing -> + $(logDebugS) "BlockStore" $ + "Not found or already deleted: " <> txHashToHex th + +deleteTx :: + MonadImport m => + -- | only delete transaction if unconfirmed + Bool -> + -- | only delete RBF + Bool -> + TxHash -> + m () +deleteTx memonly rbfcheck th = do + chain <- getChain memonly rbfcheck th + $(logDebugS) "BlockStore" $ + "Deleting " <> cs (show (length chain)) + <> " txs from chain leading to " + <> txHashToHex th + mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain + +getChain :: + (MonadImport m, MonadLoggerIO m) => + -- | only delete transaction if unconfirmed + Bool -> + -- | only delete RBF + Bool -> + TxHash -> + m [Tx] +getChain memonly rbfcheck th' = do + $(logDebugS) "BlockStore" $ + "Getting chain for tx " <> txHashToHex th' + sort_clean <$> go HashSet.empty (HashSet.singleton th') + where + sort_clean = reverse . map snd . sortTxs + get_tx th = + getActiveTxData th >>= \case + Nothing -> do + $(logDebugS) "BlockStore" $ + "Transaction not found: " <> txHashToHex th + return Nothing + Just td + | memonly && confirmed (txDataBlock td) -> do + $(logErrorS) "BlockStore" $ + "Transaction already confirmed: " + <> txHashToHex th + throwError TxConfirmed + | rbfcheck -> + isRBF (txDataBlock td) (txData td) >>= \case + True -> return $ Just $ txData td + False -> do + $(logErrorS) "BlockStore" $ + "Double-spending transaction: " + <> txHashToHex th + throwError DoubleSpend + | otherwise -> return $ Just $ txData td + go txs pdg = do + txs1 <- HashSet.fromList . catMaybes <$> mapM get_tx (HashSet.toList pdg) + pdg1 <- + HashSet.fromList . concatMap (map spenderHash . I.elems) + <$> mapM getSpenders (HashSet.toList pdg) + let txs' = txs1 <> txs + pdg' = pdg1 `HashSet.difference` HashSet.map txHash txs' + if HashSet.null pdg' + then return $ HashSet.toList txs' + else go txs' pdg' + +deleteSingleTx :: MonadImport m => TxHash -> m () +deleteSingleTx th = + getActiveTxData th >>= \case + Nothing -> do + $(logErrorS) "BlockStore" $ + "Already deleted: " <> txHashToHex th + throwError TxNotFound + Just td -> do + $(logDebugS) "BlockStore" $ + "Deleting tx: " <> txHashToHex th + getSpenders th >>= \case + m + | I.null m -> commitDelTx td + | otherwise -> do + $(logErrorS) "BlockStore" $ + "Tried to delete spent tx: " + <> txHashToHex th + throwError TxSpent + +commitDelTx :: MonadImport m => TxData -> m () +commitDelTx = commitModTx False + +commitAddTx :: MonadImport m => TxData -> m () +commitAddTx = commitModTx True + +commitModTx :: MonadImport m => Bool -> TxData -> m () +commitModTx add tx_data = do + mapM_ mod_addr_tx (txDataAddresses td) + mod_outputs + mod_unspent + insertTx td + updateMempool td + where + tx = txData td + br = txDataBlock td + td = tx_data {txDataDeleted = not add} + tx_ref = TxRef br (txHash tx) + mod_addr_tx a + | add = do + insertAddrTx a tx_ref + modAddressCount add a + | otherwise = do + deleteAddrTx a tx_ref + modAddressCount add a + mod_unspent + | add = spendOutputs tx + | otherwise = unspendOutputs tx + mod_outputs + | add = addOutputs br tx + | otherwise = delOutputs br tx + +updateMempool :: MonadImport m => TxData -> m () +updateMempool td@TxData {txDataDeleted = True} = + deleteFromMempool (txHash (txData td)) +updateMempool td@TxData {txDataBlock = MemRef t} = + addToMempool (txHash (txData td)) t +updateMempool td@TxData {txDataBlock = BlockRef {}} = + deleteFromMempool (txHash (txData td)) + +spendOutputs :: MonadImport m => Tx -> m () +spendOutputs tx = + zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx) + +addOutputs :: MonadImport m => BlockRef -> Tx -> m () +addOutputs br tx = + zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx) + +isRBF :: + StoreReadBase m => + BlockRef -> + Tx -> + m Bool +isRBF br tx + | confirmed br = return False + | otherwise = + getNetwork >>= \net -> + if getReplaceByFee net + then go + else return False + where + go + | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True + | otherwise = carry_on + carry_on = + let hs = nub' $ map (outPointHash . prevOutput) (txIn tx) + ck [] = return False + ck (h : hs') = + getActiveTxData h >>= \case + Nothing -> return False + Just t + | confirmed (txDataBlock t) -> ck hs' + | txDataRBF t -> return True + | otherwise -> ck hs' + in ck hs + +addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m () +addOutput = modOutput True + +delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m () +delOutput = modOutput False + +modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m () +modOutput add br op o = do + mod_unspent + forM_ ma $ \a -> do + mod_addr_unspent a u + modBalance (confirmed br) add a (outValue o) + modifyReceived a v + where + v + | add = (+ outValue o) + | otherwise = subtract (outValue o) + ma = eitherToMaybe (scriptToAddressBS (scriptOutput o)) + u = + Unspent + { unspentScript = scriptOutput o, + unspentBlock = br, + unspentPoint = op, + unspentAmount = outValue o, + unspentAddress = ma + } + mod_unspent + | add = insertUnspent u + | otherwise = deleteUnspent op + mod_addr_unspent + | add = insertAddrUnspent + | otherwise = deleteAddrUnspent + +delOutputs :: MonadImport m => BlockRef -> Tx -> m () +delOutputs br tx = + forM_ (zip [0 ..] (txOut tx)) $ \(i, o) -> do + let op = OutPoint (txHash tx) i + delOutput br op o + +getImportTxData :: MonadImport m => TxHash -> m TxData +getImportTxData th = + getActiveTxData th >>= \case + Nothing -> do + $(logDebugS) "BlockStore" $ "Tx not found: " <> txHashToHex th + throwError TxNotFound + Just d -> return d + +getTxOut :: Word32 -> Tx -> Maybe TxOut +getTxOut i tx = do + guard (fromIntegral i < length (txOut tx)) + return $ txOut tx !! fromIntegral i + +spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m () +spendOutput th ix op = do + u <- + getUnspent op >>= \case + Just u -> return u + Nothing -> error $ "Could not find UTXO to spend: " <> show op + deleteUnspent op + insertSpender op (Spender th ix) + let pk = unspentScript u + forM_ (scriptToAddressBS pk) $ \a -> do + decreaseBalance + (confirmed (unspentBlock u)) + a + (unspentAmount u) + deleteAddrUnspent a u + +unspendOutputs :: MonadImport m => Tx -> m () +unspendOutputs = mapM_ unspendOutput . prevOuts + +unspendOutput :: MonadImport m => OutPoint -> m () +unspendOutput op = do + t <- + getActiveTxData (outPointHash op) >>= \case + Nothing -> error $ "Could not find tx data: " <> show (outPointHash op) + Just t -> return t + let o = + fromMaybe + (error ("Could not find output: " <> show op)) + (getTxOut (outPointIndex op) (txData t)) + m = eitherToMaybe (scriptToAddressBS (scriptOutput o)) + u = + Unspent + { unspentAmount = outValue o, + unspentBlock = txDataBlock t, + unspentScript = scriptOutput o, + unspentPoint = op, + unspentAddress = m + } + deleteSpender op + insertUnspent u + forM_ m $ \a -> do + insertAddrUnspent a u + increaseBalance (confirmed (unspentBlock u)) a (outValue o) + +modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m () +modifyReceived a f = do + b <- getDefaultBalance a + setBalance b {balanceTotalReceived = f (balanceTotalReceived b)} + +decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () +decreaseBalance conf = modBalance conf False + +increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () +increaseBalance conf = modBalance conf True + +modBalance :: + MonadImport m => + -- | confirmed + Bool -> + -- | add + Bool -> + Address -> + Word64 -> + m () +modBalance conf add a val = do + b <- getDefaultBalance a + setBalance $ (g . f) b + where + g b = b {balanceUnspentCount = m 1 (balanceUnspentCount b)} + f b + | conf = b {balanceAmount = m val (balanceAmount b)} + | otherwise = b {balanceZero = m val (balanceZero b)} + m + | add = (+) + | otherwise = subtract + +modAddressCount :: MonadImport m => Bool -> Address -> m () +modAddressCount add a = do + b <- getDefaultBalance a + setBalance b {balanceTxCount = f (balanceTxCount b)} + where + f + | add = (+ 1) + | otherwise = subtract 1 + +txOutAddrs :: [TxOut] -> [Address] +txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput) + +txInAddrs :: [Prev] -> [Address] +txInAddrs = nub' . rights . map (scriptToAddressBS . prevScript) + +txDataAddresses :: TxData -> [Address] +txDataAddresses t = + nub' $ txInAddrs prevs <> txOutAddrs outs where prevs = I.elems (txDataPrevs t) outs = txOut (txData t) 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,10 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} -module Haskoin.Store.Manager ( - StoreConfig (..), +module Haskoin.Store.Manager + ( StoreConfig (..), Store (..), withStore, -) where + ) +where import Control.Monad (forever, unless, when) import Control.Monad.Logger (MonadLoggerIO) @@ -12,8 +13,8 @@ import Data.Serialize (decode) import Data.Time.Clock (NominalDiffTime) import Data.Word (Word32) -import Haskoin ( - BlockHash (..), +import Haskoin + ( BlockHash (..), Inv (..), InvType (..), InvVector (..), @@ -27,9 +28,9 @@ TxHash (..), VarString (..), sockToHostAddress, - ) -import Haskoin.Node ( - Chain, + ) +import Haskoin.Node + ( Chain, ChainEvent (..), HostPort, Node (..), @@ -39,9 +40,9 @@ PeerManager, WithConnection, withNode, - ) -import Haskoin.Store.BlockStore ( - BlockStore, + ) +import Haskoin.Store.BlockStore + ( BlockStore, BlockStoreConfig (..), blockStoreBlockSTM, blockStoreHeadSTM, @@ -51,27 +52,27 @@ blockStoreTxHashSTM, blockStoreTxSTM, withBlockStore, - ) -import Haskoin.Store.Cache ( - CacheConfig (..), + ) +import Haskoin.Store.Cache + ( CacheConfig (..), CacheWriter, cacheNewBlock, cacheNewTx, cacheWriter, connectRedis, newCacheMetrics, - ) -import Haskoin.Store.Common ( - StoreEvent (..), + ) +import Haskoin.Store.Common + ( StoreEvent (..), createDataMetrics, - ) -import Haskoin.Store.Database.Reader ( - DatabaseReader (..), + ) +import Haskoin.Store.Database.Reader + ( DatabaseReader (..), DatabaseReaderT, withDatabaseReader, - ) -import NQE ( - Inbox, + ) +import NQE + ( Inbox, Process (..), Publisher, publishSTM, @@ -79,199 +80,199 @@ withProcess, withPublisher, withSubscription, - ) + ) import Network.Socket (SockAddr (..)) import qualified System.Metrics as Metrics (Store) -import UnliftIO ( - MonadIO, +import UnliftIO + ( MonadIO, MonadUnliftIO, STM, atomically, link, withAsync, - ) + ) import UnliftIO.Concurrent (threadDelay) -- | Store mailboxes. data Store = Store - { storeManager :: !PeerManager - , storeChain :: !Chain - , storeBlock :: !BlockStore - , storeDB :: !DatabaseReader - , storeCache :: !(Maybe CacheConfig) - , storePublisher :: !(Publisher StoreEvent) - , storeNetwork :: !Network - } + { storeManager :: !PeerManager, + storeChain :: !Chain, + storeBlock :: !BlockStore, + storeDB :: !DatabaseReader, + storeCache :: !(Maybe CacheConfig), + storePublisher :: !(Publisher StoreEvent), + storeNetwork :: !Network + } -- | Configuration for a 'Store'. data StoreConfig = StoreConfig - { -- | max peers to connect to - storeConfMaxPeers :: !Int - , -- | static set of peers to connect to - storeConfInitPeers :: ![HostPort] - , -- | discover new peers - storeConfDiscover :: !Bool - , -- | RocksDB database path - storeConfDB :: !FilePath - , -- | network constants - storeConfNetwork :: !Network - , -- | Redis cache configuration - storeConfCache :: !(Maybe String) - , -- | gap on extended public key with no transactions - storeConfInitialGap :: !Word32 - , -- | gap for extended public keys - storeConfGap :: !Word32 - , -- | cache xpubs with more than this many used addresses - storeConfCacheMin :: !Int - , -- | maximum number of keys in Redis cache - storeConfMaxKeys :: !Integer - , -- | do not index new mempool transactions - storeConfNoMempool :: !Bool - , -- | wipe mempool when starting - storeConfWipeMempool :: !Bool - , -- | sync mempool from peers - storeConfSyncMempool :: !Bool - , -- | disconnect peer if message not received for this many seconds - storeConfPeerTimeout :: !NominalDiffTime - , -- | disconnect peer if it has been connected this long - storeConfPeerMaxLife :: !NominalDiffTime - , -- | connect to peers using the function 'withConnection' - storeConfConnect :: !(SockAddr -> WithConnection) - , -- | delay in microseconds to retry getting cache lock - storeConfCacheRetryDelay :: !Int - , -- | stats store - storeConfStats :: !(Maybe Metrics.Store) - } + { -- | max peers to connect to + storeConfMaxPeers :: !Int, + -- | static set of peers to connect to + storeConfInitPeers :: ![HostPort], + -- | discover new peers + storeConfDiscover :: !Bool, + -- | RocksDB database path + storeConfDB :: !FilePath, + -- | network constants + storeConfNetwork :: !Network, + -- | Redis cache configuration + storeConfCache :: !(Maybe String), + -- | gap on extended public key with no transactions + storeConfInitialGap :: !Word32, + -- | gap for extended public keys + storeConfGap :: !Word32, + -- | cache xpubs with more than this many used addresses + storeConfCacheMin :: !Int, + -- | maximum number of keys in Redis cache + storeConfMaxKeys :: !Integer, + -- | do not index new mempool transactions + storeConfNoMempool :: !Bool, + -- | wipe mempool when starting + storeConfWipeMempool :: !Bool, + -- | sync mempool from peers + storeConfSyncMempool :: !Bool, + -- | disconnect peer if message not received for this many seconds + storeConfPeerTimeout :: !NominalDiffTime, + -- | disconnect peer if it has been connected this long + storeConfPeerMaxLife :: !NominalDiffTime, + -- | connect to peers using the function 'withConnection' + storeConfConnect :: !(SockAddr -> WithConnection), + -- | delay in microseconds to retry getting cache lock + storeConfCacheRetryDelay :: !Int, + -- | stats store + storeConfStats :: !(Maybe Metrics.Store) + } withStore :: - (MonadLoggerIO m, MonadUnliftIO m) => - StoreConfig -> - (Store -> m a) -> - m a + (MonadLoggerIO m, MonadUnliftIO m) => + StoreConfig -> + (Store -> m a) -> + m a withStore cfg action = - connectDB cfg $ - ReaderT $ \db -> - withPublisher $ \pub -> - withPublisher $ \node_pub -> - withSubscription node_pub $ \node_sub -> - withNode (nodeCfg cfg db node_pub) $ \node -> - withCache cfg (nodeChain node) db pub $ \mcache -> - withBlockStore (blockStoreCfg cfg node pub db) $ \b -> - withAsync (nodeForwarder b pub node_sub) $ \a1 -> - link a1 - >> action - Store - { storeManager = nodeManager node - , storeChain = nodeChain node - , storeBlock = b - , storeDB = db - , storeCache = mcache - , storePublisher = pub - , storeNetwork = storeConfNetwork cfg - } + connectDB cfg $ + ReaderT $ \db -> + withPublisher $ \pub -> + withPublisher $ \node_pub -> + withSubscription node_pub $ \node_sub -> + withNode (nodeCfg cfg db node_pub) $ \node -> + withCache cfg (nodeChain node) db pub $ \mcache -> + withBlockStore (blockStoreCfg cfg node pub db) $ \b -> + withAsync (nodeForwarder b pub node_sub) $ \a1 -> + link a1 + >> action + Store + { storeManager = nodeManager node, + storeChain = nodeChain node, + storeBlock = b, + storeDB = db, + storeCache = mcache, + storePublisher = pub, + storeNetwork = storeConfNetwork cfg + } connectDB :: MonadUnliftIO m => StoreConfig -> DatabaseReaderT m a -> m a connectDB cfg f = do - stats <- mapM createDataMetrics (storeConfStats cfg) - withDatabaseReader - (storeConfNetwork cfg) - (storeConfInitialGap cfg) - (storeConfGap cfg) - (storeConfDB cfg) - stats - f + stats <- mapM createDataMetrics (storeConfStats cfg) + withDatabaseReader + (storeConfNetwork cfg) + (storeConfInitialGap cfg) + (storeConfGap cfg) + (storeConfDB cfg) + stats + f blockStoreCfg :: - StoreConfig -> - Node -> - Publisher StoreEvent -> - DatabaseReader -> - BlockStoreConfig + StoreConfig -> + Node -> + Publisher StoreEvent -> + DatabaseReader -> + BlockStoreConfig blockStoreCfg cfg node pub db = - BlockStoreConfig - { blockConfChain = nodeChain node - , blockConfManager = nodeManager node - , blockConfListener = pub - , blockConfDB = db - , blockConfNet = storeConfNetwork cfg - , blockConfNoMempool = storeConfNoMempool cfg - , blockConfWipeMempool = storeConfWipeMempool cfg - , blockConfSyncMempool = storeConfSyncMempool cfg - , blockConfPeerTimeout = storeConfPeerTimeout cfg - , blockConfStats = storeConfStats cfg - } + BlockStoreConfig + { blockConfChain = nodeChain node, + blockConfManager = nodeManager node, + blockConfListener = pub, + blockConfDB = db, + blockConfNet = storeConfNetwork cfg, + blockConfNoMempool = storeConfNoMempool cfg, + blockConfWipeMempool = storeConfWipeMempool cfg, + blockConfSyncMempool = storeConfSyncMempool cfg, + blockConfPeerTimeout = storeConfPeerTimeout cfg, + blockConfStats = storeConfStats cfg + } nodeCfg :: - StoreConfig -> - DatabaseReader -> - Publisher NodeEvent -> - NodeConfig + StoreConfig -> + DatabaseReader -> + Publisher NodeEvent -> + NodeConfig nodeCfg cfg db pub = - NodeConfig - { nodeConfMaxPeers = storeConfMaxPeers cfg - , nodeConfDB = databaseHandle db - , nodeConfColumnFamily = Nothing - , nodeConfPeers = storeConfInitPeers cfg - , nodeConfDiscover = storeConfDiscover cfg - , nodeConfEvents = pub - , nodeConfNetAddr = - NetworkAddress - 0 - (sockToHostAddress (SockAddrInet 0 0)) - , nodeConfNet = storeConfNetwork cfg - , nodeConfTimeout = storeConfPeerTimeout cfg - , nodeConfPeerMaxLife = storeConfPeerMaxLife cfg - , nodeConfConnect = storeConfConnect cfg - } + NodeConfig + { nodeConfMaxPeers = storeConfMaxPeers cfg, + nodeConfDB = databaseHandle db, + nodeConfColumnFamily = Nothing, + nodeConfPeers = storeConfInitPeers cfg, + nodeConfDiscover = storeConfDiscover cfg, + nodeConfEvents = pub, + nodeConfNetAddr = + NetworkAddress + 0 + (sockToHostAddress (SockAddrInet 0 0)), + nodeConfNet = storeConfNetwork cfg, + nodeConfTimeout = storeConfPeerTimeout cfg, + nodeConfPeerMaxLife = storeConfPeerMaxLife cfg, + nodeConfConnect = storeConfConnect cfg + } withCache :: - (MonadUnliftIO m, MonadLoggerIO m) => - StoreConfig -> - Chain -> - DatabaseReader -> - Publisher StoreEvent -> - (Maybe CacheConfig -> m a) -> - m a + (MonadUnliftIO m, MonadLoggerIO m) => + StoreConfig -> + Chain -> + DatabaseReader -> + Publisher StoreEvent -> + (Maybe CacheConfig -> m a) -> + m a withCache cfg chain db pub action = - case storeConfCache cfg of - Nothing -> - action Nothing - Just redisurl -> - mapM newCacheMetrics (storeConfStats cfg) >>= \metrics -> - connectRedis redisurl >>= \conn -> - withSubscription pub $ \evts -> - let conf = c conn metrics - in withProcess (f conf) $ \p -> - cacheWriterProcesses evts (getProcessMailbox p) $ do - action (Just conf) + case storeConfCache cfg of + Nothing -> + action Nothing + Just redisurl -> + mapM newCacheMetrics (storeConfStats cfg) >>= \metrics -> + connectRedis redisurl >>= \conn -> + withSubscription pub $ \evts -> + let conf = c conn metrics + in withProcess (f conf) $ \p -> + cacheWriterProcesses evts (getProcessMailbox p) $ do + action (Just conf) where f conf cwinbox = runReaderT (cacheWriter conf cwinbox) db c conn metrics = - CacheConfig - { cacheConn = conn - , cacheMin = storeConfCacheMin cfg - , cacheChain = chain - , cacheMax = storeConfMaxKeys cfg - , cacheRetryDelay = storeConfCacheRetryDelay cfg - , cacheMetrics = metrics - } + CacheConfig + { cacheConn = conn, + cacheMin = storeConfCacheMin cfg, + cacheChain = chain, + cacheMax = storeConfMaxKeys cfg, + cacheRetryDelay = storeConfCacheRetryDelay cfg, + cacheMetrics = metrics + } cacheWriterProcesses :: - MonadUnliftIO m => - Inbox StoreEvent -> - CacheWriter -> - m a -> - m a + MonadUnliftIO m => + Inbox StoreEvent -> + CacheWriter -> + m a -> + m a cacheWriterProcesses evts cwm action = - withAsync events $ \a1 -> link a1 >> action + withAsync events $ \a1 -> link a1 >> action where events = cacheWriterEvents evts cwm cacheWriterEvents :: MonadIO m => Inbox StoreEvent -> CacheWriter -> m () cacheWriterEvents evts cwm = - forever $ - receive evts >>= \e -> - e `cacheWriterDispatch` cwm + forever $ + receive evts >>= \e -> + e `cacheWriterDispatch` cwm cacheWriterDispatch :: MonadIO m => StoreEvent -> CacheWriter -> m () cacheWriterDispatch (StoreBestBlock _) = cacheNewBlock @@ -280,58 +281,58 @@ cacheWriterDispatch _ = const (return ()) nodeForwarder :: - MonadIO m => - BlockStore -> - Publisher StoreEvent -> - Inbox NodeEvent -> - m () + MonadIO m => + BlockStore -> + Publisher StoreEvent -> + Inbox NodeEvent -> + m () nodeForwarder b pub sub = - forever $ receive sub >>= atomically . storeDispatch b pub + forever $ receive sub >>= atomically . storeDispatch b pub -- | Dispatcher of node events. storeDispatch :: - BlockStore -> - Publisher StoreEvent -> - NodeEvent -> - STM () + BlockStore -> + Publisher StoreEvent -> + NodeEvent -> + STM () storeDispatch b pub (PeerEvent (PeerConnected p)) = do - publishSTM (StorePeerConnected p) pub - blockStorePeerConnectSTM p b + publishSTM (StorePeerConnected p) pub + blockStorePeerConnectSTM p b storeDispatch b pub (PeerEvent (PeerDisconnected p)) = do - publishSTM (StorePeerDisconnected p) pub - blockStorePeerDisconnectSTM p b + publishSTM (StorePeerDisconnected p) pub + blockStorePeerDisconnectSTM p b storeDispatch b _ (ChainEvent (ChainBestBlock bn)) = - blockStoreHeadSTM bn b + blockStoreHeadSTM bn b storeDispatch _ _ (ChainEvent _) = - return () + return () storeDispatch _ pub (PeerMessage p (MPong (Pong n))) = - publishSTM (StorePeerPong p n) pub + publishSTM (StorePeerPong p n) pub storeDispatch b _ (PeerMessage p (MBlock block)) = - blockStoreBlockSTM p block b + blockStoreBlockSTM p block b storeDispatch b _ (PeerMessage p (MTx tx)) = - blockStoreTxSTM p tx b + blockStoreTxSTM p tx b storeDispatch b _ (PeerMessage p (MNotFound (NotFound is))) = do - let blocks = - [ BlockHash h - | InvVector t h <- is - , t == InvBlock || t == InvWitnessBlock - ] - unless (null blocks) $ blockStoreNotFoundSTM p blocks b + let blocks = + [ BlockHash h + | InvVector t h <- is, + t == InvBlock || t == InvWitnessBlock + ] + unless (null blocks) $ blockStoreNotFoundSTM p blocks b storeDispatch b pub (PeerMessage p (MInv (Inv is))) = do - let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx] - publishSTM (StoreTxAnnounce p txs) pub - unless (null txs) $ blockStoreTxHashSTM p txs b + let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx] + publishSTM (StoreTxAnnounce p txs) pub + unless (null txs) $ blockStoreTxHashSTM p txs b storeDispatch _ pub (PeerMessage p (MReject r)) = - when (rejectMessage r == MCTx) $ - case decode (rejectData r) of - Left _ -> return () - Right th -> - let reject = - StoreTxReject - p - th - (rejectCode r) - (getVarString (rejectReason r)) - in publishSTM reject pub + when (rejectMessage r == MCTx) $ + case decode (rejectData r) of + Left _ -> return () + Right th -> + let reject = + StoreTxReject + p + th + (rejectCode r) + (getVarString (rejectReason r)) + in publishSTM reject pub storeDispatch _ _ _ = - return () + return () 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,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Haskoin.Store.Stats ( - StatDist, +module Haskoin.Store.Stats + ( StatDist, withStats, createStatDist, addStatTime, @@ -10,13 +10,14 @@ addServerError, addStatQuery, addStatItems, -) where + ) +where -import Control.Concurrent.STM.TQueue ( - TQueue, +import Control.Concurrent.STM.TQueue + ( TQueue, flushTQueue, writeTQueue, - ) + ) import qualified Control.Foldl as L import Control.Monad (forever) import Data.Function (on) @@ -28,24 +29,24 @@ import Data.Ord (Down (..), comparing) import Data.String.Conversions (cs) import Data.Text (Text) -import System.Metrics ( - Store, +import System.Metrics + ( Store, Value (..), newStore, registerGcMetrics, registerGroup, sampleAll, - ) -import System.Remote.Monitoring.Statsd ( - defaultStatsdOptions, + ) +import System.Remote.Monitoring.Statsd + ( defaultStatsdOptions, flushInterval, forkStatsd, host, port, prefix, - ) -import UnliftIO ( - MonadIO, + ) +import UnliftIO + ( MonadIO, TVar, atomically, liftIO, @@ -54,129 +55,118 @@ newTVarIO, readTVar, withAsync, - ) + ) import UnliftIO.Concurrent (threadDelay) withStats :: MonadIO m => Text -> Int -> Text -> (Store -> m a) -> m a withStats h p pfx go = do - store <- liftIO newStore - _statsd <- - liftIO $ - forkStatsd - defaultStatsdOptions - { prefix = pfx - , host = h - , port = p - } - store - liftIO $ registerGcMetrics store - go store + store <- liftIO newStore + _statsd <- + liftIO $ + forkStatsd + defaultStatsdOptions + { prefix = pfx, + host = h, + port = p + } + store + liftIO $ registerGcMetrics store + go store data StatData = StatData - { statTimes :: ![Int64] - , statQueries :: !Int64 - , statItems :: !Int64 - , statClientErrors :: !Int64 - , statServerErrors :: !Int64 - } + { statTimes :: ![Int64], + statQueries :: !Int64, + statItems :: !Int64, + statClientErrors :: !Int64, + statServerErrors :: !Int64 + } data StatDist = StatDist - { distQueue :: !(TQueue Int64) - , distQueries :: !(TVar Int64) - , distItems :: !(TVar Int64) - , distClientErrors :: !(TVar Int64) - , distServerErrors :: !(TVar Int64) - } + { distQueue :: !(TQueue Int64), + distQueries :: !(TVar Int64), + distItems :: !(TVar Int64), + distClientErrors :: !(TVar Int64), + distServerErrors :: !(TVar Int64) + } createStatDist :: MonadIO m => Text -> Store -> m StatDist createStatDist t store = liftIO $ do - distQueue <- newTQueueIO - distQueries <- newTVarIO 0 - distItems <- newTVarIO 0 - distClientErrors <- newTVarIO 0 - distServerErrors <- newTVarIO 0 - let metrics = - HashMap.fromList - [ - ( t <> ".request_count" - , Counter . statQueries - ) - , - ( t <> ".item_count" - , Counter . statItems - ) - , - ( t <> ".client_errors" - , Counter . statClientErrors - ) - , - ( t <> ".server_errors" - , Counter . statServerErrors - ) - , - ( t <> ".mean_ms" - , Gauge . mean . statTimes - ) - , - ( t <> ".avg_ms" - , Gauge . avg . statTimes - ) - , - ( t <> ".max_ms" - , Gauge . maxi . statTimes - ) - , - ( t <> ".min_ms" - , Gauge . mini . statTimes - ) - , - ( t <> ".p90max_ms" - , Gauge . p90max . statTimes - ) - , - ( t <> ".p90avg_ms" - , Gauge . p90avg . statTimes - ) - , - ( t <> ".var_ms" - , Gauge . var . statTimes - ) - ] - let sd = StatDist{..} - registerGroup metrics (flush sd) store - return sd + distQueue <- newTQueueIO + distQueries <- newTVarIO 0 + distItems <- newTVarIO 0 + distClientErrors <- newTVarIO 0 + distServerErrors <- newTVarIO 0 + let metrics = + HashMap.fromList + [ ( t <> ".request_count", + Counter . statQueries + ), + ( t <> ".item_count", + Counter . statItems + ), + ( t <> ".client_errors", + Counter . statClientErrors + ), + ( t <> ".server_errors", + Counter . statServerErrors + ), + ( t <> ".mean_ms", + Gauge . mean . statTimes + ), + ( t <> ".avg_ms", + Gauge . avg . statTimes + ), + ( t <> ".max_ms", + Gauge . maxi . statTimes + ), + ( t <> ".min_ms", + Gauge . mini . statTimes + ), + ( t <> ".p90max_ms", + Gauge . p90max . statTimes + ), + ( t <> ".p90avg_ms", + Gauge . p90avg . statTimes + ), + ( t <> ".var_ms", + Gauge . var . statTimes + ) + ] + let sd = StatDist {..} + registerGroup metrics (flush sd) store + return sd toDouble :: Int64 -> Double toDouble = fromIntegral addStatTime :: MonadIO m => StatDist -> Int64 -> m () addStatTime q = - liftIO . atomically . writeTQueue (distQueue q) + liftIO . atomically . writeTQueue (distQueue q) addStatQuery :: MonadIO m => StatDist -> m () addStatQuery q = - liftIO . atomically $ modifyTVar (distQueries q) (+ 1) + liftIO . atomically $ modifyTVar (distQueries q) (+ 1) addStatItems :: MonadIO m => StatDist -> Int64 -> m () addStatItems q = - liftIO . atomically . modifyTVar (distItems q) . (+) + liftIO . atomically . modifyTVar (distItems q) . (+) addClientError :: MonadIO m => StatDist -> m () addClientError q = - liftIO . atomically $ modifyTVar (distClientErrors q) (+ 1) + liftIO . atomically $ modifyTVar (distClientErrors q) (+ 1) addServerError :: MonadIO m => StatDist -> m () addServerError q = - liftIO . atomically $ modifyTVar (distServerErrors q) (+ 1) + liftIO . atomically $ modifyTVar (distServerErrors q) (+ 1) flush :: MonadIO m => StatDist -> m StatData -flush StatDist{..} = atomically $ do - statTimes <- flushTQueue distQueue - statQueries <- readTVar distQueries - statItems <- readTVar distItems - statClientErrors <- readTVar distClientErrors - statServerErrors <- readTVar distServerErrors - return $ StatData{..} +flush StatDist {..} = atomically $ do + statTimes <- flushTQueue distQueue + statQueries <- readTVar distQueries + statItems <- readTVar distItems + statClientErrors <- readTVar distClientErrors + statServerErrors <- readTVar distServerErrors + return $ StatData {..} average :: Fractional a => L.Fold a a average = (/) <$> L.sum <*> L.genericLength @@ -198,9 +188,9 @@ p90max :: [Int64] -> Int64 p90max ls = - case chopped of - [] -> 0 - h : _ -> h + case chopped of + [] -> 0 + h : _ -> h where sorted = sortBy (comparing Down) ls len = length sorted @@ -208,7 +198,7 @@ p90avg :: [Int64] -> Int64 p90avg ls = - avg chopped + avg chopped where sorted = sortBy (comparing Down) ls len = length sorted 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 @@ -11,3053 +11,3140 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-deprecations #-} -module Haskoin.Store.Web ( - -- * Web - WebConfig (..), - Except (..), - WebLimits (..), - WebTimeouts (..), - runWeb, -) where - -import Conduit ( - ConduitT, - await, - concatMapC, - concatMapMC, - dropC, - dropWhileC, - headC, - mapC, - runConduit, - sinkList, - takeC, - takeWhileC, - yield, - (.|), - ) -import Control.Applicative ((<|>)) -import Control.Arrow (second) -import Control.Lens ((.~), (^.)) -import Control.Monad ( - forM_, - forever, - join, - unless, - when, - (<=<), - ) -import Control.Monad.Logger ( - MonadLoggerIO, - logDebugS, - logErrorS, - logWarnS, - ) -import Control.Monad.Reader ( - ReaderT, - asks, - local, - runReaderT, - ) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Control (liftWith, restoreT) -import Control.Monad.Trans.Maybe ( - MaybeT (..), - runMaybeT, - ) -import Data.Aeson ( - Encoding, - ToJSON (..), - Value, - ) -import qualified Data.Aeson as A -import Data.Aeson.Encode.Pretty ( - Config (..), - defConfig, - encodePretty', - ) -import Data.Aeson.Encoding ( - encodingToLazyByteString, - list, - ) -import Data.Aeson.Text (encodeToLazyText) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Base16 as B16 -import Data.ByteString.Builder (lazyByteString) -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as L -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Char (isSpace) -import Data.Default (Default (..)) -import Data.Function ((&)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.Int (Int64) -import Data.List (nub) -import Data.Maybe ( - catMaybes, - fromJust, - fromMaybe, - isJust, - mapMaybe, - maybeToList, - ) -import Data.Proxy (Proxy (..)) -import Data.Serialize (decode) -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Text.Lazy (toStrict) -import qualified Data.Text.Lazy as TL -import Data.Time.Clock (diffUTCTime) -import Data.Time.Clock.System ( - getSystemTime, - systemSeconds, - systemToUTCTime, - ) -import qualified Data.Vault.Lazy as V -import Data.Word (Word32, Word64) -import Database.RocksDB ( - Property (..), - getProperty, - ) -import Haskoin.Address -import qualified Haskoin.Block as H -import Haskoin.Constants -import Haskoin.Data -import Haskoin.Keys -import Haskoin.Network -import Haskoin.Node ( - Chain, - OnlinePeer (..), - PeerManager, - chainGetAncestor, - chainGetBest, - getPeers, - sendMessage, - ) -import Haskoin.Script -import Haskoin.Store.BlockStore -import Haskoin.Store.Cache -import Haskoin.Store.Common -import Haskoin.Store.Data -import Haskoin.Store.Database.Reader -import Haskoin.Store.Manager -import Haskoin.Store.Stats -import Haskoin.Store.WebCommon -import Haskoin.Transaction -import Haskoin.Util -import NQE ( - Inbox, - Publisher, - receive, - withSubscription, - ) -import Network.HTTP.Types ( - Status (..), - requestEntityTooLarge413, - status400, - status404, - status409, - status413, - status500, - status503, - statusIsClientError, - statusIsServerError, - statusIsSuccessful, - ) -import Network.Wai ( - Middleware, - Request (..), - Response, - getRequestBodyChunk, - responseLBS, - responseStatus, - ) -import Network.Wai.Handler.Warp ( - defaultSettings, - setHost, - setPort, - ) -import Network.Wai.Handler.WebSockets (websocketsOr) -import Network.Wai.Middleware.RequestSizeLimit -import Network.WebSockets ( - ServerApp, - acceptRequest, - defaultConnectionOptions, - pendingRequest, - rejectRequestWith, - requestPath, - sendTextData, - ) -import qualified Network.WebSockets as WebSockets -import qualified Network.Wreq as Wreq -import Network.Wreq.Session as Wreq (Session) -import qualified Network.Wreq.Session as Wreq.Session -import System.IO.Unsafe (unsafeInterleaveIO) -import qualified System.Metrics as Metrics -import qualified System.Metrics.Gauge as Metrics (Gauge) -import qualified System.Metrics.Gauge as Metrics.Gauge -import UnliftIO ( - MonadIO, - MonadUnliftIO, - TVar, - askRunInIO, - atomically, - bracket, - bracket_, - handleAny, - liftIO, - modifyTVar, - newTVarIO, - readTVarIO, - timeout, - withAsync, - withRunInIO, - writeTVar, - ) -import UnliftIO.Concurrent (threadDelay) -import Web.Scotty.Internal.Types (ActionT) -import qualified Web.Scotty.Trans as S - -type WebT m = ActionT Except (ReaderT WebState m) - -data WebLimits = WebLimits - { maxLimitCount :: !Word32 - , maxLimitFull :: !Word32 - , maxLimitOffset :: !Word32 - , maxLimitDefault :: !Word32 - , maxLimitGap :: !Word32 - , maxLimitInitialGap :: !Word32 - , maxLimitBody :: !Word32 - } - deriving (Eq, Show) - -instance Default WebLimits where - def = - WebLimits - { maxLimitCount = 200000 - , maxLimitFull = 5000 - , maxLimitOffset = 50000 - , maxLimitDefault = 100 - , maxLimitGap = 32 - , maxLimitInitialGap = 20 - , maxLimitBody = 1024 * 1024 - } - -data WebConfig = WebConfig - { webHost :: !String - , webPort :: !Int - , webStore :: !Store - , webMaxDiff :: !Int - , webMaxPending :: !Int - , webMaxLimits :: !WebLimits - , webTimeouts :: !WebTimeouts - , webVersion :: !String - , webNoMempool :: !Bool - , webStats :: !(Maybe Metrics.Store) - , webPriceGet :: !Int - , webTickerURL :: !String - , webHistoryURL :: !String - } - -data WebState = WebState - { webConfig :: !WebConfig - , webTicker :: !(TVar (HashMap Text BinfoTicker)) - , webMetrics :: !(Maybe WebMetrics) - , webWreqSession :: !Wreq.Session - } - -data WebMetrics = WebMetrics - { statAll :: !StatDist - , -- Addresses - statAddressTransactions :: !StatDist - , statAddressTransactionsFull :: !StatDist - , statAddressBalance :: !StatDist - , statAddressUnspent :: !StatDist - , statXpub :: !StatDist - , statXpubDelete :: !StatDist - , statXpubTransactionsFull :: !StatDist - , statXpubTransactions :: !StatDist - , statXpubBalances :: !StatDist - , statXpubUnspent :: !StatDist - , -- Transactions - statTransaction :: !StatDist - , statTransactionRaw :: !StatDist - , statTransactionAfter :: !StatDist - , statTransactionsBlock :: !StatDist - , statTransactionsBlockRaw :: !StatDist - , statTransactionPost :: !StatDist - , statMempool :: !StatDist - , -- Blocks - statBlock :: !StatDist - , statBlockRaw :: !StatDist - , -- Blockchain - statBlockchainMultiaddr :: !StatDist - , statBlockchainBalance :: !StatDist - , statBlockchainRawaddr :: !StatDist - , statBlockchainUnspent :: !StatDist - , statBlockchainRawtx :: !StatDist - , statBlockchainRawblock :: !StatDist - , statBlockchainMempool :: !StatDist - , statBlockchainBlockHeight :: !StatDist - , statBlockchainBlocks :: !StatDist - , statBlockchainLatestblock :: !StatDist - , statBlockchainExportHistory :: !StatDist - , -- Blockchain /q endpoints - statBlockchainQaddresstohash :: !StatDist - , statBlockchainQhashtoaddress :: !StatDist - , statBlockchainQaddrpubkey :: !StatDist - , statBlockchainQpubkeyaddr :: !StatDist - , statBlockchainQhashpubkey :: !StatDist - , statBlockchainQgetblockcount :: !StatDist - , statBlockchainQlatesthash :: !StatDist - , statBlockchainQbcperblock :: !StatDist - , statBlockchainQtxtotalbtcoutput :: !StatDist - , statBlockchainQtxtotalbtcinput :: !StatDist - , statBlockchainQtxfee :: !StatDist - , statBlockchainQtxresult :: !StatDist - , statBlockchainQgetreceivedbyaddress :: !StatDist - , statBlockchainQgetsentbyaddress :: !StatDist - , statBlockchainQaddressbalance :: !StatDist - , statBlockchainQaddressfirstseen :: !StatDist - , -- Others - statHealth :: !StatDist - , statPeers :: !StatDist - , statDbstats :: !StatDist - , statEvents :: !Metrics.Gauge.Gauge - , -- Request - statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist)))) - } - -createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics -createMetrics s = liftIO $ do - statAll <- d "all" - - -- Addresses - statAddressTransactions <- d "address_transactions" - statAddressTransactionsFull <- d "address_transactions_full" - statAddressBalance <- d "address_balance" - statAddressUnspent <- d "address_unspent" - statXpub <- d "xpub" - statXpubDelete <- d "xpub_delete" - statXpubTransactionsFull <- d "xpub_transactions_full" - statXpubTransactions <- d "xpub_transactions" - statXpubBalances <- d "xpub_balances" - statXpubUnspent <- d "xpub_unspent" - - -- Transactions - statTransaction <- d "transaction" - statTransactionRaw <- d "transaction_raw" - statTransactionAfter <- d "transaction_after" - statTransactionPost <- d "transaction_post" - statTransactionsBlock <- d "transactions_block" - statTransactionsBlockRaw <- d "transactions_block_raw" - statMempool <- d "mempool" - - -- Blocks - statBlockBest <- d "block_best" - statBlockLatest <- d "block_latest" - statBlock <- d "block" - statBlockRaw <- d "block_raw" - statBlockHeight <- d "block_height" - statBlockHeightRaw <- d "block_height_raw" - statBlockTime <- d "block_time" - statBlockTimeRaw <- d "block_time_raw" - statBlockMtp <- d "block_mtp" - statBlockMtpRaw <- d "block_mtp_raw" - - -- Blockchain - statBlockchainMultiaddr <- d "blockchain_multiaddr" - statBlockchainBalance <- d "blockchain_balance" - statBlockchainRawaddr <- d "blockchain_rawaddr" - statBlockchainUnspent <- d "blockchain_unspent" - statBlockchainRawtx <- d "blockchain_rawtx" - statBlockchainRawblock <- d "blockchain_rawblock" - statBlockchainLatestblock <- d "blockchain_latestblock" - statBlockchainMempool <- d "blockchain_mempool" - statBlockchainBlockHeight <- d "blockchain_block_height" - statBlockchainBlocks <- d "blockchain_blocks" - statBlockchainExportHistory <- d "blockchain_export_history" - - -- Blockchain /q endpoints - statBlockchainQaddresstohash <- d "blockchain_q_addresstohash" - statBlockchainQhashtoaddress <- d "blockchain_q_hashtoaddress" - statBlockchainQaddrpubkey <- d "blockckhain_q_addrpubkey" - statBlockchainQpubkeyaddr <- d "blockchain_q_pubkeyaddr" - statBlockchainQhashpubkey <- d "blockchain_q_hashpubkey" - statBlockchainQgetblockcount <- d "blockchain_q_getblockcount" - statBlockchainQlatesthash <- d "blockchain_q_latesthash" - statBlockchainQbcperblock <- d "blockchain_q_bcperblock" - statBlockchainQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput" - statBlockchainQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput" - statBlockchainQtxfee <- d "blockchain_q_txfee" - statBlockchainQtxresult <- d "blockchain_q_txresult" - statBlockchainQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress" - statBlockchainQgetsentbyaddress <- d "blockchain_q_getsentbyaddress" - statBlockchainQaddressbalance <- d "blockchain_q_addressbalance" - statBlockchainQaddressfirstseen <- d "blockchain_q_addressfirstseen" - - -- Others - statHealth <- d "health" - statPeers <- d "peers" - statDbstats <- d "dbstats" - - statEvents <- g "events_connected" - statKey <- V.newKey - return WebMetrics{..} - where - d x = createStatDist ("web." <> x) s - g x = Metrics.createGauge ("web." <> x) s - -withGaugeIO :: MonadUnliftIO m => Metrics.Gauge -> m a -> m a -withGaugeIO g = - bracket_ - (liftIO $ Metrics.Gauge.inc g) - (liftIO $ Metrics.Gauge.dec g) - -withGaugeIncrease :: - MonadUnliftIO m => - (WebMetrics -> Metrics.Gauge) -> - WebT m a -> - WebT m a -withGaugeIncrease gf go = - lift (asks webMetrics) >>= \case - Nothing -> go - Just m -> do - s <- liftWith $ \run -> withGaugeIO (gf m) (run go) - restoreT $ return s - -setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) -> WebT m () -setMetrics df = - asks webMetrics >>= mapM_ go - where - go m = do - req <- S.request - let t = fromMaybe e $ V.lookup (statKey m) (vault req) - atomically $ writeTVar t (Just df) - e = error "the ways of the warrior are yet to be mastered" - -addItemCount :: MonadUnliftIO m => Int -> WebT m () -addItemCount i = - asks webMetrics >>= mapM_ \m -> - addStatItems (statAll m) (fromIntegral i) - >> S.request >>= \req -> - forM_ (V.lookup (statKey m) (vault req)) \t -> - readTVarIO t >>= mapM_ \s -> - addStatItems (s m) (fromIntegral i) - -data WebTimeouts = WebTimeouts - { txTimeout :: !Word64 - , blockTimeout :: !Word64 - } - deriving (Eq, Show) - -data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON - deriving (Eq, Show) - -instance Default WebTimeouts where - def = WebTimeouts{txTimeout = 300, blockTimeout = 7200} - -instance - (MonadUnliftIO m, MonadLoggerIO m) => - StoreReadBase (ReaderT WebState m) - where - getNetwork = runInWebReader getNetwork - getBestBlock = runInWebReader getBestBlock - getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height) - getBlock bh = runInWebReader (getBlock bh) - getTxData th = runInWebReader (getTxData th) - getSpender op = runInWebReader (getSpender op) - getUnspent op = runInWebReader (getUnspent op) - getBalance a = runInWebReader (getBalance a) - getMempool = runInWebReader getMempool - -instance - (MonadUnliftIO m, MonadLoggerIO m) => - StoreReadExtra (ReaderT WebState m) - where - getMaxGap = runInWebReader getMaxGap - getInitialGap = runInWebReader getInitialGap - getBalances as = runInWebReader (getBalances as) - getAddressesTxs as = runInWebReader . getAddressesTxs as - getAddressTxs a = runInWebReader . getAddressTxs a - getAddressUnspents a = runInWebReader . getAddressUnspents a - getAddressesUnspents as = runInWebReader . getAddressesUnspents as - xPubBals = runInWebReader . xPubBals - xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals - xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals - xPubTxCount xpub = runInWebReader . xPubTxCount xpub - getNumTxData = runInWebReader . getNumTxData - -instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where - getNetwork = lift getNetwork - getBestBlock = lift getBestBlock - getBlocksAtHeight = lift . getBlocksAtHeight - getBlock = lift . getBlock - getTxData = lift . getTxData - getSpender = lift . getSpender - getUnspent = lift . getUnspent - getBalance = lift . getBalance - getMempool = lift getMempool - -instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where - getBalances = lift . getBalances - getAddressesTxs as = lift . getAddressesTxs as - getAddressTxs a = lift . getAddressTxs a - getAddressUnspents a = lift . getAddressUnspents a - getAddressesUnspents as = lift . getAddressesUnspents as - xPubBals = lift . xPubBals - xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals - xPubTxs xpub xbals = lift . xPubTxs xpub xbals - xPubTxCount xpub = lift . xPubTxCount xpub - getMaxGap = lift getMaxGap - getInitialGap = lift getInitialGap - getNumTxData = lift . getNumTxData - -------------------- --- Path Handlers -- -------------------- - -runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => WebConfig -> m () -runWeb - cfg@WebConfig - { webHost = host - , webPort = port - , webStore = store' - , webStats = stats - , webPriceGet = pget - , webTickerURL = turl - , webMaxLimits = WebLimits{..} - } = do - ticker <- newTVarIO HashMap.empty - metrics <- mapM createMetrics stats - session <- liftIO Wreq.Session.newAPISession - let st = - WebState - { webConfig = cfg - , webTicker = ticker - , webMetrics = metrics - , webWreqSession = session - } - net = storeNetwork store' - withAsync (price net session turl pget ticker) $ - const $ do - reqLogger <- logIt metrics - runner <- askRunInIO - S.scottyOptsT opts (runner . (`runReaderT` st)) $ do - S.middleware (webSocketEvents st) - S.middleware reqLogger - S.middleware (reqSizeLimit maxLimitBody) - S.defaultHandler defHandler - handlePaths - S.notFound $ raise ThingNotFound - where - opts = def{S.settings = settings defaultSettings} - settings = setPort port . setHost (fromString host) - -getRates :: - (MonadUnliftIO m, MonadLoggerIO m) => - Network -> - Wreq.Session -> - String -> - Text -> - [Word64] -> - m [BinfoRate] -getRates net session url currency times = do - handleAny err $ do - r <- - liftIO $ - Wreq.asJSON - =<< Wreq.Session.postWith opts session url body - return $ r ^. Wreq.responseBody - where - err _ = do - $(logErrorS) "Web" "Could not get historic prices" - return [] - body = toJSON times - base = - Wreq.defaults - & Wreq.param "base" .~ [T.toUpper (T.pack (getNetworkName net))] - opts = base & Wreq.param "quote" .~ [currency] - -price :: - (MonadUnliftIO m, MonadLoggerIO m) => - Network -> - Wreq.Session -> - String -> - Int -> - TVar (HashMap Text BinfoTicker) -> - m () -price net session url pget v = forM_ purl $ \u -> forever $ do - let err e = $(logErrorS) "Price" $ cs (show e) - handleAny err $ do - r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u - atomically . writeTVar v $ r ^. Wreq.responseBody - threadDelay pget - where - purl = case code of - Nothing -> Nothing - Just x -> Just (url <> "?base=" <> x) - where - code - | net == btc = Just "btc" - | net == bch = Just "bch" - | otherwise = Nothing - -raise :: MonadIO m => Except -> WebT m a -raise err = - lift (asks webMetrics) >>= \case - Nothing -> S.raise err - Just m -> do - req <- S.request - mM <- case V.lookup (statKey m) (vault req) of - Nothing -> return Nothing - Just t -> readTVarIO t - let status = errStatus err - if - | statusIsClientError status -> - liftIO $ do - addClientError (statAll m) - forM_ mM $ \f -> addClientError (f m) - | statusIsServerError status -> - liftIO $ do - addServerError (statAll m) - forM_ mM $ \f -> addServerError (f m) - | otherwise -> - return () - S.raise err - -errStatus :: Except -> Status -errStatus ThingNotFound = status404 -errStatus BadRequest = status400 -errStatus UserError{} = status400 -errStatus StringError{} = status400 -errStatus ServerError = status500 -errStatus TxIndexConflict{} = status409 -errStatus ServerTimeout = status500 -errStatus RequestTooLarge = status413 - -defHandler :: Monad m => Except -> WebT m () -defHandler e = do - setHeaders - S.status $ errStatus e - S.json e - -handlePaths :: - (MonadUnliftIO m, MonadLoggerIO m) => - S.ScottyT Except (ReaderT WebState m) () -handlePaths = do - -- Block Paths - pathCompact - (GetBlock <$> paramLazy <*> paramDef) - scottyBlock - blockDataToEncoding - blockDataToJSON - pathCompact - (GetBlocks <$> param <*> paramDef) - (fmap SerialList . scottyBlocks) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact - (GetBlockRaw <$> paramLazy) - scottyBlockRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetBlockBest <$> paramDef) - scottyBlockBest - blockDataToEncoding - blockDataToJSON - pathCompact - (GetBlockBestRaw & return) - scottyBlockBestRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetBlockLatest <$> paramDef) - (fmap SerialList . scottyBlockLatest) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact - (GetBlockHeight <$> paramLazy <*> paramDef) - (fmap SerialList . scottyBlockHeight) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact - (GetBlockHeights <$> param <*> paramDef) - (fmap SerialList . scottyBlockHeights) - (\n -> list (blockDataToEncoding n) . getSerialList) - (\n -> json_list blockDataToJSON n . getSerialList) - pathCompact - (GetBlockHeightRaw <$> paramLazy) - scottyBlockHeightRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetBlockTime <$> paramLazy <*> paramDef) - scottyBlockTime - blockDataToEncoding - blockDataToJSON - pathCompact - (GetBlockTimeRaw <$> paramLazy) - scottyBlockTimeRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetBlockMTP <$> paramLazy <*> paramDef) - scottyBlockMTP - blockDataToEncoding - blockDataToJSON - pathCompact - (GetBlockMTPRaw <$> paramLazy) - scottyBlockMTPRaw - (const toEncoding) - (const toJSON) - -- Transaction Paths - pathCompact - (GetTx <$> paramLazy) - scottyTx - transactionToEncoding - transactionToJSON - pathCompact - (GetTxs <$> param) - (fmap SerialList . scottyTxs) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - pathCompact - (GetTxRaw <$> paramLazy) - scottyTxRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetTxsRaw <$> param) - scottyTxsRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetTxsBlock <$> paramLazy) - (fmap SerialList . scottyTxsBlock) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - pathCompact - (GetTxsBlockRaw <$> paramLazy) - scottyTxsBlockRaw - (const toEncoding) - (const toJSON) - pathCompact - (GetTxAfter <$> paramLazy <*> paramLazy) - scottyTxAfter - (const toEncoding) - (const toJSON) - pathCompact - (PostTx <$> parseBody) - scottyPostTx - (const toEncoding) - (const toJSON) - pathCompact - (GetMempool <$> paramOptional <*> parseOffset) - (fmap SerialList . scottyMempool) - (const toEncoding) - (const toJSON) - -- Address Paths - pathCompact - (GetAddrTxs <$> paramLazy <*> parseLimits) - (fmap SerialList . scottyAddrTxs) - (const toEncoding) - (const toJSON) - pathCompact - (GetAddrsTxs <$> param <*> parseLimits) - (fmap SerialList . scottyAddrsTxs) - (const toEncoding) - (const toJSON) - pathCompact - (GetAddrTxsFull <$> paramLazy <*> parseLimits) - (fmap SerialList . scottyAddrTxsFull) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - pathCompact - (GetAddrsTxsFull <$> param <*> parseLimits) - (fmap SerialList . scottyAddrsTxsFull) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - pathCompact - (GetAddrBalance <$> paramLazy) - scottyAddrBalance - balanceToEncoding - balanceToJSON - pathCompact - (GetAddrsBalance <$> param) - (fmap SerialList . scottyAddrsBalance) - (\n -> list (balanceToEncoding n) . getSerialList) - (\n -> json_list balanceToJSON n . getSerialList) - pathCompact - (GetAddrUnspent <$> paramLazy <*> parseLimits) - (fmap SerialList . scottyAddrUnspent) - (\n -> list (unspentToEncoding n) . getSerialList) - (\n -> json_list unspentToJSON n . getSerialList) - pathCompact - (GetAddrsUnspent <$> param <*> parseLimits) - (fmap SerialList . scottyAddrsUnspent) - (\n -> list (unspentToEncoding n) . getSerialList) - (\n -> json_list unspentToJSON n . getSerialList) - -- XPubs - pathCompact - (GetXPub <$> paramLazy <*> paramDef <*> paramDef) - scottyXPub - (const toEncoding) - (const toJSON) - pathCompact - (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubTxs) - (const toEncoding) - (const toJSON) - pathCompact - (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubTxsFull) - (\n -> list (transactionToEncoding n) . getSerialList) - (\n -> json_list transactionToJSON n . getSerialList) - pathCompact - (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef) - (fmap SerialList . scottyXPubBalances) - (\n -> list (xPubBalToEncoding n) . getSerialList) - (\n -> json_list xPubBalToJSON n . getSerialList) - pathCompact - (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubUnspent) - (\n -> list (xPubUnspentToEncoding n) . getSerialList) - (\n -> json_list xPubUnspentToJSON n . getSerialList) - pathCompact - (DelCachedXPub <$> paramLazy <*> paramDef) - scottyDelXPub - (const toEncoding) - (const toJSON) - -- Network - pathCompact - (GetPeers & return) - (fmap SerialList . scottyPeers) - (const toEncoding) - (const toJSON) - pathCompact - (GetHealth & return) - scottyHealth - (const toEncoding) - (const toJSON) - S.get "/events" scottyEvents - S.get "/dbstats" scottyDbStats - -- Blockchain.info - S.post "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/balance" scottyShortBal - S.post "/blockchain/balance" scottyShortBal - S.get "/blockchain/rawaddr/:addr" scottyRawAddr - S.get "/blockchain/address/:addr" scottyRawAddr - S.get "/blockchain/xpub/:addr" scottyRawAddr - S.post "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/rawtx/:txid" scottyBinfoTx - S.get "/blockchain/rawblock/:block" scottyBinfoBlock - S.get "/blockchain/latestblock" scottyBinfoLatest - S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool - S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight - S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay - S.get "/blockchain/export-history" scottyBinfoHistory - S.post "/blockchain/export-history" scottyBinfoHistory - S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash - S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr - S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey - S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr - S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey - S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount - S.get "/blockchain/q/latesthash" scottyBinfoLatestHash - S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy - S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut - S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput - S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees - S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult - S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived - S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent - S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance - S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen - where - json_list f net = toJSONList . map (f net) - -pathCompact :: - (ApiResource a b, MonadIO m) => - WebT m a -> - (a -> WebT m b) -> - (Network -> b -> Encoding) -> - (Network -> b -> Value) -> - S.ScottyT Except (ReaderT WebState m) () -pathCompact parser action encJson encValue = - pathCommon parser action encJson encValue False - -pathCommon :: - (ApiResource a b, MonadIO m) => - WebT m a -> - (a -> WebT m b) -> - (Network -> b -> Encoding) -> - (Network -> b -> Value) -> - Bool -> - S.ScottyT Except (ReaderT WebState m) () -pathCommon parser action encJson encValue pretty = - S.addroute (resourceMethod proxy) (capturePath proxy) $ do - setHeaders - proto <- setupContentType pretty - net <- lift $ asks (storeNetwork . webStore . webConfig) - apiRes <- parser - res <- action apiRes - S.raw $ protoSerial proto (encJson net) (encValue net) res - where - toProxy :: WebT m a -> Proxy a - toProxy = const Proxy - proxy = toProxy parser - -streamEncoding :: Monad m => Encoding -> WebT m () -streamEncoding e = do - S.setHeader "Content-Type" "application/json; charset=utf-8" - S.raw (encodingToLazyByteString e) - -protoSerial :: - Serial a => - SerialAs -> - (a -> Encoding) -> - (a -> Value) -> - a -> - L.ByteString -protoSerial SerialAsBinary _ _ = runPutL . serialize -protoSerial SerialAsJSON f _ = encodingToLazyByteString . f -protoSerial SerialAsPrettyJSON _ g = - encodePretty' defConfig{confTrailingNewline = True} . g - -setHeaders :: (Monad m, S.ScottyError e) => ActionT e m () -setHeaders = S.setHeader "Access-Control-Allow-Origin" "*" - -waiExcept :: Status -> Except -> Response -waiExcept s e = - responseLBS s hs e' - where - hs = - [ ("Access-Control-Allow-Origin", "*") - , ("Content-Type", "application/json") - ] - e' = A.encode e - -setupJSON :: Monad m => Bool -> ActionT Except m SerialAs -setupJSON pretty = do - S.setHeader "Content-Type" "application/json" - p <- S.param "pretty" `S.rescue` const (return pretty) - return $ if p then SerialAsPrettyJSON else SerialAsJSON - -setupBinary :: Monad m => ActionT Except m SerialAs -setupBinary = do - S.setHeader "Content-Type" "application/octet-stream" - return SerialAsBinary - -setupContentType :: Monad m => Bool -> ActionT Except m SerialAs -setupContentType pretty = do - accept <- S.header "accept" - maybe (setupJSON pretty) setType accept - where - setType "application/octet-stream" = setupBinary - setType _ = setupJSON pretty - --- GET Block / GET Blocks -- - -scottyBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData -scottyBlock (GetBlock h (NoTx noTx)) = do - setMetrics statBlock - getBlock h >>= \case - Nothing -> - raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx noTx b - -getBlocks :: - (MonadUnliftIO m, MonadLoggerIO m) => - [H.BlockHash] -> - Bool -> - WebT m [BlockData] -getBlocks hs notx = - (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs) - -scottyBlocks :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData] -scottyBlocks (GetBlocks hs (NoTx notx)) = do - setMetrics statBlock - bs <- getBlocks hs notx - addItemCount (length bs) - return bs - -pruneTx :: Bool -> BlockData -> BlockData -pruneTx False b = b -pruneTx True b = b{blockDataTxs = take 1 (blockDataTxs b)} - --- GET BlockRaw -- - -scottyBlockRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockRaw -> - WebT m (RawResult H.Block) -scottyBlockRaw (GetBlockRaw h) = do - setMetrics statBlockRaw - b <- getRawBlock h - addItemCount (1 + length (H.blockTxns b)) - return $ RawResult b - -getRawBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => - H.BlockHash -> - WebT m H.Block -getRawBlock h = do - b <- getBlock h >>= maybe (raise ThingNotFound) return - lift (toRawBlock b) - -toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block -toRawBlock b = do - let ths = blockDataTxs b - txs <- mapM f ths - return H.Block{H.blockHeader = blockDataHeader b, H.blockTxns = txs} - where - f x = withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x >>= \case - Nothing -> undefined - Just t -> return $ transactionData t - --- GET BlockBest / BlockBestRaw -- - -scottyBlockBest :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData -scottyBlockBest (GetBlockBest (NoTx notx)) = do - setMetrics statBlock - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bb -> - getBlock bb >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx notx b - -scottyBlockBestRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockBestRaw -> - WebT m (RawResult H.Block) -scottyBlockBestRaw _ = do - setMetrics statBlockRaw - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bb -> do - b <- getRawBlock bb - addItemCount (1 + length (H.blockTxns b)) - return $ RawResult b - --- GET BlockLatest -- - -scottyBlockLatest :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockLatest -> - WebT m [BlockData] -scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do - setMetrics statBlock - blocks <- - getBestBlock - >>= maybe - (raise ThingNotFound) - (go [] <=< getBlock) - addItemCount (length blocks) - return blocks - where - go acc Nothing = return $ reverse acc - go acc (Just b) - | blockDataHeight b <= 0 = return $ reverse acc - | length acc == 99 = return . reverse $ pruneTx noTx b : acc - | otherwise = do - let prev = H.prevBlock (blockDataHeader b) - go (pruneTx noTx b : acc) =<< getBlock prev - --- GET BlockHeight / BlockHeights / BlockHeightRaw -- - -scottyBlockHeight :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData] -scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do - setMetrics statBlock - blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h) - addItemCount (length blocks) - return blocks - -scottyBlockHeights :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockHeights -> - WebT m [BlockData] -scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do - setMetrics statBlock - bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights) - blocks <- getBlocks bhs notx - addItemCount (length blocks) - return blocks - -scottyBlockHeightRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockHeightRaw -> - WebT m (RawResultList H.Block) -scottyBlockHeightRaw (GetBlockHeightRaw h) = do - setMetrics statBlockRaw - blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h) - addItemCount (length blocks + sum (map (length . H.blockTxns) blocks)) - return $ RawResultList blocks - --- GET BlockTime / BlockTimeRaw -- - -scottyBlockTime :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockTime -> - WebT m BlockData -scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do - setMetrics statBlock - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrBefore ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx notx b - -scottyBlockMTP :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockMTP -> - WebT m BlockData -scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = do - setMetrics statBlock - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrAfterMTP ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - return $ pruneTx notx b - -scottyBlockTimeRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockTimeRaw -> - WebT m (RawResult H.Block) -scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do - setMetrics statBlockRaw - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrBefore ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - raw <- lift $ toRawBlock b - addItemCount (1 + length (H.blockTxns raw)) - return $ RawResult raw - -scottyBlockMTPRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetBlockMTPRaw -> - WebT m (RawResult H.Block) -scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do - setMetrics statBlockRaw - ch <- lift $ asks (storeChain . webStore . webConfig) - blockAtOrAfterMTP ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> do - raw <- lift $ toRawBlock b - addItemCount (1 + length (H.blockTxns raw)) - return $ RawResult raw - --- GET Transactions -- - -scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction -scottyTx (GetTx txid) = do - setMetrics statTransaction - getTransaction txid >>= \case - Nothing -> raise ThingNotFound - Just tx -> do - addItemCount 1 - return tx - -scottyTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction] -scottyTxs (GetTxs txids) = do - setMetrics statTransaction - txs <- catMaybes <$> mapM f (nub txids) - addItemCount (length txs) - return txs - where - f x = lift $ - withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x - -scottyTxRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx) -scottyTxRaw (GetTxRaw txid) = do - setMetrics statTransactionRaw - getTransaction txid >>= \case - Nothing -> raise ThingNotFound - Just tx -> do - addItemCount 1 - return $ RawResult (transactionData tx) - -scottyTxsRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxsRaw -> - WebT m (RawResultList Tx) -scottyTxsRaw (GetTxsRaw txids) = do - setMetrics statTransactionRaw - txs <- catMaybes <$> mapM f (nub txids) - addItemCount (length txs) - return $ RawResultList $ transactionData <$> txs - where - f x = lift $ - withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x - -getTxsBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => - H.BlockHash -> - WebT m [Transaction] -getTxsBlock h = - getBlock h >>= \case - Nothing -> raise ThingNotFound - Just b -> do - txs <- mapM f (blockDataTxs b) - addItemCount (length txs) - return txs - where - f x = lift $ - withRunInIO $ \run -> - unsafeInterleaveIO . run $ - getTransaction x >>= \case - Nothing -> undefined - Just t -> return t - -scottyTxsBlock :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxsBlock -> - WebT m [Transaction] -scottyTxsBlock (GetTxsBlock h) = do - setMetrics statTransactionsBlock - txs <- getTxsBlock h - addItemCount (length txs) - return txs - -scottyTxsBlockRaw :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxsBlockRaw -> - WebT m (RawResultList Tx) -scottyTxsBlockRaw (GetTxsBlockRaw h) = do - setMetrics statTransactionsBlockRaw - txs <- fmap transactionData <$> getTxsBlock h - addItemCount (length txs) - return $ RawResultList txs - --- GET TransactionAfterHeight -- - -scottyTxAfter :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetTxAfter -> - WebT m (GenericResult (Maybe Bool)) -scottyTxAfter (GetTxAfter txid height) = do - setMetrics statTransactionAfter - (result, count) <- cbAfterHeight (fromIntegral height) txid - addItemCount count - return $ GenericResult result - -{- | Check if any of the ancestors of this transaction is a coinbase after the - specified height. Returns 'Nothing' if answer cannot be computed before - hitting limits. --} -cbAfterHeight :: - (MonadIO m, StoreReadBase m) => - H.BlockHeight -> - TxHash -> - m (Maybe Bool, Int) -cbAfterHeight height txid = - inputs n HashSet.empty HashSet.empty [txid] - where - n = 10000 - inputs 0 _ _ [] = return (Nothing, 10000) - inputs i is ns [] = - let is' = HashSet.union is ns - ns' = HashSet.empty - ts = HashSet.toList (HashSet.difference ns is) - in case ts of - [] -> return (Just False, n - i) - _ -> inputs i is' ns' ts - inputs i is ns (t : ts) = - getTransaction t >>= \case - Nothing -> return (Nothing, n - i) - Just tx - | height_check tx -> - if cb_check tx - then return (Just True, n - i + 1) - else - let ns' = HashSet.union (ins tx) ns - in inputs (i - 1) is ns' ts - | otherwise -> inputs (i - 1) is ns ts - cb_check = any isCoinbase . transactionInputs - ins = HashSet.fromList . map (outPointHash . inputPoint) . transactionInputs - height_check tx = - case transactionBlock tx of - BlockRef h _ -> h > height - _ -> True - --- POST Transaction -- - -scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId -scottyPostTx (PostTx tx) = do - setMetrics statTransactionPost - addItemCount 1 - lift (asks webConfig) >>= \cfg -> - lift (publishTx cfg tx) >>= \case - Right () -> return (TxId (txHash tx)) - Left e@(PubReject _) -> raise $ UserError (show e) - _ -> raise ServerError - --- | Publish a new transaction to the network. -publishTx :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - Tx -> - m (Either PubExcept ()) -publishTx cfg tx = - withSubscription pub $ \s -> - getTransaction (txHash tx) >>= \case - Just _ -> return $ Right () - Nothing -> go s - where - pub = storePublisher (webStore cfg) - mgr = storeManager (webStore cfg) - net = storeNetwork (webStore cfg) - go s = - getPeers mgr >>= \case - [] -> return $ Left PubNoPeers - OnlinePeer{onlinePeerMailbox = p} : _ -> do - MTx tx `sendMessage` p - let v = - if getSegWit net - then InvWitnessTx - else InvTx - sendMessage - (MGetData (GetData [InvVector v (getTxHash (txHash tx))])) - p - f p s - t = 5 * 1000 * 1000 - f p s - | webNoMempool cfg = return $ Right () - | otherwise = - liftIO (timeout t (g p s)) >>= \case - Nothing -> return $ Left PubTimeout - Just (Left e) -> return $ Left e - Just (Right ()) -> return $ Right () - g p s = - receive s >>= \case - StoreTxReject p' h' c _ - | p == p' && h' == txHash tx -> return . Left $ PubReject c - StorePeerDisconnected p' - | p == p' -> return $ Left PubPeerDisconnected - StoreMempoolNew h' - | h' == txHash tx -> return $ Right () - _ -> g p s - --- GET Mempool / Events -- - -scottyMempool :: - (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash] -scottyMempool (GetMempool limitM (OffsetParam o)) = do - setMetrics statMempool - wl <- lift $ asks (webMaxLimits . webConfig) - let wl' = wl{maxLimitCount = 0} - l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing - ths <- map snd . applyLimits l <$> getMempool - addItemCount 1 - return ths - -webSocketEvents :: WebState -> Middleware -webSocketEvents s = - websocketsOr defaultConnectionOptions events - where - pub = (storePublisher . webStore . webConfig) s - gauge = statEvents <$> webMetrics s - events pending = withSubscription pub $ \sub -> do - let path = requestPath $ pendingRequest pending - if path == "/events" - then do - conn <- acceptRequest pending - forever $ - receiveEvent sub >>= \case - Nothing -> return () - Just event -> sendTextData conn (A.encode event) - else - rejectRequestWith - pending - WebSockets.defaultRejectRequest - { WebSockets.rejectBody = L.toStrict $ A.encode ThingNotFound - , WebSockets.rejectCode = 404 - , WebSockets.rejectMessage = "Not Found" - , WebSockets.rejectHeaders = [("Content-Type", "application/json")] - } - -scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyEvents = - withGaugeIncrease statEvents $ do - setHeaders - proto <- setupContentType False - pub <- lift $ asks (storePublisher . webStore . webConfig) - S.stream $ \io flush' -> - withSubscription pub $ \sub -> - forever $ - flush' >> receiveEvent sub >>= maybe (return ()) (io . serial proto) - where - serial proto e = - lazyByteString $ protoSerial proto toEncoding toJSON e <> newLine proto - newLine SerialAsBinary = mempty - newLine SerialAsJSON = "\n" - newLine SerialAsPrettyJSON = mempty - -receiveEvent :: Inbox StoreEvent -> IO (Maybe Event) -receiveEvent sub = - go <$> receive sub - where - go = \case - StoreBestBlock b -> Just (EventBlock b) - StoreMempoolNew t -> Just (EventTx t) - StoreMempoolDelete t -> Just (EventTx t) - _ -> Nothing - --- GET Address Transactions -- - -scottyAddrTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef] -scottyAddrTxs (GetAddrTxs addr pLimits) = do - setMetrics statAddressTransactions - txs <- getAddressTxs addr =<< paramToLimits False pLimits - addItemCount (length txs) - return txs - -scottyAddrsTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef] -scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do - setMetrics statAddressTransactions - txs <- getAddressesTxs addrs =<< paramToLimits False pLimits - addItemCount (length txs) - return txs - -scottyAddrTxsFull :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetAddrTxsFull -> - WebT m [Transaction] -scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do - setMetrics statAddressTransactionsFull - txs <- getAddressTxs addr =<< paramToLimits True pLimits - ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs - addItemCount (length ts) - return ts - -scottyAddrsTxsFull :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetAddrsTxsFull -> - WebT m [Transaction] -scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do - setMetrics statAddressTransactionsFull - txs <- getAddressesTxs addrs =<< paramToLimits True pLimits - ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs - addItemCount (length ts) - return ts - -scottyAddrBalance :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetAddrBalance -> - WebT m Balance -scottyAddrBalance (GetAddrBalance addr) = do - setMetrics statAddressBalance - addItemCount 1 - getDefaultBalance addr - -scottyAddrsBalance :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance] -scottyAddrsBalance (GetAddrsBalance addrs) = do - setMetrics statAddressBalance - balances <- getBalances addrs - addItemCount (length balances) - return balances - -scottyAddrUnspent :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent] -scottyAddrUnspent (GetAddrUnspent addr pLimits) = do - setMetrics statAddressUnspent - unspents <- getAddressUnspents addr =<< paramToLimits False pLimits - addItemCount (length unspents) - return unspents - -scottyAddrsUnspent :: - (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent] -scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do - setMetrics statAddressUnspent - unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits - addItemCount (length unspents) - return unspents - --- GET XPubs -- - -scottyXPub :: - (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary -scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do - setMetrics statXpub - let xspec = XPubSpec xpub deriv - xbals <- lift . runNoCache noCache $ xPubBals xspec - addItemCount (length xbals) - return $ xPubSummary xspec xbals - -scottyDelXPub :: - (MonadUnliftIO m, MonadLoggerIO m) => - DelCachedXPub -> - WebT m (GenericResult Bool) -scottyDelXPub (DelCachedXPub xpub deriv) = do - setMetrics statXpubDelete - let xspec = XPubSpec xpub deriv - cacheM <- lift (asks (storeCache . webStore . webConfig)) - n <- lift $ withCache cacheM (cacheDelXPubs [xspec]) - addItemCount (fromIntegral n) - return (GenericResult (n > 0)) - -getXPubTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => - XPubKey -> - DeriveType -> - LimitsParam -> - Bool -> - WebT m [TxRef] -getXPubTxs xpub deriv plimits nocache = do - limits <- paramToLimits False plimits - let xspec = XPubSpec xpub deriv - xbals <- xPubBals xspec - addItemCount (length xbals) - lift . runNoCache nocache $ xPubTxs xspec xbals limits - -scottyXPubTxs :: - (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef] -scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do - setMetrics statXpubTransactions - txs <- getXPubTxs xpub deriv plimits nocache - addItemCount (length txs) - return txs - -scottyXPubTxsFull :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetXPubTxsFull -> - WebT m [Transaction] -scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do - setMetrics statXpubTransactionsFull - refs <- getXPubTxs xpub deriv plimits nocache - txs <- - fmap catMaybes $ - lift . runNoCache nocache $ - mapM (getTransaction . txRefHash) refs - addItemCount (length txs) - return txs - -scottyXPubBalances :: - (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal] -scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do - setMetrics statXpubBalances - balances <- filter f <$> lift (runNoCache noCache (xPubBals spec)) - addItemCount (length balances) - return balances - where - spec = XPubSpec xpub deriv - f = not . nullBalance . xPubBal - -scottyXPubUnspent :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetXPubUnspent -> - WebT m [XPubUnspent] -scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do - setMetrics statXpubUnspent - limits <- paramToLimits False pLimits - let xspec = XPubSpec xpub deriv - xbals <- xPubBals xspec - addItemCount (length xbals) - unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits - addItemCount (length unspents) - return unspents - ---------------------------------------- --- Blockchain.info API Compatibility -- ---------------------------------------- - -netBinfoSymbol :: Network -> BinfoSymbol -netBinfoSymbol net - | net == btc = - BinfoSymbol - { getBinfoSymbolCode = "BTC" - , getBinfoSymbolString = "BTC" - , getBinfoSymbolName = "Bitcoin" - , getBinfoSymbolConversion = 100 * 1000 * 1000 - , getBinfoSymbolAfter = True - , getBinfoSymbolLocal = False - } - | net == bch = - BinfoSymbol - { getBinfoSymbolCode = "BCH" - , getBinfoSymbolString = "BCH" - , getBinfoSymbolName = "Bitcoin Cash" - , getBinfoSymbolConversion = 100 * 1000 * 1000 - , getBinfoSymbolAfter = True - , getBinfoSymbolLocal = False - } - | otherwise = - BinfoSymbol - { getBinfoSymbolCode = "XTS" - , getBinfoSymbolString = "¤" - , getBinfoSymbolName = "Test" - , getBinfoSymbolConversion = 100 * 1000 * 1000 - , getBinfoSymbolAfter = False - , getBinfoSymbolLocal = False - } - -binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol -binfoTickerToSymbol code BinfoTicker{..} = - BinfoSymbol - { getBinfoSymbolCode = code - , getBinfoSymbolString = binfoTickerSymbol - , getBinfoSymbolName = name - , getBinfoSymbolConversion = - 100 * 1000 * 1000 / binfoTicker15m -- sat/usd - , getBinfoSymbolAfter = False - , getBinfoSymbolLocal = True - } - where - name = case code of - "EUR" -> "Euro" - "USD" -> "U.S. dollar" - "GBP" -> "British pound" - x -> x - -getBinfoAddrsParam :: - MonadIO m => - Text -> - WebT m (HashSet BinfoAddr) -getBinfoAddrsParam name = do - net <- lift (asks (storeNetwork . webStore . webConfig)) - p <- S.param (cs name) `S.rescue` const (return "") - if T.null p - then return HashSet.empty - else case parseBinfoAddr net p of - Nothing -> raise (UserError "invalid address") - Just xs -> return $ HashSet.fromList xs - -getBinfoActive :: - MonadIO m => - WebT m (HashSet XPubSpec, HashSet Address) -getBinfoActive = do - active <- getBinfoAddrsParam "active" - p2sh <- getBinfoAddrsParam "activeP2SH" - bech32 <- getBinfoAddrsParam "activeBech32" - let xspec d b = (`XPubSpec` d) <$> xpub b - xspecs = - HashSet.fromList $ - concat - [ mapMaybe (xspec DeriveNormal) (HashSet.toList active) - , mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh) - , mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32) - ] - addrs = HashSet.fromList . mapMaybe addr $ HashSet.toList active - return (xspecs, addrs) - where - addr (BinfoAddr a) = Just a - addr (BinfoXpub _) = Nothing - xpub (BinfoXpub x) = Just x - xpub (BinfoAddr _) = Nothing - -getNumTxId :: MonadIO m => WebT m Bool -getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False) - -getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight -getChainHeight = do - ch <- lift $ asks (storeChain . webStore . webConfig) - H.nodeHeight <$> chainGetBest ch - -scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoUnspent = do - setMetrics statBlockchainUnspent - (xspecs, addrs) <- getBinfoActive - numtxid <- getNumTxId - limit <- get_limit - min_conf <- get_min_conf - net <- lift $ asks (storeNetwork . webStore . webConfig) - height <- getChainHeight - let mn BinfoUnspent{..} = min_conf > getBinfoUnspentConfirmations - xbals <- lift $ getXBals xspecs - addItemCount . sum . map length $ HashMap.elems xbals - bus <- - lift . runConduit $ - getBinfoUnspents numtxid height xbals xspecs addrs - .| (dropWhileC mn >> takeC limit .| sinkList) - addItemCount (length bus) -- TODO: does not include bypassed items - setHeaders - streamEncoding (binfoUnspentsToEncoding net (BinfoUnspents bus)) - where - get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250) - get_min_conf = S.param "confirmations" `S.rescue` const (return 0) - -getBinfoUnspents :: - (StoreReadExtra m, MonadIO m) => - Bool -> - H.BlockHeight -> - HashMap XPubSpec [XPubBal] -> - HashSet XPubSpec -> - HashSet Address -> - ConduitT () BinfoUnspent m () -getBinfoUnspents numtxid height xbals xspecs addrs = do - cs' <- conduits - joinDescStreams cs' .| mapC (uncurry binfo) - where - binfo Unspent{..} xp = - let conf = case unspentBlock of - MemRef{} -> 0 - BlockRef h _ -> height - h + 1 - hash = outPointHash unspentPoint - idx = outPointIndex unspentPoint - val = unspentAmount - script = unspentScript - txi = encodeBinfoTxId numtxid hash - in BinfoUnspent - { getBinfoUnspentHash = hash - , getBinfoUnspentOutputIndex = idx - , getBinfoUnspentScript = script - , getBinfoUnspentValue = val - , getBinfoUnspentConfirmations = fromIntegral conf - , getBinfoUnspentTxIndex = txi - , getBinfoUnspentXPub = xp - } - conduits = (<>) <$> xconduits <*> pure acounduits - xconduits = lift $ do - let f x (XPubUnspent u p) = - let path = toSoft (listToPath p) - xp = BinfoXPubPath (xPubSpecKey x) <$> path - in (u, xp) - g x = do - return $ - streamThings - (xPubUnspents x (xBals x xbals)) - Nothing - def{limit = 250} - .| mapC (f x) - mapM g (HashSet.toList xspecs) - acounduits = - let f u = (u, Nothing) - g a = - streamThings - (getAddressUnspents a) - Nothing - def{limit = 250} - .| mapC f - in map g (HashSet.toList addrs) - -getXBals :: StoreReadExtra m => HashSet XPubSpec -> m (HashMap XPubSpec [XPubBal]) -getXBals = fmap HashMap.fromList . mapM (\x -> (x,) . filter (not . nullBalance . xPubBal) <$> (xPubBals x)) . HashSet.toList - -xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal] -xBals = HashMap.findWithDefault [] - -getBinfoTxs :: - (StoreReadExtra m, MonadIO m) => - HashMap XPubSpec [XPubBal] -> -- xpub balances - HashMap Address (Maybe BinfoXPubPath) -> -- address book - HashSet XPubSpec -> -- show xpubs - HashSet Address -> -- show addrs - HashSet Address -> -- balance addresses - BinfoFilter -> - Bool -> -- numtxid - Bool -> -- prune outputs - Int64 -> -- starting balance - ConduitT () BinfoTx m () -getBinfoTxs xbals abook sxspecs saddrs baddrs bfilter numtxid prune bal = do - cs' <- conduits - joinDescStreams cs' .| go bal - where - sxspecs_ls = HashSet.toList sxspecs - saddrs_ls = HashSet.toList saddrs - conduits = (<>) <$> mapM xpub_c sxspecs_ls <*> pure (map addr_c saddrs_ls) - xpub_c x = lift $ - return $ streamThings (xPubTxs x (xBals x xbals)) (Just txRefHash) def{limit = 50} - addr_c a = streamThings (getAddressTxs a) (Just txRefHash) def{limit = 50} - binfo_tx b = toBinfoTx numtxid abook prune b - compute_bal_change BinfoTx{..} = - let ins = map getBinfoTxInputPrevOut getBinfoTxInputs - out = getBinfoTxOutputs - f b BinfoTxOutput{..} = - let val = fromIntegral getBinfoTxOutputValue - in case getBinfoTxOutputAddress of - Nothing -> 0 - Just a - | a `HashSet.member` baddrs -> - if b then val else negate val - | otherwise -> 0 - in sum $ map (f False) ins <> map (f True) out - go b = - await >>= \case - Nothing -> return () - Just (TxRef _ t) -> - lift (getTransaction t) >>= \case - Nothing -> go b - Just x -> do - let a = binfo_tx b x - b' = b - compute_bal_change a - c = isJust (getBinfoTxBlockHeight a) - Just (d, _) = getBinfoTxResultBal a - r = d + fromIntegral (getBinfoTxFee a) - case bfilter of - BinfoFilterAll -> - yield a >> go b' - BinfoFilterSent - | 0 > r -> yield a >> go b' - | otherwise -> go b' - BinfoFilterReceived - | r > 0 -> yield a >> go b' - | otherwise -> go b' - BinfoFilterMoved - | r == 0 -> yield a >> go b' - | otherwise -> go b' - BinfoFilterConfirmed - | c -> yield a >> go b' - | otherwise -> go b' - BinfoFilterMempool - | c -> return () - | otherwise -> yield a >> go b' - -getCashAddr :: Monad m => WebT m Bool -getCashAddr = S.param "cashaddr" `S.rescue` const (return False) - -getAddress :: (Monad m, MonadUnliftIO m) => TL.Text -> WebT m Address -getAddress param' = do - txt <- S.param param' - net <- lift $ asks (storeNetwork . webStore . webConfig) - case textToAddr net txt of - Nothing -> raise ThingNotFound - Just a -> return a - -getBinfoAddr :: Monad m => TL.Text -> WebT m BinfoAddr -getBinfoAddr param' = do - txt <- S.param param' - net <- lift $ asks (storeNetwork . webStore . webConfig) - let x = - BinfoAddr <$> textToAddr net txt - <|> BinfoXpub <$> xPubImport net txt - maybe S.next return x - -scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoHistory = do - setMetrics statBlockchainExportHistory - (xspecs, addrs) <- getBinfoActive - (startM, endM) <- get_dates - (code, price') <- getPrice - xbals <- getXBals xspecs - addItemCount . sum . map length $ HashMap.elems xbals - let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals) - aaddrs = xaddrs <> addrs - cur = binfoTicker15m price' - cs' = conduits (HashMap.toList xbals) addrs endM - txs <- - lift . runConduit $ - joinDescStreams cs' - .| takeWhileC (is_newer startM) - .| concatMapMC get_transaction - .| sinkList - addItemCount (length txs) - let times = map transactionTime txs - net <- lift $ asks (storeNetwork . webStore . webConfig) - url <- lift $ asks (webHistoryURL . webConfig) - session <- lift $ asks webWreqSession - rates <- map binfoRatePrice <$> lift (getRates net session url code times) - addItemCount (length rates) - let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) - setHeaders - streamEncoding $ toEncoding hs - where - is_newer (Just BlockData{..}) TxRef{txRefBlock = BlockRef{..}} = - blockRefHeight >= blockDataHeight - is_newer _ _ = True - get_addr = balanceAddress . xPubBal - get_transaction TxRef{txRefHash = h} = - getTransaction h - convert cur addrs tx rate = - let ins = transactionInputs tx - outs = transactionOutputs tx - fins = filter (input_addr addrs) ins - fouts = filter (output_addr addrs) outs - vin = fromIntegral . sum $ map inputAmount fins - vout = fromIntegral . sum $ map outputAmount fouts - v = vout - vin - t = transactionTime tx - h = txHash $ transactionData tx - in toBinfoHistory v t rate cur h - input_addr addrs' StoreInput{inputAddress = Just a} = - a `HashSet.member` addrs' - input_addr _ _ = False - output_addr addrs' StoreOutput{outputAddr = Just a} = - a `HashSet.member` addrs' - output_addr _ _ = False - get_dates = do - BinfoDate start <- S.param "start" - BinfoDate end' <- S.param "end" - let end = end' + 24 * 60 * 60 - ch <- lift $ asks (storeChain . webStore . webConfig) - startM <- blockAtOrAfter ch start - endM <- blockAtOrBefore ch end - return (startM, endM) - conduits xpubs addrs endM = - map (uncurry (xpub_c endM)) xpubs - <> map (addr_c endM) (HashSet.toList addrs) - addr_c endM a = - streamThings - (getAddressTxs a) - (Just txRefHash) - def - { limit = 50 - , start = AtBlock . blockDataHeight <$> endM - } - xpub_c endM x bs = - streamThings - (xPubTxs x bs) - (Just txRefHash) - def - { limit = 50 - , start = AtBlock . blockDataHeight <$> endM - } - -getPrice :: MonadIO m => WebT m (Text, BinfoTicker) -getPrice = do - code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD") - ticker <- lift $ asks webTicker - prices <- readTVarIO ticker - case HashMap.lookup code prices of - Nothing -> return (code, def) - Just p -> return (code, p) - -getSymbol :: MonadIO m => WebT m BinfoSymbol -getSymbol = uncurry binfoTickerToSymbol <$> getPrice - -scottyBinfoBlocksDay :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoBlocksDay = do - setMetrics statBlockchainBlocks - t <- min h . (`div` 1000) <$> S.param "milliseconds" - ch <- lift $ asks (storeChain . webStore . webConfig) - m <- blockAtOrBefore ch t - bs <- go (d t) m - addItemCount (length bs) - streamEncoding $ toEncoding $ map toBinfoBlockInfo bs - where - h = fromIntegral (maxBound :: H.Timestamp) - d = subtract (24 * 3600) - go _ Nothing = return [] - go t (Just b) - | H.blockTimestamp (blockDataHeader b) <= fromIntegral t = - return [] - | otherwise = do - b' <- getBlock (H.prevBlock (blockDataHeader b)) - (b :) <$> go t b' - -scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyMultiAddr = do - setMetrics statBlockchainMultiaddr - (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs - numtxid <- getNumTxId - cashaddr <- getCashAddr - local' <- getSymbol - offset <- getBinfoOffset - n <- getBinfoCount "n" - prune <- get_prune - fltr <- get_filter - xbals <- getXBals xspecs - addItemCount . sum . map length $ HashMap.elems xbals - xtxns <- get_xpub_tx_count xbals xspecs - addItemCount (length xtxns) - let sxbals = only_show_xbals sxpubs xbals - xabals = compute_xabals xbals - addrs = addrs' `HashSet.difference` HashMap.keysSet xabals - abals <- get_abals addrs - addItemCount (length abals) - let sxspecs = only_show_xspecs sxpubs xspecs - sxabals = compute_xabals sxbals - sabals = only_show_abals saddrs abals - sallbals = sabals <> sxabals - sbal = compute_bal sallbals - allbals = abals <> xabals - abook = compute_abook addrs xbals - sxaddrs = compute_xaddrs sxbals - salladdrs = saddrs <> sxaddrs - bal = compute_bal allbals - let ibal = fromIntegral sbal - ftxs <- - lift . runConduit $ - getBinfoTxs xbals abook sxspecs saddrs salladdrs fltr numtxid prune ibal - .| (dropC offset >> takeC n .| sinkList) - addItemCount (length ftxs) - best <- get_best_block - addItemCount 1 - peers <- get_peers - addItemCount (fromIntegral peers) - net <- lift $ asks (storeNetwork . webStore . webConfig) - let baddrs = toBinfoAddrs sabals sxbals xtxns - abaddrs = toBinfoAddrs abals xbals xtxns - recv = sum $ map getBinfoAddrReceived abaddrs - sent' = sum $ map getBinfoAddrSent abaddrs - txn = fromIntegral $ length ftxs - wallet = - BinfoWallet - { getBinfoWalletBalance = bal - , getBinfoWalletTxCount = txn - , getBinfoWalletFilteredCount = txn - , getBinfoWalletTotalReceived = recv - , getBinfoWalletTotalSent = sent' - } - coin = netBinfoSymbol net - block = - BinfoBlockInfo - { getBinfoBlockInfoHash = H.headerHash (blockDataHeader best) - , getBinfoBlockInfoHeight = blockDataHeight best - , getBinfoBlockInfoTime = H.blockTimestamp (blockDataHeader best) - , getBinfoBlockInfoIndex = blockDataHeight best - } - info = - BinfoInfo - { getBinfoConnected = peers - , getBinfoConversion = 100 * 1000 * 1000 - , getBinfoLocal = local' - , getBinfoBTC = coin - , getBinfoLatestBlock = block - } - setHeaders - streamEncoding $ - binfoMultiAddrToEncoding - net - BinfoMultiAddr - { getBinfoMultiAddrAddresses = baddrs - , getBinfoMultiAddrWallet = wallet - , getBinfoMultiAddrTxs = ftxs - , getBinfoMultiAddrInfo = info - , getBinfoMultiAddrRecommendFee = True - , getBinfoMultiAddrCashAddr = cashaddr - } - where - get_xpub_tx_count xbals = - fmap HashMap.fromList . mapM (\x -> (x,) . fromIntegral <$> xPubTxCount x (xBals x xbals)) . HashSet.toList - get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll) - get_best_block = - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bh -> - getBlock bh >>= \case - Nothing -> raise ThingNotFound - Just b -> return b - get_prune = - fmap not $ - S.param "no_compact" - `S.rescue` const (return False) - only_show_xbals sxpubs = HashMap.filterWithKey (\k _ -> xPubSpecKey k `HashSet.member` sxpubs) - only_show_xspecs sxpubs = HashSet.filter (\k -> xPubSpecKey k `HashSet.member` sxpubs) - only_show_abals saddrs = HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs) - addr (BinfoAddr a) = Just a - addr (BinfoXpub _) = Nothing - xpub (BinfoXpub x) = Just x - xpub (BinfoAddr _) = Nothing - get_addrs = do - (xspecs, addrs) <- getBinfoActive - sh <- getBinfoAddrsParam "onlyShow" - let xpubs = HashSet.map xPubSpecKey xspecs - actives = - HashSet.map BinfoAddr addrs - <> HashSet.map BinfoXpub xpubs - sh' = if HashSet.null sh then actives else sh - saddrs = HashSet.fromList . mapMaybe addr $ HashSet.toList sh' - sxpubs = HashSet.fromList . mapMaybe xpub $ HashSet.toList sh' - return (addrs, xpubs, saddrs, sxpubs, xspecs) - get_abals = - let f b = (balanceAddress b, b) - g = HashMap.fromList . map f - in fmap g . getBalances . HashSet.toList - get_peers = do - ps <- - lift $ - getPeersInformation - =<< asks (storeManager . webStore . webConfig) - return (fromIntegral (length ps)) - compute_xabals = - let f b = (balanceAddress (xPubBal b), xPubBal b) - in HashMap.fromList . concatMap (map f) . HashMap.elems - compute_bal = - let f b = balanceAmount b + balanceZero b - in sum . map f . HashMap.elems - compute_abook addrs xbals = - let f XPubSpec{..} XPubBal{..} = - let a = balanceAddress xPubBal - e = error "lions and tigers and bears" - s = toSoft (listToPath xPubBalPath) - in (a, Just (BinfoXPubPath xPubSpecKey (fromMaybe e s))) - amap = - HashMap.map (const Nothing) $ - HashSet.toMap addrs - xmap = - HashMap.fromList - . concatMap (uncurry (map . f)) - $ HashMap.toList xbals - in amap <> xmap - compute_xaddrs = - let f = map (balanceAddress . xPubBal) - in HashSet.fromList . concatMap f . HashMap.elems - -getBinfoCount :: (MonadUnliftIO m, MonadLoggerIO m) => TL.Text -> WebT m Int -getBinfoCount str = do - d <- lift (asks (maxLimitDefault . webMaxLimits . webConfig)) - x <- lift (asks (maxLimitFull . webMaxLimits . webConfig)) - i <- min x <$> (S.param str `S.rescue` const (return d)) - return (fromIntegral i :: Int) - -getBinfoOffset :: - (MonadUnliftIO m, MonadLoggerIO m) => - WebT m Int -getBinfoOffset = do - x <- lift (asks (maxLimitOffset . webMaxLimits . webConfig)) - o <- S.param "offset" `S.rescue` const (return 0) - when (o > x) $ - raise $ - UserError $ "offset exceeded: " <> show o <> " > " <> show x - return (fromIntegral o :: Int) - -scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyRawAddr = - setMetrics statBlockchainRawaddr - >> getBinfoAddr "addr" >>= \case - BinfoAddr addr -> do_addr addr - BinfoXpub xpub -> do_xpub xpub - where - do_xpub xpub = do - numtxid <- getNumTxId - derive <- S.param "derive" `S.rescue` const (return DeriveNormal) - let xspec = XPubSpec xpub derive - n <- getBinfoCount "limit" - off <- getBinfoOffset - xbals <- getXBals $ HashSet.singleton xspec - addItemCount . sum . map length $ HashMap.elems xbals - net <- lift $ asks (storeNetwork . webStore . webConfig) - let summary = xPubSummary xspec (xBals xspec xbals) - abook = compute_abook xpub (xBals xspec xbals) - xspecs = HashSet.singleton xspec - saddrs = HashSet.empty - baddrs = HashMap.keysSet abook - bfilter = BinfoFilterAll - amnt = - xPubSummaryConfirmed summary - + xPubSummaryZero summary - txs <- - lift . runConduit $ - getBinfoTxs - xbals - abook - xspecs - saddrs - baddrs - bfilter - numtxid - False - (fromIntegral amnt) - .| (dropC off >> takeC n .| sinkList) - addItemCount (length txs) - let ra = - BinfoRawAddr - { binfoRawAddr = BinfoXpub xpub - , binfoRawBalance = amnt - , binfoRawTxCount = fromIntegral $ length txs - , binfoRawUnredeemed = xPubUnspentCount summary - , binfoRawReceived = xPubSummaryReceived summary - , binfoRawSent = - fromIntegral (xPubSummaryReceived summary) - - fromIntegral amnt - , binfoRawTxs = txs - } - setHeaders - streamEncoding $ binfoRawAddrToEncoding net ra - compute_abook xpub xbals = - let f XPubBal{..} = - let a = balanceAddress xPubBal - e = error "black hole swallows all your code" - s = toSoft (listToPath xPubBalPath) - m = fromMaybe e s - in (a, Just (BinfoXPubPath xpub m)) - in HashMap.fromList $ map f xbals - do_addr addr = do - numtxid <- getNumTxId - n <- getBinfoCount "limit" - off <- getBinfoOffset - bal <- fromMaybe (zeroBalance addr) <$> getBalance addr - addItemCount 1 - net <- lift $ asks (storeNetwork . webStore . webConfig) - let abook = HashMap.singleton addr Nothing - xspecs = HashSet.empty - saddrs = HashSet.singleton addr - bfilter = BinfoFilterAll - amnt = balanceAmount bal + balanceZero bal - txs <- - lift . runConduit $ - getBinfoTxs - HashMap.empty - abook - xspecs - saddrs - saddrs - bfilter - numtxid - False - (fromIntegral amnt) - .| (dropC off >> takeC n .| sinkList) - addItemCount (length txs) - let ra = - BinfoRawAddr - { binfoRawAddr = BinfoAddr addr - , binfoRawBalance = amnt - , binfoRawTxCount = balanceTxCount bal - , binfoRawUnredeemed = balanceUnspentCount bal - , binfoRawReceived = balanceTotalReceived bal - , binfoRawSent = - fromIntegral (balanceTotalReceived bal) - - fromIntegral amnt - , binfoRawTxs = txs - } - setHeaders - streamEncoding $ binfoRawAddrToEncoding net ra - -scottyBinfoReceived :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoReceived = do - setMetrics statBlockchainQgetreceivedbyaddress - a <- getAddress "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - addItemCount 1 - S.text . cs . show $ balanceTotalReceived b - -scottyBinfoSent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoSent = do - setMetrics statBlockchainQgetsentbyaddress - a <- getAddress "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - addItemCount 1 - S.text . cs . show $ balanceTotalReceived b - balanceAmount b - balanceZero b - -scottyBinfoAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoAddrBalance = do - setMetrics statBlockchainQaddressbalance - a <- getAddress "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - addItemCount 1 - S.text . cs . show $ balanceAmount b + balanceZero b - -scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyFirstSeen = do - setMetrics statBlockchainQaddressfirstseen - a <- getAddress "addr" - ch <- lift $ asks (storeChain . webStore . webConfig) - bb <- chainGetBest ch - let top = H.nodeHeight bb - bot = 0 - i <- go ch bb a bot top - setHeaders - addItemCount 1 - S.text . cs $ show i - where - go ch bb a bot top = do - let mid = bot + (top - bot) `div` 2 - n = top - bot < 2 - x <- hasone a bot - y <- hasone a mid - z <- hasone a top - if - | x -> getblocktime ch bb bot - | n -> getblocktime ch bb top - | y -> go ch bb a bot mid - | z -> go ch bb a mid top - | otherwise -> return 0 - getblocktime ch bb h = - H.blockTimestamp . H.nodeHeader . fromJust - <$> chainGetAncestor h bb ch - hasone a h = do - let l = Limits 1 0 (Just (AtBlock h)) - not . null <$> getAddressTxs a l - -scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyShortBal = do - setMetrics statBlockchainBalance - (xspecs, addrs) <- getBinfoActive - cashaddr <- getCashAddr - net <- lift $ asks (storeNetwork . webStore . webConfig) - abals <- - catMaybes - <$> mapM (get_addr_balance net cashaddr) (HashSet.toList addrs) - addItemCount (length abals) - xbals <- mapM (get_xspec_balance net) (HashSet.toList xspecs) - let res = HashMap.fromList (abals <> xbals) - setHeaders - streamEncoding $ toEncoding res - where - to_short_bal Balance{..} = - BinfoShortBal - { binfoShortBalFinal = balanceAmount + balanceZero - , binfoShortBalTxCount = balanceTxCount - , binfoShortBalReceived = balanceTotalReceived - } - get_addr_balance net cashaddr a = - let net' = - if - | cashaddr -> net - | net == bch -> btc - | net == bchTest -> btcTest - | net == bchTest4 -> btcTest - | otherwise -> net - in case addrToText net' a of - Nothing -> return Nothing - Just a' -> - getBalance a >>= \case - Nothing -> return $ Just (a', to_short_bal (zeroBalance a)) - Just b -> return $ Just (a', to_short_bal b) - is_ext XPubBal{xPubBalPath = 0 : _} = True - is_ext _ = False - get_xspec_balance net xpub = do - xbals <- xPubBals xpub - xts <- xPubTxCount xpub xbals - addItemCount (length xbals + 1) - let val = sum $ map (balanceAmount . xPubBal) xbals - zro = sum $ map (balanceZero . xPubBal) xbals - exs = filter is_ext xbals - rcv = sum $ map (balanceTotalReceived . xPubBal) exs - sbl = - BinfoShortBal - { binfoShortBalFinal = val + zro - , binfoShortBalTxCount = fromIntegral xts - , binfoShortBalReceived = rcv - } - return (xPubExport net (xPubSpecKey xpub), sbl) - -getBinfoHex :: Monad m => WebT m Bool -getBinfoHex = - (== ("hex" :: Text)) - <$> S.param "format" `S.rescue` const (return "json") - -scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoBlockHeight = do - numtxid <- getNumTxId - height <- S.param "height" - setMetrics statBlockchainBlockHeight - block_hashes <- getBlocksAtHeight height - block_headers <- catMaybes <$> mapM getBlock block_hashes - addItemCount (length block_headers) - next_block_hashes <- getBlocksAtHeight (height + 1) - next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes - addItemCount (length next_block_headers) - binfo_blocks <- - mapM (get_binfo_blocks numtxid next_block_headers) block_headers - setHeaders - net <- lift $ asks (storeNetwork . webStore . webConfig) - streamEncoding $ binfoBlocksToEncoding net binfo_blocks - where - get_tx th = - withRunInIO $ \run -> - unsafeInterleaveIO $ - run $ fromJust <$> getTransaction th - get_binfo_blocks numtxid next_block_headers block_header = do - let my_hash = H.headerHash (blockDataHeader block_header) - get_prev = H.prevBlock . blockDataHeader - get_hash = H.headerHash . blockDataHeader - txs <- lift $ mapM get_tx (blockDataTxs block_header) - addItemCount (length txs) - let next_blocks = - map get_hash $ - filter - ((== my_hash) . get_prev) - next_block_headers - binfo_txs = map (toBinfoTxSimple numtxid) txs - binfo_block = toBinfoBlock block_header binfo_txs next_blocks - return binfo_block - -scottyBinfoLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoLatest = do - numtxid <- getNumTxId - setMetrics statBlockchainLatestblock - best <- get_best_block - let binfoTxIndices = map (encodeBinfoTxId numtxid) (blockDataTxs best) - binfoHeaderHash = H.headerHash (blockDataHeader best) - binfoHeaderTime = H.blockTimestamp (blockDataHeader best) - binfoHeaderIndex = binfoHeaderTime - binfoHeaderHeight = blockDataHeight best - addItemCount 1 - streamEncoding $ toEncoding BinfoHeader{..} - where - get_best_block = - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bh -> - getBlock bh >>= \case - Nothing -> raise ThingNotFound - Just b -> return b - -scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoBlock = do - numtxid <- getNumTxId - hex <- getBinfoHex - setMetrics statBlockchainRawblock - S.param "block" >>= \case - BinfoBlockHash bh -> go numtxid hex bh - BinfoBlockIndex i -> - getBlocksAtHeight i >>= \case - [] -> raise ThingNotFound - bh : _ -> go numtxid hex bh - where - get_tx th = - withRunInIO $ \run -> - unsafeInterleaveIO $ - run $ fromJust <$> getTransaction th - go numtxid hex bh = - getBlock bh >>= \case - Nothing -> raise ThingNotFound - Just b -> do - addItemCount 1 - txs <- lift $ mapM get_tx (blockDataTxs b) - addItemCount (length txs) - let my_hash = H.headerHash (blockDataHeader b) - get_prev = H.prevBlock . blockDataHeader - get_hash = H.headerHash . blockDataHeader - nxt_headers <- - fmap catMaybes $ - mapM getBlock - =<< getBlocksAtHeight (blockDataHeight b + 1) - addItemCount (length nxt_headers) - let nxt = - map get_hash $ - filter - ((== my_hash) . get_prev) - nxt_headers - if hex - then do - let x = H.Block (blockDataHeader b) (map transactionData txs) - setHeaders - S.text . encodeHexLazy . runPutL $ serialize x - else do - let btxs = map (toBinfoTxSimple numtxid) txs - y = toBinfoBlock b btxs nxt - setHeaders - net <- lift $ asks (storeNetwork . webStore . webConfig) - streamEncoding $ binfoBlockToEncoding net y - -getBinfoTx :: - (MonadLoggerIO m, MonadUnliftIO m) => - BinfoTxId -> - WebT m (Either Except Transaction) -getBinfoTx txid = do - tx <- case txid of - BinfoTxIdHash h -> maybeToList <$> getTransaction h - BinfoTxIdIndex i -> getNumTransaction i - case tx of - [t] -> return $ Right t - [] -> return $ Left ThingNotFound - ts -> - let tids = map (txHash . transactionData) ts - in return $ Left (TxIndexConflict tids) - -scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTx = do - numtxid <- getNumTxId - hex <- getBinfoHex - txid <- S.param "txid" - setMetrics statBlockchainRawtx - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - addItemCount 1 - if hex then hx tx else js numtxid tx - where - js numtxid t = do - net <- lift $ asks (storeNetwork . webStore . webConfig) - setHeaders - streamEncoding $ binfoTxToEncoding net $ toBinfoTxSimple numtxid t - hx t = do - setHeaders - S.text . encodeHexLazy . runPutL . serialize $ transactionData t - -scottyBinfoTotalOut :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTotalOut = do - txid <- S.param "txid" - setMetrics statBlockchainQtxtotalbtcoutput - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - addItemCount 1 - S.text . cs . show . sum . map outputAmount $ transactionOutputs tx - -scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTxFees = do - txid <- S.param "txid" - setMetrics statBlockchainQtxfee - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - let i = - sum . map inputAmount . filter f $ - transactionInputs tx - o = sum . map outputAmount $ transactionOutputs tx - addItemCount 1 - S.text . cs . show $ i - o - where - f StoreInput{} = True - f StoreCoinbase{} = False - -scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTxResult = do - txid <- S.param "txid" - addr <- getAddress "addr" - setMetrics statBlockchainQtxresult - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - let i = - toInteger . sum . map inputAmount . filter (f addr) $ - transactionInputs tx - o = - toInteger . sum . map outputAmount . filter (g addr) $ - transactionOutputs tx - addItemCount 1 - S.text . cs . show $ o - i - where - f addr StoreInput{inputAddress = Just a} = a == addr - f _ _ = False - g addr StoreOutput{outputAddr = Just a} = a == addr - g _ _ = False - -scottyBinfoTotalInput :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoTotalInput = do - txid <- S.param "txid" - setMetrics statBlockchainQtxtotalbtcinput - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - addItemCount 1 - S.text . cs . show . sum . map inputAmount . filter f $ transactionInputs tx - where - f StoreInput{} = True - f StoreCoinbase{} = False - -scottyBinfoMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoMempool = do - setMetrics statBlockchainMempool - numtxid <- getNumTxId - offset <- getBinfoOffset - n <- getBinfoCount "limit" - mempool <- getMempool - let txids = map snd $ take n $ drop offset mempool - txs <- catMaybes <$> mapM getTransaction txids - net <- lift $ asks (storeNetwork . webStore . webConfig) - setHeaders - let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs - addItemCount (length txs) - streamEncoding $ binfoMempoolToEncoding net mem - -scottyBinfoGetBlockCount :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoGetBlockCount = do - setMetrics statBlockchainQgetblockcount - ch <- asks (storeChain . webStore . webConfig) - bn <- chainGetBest ch - setHeaders - addItemCount 1 - S.text . cs . show $ H.nodeHeight bn - -scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoLatestHash = do - setMetrics statBlockchainQlatesthash - ch <- asks (storeChain . webStore . webConfig) - bn <- chainGetBest ch - setHeaders - addItemCount 1 - S.text . TL.fromStrict . H.blockHashToHex . H.headerHash $ H.nodeHeader bn - -scottyBinfoSubsidy :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoSubsidy = do - setMetrics statBlockchainQbcperblock - ch <- asks (storeChain . webStore . webConfig) - net <- asks (storeNetwork . webStore . webConfig) - bn <- chainGetBest ch - setHeaders - addItemCount 1 - S.text . cs . show . (/ (100 * 1000 * 1000 :: Double)) . fromIntegral $ - H.computeSubsidy net (H.nodeHeight bn + 1) - -scottyBinfoAddrToHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoAddrToHash = do - setMetrics statBlockchainQaddresstohash - addr <- getAddress "addr" - setHeaders - addItemCount 1 - S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr - -scottyBinfoHashToAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoHashToAddr = do - setMetrics statBlockchainQhashtoaddress - bs <- maybe S.next return . decodeHex =<< S.param "hash" - net <- asks (storeNetwork . webStore . webConfig) - hash <- either (const S.next) return (decode bs) - addr <- maybe S.next return (addrToText net (PubKeyAddress hash)) - setHeaders - addItemCount 1 - S.text $ TL.fromStrict addr - -scottyBinfoAddrPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoAddrPubkey = do - setMetrics statBlockchainQaddrpubkey - hex <- S.param "pubkey" - pubkey <- - maybe S.next (return . pubKeyAddr) $ - eitherToMaybe . runGetS deserialize =<< decodeHex hex - net <- lift $ asks (storeNetwork . webStore . webConfig) - setHeaders - case addrToText net pubkey of - Nothing -> raise ThingNotFound - Just a -> do - addItemCount 1 - S.text $ TL.fromStrict a - -scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoPubKeyAddr = do - setMetrics statBlockchainQpubkeyaddr - addr <- getAddress "addr" - mi <- strm addr - i <- case mi of - Nothing -> raise ThingNotFound - Just i -> return i - pk <- case extr addr i of - Left e -> raise $ UserError e - Right t -> return t - setHeaders - addItemCount 1 - S.text $ encodeHexLazy $ L.fromStrict pk - where - strm addr = - runConduit $ - streamThings (getAddressTxs addr) (Just txRefHash) def{limit = 50} - .| concatMapMC (getTransaction . txRefHash) - .| concatMapC (filter (inp addr) . transactionInputs) - .| headC - inp addr StoreInput{inputAddress = Just a} = a == addr - inp _ _ = False - extr addr StoreInput{inputSigScript, inputPkScript, inputWitness} = do - Script sig <- decode inputSigScript - Script pks <- decode inputPkScript - case addr of - PubKeyAddress{} -> - case sig of - [OP_PUSHDATA _ _, OP_PUSHDATA pub _] -> - Right pub - [OP_PUSHDATA _ _] -> - case pks of - [OP_PUSHDATA pub _, OP_CHECKSIG] -> - Right pub - _ -> Left "Could not parse scriptPubKey" - _ -> Left "Could not parse scriptSig" - WitnessPubKeyAddress{} -> - case inputWitness of - [_, pub] -> return pub - _ -> Left "Could not parse scriptPubKey" - _ -> Left "Address does not have public key" - extr _ _ = Left "Incorrect input type" - -scottyBinfoHashPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyBinfoHashPubkey = do - setMetrics statBlockchainQhashpubkey - pkm <- (eitherToMaybe . runGetS deserialize <=< decodeHex) <$> S.param "pubkey" - addr <- case pkm of - Nothing -> raise $ UserError "Could not decode public key" - Just pk -> return $ pubKeyAddr pk - setHeaders - addItemCount 1 - S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr - --- GET Network Information -- - -scottyPeers :: - (MonadUnliftIO m, MonadLoggerIO m) => - GetPeers -> - WebT m [PeerInformation] -scottyPeers _ = do - setMetrics statPeers - ps <- - lift $ - getPeersInformation - =<< asks (storeManager . webStore . webConfig) - addItemCount (length ps) - return ps - --- | Obtain information about connected peers from peer manager process. -getPeersInformation :: - MonadLoggerIO m => PeerManager -> m [PeerInformation] -getPeersInformation mgr = - mapMaybe toInfo <$> getPeers mgr - where - toInfo op = do - ver <- onlinePeerVersion op - let as = onlinePeerAddress op - ua = getVarString $ userAgent ver - vs = version ver - sv = services ver - rl = relay ver - return - PeerInformation - { peerUserAgent = ua - , peerAddress = show as - , peerVersion = vs - , peerServices = sv - , peerRelay = rl - } - -scottyHealth :: - (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck -scottyHealth _ = do - setMetrics statHealth - h <- lift $ asks webConfig >>= healthCheck - unless (isOK h) $ S.status status503 - addItemCount 1 - return h - -blockHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m BlockHealth -blockHealthCheck cfg = do - let ch = storeChain $ webStore cfg - blockHealthMaxDiff = fromIntegral $ webMaxDiff cfg - blockHealthHeaders <- - H.nodeHeight <$> chainGetBest ch - blockHealthBlocks <- - maybe 0 blockDataHeight - <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock) - return BlockHealth{..} - -lastBlockHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - Chain -> - WebTimeouts -> - m TimeHealth -lastBlockHealthCheck ch tos = do - n <- fromIntegral . systemSeconds <$> liftIO getSystemTime - t <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch - let timeHealthAge = n - t - timeHealthMax = fromIntegral $ blockTimeout tos - return TimeHealth{..} - -lastTxHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m TimeHealth -lastTxHealthCheck WebConfig{..} = do - n <- fromIntegral . systemSeconds <$> liftIO getSystemTime - b <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch - t <- - getMempool >>= \case - t : _ -> - let x = fromIntegral $ fst t - in return $ max x b - [] -> return b - let timeHealthAge = n - t - timeHealthMax = fromIntegral to - return TimeHealth{..} - where - ch = storeChain webStore - to = - if webNoMempool - then blockTimeout webTimeouts - else txTimeout webTimeouts - -pendingTxsHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m MaxHealth -pendingTxsHealthCheck cfg = do - let maxHealthMax = fromIntegral $ webMaxPending cfg - maxHealthNum <- - fromIntegral - <$> blockStorePendingTxs (storeBlock (webStore cfg)) - return MaxHealth{..} - -peerHealthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - PeerManager -> - m CountHealth -peerHealthCheck mgr = do - let countHealthMin = 1 - countHealthNum <- fromIntegral . length <$> getPeers mgr - return CountHealth{..} - -healthCheck :: - (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => - WebConfig -> - m HealthCheck -healthCheck cfg@WebConfig{..} = do - healthBlocks <- blockHealthCheck cfg - healthLastBlock <- lastBlockHealthCheck (storeChain webStore) webTimeouts - healthLastTx <- lastTxHealthCheck cfg - healthPendingTxs <- pendingTxsHealthCheck cfg - healthPeers <- peerHealthCheck (storeManager webStore) - let healthNetwork = getNetworkName (storeNetwork webStore) - healthVersion = webVersion - hc = HealthCheck{..} - unless (isOK hc) $ do - let t = toStrict $ encodeToLazyText hc - $(logErrorS) "Web" $ "Health check failed: " <> t - return hc - -scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () -scottyDbStats = do - setMetrics statDbstats - setHeaders - db <- lift $ asks (databaseHandle . storeDB . webStore . webConfig) - statsM <- lift (getProperty db Stats) - addItemCount 1 - S.text $ maybe "Could not get stats" cs statsM - ------------------------ --- Parameter Parsing -- ------------------------ - -{- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on - parse failure. --} -paramOptional :: (Param a, MonadIO m) => WebT m (Maybe a) -paramOptional = go Proxy - where - go :: (Param a, MonadIO m) => Proxy a -> WebT m (Maybe a) - go proxy = do - net <- lift $ asks (storeNetwork . webStore . webConfig) - tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing) - case tsM of - Nothing -> return Nothing -- Parameter was not supplied - Just ts -> maybe (raise err) (return . Just) $ parseParam net ts - where - l = proxyLabel proxy - p = Just <$> S.param (cs l) - err = UserError $ "Unable to parse param " <> cs l - --- | Raises an exception if the parameter is not supplied -param :: (Param a, MonadIO m) => WebT m a -param = go Proxy - where - go :: (Param a, MonadIO m) => Proxy a -> WebT m a - go proxy = do - resM <- paramOptional - case resM of - Just res -> return res - _ -> - raise . UserError $ - "The param " <> cs (proxyLabel proxy) <> " was not defined" - -{- | Returns the default value of a parameter if it is not supplied. Raises an - exception on parse failure. --} -paramDef :: (Default a, Param a, MonadIO m) => WebT m a -paramDef = fromMaybe def <$> paramOptional - -{- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is - not supplied or if parsing fails. --} -paramLazy :: (Param a, MonadIO m) => WebT m a -paramLazy = do - resM <- paramOptional `S.rescue` const (return Nothing) - maybe S.next return resM - -parseBody :: (MonadIO m, Serial a) => WebT m a -parseBody = do - b <- L.toStrict <$> S.body - case hex b <> bin b of - Left _ -> raise $ UserError "Failed to parse request body" - Right x -> return x - where - bin = runGetS deserialize - hex b = case B16.decodeBase16 $ C.filter (not . isSpace) b of - Right x -> bin x - Left s -> Left (T.unpack s) - -parseOffset :: MonadIO m => WebT m OffsetParam -parseOffset = do - res@(OffsetParam o) <- paramDef - limits <- lift $ asks (webMaxLimits . webConfig) - when (maxLimitOffset limits > 0 && fromIntegral o > maxLimitOffset limits) $ - raise . UserError $ - "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits) - return res - -parseStart :: - (MonadUnliftIO m, MonadLoggerIO m) => - Maybe StartParam -> - WebT m (Maybe Start) -parseStart Nothing = return Nothing -parseStart (Just s) = - runMaybeT $ - case s of - StartParamHash{startParamHash = h} -> start_tx h <|> start_block h - StartParamHeight{startParamHeight = h} -> start_height h - StartParamTime{startParamTime = q} -> start_time q - where - start_height h = return $ AtBlock $ fromIntegral h - start_block h = do - b <- MaybeT $ getBlock (H.BlockHash h) - return $ AtBlock (blockDataHeight b) - start_tx h = do - _ <- MaybeT $ getTxData (TxHash h) - return $ AtTx (TxHash h) - start_time q = do - ch <- lift $ asks (storeChain . webStore . webConfig) - b <- MaybeT $ blockAtOrBefore ch q - let g = blockDataHeight b - return $ AtBlock g - -parseLimits :: MonadIO m => WebT m LimitsParam -parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional - -paramToLimits :: - (MonadUnliftIO m, MonadLoggerIO m) => - Bool -> - LimitsParam -> - WebT m Limits -paramToLimits full (LimitsParam limitM o startM) = do - wl <- lift $ asks (webMaxLimits . webConfig) - Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM - -validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32 -validateLimit wl full limitM = - f m $ maybe d (fromIntegral . getLimitParam) limitM - where - m - | full && maxLimitFull wl > 0 = maxLimitFull wl - | otherwise = maxLimitCount wl - d = maxLimitDefault wl - f a 0 = a - f 0 b = b - f a b = min a b - ---------------- --- Utilities -- ---------------- - -runInWebReader :: - MonadIO m => - CacheT (DatabaseReaderT m) a -> - ReaderT WebState m a -runInWebReader f = do - bdb <- asks (storeDB . webStore . webConfig) - mc <- asks (storeCache . webStore . webConfig) - lift $ runReaderT (withCache mc f) bdb - -runNoCache :: MonadIO m => Bool -> ReaderT WebState m a -> ReaderT WebState m a -runNoCache False f = f -runNoCache True f = local g f - where - g s = s{webConfig = h (webConfig s)} - h c = c{webStore = i (webStore c)} - i s = s{storeCache = Nothing} - -logIt :: - (MonadUnliftIO m, MonadLoggerIO m) => - Maybe WebMetrics -> - m Middleware -logIt metrics = do - runner <- askRunInIO - return $ \app req respond -> do - var <- newTVarIO B.empty - req' <- - let rb = req_body var (getRequestBodyChunk req) - rq = req{requestBody = rb} - in case metrics of - Nothing -> return rq - Just m -> do - stat_var <- newTVarIO Nothing - let vt = - V.insert (statKey m) stat_var $ - vault rq - return rq{vault = vt} - bracket start (end var runner req') $ \_ -> - app req' $ \res -> do - b <- readTVarIO var - let s = responseStatus res - msg = fmtReq b req' <> ": " <> fmtStatus s - if statusIsSuccessful s - then runner $ $(logDebugS) "Web" msg - else runner $ $(logErrorS) "Web" msg - respond res - where - start = systemToUTCTime <$> getSystemTime - req_body var old_body = do - b <- old_body - unless (B.null b) . atomically $ modifyTVar var (<> b) - return b - add_stat d s = do - addStatQuery s - addStatTime s d - end var runner req t1 = do - t2 <- systemToUTCTime <$> getSystemTime - let diff = round $ diffUTCTime t2 t1 * 1000 - case metrics of - Nothing -> return () - Just m -> do - let m_stat_var = V.lookup (statKey m) (vault req) - add_stat diff (statAll m) - case m_stat_var of - Nothing -> return () - Just stat_var -> - readTVarIO stat_var >>= \case - Nothing -> return () - Just f -> add_stat diff (f m) - when (diff > 10000) $ do - b <- readTVarIO var - runner $ - $(logWarnS) "Web" $ - "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req - -reqSizeLimit :: Integral i => i -> Middleware -reqSizeLimit i = requestSizeLimitMiddleware lim - where - max_len _req = return (Just (fromIntegral i)) - lim = - setOnLengthExceeded too_big $ - setMaxLengthForRequest - max_len - defaultRequestSizeLimitSettings - too_big _ = \_app _req send -> - send $ - waiExcept requestEntityTooLarge413 RequestTooLarge - -fmtReq :: ByteString -> Request -> Text -fmtReq bs req = - let m = requestMethod req - v = httpVersion req - p = rawPathInfo req - q = rawQueryString req - txt = case T.decodeUtf8' bs of - Left _ -> " {invalid utf8}" - Right "" -> "" - Right t -> " [" <> t <> "]" - in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt +module Haskoin.Store.Web + ( -- * Web + WebConfig (..), + Except (..), + WebLimits (..), + WebTimeouts (..), + runWeb, + ) +where + +import Conduit + ( ConduitT, + await, + concatMapC, + concatMapMC, + dropC, + dropWhileC, + headC, + iterMC, + mapC, + runConduit, + sinkList, + takeC, + takeWhileC, + yield, + (.|), + ) +import Control.Applicative ((<|>)) +import Control.Arrow (second) +import Control.Lens ((.~), (^.)) +import Control.Monad + ( forM_, + forever, + join, + unless, + when, + (<=<), + ) +import Control.Monad.Logger + ( MonadLoggerIO, + logDebugS, + logErrorS, + logWarnS, + ) +import Control.Monad.Reader + ( ReaderT, + asks, + local, + runReaderT, + ) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Control (liftWith, restoreT) +import Control.Monad.Trans.Maybe + ( MaybeT (..), + runMaybeT, + ) +import Data.Aeson + ( Encoding, + ToJSON (..), + Value, + ) +import qualified Data.Aeson as A +import Data.Aeson.Encode.Pretty + ( Config (..), + defConfig, + encodePretty', + ) +import Data.Aeson.Encoding + ( encodingToLazyByteString, + list, + ) +import Data.Aeson.Text (encodeToLazyText) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import Data.ByteString.Builder (lazyByteString) +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Char (isSpace) +import Data.Default (Default (..)) +import Data.Function ((&)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Int (Int64) +import Data.List (nub) +import Data.Maybe + ( catMaybes, + fromJust, + fromMaybe, + isJust, + mapMaybe, + maybeToList, + ) +import Data.Proxy (Proxy (..)) +import Data.Serialize (decode) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.Lazy (toStrict) +import qualified Data.Text.Lazy as TL +import Data.Time.Clock (diffUTCTime) +import Data.Time.Clock.System + ( getSystemTime, + systemSeconds, + systemToUTCTime, + ) +import qualified Data.Vault.Lazy as V +import Data.Word (Word32, Word64) +import Database.RocksDB + ( Property (..), + getProperty, + ) +import Haskoin.Address +import qualified Haskoin.Block as H +import Haskoin.Constants +import Haskoin.Data +import Haskoin.Keys +import Haskoin.Network +import Haskoin.Node + ( Chain, + OnlinePeer (..), + PeerManager, + chainGetAncestor, + chainGetBest, + getPeers, + sendMessage, + ) +import Haskoin.Script +import Haskoin.Store.BlockStore +import Haskoin.Store.Cache +import Haskoin.Store.Common +import Haskoin.Store.Data +import Haskoin.Store.Database.Reader +import Haskoin.Store.Manager +import Haskoin.Store.Stats +import Haskoin.Store.WebCommon +import Haskoin.Transaction +import Haskoin.Util +import NQE + ( Inbox, + Publisher, + receive, + withSubscription, + ) +import Network.HTTP.Types + ( Status (..), + requestEntityTooLarge413, + status400, + status404, + status409, + status413, + status500, + status503, + statusIsClientError, + statusIsServerError, + statusIsSuccessful, + ) +import Network.Wai + ( Middleware, + Request (..), + Response, + getRequestBodyChunk, + responseLBS, + responseStatus, + ) +import Network.Wai.Handler.Warp + ( defaultSettings, + setHost, + setPort, + ) +import Network.Wai.Handler.WebSockets (websocketsOr) +import Network.Wai.Middleware.RequestSizeLimit +import Network.WebSockets + ( ServerApp, + acceptRequest, + defaultConnectionOptions, + pendingRequest, + rejectRequestWith, + requestPath, + sendTextData, + ) +import qualified Network.WebSockets as WebSockets +import qualified Network.Wreq as Wreq +import Network.Wreq.Session as Wreq (Session) +import qualified Network.Wreq.Session as Wreq.Session +import System.IO.Unsafe (unsafeInterleaveIO) +import qualified System.Metrics as Metrics +import qualified System.Metrics.Gauge as Metrics (Gauge) +import qualified System.Metrics.Gauge as Metrics.Gauge +import UnliftIO + ( MonadIO, + MonadUnliftIO, + TVar, + askRunInIO, + atomically, + bracket, + bracket_, + handleAny, + liftIO, + modifyTVar, + newTVarIO, + readTVarIO, + timeout, + withAsync, + withRunInIO, + writeTVar, + ) +import UnliftIO.Concurrent (threadDelay) +import Web.Scotty.Internal.Types (ActionT) +import qualified Web.Scotty.Trans as S + +type WebT m = ActionT Except (ReaderT WebState m) + +data WebLimits = WebLimits + { maxLimitCount :: !Word32, + maxLimitFull :: !Word32, + maxLimitOffset :: !Word32, + maxLimitDefault :: !Word32, + maxLimitGap :: !Word32, + maxLimitInitialGap :: !Word32, + maxLimitBody :: !Word32 + } + deriving (Eq, Show) + +instance Default WebLimits where + def = + WebLimits + { maxLimitCount = 200000, + maxLimitFull = 5000, + maxLimitOffset = 50000, + maxLimitDefault = 100, + maxLimitGap = 32, + maxLimitInitialGap = 20, + maxLimitBody = 1024 * 1024 + } + +data WebConfig = WebConfig + { webHost :: !String, + webPort :: !Int, + webStore :: !Store, + webMaxDiff :: !Int, + webMaxPending :: !Int, + webMaxLimits :: !WebLimits, + webTimeouts :: !WebTimeouts, + webVersion :: !String, + webNoMempool :: !Bool, + webStats :: !(Maybe Metrics.Store), + webPriceGet :: !Int, + webTickerURL :: !String, + webHistoryURL :: !String + } + +data WebState = WebState + { webConfig :: !WebConfig, + webTicker :: !(TVar (HashMap Text BinfoTicker)), + webMetrics :: !(Maybe WebMetrics), + webWreqSession :: !Wreq.Session + } + +data WebMetrics = WebMetrics + { statAll :: !StatDist, + -- Addresses + statAddressTransactions :: !StatDist, + statAddressTransactionsFull :: !StatDist, + statAddressBalance :: !StatDist, + statAddressUnspent :: !StatDist, + statXpub :: !StatDist, + statXpubDelete :: !StatDist, + statXpubTransactionsFull :: !StatDist, + statXpubTransactions :: !StatDist, + statXpubBalances :: !StatDist, + statXpubUnspent :: !StatDist, + -- Transactions + statTransaction :: !StatDist, + statTransactionRaw :: !StatDist, + statTransactionAfter :: !StatDist, + statTransactionsBlock :: !StatDist, + statTransactionsBlockRaw :: !StatDist, + statTransactionPost :: !StatDist, + statMempool :: !StatDist, + -- Blocks + statBlock :: !StatDist, + statBlockRaw :: !StatDist, + -- Blockchain + statBlockchainMultiaddr :: !StatDist, + statBlockchainBalance :: !StatDist, + statBlockchainRawaddr :: !StatDist, + statBlockchainUnspent :: !StatDist, + statBlockchainRawtx :: !StatDist, + statBlockchainRawblock :: !StatDist, + statBlockchainMempool :: !StatDist, + statBlockchainBlockHeight :: !StatDist, + statBlockchainBlocks :: !StatDist, + statBlockchainLatestblock :: !StatDist, + statBlockchainExportHistory :: !StatDist, + -- Blockchain /q endpoints + statBlockchainQaddresstohash :: !StatDist, + statBlockchainQhashtoaddress :: !StatDist, + statBlockchainQaddrpubkey :: !StatDist, + statBlockchainQpubkeyaddr :: !StatDist, + statBlockchainQhashpubkey :: !StatDist, + statBlockchainQgetblockcount :: !StatDist, + statBlockchainQlatesthash :: !StatDist, + statBlockchainQbcperblock :: !StatDist, + statBlockchainQtxtotalbtcoutput :: !StatDist, + statBlockchainQtxtotalbtcinput :: !StatDist, + statBlockchainQtxfee :: !StatDist, + statBlockchainQtxresult :: !StatDist, + statBlockchainQgetreceivedbyaddress :: !StatDist, + statBlockchainQgetsentbyaddress :: !StatDist, + statBlockchainQaddressbalance :: !StatDist, + statBlockchainQaddressfirstseen :: !StatDist, + -- Others + statHealth :: !StatDist, + statPeers :: !StatDist, + statDbstats :: !StatDist, + statEvents :: !Metrics.Gauge.Gauge, + -- Request + statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist)))) + } + +createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics +createMetrics s = liftIO $ do + statAll <- d "all" + + -- Addresses + statAddressTransactions <- d "address_transactions" + statAddressTransactionsFull <- d "address_transactions_full" + statAddressBalance <- d "address_balance" + statAddressUnspent <- d "address_unspent" + statXpub <- d "xpub" + statXpubDelete <- d "xpub_delete" + statXpubTransactionsFull <- d "xpub_transactions_full" + statXpubTransactions <- d "xpub_transactions" + statXpubBalances <- d "xpub_balances" + statXpubUnspent <- d "xpub_unspent" + + -- Transactions + statTransaction <- d "transaction" + statTransactionRaw <- d "transaction_raw" + statTransactionAfter <- d "transaction_after" + statTransactionPost <- d "transaction_post" + statTransactionsBlock <- d "transactions_block" + statTransactionsBlockRaw <- d "transactions_block_raw" + statMempool <- d "mempool" + + -- Blocks + statBlockBest <- d "block_best" + statBlockLatest <- d "block_latest" + statBlock <- d "block" + statBlockRaw <- d "block_raw" + statBlockHeight <- d "block_height" + statBlockHeightRaw <- d "block_height_raw" + statBlockTime <- d "block_time" + statBlockTimeRaw <- d "block_time_raw" + statBlockMtp <- d "block_mtp" + statBlockMtpRaw <- d "block_mtp_raw" + + -- Blockchain + statBlockchainMultiaddr <- d "blockchain_multiaddr" + statBlockchainBalance <- d "blockchain_balance" + statBlockchainRawaddr <- d "blockchain_rawaddr" + statBlockchainUnspent <- d "blockchain_unspent" + statBlockchainRawtx <- d "blockchain_rawtx" + statBlockchainRawblock <- d "blockchain_rawblock" + statBlockchainLatestblock <- d "blockchain_latestblock" + statBlockchainMempool <- d "blockchain_mempool" + statBlockchainBlockHeight <- d "blockchain_block_height" + statBlockchainBlocks <- d "blockchain_blocks" + statBlockchainExportHistory <- d "blockchain_export_history" + + -- Blockchain /q endpoints + statBlockchainQaddresstohash <- d "blockchain_q_addresstohash" + statBlockchainQhashtoaddress <- d "blockchain_q_hashtoaddress" + statBlockchainQaddrpubkey <- d "blockckhain_q_addrpubkey" + statBlockchainQpubkeyaddr <- d "blockchain_q_pubkeyaddr" + statBlockchainQhashpubkey <- d "blockchain_q_hashpubkey" + statBlockchainQgetblockcount <- d "blockchain_q_getblockcount" + statBlockchainQlatesthash <- d "blockchain_q_latesthash" + statBlockchainQbcperblock <- d "blockchain_q_bcperblock" + statBlockchainQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput" + statBlockchainQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput" + statBlockchainQtxfee <- d "blockchain_q_txfee" + statBlockchainQtxresult <- d "blockchain_q_txresult" + statBlockchainQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress" + statBlockchainQgetsentbyaddress <- d "blockchain_q_getsentbyaddress" + statBlockchainQaddressbalance <- d "blockchain_q_addressbalance" + statBlockchainQaddressfirstseen <- d "blockchain_q_addressfirstseen" + + -- Others + statHealth <- d "health" + statPeers <- d "peers" + statDbstats <- d "dbstats" + + statEvents <- g "events_connected" + statKey <- V.newKey + return WebMetrics {..} + where + d x = createStatDist ("web." <> x) s + g x = Metrics.createGauge ("web." <> x) s + +withGaugeIO :: MonadUnliftIO m => Metrics.Gauge -> m a -> m a +withGaugeIO g = + bracket_ + (liftIO $ Metrics.Gauge.inc g) + (liftIO $ Metrics.Gauge.dec g) + +withGaugeIncrease :: + MonadUnliftIO m => + (WebMetrics -> Metrics.Gauge) -> + WebT m a -> + WebT m a +withGaugeIncrease gf go = + lift (asks webMetrics) >>= \case + Nothing -> go + Just m -> do + s <- liftWith $ \run -> withGaugeIO (gf m) (run go) + restoreT $ return s + +setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) -> WebT m () +setMetrics df = + asks webMetrics >>= mapM_ go + where + go m = do + req <- S.request + let t = fromMaybe e $ V.lookup (statKey m) (vault req) + atomically $ writeTVar t (Just df) + e = error "the ways of the warrior are yet to be mastered" + +addItemCount :: MonadUnliftIO m => Int -> WebT m () +addItemCount i = + asks webMetrics >>= mapM_ \m -> + addStatItems (statAll m) (fromIntegral i) + >> S.request >>= \req -> + forM_ (V.lookup (statKey m) (vault req)) \t -> + readTVarIO t >>= mapM_ \s -> + addStatItems (s m) (fromIntegral i) + +getItemCounter :: (MonadIO m, MonadIO n) => WebT m (Int -> n ()) +getItemCounter = + fromMaybe (\_ -> return ()) <$> runMaybeT do + q <- lift S.request + m <- MaybeT $ asks webMetrics + t <- MaybeT . return $ V.lookup (statKey m) (vault q) + s <- MaybeT $ readTVarIO t + return $ addStatItems (s m) . fromIntegral + +data WebTimeouts = WebTimeouts + { txTimeout :: !Word64, + blockTimeout :: !Word64 + } + deriving (Eq, Show) + +data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON + deriving (Eq, Show) + +instance Default WebTimeouts where + def = WebTimeouts {txTimeout = 300, blockTimeout = 7200} + +instance + (MonadUnliftIO m, MonadLoggerIO m) => + StoreReadBase (ReaderT WebState m) + where + getNetwork = runInWebReader getNetwork + getBestBlock = runInWebReader getBestBlock + getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height) + getBlock bh = runInWebReader (getBlock bh) + getTxData th = runInWebReader (getTxData th) + getSpender op = runInWebReader (getSpender op) + getUnspent op = runInWebReader (getUnspent op) + getBalance a = runInWebReader (getBalance a) + getMempool = runInWebReader getMempool + +instance + (MonadUnliftIO m, MonadLoggerIO m) => + StoreReadExtra (ReaderT WebState m) + where + getMaxGap = runInWebReader getMaxGap + getInitialGap = runInWebReader getInitialGap + getBalances as = runInWebReader (getBalances as) + getAddressesTxs as = runInWebReader . getAddressesTxs as + getAddressTxs a = runInWebReader . getAddressTxs a + getAddressUnspents a = runInWebReader . getAddressUnspents a + getAddressesUnspents as = runInWebReader . getAddressesUnspents as + xPubBals = runInWebReader . xPubBals + xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals + xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals + xPubTxCount xpub = runInWebReader . xPubTxCount xpub + getNumTxData = runInWebReader . getNumTxData + +instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where + getNetwork = lift getNetwork + getBestBlock = lift getBestBlock + getBlocksAtHeight = lift . getBlocksAtHeight + getBlock = lift . getBlock + getTxData = lift . getTxData + getSpender = lift . getSpender + getUnspent = lift . getUnspent + getBalance = lift . getBalance + getMempool = lift getMempool + +instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where + getBalances = lift . getBalances + getAddressesTxs as = lift . getAddressesTxs as + getAddressTxs a = lift . getAddressTxs a + getAddressUnspents a = lift . getAddressUnspents a + getAddressesUnspents as = lift . getAddressesUnspents as + xPubBals = lift . xPubBals + xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals + xPubTxs xpub xbals = lift . xPubTxs xpub xbals + xPubTxCount xpub = lift . xPubTxCount xpub + getMaxGap = lift getMaxGap + getInitialGap = lift getInitialGap + getNumTxData = lift . getNumTxData + +------------------- +-- Path Handlers -- +------------------- + +runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => WebConfig -> m () +runWeb + cfg@WebConfig + { webHost = host, + webPort = port, + webStore = store', + webStats = stats, + webPriceGet = pget, + webTickerURL = turl, + webMaxLimits = WebLimits {..} + } = do + ticker <- newTVarIO HashMap.empty + metrics <- mapM createMetrics stats + session <- liftIO Wreq.Session.newAPISession + let st = + WebState + { webConfig = cfg, + webTicker = ticker, + webMetrics = metrics, + webWreqSession = session + } + net = storeNetwork store' + withAsync (price net session turl pget ticker) $ + const $ do + reqLogger <- logIt metrics + runner <- askRunInIO + S.scottyOptsT opts (runner . (`runReaderT` st)) $ do + S.middleware (webSocketEvents st) + S.middleware reqLogger + S.middleware (reqSizeLimit maxLimitBody) + S.defaultHandler defHandler + handlePaths + S.notFound $ raise ThingNotFound + where + opts = def {S.settings = settings defaultSettings} + settings = setPort port . setHost (fromString host) + +getRates :: + (MonadUnliftIO m, MonadLoggerIO m) => + Network -> + Wreq.Session -> + String -> + Text -> + [Word64] -> + m [BinfoRate] +getRates net session url currency times = do + handleAny err $ do + r <- + liftIO $ + Wreq.asJSON + =<< Wreq.Session.postWith opts session url body + return $ r ^. Wreq.responseBody + where + err _ = do + $(logErrorS) "Web" "Could not get historic prices" + return [] + body = toJSON times + base = + Wreq.defaults + & Wreq.param "base" .~ [T.toUpper (T.pack (getNetworkName net))] + opts = base & Wreq.param "quote" .~ [currency] + +price :: + (MonadUnliftIO m, MonadLoggerIO m) => + Network -> + Wreq.Session -> + String -> + Int -> + TVar (HashMap Text BinfoTicker) -> + m () +price net session url pget v = forM_ purl $ \u -> forever $ do + let err e = $(logErrorS) "Price" $ cs (show e) + handleAny err $ do + r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u + atomically . writeTVar v $ r ^. Wreq.responseBody + threadDelay pget + where + purl = case code of + Nothing -> Nothing + Just x -> Just (url <> "?base=" <> x) + where + code + | net == btc = Just "btc" + | net == bch = Just "bch" + | otherwise = Nothing + +raise :: MonadIO m => Except -> WebT m a +raise err = + lift (asks webMetrics) >>= \case + Nothing -> S.raise err + Just m -> do + req <- S.request + mM <- case V.lookup (statKey m) (vault req) of + Nothing -> return Nothing + Just t -> readTVarIO t + let status = errStatus err + if + | statusIsClientError status -> + liftIO $ do + addClientError (statAll m) + forM_ mM $ \f -> addClientError (f m) + | statusIsServerError status -> + liftIO $ do + addServerError (statAll m) + forM_ mM $ \f -> addServerError (f m) + | otherwise -> + return () + S.raise err + +errStatus :: Except -> Status +errStatus ThingNotFound = status404 +errStatus BadRequest = status400 +errStatus UserError {} = status400 +errStatus StringError {} = status400 +errStatus ServerError = status500 +errStatus TxIndexConflict {} = status409 +errStatus ServerTimeout = status500 +errStatus RequestTooLarge = status413 + +defHandler :: Monad m => Except -> WebT m () +defHandler e = do + setHeaders + S.status $ errStatus e + S.json e + +handlePaths :: + (MonadUnliftIO m, MonadLoggerIO m) => + S.ScottyT Except (ReaderT WebState m) () +handlePaths = do + -- Block Paths + pathCompact + (GetBlock <$> paramLazy <*> paramDef) + scottyBlock + blockDataToEncoding + blockDataToJSON + pathCompact + (GetBlocks <$> param <*> paramDef) + (fmap SerialList . scottyBlocks) + (\n -> list (blockDataToEncoding n) . getSerialList) + (\n -> json_list blockDataToJSON n . getSerialList) + pathCompact + (GetBlockRaw <$> paramLazy) + scottyBlockRaw + (const toEncoding) + (const toJSON) + pathCompact + (GetBlockBest <$> paramDef) + scottyBlockBest + blockDataToEncoding + blockDataToJSON + pathCompact + (GetBlockBestRaw & return) + scottyBlockBestRaw + (const toEncoding) + (const toJSON) + pathCompact + (GetBlockLatest <$> paramDef) + (fmap SerialList . scottyBlockLatest) + (\n -> list (blockDataToEncoding n) . getSerialList) + (\n -> json_list blockDataToJSON n . getSerialList) + pathCompact + (GetBlockHeight <$> paramLazy <*> paramDef) + (fmap SerialList . scottyBlockHeight) + (\n -> list (blockDataToEncoding n) . getSerialList) + (\n -> json_list blockDataToJSON n . getSerialList) + pathCompact + (GetBlockHeights <$> param <*> paramDef) + (fmap SerialList . scottyBlockHeights) + (\n -> list (blockDataToEncoding n) . getSerialList) + (\n -> json_list blockDataToJSON n . getSerialList) + pathCompact + (GetBlockHeightRaw <$> paramLazy) + scottyBlockHeightRaw + (const toEncoding) + (const toJSON) + pathCompact + (GetBlockTime <$> paramLazy <*> paramDef) + scottyBlockTime + blockDataToEncoding + blockDataToJSON + pathCompact + (GetBlockTimeRaw <$> paramLazy) + scottyBlockTimeRaw + (const toEncoding) + (const toJSON) + pathCompact + (GetBlockMTP <$> paramLazy <*> paramDef) + scottyBlockMTP + blockDataToEncoding + blockDataToJSON + pathCompact + (GetBlockMTPRaw <$> paramLazy) + scottyBlockMTPRaw + (const toEncoding) + (const toJSON) + -- Transaction Paths + pathCompact + (GetTx <$> paramLazy) + scottyTx + transactionToEncoding + transactionToJSON + pathCompact + (GetTxs <$> param) + (fmap SerialList . scottyTxs) + (\n -> list (transactionToEncoding n) . getSerialList) + (\n -> json_list transactionToJSON n . getSerialList) + pathCompact + (GetTxRaw <$> paramLazy) + scottyTxRaw + (const toEncoding) + (const toJSON) + pathCompact + (GetTxsRaw <$> param) + scottyTxsRaw + (const toEncoding) + (const toJSON) + pathCompact + (GetTxsBlock <$> paramLazy) + (fmap SerialList . scottyTxsBlock) + (\n -> list (transactionToEncoding n) . getSerialList) + (\n -> json_list transactionToJSON n . getSerialList) + pathCompact + (GetTxsBlockRaw <$> paramLazy) + scottyTxsBlockRaw + (const toEncoding) + (const toJSON) + pathCompact + (GetTxAfter <$> paramLazy <*> paramLazy) + scottyTxAfter + (const toEncoding) + (const toJSON) + pathCompact + (PostTx <$> parseBody) + scottyPostTx + (const toEncoding) + (const toJSON) + pathCompact + (GetMempool <$> paramOptional <*> parseOffset) + (fmap SerialList . scottyMempool) + (const toEncoding) + (const toJSON) + -- Address Paths + pathCompact + (GetAddrTxs <$> paramLazy <*> parseLimits) + (fmap SerialList . scottyAddrTxs) + (const toEncoding) + (const toJSON) + pathCompact + (GetAddrsTxs <$> param <*> parseLimits) + (fmap SerialList . scottyAddrsTxs) + (const toEncoding) + (const toJSON) + pathCompact + (GetAddrTxsFull <$> paramLazy <*> parseLimits) + (fmap SerialList . scottyAddrTxsFull) + (\n -> list (transactionToEncoding n) . getSerialList) + (\n -> json_list transactionToJSON n . getSerialList) + pathCompact + (GetAddrsTxsFull <$> param <*> parseLimits) + (fmap SerialList . scottyAddrsTxsFull) + (\n -> list (transactionToEncoding n) . getSerialList) + (\n -> json_list transactionToJSON n . getSerialList) + pathCompact + (GetAddrBalance <$> paramLazy) + scottyAddrBalance + balanceToEncoding + balanceToJSON + pathCompact + (GetAddrsBalance <$> param) + (fmap SerialList . scottyAddrsBalance) + (\n -> list (balanceToEncoding n) . getSerialList) + (\n -> json_list balanceToJSON n . getSerialList) + pathCompact + (GetAddrUnspent <$> paramLazy <*> parseLimits) + (fmap SerialList . scottyAddrUnspent) + (\n -> list (unspentToEncoding n) . getSerialList) + (\n -> json_list unspentToJSON n . getSerialList) + pathCompact + (GetAddrsUnspent <$> param <*> parseLimits) + (fmap SerialList . scottyAddrsUnspent) + (\n -> list (unspentToEncoding n) . getSerialList) + (\n -> json_list unspentToJSON n . getSerialList) + -- XPubs + pathCompact + (GetXPub <$> paramLazy <*> paramDef <*> paramDef) + scottyXPub + (const toEncoding) + (const toJSON) + pathCompact + (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) + (fmap SerialList . scottyXPubTxs) + (const toEncoding) + (const toJSON) + pathCompact + (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) + (fmap SerialList . scottyXPubTxsFull) + (\n -> list (transactionToEncoding n) . getSerialList) + (\n -> json_list transactionToJSON n . getSerialList) + pathCompact + (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef) + (fmap SerialList . scottyXPubBalances) + (\n -> list (xPubBalToEncoding n) . getSerialList) + (\n -> json_list xPubBalToJSON n . getSerialList) + pathCompact + (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) + (fmap SerialList . scottyXPubUnspent) + (\n -> list (xPubUnspentToEncoding n) . getSerialList) + (\n -> json_list xPubUnspentToJSON n . getSerialList) + pathCompact + (DelCachedXPub <$> paramLazy <*> paramDef) + scottyDelXPub + (const toEncoding) + (const toJSON) + -- Network + pathCompact + (GetPeers & return) + (fmap SerialList . scottyPeers) + (const toEncoding) + (const toJSON) + pathCompact + (GetHealth & return) + scottyHealth + (const toEncoding) + (const toJSON) + S.get "/events" scottyEvents + S.get "/dbstats" scottyDbStats + -- Blockchain.info + S.post "/blockchain/multiaddr" scottyMultiAddr + S.get "/blockchain/multiaddr" scottyMultiAddr + S.get "/blockchain/balance" scottyShortBal + S.post "/blockchain/balance" scottyShortBal + S.get "/blockchain/rawaddr/:addr" scottyRawAddr + S.get "/blockchain/address/:addr" scottyRawAddr + S.get "/blockchain/xpub/:addr" scottyRawAddr + S.post "/blockchain/unspent" scottyBinfoUnspent + S.get "/blockchain/unspent" scottyBinfoUnspent + S.get "/blockchain/rawtx/:txid" scottyBinfoTx + S.get "/blockchain/rawblock/:block" scottyBinfoBlock + S.get "/blockchain/latestblock" scottyBinfoLatest + S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool + S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight + S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay + S.get "/blockchain/export-history" scottyBinfoHistory + S.post "/blockchain/export-history" scottyBinfoHistory + S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash + S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr + S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey + S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr + S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey + S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount + S.get "/blockchain/q/latesthash" scottyBinfoLatestHash + S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy + S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut + S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput + S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees + S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult + S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived + S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent + S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance + S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen + where + json_list f net = toJSONList . map (f net) + +pathCompact :: + (ApiResource a b, MonadIO m) => + WebT m a -> + (a -> WebT m b) -> + (Network -> b -> Encoding) -> + (Network -> b -> Value) -> + S.ScottyT Except (ReaderT WebState m) () +pathCompact parser action encJson encValue = + pathCommon parser action encJson encValue False + +pathCommon :: + (ApiResource a b, MonadIO m) => + WebT m a -> + (a -> WebT m b) -> + (Network -> b -> Encoding) -> + (Network -> b -> Value) -> + Bool -> + S.ScottyT Except (ReaderT WebState m) () +pathCommon parser action encJson encValue pretty = + S.addroute (resourceMethod proxy) (capturePath proxy) $ do + setHeaders + proto <- setupContentType pretty + net <- lift $ asks (storeNetwork . webStore . webConfig) + apiRes <- parser + res <- action apiRes + S.raw $ protoSerial proto (encJson net) (encValue net) res + where + toProxy :: WebT m a -> Proxy a + toProxy = const Proxy + proxy = toProxy parser + +streamEncoding :: Monad m => Encoding -> WebT m () +streamEncoding e = do + S.setHeader "Content-Type" "application/json; charset=utf-8" + S.raw (encodingToLazyByteString e) + +protoSerial :: + Serial a => + SerialAs -> + (a -> Encoding) -> + (a -> Value) -> + a -> + L.ByteString +protoSerial SerialAsBinary _ _ = runPutL . serialize +protoSerial SerialAsJSON f _ = encodingToLazyByteString . f +protoSerial SerialAsPrettyJSON _ g = + encodePretty' defConfig {confTrailingNewline = True} . g + +setHeaders :: (Monad m, S.ScottyError e) => ActionT e m () +setHeaders = S.setHeader "Access-Control-Allow-Origin" "*" + +waiExcept :: Status -> Except -> Response +waiExcept s e = + responseLBS s hs e' + where + hs = + [ ("Access-Control-Allow-Origin", "*"), + ("Content-Type", "application/json") + ] + e' = A.encode e + +setupJSON :: Monad m => Bool -> ActionT Except m SerialAs +setupJSON pretty = do + S.setHeader "Content-Type" "application/json" + p <- S.param "pretty" `S.rescue` const (return pretty) + return $ if p then SerialAsPrettyJSON else SerialAsJSON + +setupBinary :: Monad m => ActionT Except m SerialAs +setupBinary = do + S.setHeader "Content-Type" "application/octet-stream" + return SerialAsBinary + +setupContentType :: Monad m => Bool -> ActionT Except m SerialAs +setupContentType pretty = do + accept <- S.header "accept" + maybe (setupJSON pretty) setType accept + where + setType "application/octet-stream" = setupBinary + setType _ = setupJSON pretty + +-- GET Block / GET Blocks -- + +scottyBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData +scottyBlock (GetBlock h (NoTx noTx)) = do + setMetrics statBlock + getBlock h >>= \case + Nothing -> + raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx noTx b + +getBlocks :: + (MonadUnliftIO m, MonadLoggerIO m) => + [H.BlockHash] -> + Bool -> + WebT m [BlockData] +getBlocks hs notx = + (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs) + +scottyBlocks :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData] +scottyBlocks (GetBlocks hs (NoTx notx)) = do + setMetrics statBlock + bs <- getBlocks hs notx + addItemCount (length bs) + return bs + +pruneTx :: Bool -> BlockData -> BlockData +pruneTx False b = b +pruneTx True b = b {blockDataTxs = take 1 (blockDataTxs b)} + +-- GET BlockRaw -- + +scottyBlockRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockRaw -> + WebT m (RawResult H.Block) +scottyBlockRaw (GetBlockRaw h) = do + setMetrics statBlockRaw + b <- getRawBlock h + addItemCount (1 + length (H.blockTxns b)) + return $ RawResult b + +getRawBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => + H.BlockHash -> + WebT m H.Block +getRawBlock h = do + b <- getBlock h >>= maybe (raise ThingNotFound) return + lift (toRawBlock b) + +toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block +toRawBlock b = do + let ths = blockDataTxs b + txs <- mapM f ths + return H.Block {H.blockHeader = blockDataHeader b, H.blockTxns = txs} + where + f x = withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x >>= \case + Nothing -> undefined + Just t -> return $ transactionData t + +-- GET BlockBest / BlockBestRaw -- + +scottyBlockBest :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData +scottyBlockBest (GetBlockBest (NoTx notx)) = do + setMetrics statBlock + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bb -> + getBlock bb >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx notx b + +scottyBlockBestRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockBestRaw -> + WebT m (RawResult H.Block) +scottyBlockBestRaw _ = do + setMetrics statBlockRaw + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bb -> do + b <- getRawBlock bb + addItemCount (1 + length (H.blockTxns b)) + return $ RawResult b + +-- GET BlockLatest -- + +scottyBlockLatest :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockLatest -> + WebT m [BlockData] +scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do + setMetrics statBlock + blocks <- + getBestBlock + >>= maybe + (raise ThingNotFound) + (go [] <=< getBlock) + addItemCount (length blocks) + return blocks + where + go acc Nothing = return $ reverse acc + go acc (Just b) + | blockDataHeight b <= 0 = return $ reverse acc + | length acc == 99 = return . reverse $ pruneTx noTx b : acc + | otherwise = do + let prev = H.prevBlock (blockDataHeader b) + go (pruneTx noTx b : acc) =<< getBlock prev + +-- GET BlockHeight / BlockHeights / BlockHeightRaw -- + +scottyBlockHeight :: + (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData] +scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do + setMetrics statBlock + blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h) + addItemCount (length blocks) + return blocks + +scottyBlockHeights :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockHeights -> + WebT m [BlockData] +scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do + setMetrics statBlock + bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights) + blocks <- getBlocks bhs notx + addItemCount (length blocks) + return blocks + +scottyBlockHeightRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockHeightRaw -> + WebT m (RawResultList H.Block) +scottyBlockHeightRaw (GetBlockHeightRaw h) = do + setMetrics statBlockRaw + blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h) + addItemCount (length blocks + sum (map (length . H.blockTxns) blocks)) + return $ RawResultList blocks + +-- GET BlockTime / BlockTimeRaw -- + +scottyBlockTime :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockTime -> + WebT m BlockData +scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do + setMetrics statBlock + ch <- lift $ asks (storeChain . webStore . webConfig) + blockAtOrBefore ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx notx b + +scottyBlockMTP :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockMTP -> + WebT m BlockData +scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = do + setMetrics statBlock + ch <- lift $ asks (storeChain . webStore . webConfig) + blockAtOrAfterMTP ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + return $ pruneTx notx b + +scottyBlockTimeRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockTimeRaw -> + WebT m (RawResult H.Block) +scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do + setMetrics statBlockRaw + ch <- lift $ asks (storeChain . webStore . webConfig) + blockAtOrBefore ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + raw <- lift $ toRawBlock b + addItemCount (1 + length (H.blockTxns raw)) + return $ RawResult raw + +scottyBlockMTPRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetBlockMTPRaw -> + WebT m (RawResult H.Block) +scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do + setMetrics statBlockRaw + ch <- lift $ asks (storeChain . webStore . webConfig) + blockAtOrAfterMTP ch t >>= \case + Nothing -> raise ThingNotFound + Just b -> do + raw <- lift $ toRawBlock b + addItemCount (1 + length (H.blockTxns raw)) + return $ RawResult raw + +-- GET Transactions -- + +scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction +scottyTx (GetTx txid) = do + setMetrics statTransaction + getTransaction txid >>= \case + Nothing -> raise ThingNotFound + Just tx -> do + addItemCount 1 + return tx + +scottyTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction] +scottyTxs (GetTxs txids) = do + setMetrics statTransaction + txs <- catMaybes <$> mapM f (nub txids) + addItemCount (length txs) + return txs + where + f x = lift $ + withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x + +scottyTxRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx) +scottyTxRaw (GetTxRaw txid) = do + setMetrics statTransactionRaw + getTransaction txid >>= \case + Nothing -> raise ThingNotFound + Just tx -> do + addItemCount 1 + return $ RawResult (transactionData tx) + +scottyTxsRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxsRaw -> + WebT m (RawResultList Tx) +scottyTxsRaw (GetTxsRaw txids) = do + setMetrics statTransactionRaw + txs <- catMaybes <$> mapM f (nub txids) + addItemCount (length txs) + return $ RawResultList $ transactionData <$> txs + where + f x = lift $ + withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x + +getTxsBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => + H.BlockHash -> + WebT m [Transaction] +getTxsBlock h = + getBlock h >>= \case + Nothing -> raise ThingNotFound + Just b -> do + txs <- mapM f (blockDataTxs b) + addItemCount (length txs) + return txs + where + f x = lift $ + withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x >>= \case + Nothing -> undefined + Just t -> return t + +scottyTxsBlock :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxsBlock -> + WebT m [Transaction] +scottyTxsBlock (GetTxsBlock h) = do + setMetrics statTransactionsBlock + txs <- getTxsBlock h + addItemCount (length txs) + return txs + +scottyTxsBlockRaw :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxsBlockRaw -> + WebT m (RawResultList Tx) +scottyTxsBlockRaw (GetTxsBlockRaw h) = do + setMetrics statTransactionsBlockRaw + txs <- fmap transactionData <$> getTxsBlock h + addItemCount (length txs) + return $ RawResultList txs + +-- GET TransactionAfterHeight -- + +scottyTxAfter :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetTxAfter -> + WebT m (GenericResult (Maybe Bool)) +scottyTxAfter (GetTxAfter txid height) = do + setMetrics statTransactionAfter + (result, count) <- cbAfterHeight (fromIntegral height) txid + addItemCount count + return $ GenericResult result + +-- | Check if any of the ancestors of this transaction is a coinbase after the +-- specified height. Returns 'Nothing' if answer cannot be computed before +-- hitting limits. +cbAfterHeight :: + (MonadIO m, StoreReadBase m) => + H.BlockHeight -> + TxHash -> + m (Maybe Bool, Int) +cbAfterHeight height txid = + inputs n HashSet.empty HashSet.empty [txid] + where + n = 10000 + inputs 0 _ _ [] = return (Nothing, 10000) + inputs i is ns [] = + let is' = HashSet.union is ns + ns' = HashSet.empty + ts = HashSet.toList (HashSet.difference ns is) + in case ts of + [] -> return (Just False, n - i) + _ -> inputs i is' ns' ts + inputs i is ns (t : ts) = + getTransaction t >>= \case + Nothing -> return (Nothing, n - i) + Just tx + | height_check tx -> + if cb_check tx + then return (Just True, n - i + 1) + else + let ns' = HashSet.union (ins tx) ns + in inputs (i - 1) is ns' ts + | otherwise -> inputs (i - 1) is ns ts + cb_check = any isCoinbase . transactionInputs + ins = HashSet.fromList . map (outPointHash . inputPoint) . transactionInputs + height_check tx = + case transactionBlock tx of + BlockRef h _ -> h > height + _ -> True + +-- POST Transaction -- + +scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId +scottyPostTx (PostTx tx) = do + setMetrics statTransactionPost + addItemCount 1 + lift (asks webConfig) >>= \cfg -> + lift (publishTx cfg tx) >>= \case + Right () -> return (TxId (txHash tx)) + Left e@(PubReject _) -> raise $ UserError (show e) + _ -> raise ServerError + +-- | Publish a new transaction to the network. +publishTx :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + Tx -> + m (Either PubExcept ()) +publishTx cfg tx = + withSubscription pub $ \s -> + getTransaction (txHash tx) >>= \case + Just _ -> return $ Right () + Nothing -> go s + where + pub = storePublisher (webStore cfg) + mgr = storeManager (webStore cfg) + net = storeNetwork (webStore cfg) + go s = + getPeers mgr >>= \case + [] -> return $ Left PubNoPeers + OnlinePeer {onlinePeerMailbox = p} : _ -> do + MTx tx `sendMessage` p + let v = + if getSegWit net + then InvWitnessTx + else InvTx + sendMessage + (MGetData (GetData [InvVector v (getTxHash (txHash tx))])) + p + f p s + t = 5 * 1000 * 1000 + f p s + | webNoMempool cfg = return $ Right () + | otherwise = + liftIO (timeout t (g p s)) >>= \case + Nothing -> return $ Left PubTimeout + Just (Left e) -> return $ Left e + Just (Right ()) -> return $ Right () + g p s = + receive s >>= \case + StoreTxReject p' h' c _ + | p == p' && h' == txHash tx -> return . Left $ PubReject c + StorePeerDisconnected p' + | p == p' -> return $ Left PubPeerDisconnected + StoreMempoolNew h' + | h' == txHash tx -> return $ Right () + _ -> g p s + +-- GET Mempool / Events -- + +scottyMempool :: + (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash] +scottyMempool (GetMempool limitM (OffsetParam o)) = do + setMetrics statMempool + wl <- lift $ asks (webMaxLimits . webConfig) + let wl' = wl {maxLimitCount = 0} + l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing + ths <- map snd . applyLimits l <$> getMempool + addItemCount 1 + return ths + +webSocketEvents :: WebState -> Middleware +webSocketEvents s = + websocketsOr defaultConnectionOptions events + where + pub = (storePublisher . webStore . webConfig) s + gauge = statEvents <$> webMetrics s + events pending = withSubscription pub $ \sub -> do + let path = requestPath $ pendingRequest pending + if path == "/events" + then do + conn <- acceptRequest pending + forever $ + receiveEvent sub >>= \case + Nothing -> return () + Just event -> sendTextData conn (A.encode event) + else + rejectRequestWith + pending + WebSockets.defaultRejectRequest + { WebSockets.rejectBody = L.toStrict $ A.encode ThingNotFound, + WebSockets.rejectCode = 404, + WebSockets.rejectMessage = "Not Found", + WebSockets.rejectHeaders = [("Content-Type", "application/json")] + } + +scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyEvents = + withGaugeIncrease statEvents $ do + setHeaders + proto <- setupContentType False + pub <- lift $ asks (storePublisher . webStore . webConfig) + S.stream $ \io flush' -> + withSubscription pub $ \sub -> + forever $ + flush' >> receiveEvent sub >>= maybe (return ()) (io . serial proto) + where + serial proto e = + lazyByteString $ protoSerial proto toEncoding toJSON e <> newLine proto + newLine SerialAsBinary = mempty + newLine SerialAsJSON = "\n" + newLine SerialAsPrettyJSON = mempty + +receiveEvent :: Inbox StoreEvent -> IO (Maybe Event) +receiveEvent sub = + go <$> receive sub + where + go = \case + StoreBestBlock b -> Just (EventBlock b) + StoreMempoolNew t -> Just (EventTx t) + StoreMempoolDelete t -> Just (EventTx t) + _ -> Nothing + +-- GET Address Transactions -- + +scottyAddrTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef] +scottyAddrTxs (GetAddrTxs addr pLimits) = do + setMetrics statAddressTransactions + txs <- getAddressTxs addr =<< paramToLimits False pLimits + addItemCount (length txs) + return txs + +scottyAddrsTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef] +scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do + setMetrics statAddressTransactions + txs <- getAddressesTxs addrs =<< paramToLimits False pLimits + addItemCount (length txs) + return txs + +scottyAddrTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrTxsFull -> + WebT m [Transaction] +scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do + setMetrics statAddressTransactionsFull + txs <- getAddressTxs addr =<< paramToLimits True pLimits + ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs + addItemCount (length ts) + return ts + +scottyAddrsTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrsTxsFull -> + WebT m [Transaction] +scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do + setMetrics statAddressTransactionsFull + txs <- getAddressesTxs addrs =<< paramToLimits True pLimits + ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs + addItemCount (length ts) + return ts + +scottyAddrBalance :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetAddrBalance -> + WebT m Balance +scottyAddrBalance (GetAddrBalance addr) = do + setMetrics statAddressBalance + addItemCount 1 + getDefaultBalance addr + +scottyAddrsBalance :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance] +scottyAddrsBalance (GetAddrsBalance addrs) = do + setMetrics statAddressBalance + balances <- getBalances addrs + addItemCount (length balances) + return balances + +scottyAddrUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent] +scottyAddrUnspent (GetAddrUnspent addr pLimits) = do + setMetrics statAddressUnspent + unspents <- getAddressUnspents addr =<< paramToLimits False pLimits + addItemCount (length unspents) + return unspents + +scottyAddrsUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent] +scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do + setMetrics statAddressUnspent + unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits + addItemCount (length unspents) + return unspents + +-- GET XPubs -- + +scottyXPub :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary +scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do + setMetrics statXpub + let xspec = XPubSpec xpub deriv + xbals <- lift . runNoCache noCache $ xPubBals xspec + addItemCount (length xbals) + return $ xPubSummary xspec xbals + +scottyDelXPub :: + (MonadUnliftIO m, MonadLoggerIO m) => + DelCachedXPub -> + WebT m (GenericResult Bool) +scottyDelXPub (DelCachedXPub xpub deriv) = do + setMetrics statXpubDelete + let xspec = XPubSpec xpub deriv + cacheM <- lift (asks (storeCache . webStore . webConfig)) + n <- lift $ withCache cacheM (cacheDelXPubs [xspec]) + addItemCount (fromIntegral n) + return (GenericResult (n > 0)) + +getXPubTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => + XPubKey -> + DeriveType -> + LimitsParam -> + Bool -> + WebT m [TxRef] +getXPubTxs xpub deriv plimits nocache = do + limits <- paramToLimits False plimits + let xspec = XPubSpec xpub deriv + xbals <- xPubBals xspec + addItemCount (length xbals) + lift . runNoCache nocache $ xPubTxs xspec xbals limits + +scottyXPubTxs :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef] +scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do + setMetrics statXpubTransactions + txs <- getXPubTxs xpub deriv plimits nocache + addItemCount (length txs) + return txs + +scottyXPubTxsFull :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetXPubTxsFull -> + WebT m [Transaction] +scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do + setMetrics statXpubTransactionsFull + refs <- getXPubTxs xpub deriv plimits nocache + txs <- + fmap catMaybes $ + lift . runNoCache nocache $ + mapM (getTransaction . txRefHash) refs + addItemCount (length txs) + return txs + +scottyXPubBalances :: + (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal] +scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do + setMetrics statXpubBalances + balances <- filter f <$> lift (runNoCache noCache (xPubBals spec)) + addItemCount (length balances) + return balances + where + spec = XPubSpec xpub deriv + f = not . nullBalance . xPubBal + +scottyXPubUnspent :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetXPubUnspent -> + WebT m [XPubUnspent] +scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do + setMetrics statXpubUnspent + limits <- paramToLimits False pLimits + let xspec = XPubSpec xpub deriv + xbals <- xPubBals xspec + addItemCount (length xbals) + unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits + addItemCount (length unspents) + return unspents + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- + +netBinfoSymbol :: Network -> BinfoSymbol +netBinfoSymbol net + | net == btc = + BinfoSymbol + { getBinfoSymbolCode = "BTC", + getBinfoSymbolString = "BTC", + getBinfoSymbolName = "Bitcoin", + getBinfoSymbolConversion = 100 * 1000 * 1000, + getBinfoSymbolAfter = True, + getBinfoSymbolLocal = False + } + | net == bch = + BinfoSymbol + { getBinfoSymbolCode = "BCH", + getBinfoSymbolString = "BCH", + getBinfoSymbolName = "Bitcoin Cash", + getBinfoSymbolConversion = 100 * 1000 * 1000, + getBinfoSymbolAfter = True, + getBinfoSymbolLocal = False + } + | otherwise = + BinfoSymbol + { getBinfoSymbolCode = "XTS", + getBinfoSymbolString = "¤", + getBinfoSymbolName = "Test", + getBinfoSymbolConversion = 100 * 1000 * 1000, + getBinfoSymbolAfter = False, + getBinfoSymbolLocal = False + } + +binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol +binfoTickerToSymbol code BinfoTicker {..} = + BinfoSymbol + { getBinfoSymbolCode = code, + getBinfoSymbolString = binfoTickerSymbol, + getBinfoSymbolName = name, + getBinfoSymbolConversion = + 100 * 1000 * 1000 / binfoTicker15m, -- sat/usd + getBinfoSymbolAfter = False, + getBinfoSymbolLocal = True + } + where + name = case code of + "EUR" -> "Euro" + "USD" -> "U.S. dollar" + "GBP" -> "British pound" + x -> x + +getBinfoAddrsParam :: + MonadIO m => + Text -> + WebT m (HashSet BinfoAddr) +getBinfoAddrsParam name = do + net <- lift (asks (storeNetwork . webStore . webConfig)) + p <- S.param (cs name) `S.rescue` const (return "") + if T.null p + then return HashSet.empty + else case parseBinfoAddr net p of + Nothing -> raise (UserError "invalid address") + Just xs -> return $ HashSet.fromList xs + +getBinfoActive :: + MonadIO m => + WebT m (HashSet XPubSpec, HashSet Address) +getBinfoActive = do + active <- getBinfoAddrsParam "active" + p2sh <- getBinfoAddrsParam "activeP2SH" + bech32 <- getBinfoAddrsParam "activeBech32" + let xspec d b = (`XPubSpec` d) <$> xpub b + xspecs = + HashSet.fromList $ + concat + [ mapMaybe (xspec DeriveNormal) (HashSet.toList active), + mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh), + mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32) + ] + addrs = HashSet.fromList . mapMaybe addr $ HashSet.toList active + return (xspecs, addrs) + where + addr (BinfoAddr a) = Just a + addr (BinfoXpub _) = Nothing + xpub (BinfoXpub x) = Just x + xpub (BinfoAddr _) = Nothing + +getNumTxId :: MonadIO m => WebT m Bool +getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False) + +getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight +getChainHeight = do + ch <- lift $ asks (storeChain . webStore . webConfig) + H.nodeHeight <$> chainGetBest ch + +scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoUnspent = do + setMetrics statBlockchainUnspent + (xspecs, addrs) <- getBinfoActive + numtxid <- getNumTxId + limit <- get_limit + min_conf <- get_min_conf + net <- lift $ asks (storeNetwork . webStore . webConfig) + height <- getChainHeight + let mn BinfoUnspent {..} = min_conf > getBinfoUnspentConfirmations + xbals <- lift $ getXBals xspecs + addItemCount . sum . map length $ HashMap.elems xbals + counter <- getItemCounter + bus <- + lift . runConduit $ + getBinfoUnspents counter numtxid height xbals xspecs addrs + .| (dropWhileC mn >> takeC limit .| sinkList) + setHeaders + streamEncoding (binfoUnspentsToEncoding net (BinfoUnspents bus)) + where + get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250) + get_min_conf = S.param "confirmations" `S.rescue` const (return 0) + +getBinfoUnspents :: + (StoreReadExtra m, MonadIO m) => + (Int -> m ()) -> + Bool -> + H.BlockHeight -> + HashMap XPubSpec [XPubBal] -> + HashSet XPubSpec -> + HashSet Address -> + ConduitT () BinfoUnspent m () +getBinfoUnspents counter numtxid height xbals xspecs addrs = do + cs' <- conduits + joinDescStreams cs' .| mapC (uncurry binfo) + where + binfo Unspent {..} xp = + let conf = case unspentBlock of + MemRef {} -> 0 + BlockRef h _ -> height - h + 1 + hash = outPointHash unspentPoint + idx = outPointIndex unspentPoint + val = unspentAmount + script = unspentScript + txi = encodeBinfoTxId numtxid hash + in BinfoUnspent + { getBinfoUnspentHash = hash, + getBinfoUnspentOutputIndex = idx, + getBinfoUnspentScript = script, + getBinfoUnspentValue = val, + getBinfoUnspentConfirmations = fromIntegral conf, + getBinfoUnspentTxIndex = txi, + getBinfoUnspentXPub = xp + } + conduits = (<>) <$> xconduits <*> pure acounduits + xconduits = lift $ do + let f x (XPubUnspent u p) = + let path = toSoft (listToPath p) + xp = BinfoXPubPath (xPubSpecKey x) <$> path + in (u, xp) + g x = do + return $ + streamThings + ( \l -> do + us <- xPubUnspents x (xBals x xbals) l + counter (length us) + return us + ) + Nothing + def {limit = 16} + .| mapC (f x) + mapM g (HashSet.toList xspecs) + acounduits = + let f u = (u, Nothing) + g a = + streamThings + ( \l -> do + us <- getAddressUnspents a l + counter (length us) + return us + ) + Nothing + def {limit = 16} + .| mapC f + in map g (HashSet.toList addrs) + +getXBals :: StoreReadExtra m => HashSet XPubSpec -> m (HashMap XPubSpec [XPubBal]) +getXBals = + fmap HashMap.fromList + . mapM + ( \x -> + (x,) . filter (not . nullBalance . xPubBal) + <$> (xPubBals x) + ) + . HashSet.toList + +xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal] +xBals = HashMap.findWithDefault [] + +getBinfoTxs :: + (StoreReadExtra m, MonadIO m) => + (Int -> m ()) -> -- counter + HashMap XPubSpec [XPubBal] -> -- xpub balances + HashMap Address (Maybe BinfoXPubPath) -> -- address book + HashSet XPubSpec -> -- show xpubs + HashSet Address -> -- show addrs + HashSet Address -> -- balance addresses + BinfoFilter -> + Bool -> -- numtxid + Bool -> -- prune outputs + Int64 -> -- starting balance + ConduitT () BinfoTx m () +getBinfoTxs + counter + xbals + abook + sxspecs + saddrs + baddrs + bfilter + numtxid + prune + bal = do + cs' <- conduits + joinDescStreams cs' .| go bal + where + sxspecs_ls = HashSet.toList sxspecs + saddrs_ls = HashSet.toList saddrs + conduits = (<>) <$> mapM xpub_c sxspecs_ls <*> pure (map addr_c saddrs_ls) + xpub_c x = + lift . return $ + streamThings + ( \l -> do + ts <- xPubTxs x (xBals x xbals) l + counter (length ts) + return ts + ) + (Just txRefHash) + def {limit = 16} + addr_c a = + streamThings + ( \l -> do + as <- getAddressTxs a l + counter (length as) + return as + ) + (Just txRefHash) + def {limit = 16} + binfo_tx b = toBinfoTx numtxid abook prune b + compute_bal_change BinfoTx {..} = + let ins = map getBinfoTxInputPrevOut getBinfoTxInputs + out = getBinfoTxOutputs + f b BinfoTxOutput {..} = + let val = fromIntegral getBinfoTxOutputValue + in case getBinfoTxOutputAddress of + Nothing -> 0 + Just a + | a `HashSet.member` baddrs -> + if b then val else negate val + | otherwise -> 0 + in sum $ map (f False) ins <> map (f True) out + go b = + await >>= \case + Nothing -> return () + Just (TxRef _ t) -> + lift (getTransaction t) >>= \case + Nothing -> go b + Just x -> do + lift $ counter 1 + let a = binfo_tx b x + b' = b - compute_bal_change a + c = isJust (getBinfoTxBlockHeight a) + Just (d, _) = getBinfoTxResultBal a + r = d + fromIntegral (getBinfoTxFee a) + case bfilter of + BinfoFilterAll -> + yield a >> go b' + BinfoFilterSent + | 0 > r -> yield a >> go b' + | otherwise -> go b' + BinfoFilterReceived + | r > 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMoved + | r == 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterConfirmed + | c -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMempool + | c -> return () + | otherwise -> yield a >> go b' + +getCashAddr :: Monad m => WebT m Bool +getCashAddr = S.param "cashaddr" `S.rescue` const (return False) + +getAddress :: (Monad m, MonadUnliftIO m) => TL.Text -> WebT m Address +getAddress param' = do + txt <- S.param param' + net <- lift $ asks (storeNetwork . webStore . webConfig) + case textToAddr net txt of + Nothing -> raise ThingNotFound + Just a -> return a + +getBinfoAddr :: Monad m => TL.Text -> WebT m BinfoAddr +getBinfoAddr param' = do + txt <- S.param param' + net <- lift $ asks (storeNetwork . webStore . webConfig) + let x = + BinfoAddr <$> textToAddr net txt + <|> BinfoXpub <$> xPubImport net txt + maybe S.next return x + +scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoHistory = do + setMetrics statBlockchainExportHistory + (xspecs, addrs) <- getBinfoActive + (startM, endM) <- get_dates + (code, price') <- getPrice + xbals <- getXBals xspecs + addItemCount . sum . map length $ HashMap.elems xbals + counter <- getItemCounter + let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals) + aaddrs = xaddrs <> addrs + cur = binfoTicker15m price' + cs' = conduits counter (HashMap.toList xbals) addrs endM + txs <- + lift . runConduit $ + joinDescStreams cs' + .| takeWhileC (is_newer startM) + .| concatMapMC get_transaction + .| sinkList + addItemCount (length txs) + let times = map transactionTime txs + net <- lift $ asks (storeNetwork . webStore . webConfig) + url <- lift $ asks (webHistoryURL . webConfig) + session <- lift $ asks webWreqSession + rates <- map binfoRatePrice <$> lift (getRates net session url code times) + addItemCount (length rates) + let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) + setHeaders + streamEncoding $ toEncoding hs + where + is_newer (Just BlockData {..}) TxRef {txRefBlock = BlockRef {..}} = + blockRefHeight >= blockDataHeight + is_newer _ _ = True + get_addr = balanceAddress . xPubBal + get_transaction TxRef {txRefHash = h} = + getTransaction h + convert cur addrs tx rate = + let ins = transactionInputs tx + outs = transactionOutputs tx + fins = filter (input_addr addrs) ins + fouts = filter (output_addr addrs) outs + vin = fromIntegral . sum $ map inputAmount fins + vout = fromIntegral . sum $ map outputAmount fouts + v = vout - vin + t = transactionTime tx + h = txHash $ transactionData tx + in toBinfoHistory v t rate cur h + input_addr addrs' StoreInput {inputAddress = Just a} = + a `HashSet.member` addrs' + input_addr _ _ = False + output_addr addrs' StoreOutput {outputAddr = Just a} = + a `HashSet.member` addrs' + output_addr _ _ = False + get_dates = do + BinfoDate start <- S.param "start" + BinfoDate end' <- S.param "end" + let end = end' + 24 * 60 * 60 + ch <- lift $ asks (storeChain . webStore . webConfig) + startM <- blockAtOrAfter ch start + endM <- blockAtOrBefore ch end + return (startM, endM) + conduits counter xpubs addrs endM = + map (uncurry (xpub_c counter endM)) xpubs + <> map (addr_c counter endM) (HashSet.toList addrs) + addr_c counter endM a = + streamThings + ( \l -> do + ts <- getAddressTxs a l + counter (length ts) + return ts + ) + (Just txRefHash) + def + { limit = 16, + start = AtBlock . blockDataHeight <$> endM + } + xpub_c counter endM x bs = + streamThings + ( \l -> do + ts <- xPubTxs x bs l + counter (length ts) + return ts + ) + (Just txRefHash) + def + { limit = 16, + start = AtBlock . blockDataHeight <$> endM + } + +getPrice :: MonadIO m => WebT m (Text, BinfoTicker) +getPrice = do + code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD") + ticker <- lift $ asks webTicker + prices <- readTVarIO ticker + case HashMap.lookup code prices of + Nothing -> return (code, def) + Just p -> return (code, p) + +getSymbol :: MonadIO m => WebT m BinfoSymbol +getSymbol = uncurry binfoTickerToSymbol <$> getPrice + +scottyBinfoBlocksDay :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlocksDay = do + setMetrics statBlockchainBlocks + t <- min h . (`div` 1000) <$> S.param "milliseconds" + ch <- lift $ asks (storeChain . webStore . webConfig) + m <- blockAtOrBefore ch t + bs <- go (d t) m + addItemCount (length bs) + streamEncoding $ toEncoding $ map toBinfoBlockInfo bs + where + h = fromIntegral (maxBound :: H.Timestamp) + d = subtract (24 * 3600) + go _ Nothing = return [] + go t (Just b) + | H.blockTimestamp (blockDataHeader b) <= fromIntegral t = + return [] + | otherwise = do + b' <- getBlock (H.prevBlock (blockDataHeader b)) + (b :) <$> go t b' + +scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyMultiAddr = do + setMetrics statBlockchainMultiaddr + (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs + numtxid <- getNumTxId + cashaddr <- getCashAddr + local' <- getSymbol + offset <- getBinfoOffset + n <- getBinfoCount "n" + prune <- get_prune + fltr <- get_filter + xbals <- getXBals xspecs + addItemCount . sum . map length $ HashMap.elems xbals + xtxns <- get_xpub_tx_count xbals xspecs + addItemCount (length xtxns) + let sxbals = only_show_xbals sxpubs xbals + xabals = compute_xabals xbals + addrs = addrs' `HashSet.difference` HashMap.keysSet xabals + abals <- get_abals addrs + addItemCount (length abals) + let sxspecs = only_show_xspecs sxpubs xspecs + sxabals = compute_xabals sxbals + sabals = only_show_abals saddrs abals + sallbals = sabals <> sxabals + sbal = compute_bal sallbals + allbals = abals <> xabals + abook = compute_abook addrs xbals + sxaddrs = compute_xaddrs sxbals + salladdrs = saddrs <> sxaddrs + bal = compute_bal allbals + ibal = fromIntegral sbal + counter <- getItemCounter + ftxs <- + lift . runConduit $ + getBinfoTxs + counter + xbals + abook + sxspecs + saddrs + salladdrs + fltr + numtxid + prune + ibal + .| (dropC offset >> takeC n .| sinkList) + best <- get_best_block + addItemCount 1 + peers <- get_peers + addItemCount (fromIntegral peers) + net <- lift $ asks (storeNetwork . webStore . webConfig) + let baddrs = toBinfoAddrs sabals sxbals xtxns + abaddrs = toBinfoAddrs abals xbals xtxns + recv = sum $ map getBinfoAddrReceived abaddrs + sent' = sum $ map getBinfoAddrSent abaddrs + txn = fromIntegral $ length ftxs + wallet = + BinfoWallet + { getBinfoWalletBalance = bal, + getBinfoWalletTxCount = txn, + getBinfoWalletFilteredCount = txn, + getBinfoWalletTotalReceived = recv, + getBinfoWalletTotalSent = sent' + } + coin = netBinfoSymbol net + block = + BinfoBlockInfo + { getBinfoBlockInfoHash = H.headerHash (blockDataHeader best), + getBinfoBlockInfoHeight = blockDataHeight best, + getBinfoBlockInfoTime = H.blockTimestamp (blockDataHeader best), + getBinfoBlockInfoIndex = blockDataHeight best + } + info = + BinfoInfo + { getBinfoConnected = peers, + getBinfoConversion = 100 * 1000 * 1000, + getBinfoLocal = local', + getBinfoBTC = coin, + getBinfoLatestBlock = block + } + setHeaders + streamEncoding $ + binfoMultiAddrToEncoding + net + BinfoMultiAddr + { getBinfoMultiAddrAddresses = baddrs, + getBinfoMultiAddrWallet = wallet, + getBinfoMultiAddrTxs = ftxs, + getBinfoMultiAddrInfo = info, + getBinfoMultiAddrRecommendFee = True, + getBinfoMultiAddrCashAddr = cashaddr + } + where + get_xpub_tx_count xbals = + fmap HashMap.fromList + . mapM + ( \x -> + (x,) + . fromIntegral + <$> xPubTxCount x (xBals x xbals) + ) + . HashSet.toList + get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll) + get_best_block = + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bh -> + getBlock bh >>= \case + Nothing -> raise ThingNotFound + Just b -> return b + get_prune = + fmap not $ + S.param "no_compact" + `S.rescue` const (return False) + only_show_xbals sxpubs = HashMap.filterWithKey (\k _ -> xPubSpecKey k `HashSet.member` sxpubs) + only_show_xspecs sxpubs = HashSet.filter (\k -> xPubSpecKey k `HashSet.member` sxpubs) + only_show_abals saddrs = HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs) + addr (BinfoAddr a) = Just a + addr (BinfoXpub _) = Nothing + xpub (BinfoXpub x) = Just x + xpub (BinfoAddr _) = Nothing + get_addrs = do + (xspecs, addrs) <- getBinfoActive + sh <- getBinfoAddrsParam "onlyShow" + let xpubs = HashSet.map xPubSpecKey xspecs + actives = + HashSet.map BinfoAddr addrs + <> HashSet.map BinfoXpub xpubs + sh' = if HashSet.null sh then actives else sh + saddrs = HashSet.fromList . mapMaybe addr $ HashSet.toList sh' + sxpubs = HashSet.fromList . mapMaybe xpub $ HashSet.toList sh' + return (addrs, xpubs, saddrs, sxpubs, xspecs) + get_abals = + let f b = (balanceAddress b, b) + g = HashMap.fromList . map f + in fmap g . getBalances . HashSet.toList + get_peers = do + ps <- + lift $ + getPeersInformation + =<< asks (storeManager . webStore . webConfig) + return (fromIntegral (length ps)) + compute_xabals = + let f b = (balanceAddress (xPubBal b), xPubBal b) + in HashMap.fromList . concatMap (map f) . HashMap.elems + compute_bal = + let f b = balanceAmount b + balanceZero b + in sum . map f . HashMap.elems + compute_abook addrs xbals = + let f XPubSpec {..} XPubBal {..} = + let a = balanceAddress xPubBal + e = error "lions and tigers and bears" + s = toSoft (listToPath xPubBalPath) + in (a, Just (BinfoXPubPath xPubSpecKey (fromMaybe e s))) + amap = + HashMap.map (const Nothing) $ + HashSet.toMap addrs + xmap = + HashMap.fromList + . concatMap (uncurry (map . f)) + $ HashMap.toList xbals + in amap <> xmap + compute_xaddrs = + let f = map (balanceAddress . xPubBal) + in HashSet.fromList . concatMap f . HashMap.elems + +getBinfoCount :: (MonadUnliftIO m, MonadLoggerIO m) => TL.Text -> WebT m Int +getBinfoCount str = do + d <- lift (asks (maxLimitDefault . webMaxLimits . webConfig)) + x <- lift (asks (maxLimitFull . webMaxLimits . webConfig)) + i <- min x <$> (S.param str `S.rescue` const (return d)) + return (fromIntegral i :: Int) + +getBinfoOffset :: + (MonadUnliftIO m, MonadLoggerIO m) => + WebT m Int +getBinfoOffset = do + x <- lift (asks (maxLimitOffset . webMaxLimits . webConfig)) + o <- S.param "offset" `S.rescue` const (return 0) + when (o > x) $ + raise $ + UserError $ "offset exceeded: " <> show o <> " > " <> show x + return (fromIntegral o :: Int) + +scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyRawAddr = + setMetrics statBlockchainRawaddr + >> getBinfoAddr "addr" >>= \case + BinfoAddr addr -> do_addr addr + BinfoXpub xpub -> do_xpub xpub + where + do_xpub xpub = do + numtxid <- getNumTxId + derive <- S.param "derive" `S.rescue` const (return DeriveNormal) + let xspec = XPubSpec xpub derive + n <- getBinfoCount "limit" + off <- getBinfoOffset + xbals <- getXBals $ HashSet.singleton xspec + addItemCount . sum . map length $ HashMap.elems xbals + net <- lift $ asks (storeNetwork . webStore . webConfig) + let summary = xPubSummary xspec (xBals xspec xbals) + abook = compute_abook xpub (xBals xspec xbals) + xspecs = HashSet.singleton xspec + saddrs = HashSet.empty + baddrs = HashMap.keysSet abook + bfilter = BinfoFilterAll + amnt = + xPubSummaryConfirmed summary + + xPubSummaryZero summary + counter <- getItemCounter + txs <- + lift . runConduit $ + getBinfoTxs + counter + xbals + abook + xspecs + saddrs + baddrs + bfilter + numtxid + False + (fromIntegral amnt) + .| (dropC off >> takeC n .| sinkList) + let ra = + BinfoRawAddr + { binfoRawAddr = BinfoXpub xpub, + binfoRawBalance = amnt, + binfoRawTxCount = fromIntegral $ length txs, + binfoRawUnredeemed = xPubUnspentCount summary, + binfoRawReceived = xPubSummaryReceived summary, + binfoRawSent = + fromIntegral (xPubSummaryReceived summary) + - fromIntegral amnt, + binfoRawTxs = txs + } + setHeaders + streamEncoding $ binfoRawAddrToEncoding net ra + compute_abook xpub xbals = + let f XPubBal {..} = + let a = balanceAddress xPubBal + e = error "black hole swallows all your code" + s = toSoft (listToPath xPubBalPath) + m = fromMaybe e s + in (a, Just (BinfoXPubPath xpub m)) + in HashMap.fromList $ map f xbals + do_addr addr = do + numtxid <- getNumTxId + n <- getBinfoCount "limit" + off <- getBinfoOffset + bal <- fromMaybe (zeroBalance addr) <$> getBalance addr + addItemCount 1 + net <- lift $ asks (storeNetwork . webStore . webConfig) + let abook = HashMap.singleton addr Nothing + xspecs = HashSet.empty + saddrs = HashSet.singleton addr + bfilter = BinfoFilterAll + amnt = balanceAmount bal + balanceZero bal + counter <- getItemCounter + txs <- + lift . runConduit $ + getBinfoTxs + counter + HashMap.empty + abook + xspecs + saddrs + saddrs + bfilter + numtxid + False + (fromIntegral amnt) + .| (dropC off >> takeC n .| sinkList) + let ra = + BinfoRawAddr + { binfoRawAddr = BinfoAddr addr, + binfoRawBalance = amnt, + binfoRawTxCount = balanceTxCount bal, + binfoRawUnredeemed = balanceUnspentCount bal, + binfoRawReceived = balanceTotalReceived bal, + binfoRawSent = + fromIntegral (balanceTotalReceived bal) + - fromIntegral amnt, + binfoRawTxs = txs + } + setHeaders + streamEncoding $ binfoRawAddrToEncoding net ra + +scottyBinfoReceived :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoReceived = do + setMetrics statBlockchainQgetreceivedbyaddress + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + addItemCount 1 + S.text . cs . show $ balanceTotalReceived b + +scottyBinfoSent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoSent = do + setMetrics statBlockchainQgetsentbyaddress + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + addItemCount 1 + S.text . cs . show $ balanceTotalReceived b - balanceAmount b - balanceZero b + +scottyBinfoAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoAddrBalance = do + setMetrics statBlockchainQaddressbalance + a <- getAddress "addr" + b <- fromMaybe (zeroBalance a) <$> getBalance a + setHeaders + addItemCount 1 + S.text . cs . show $ balanceAmount b + balanceZero b + +scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyFirstSeen = do + setMetrics statBlockchainQaddressfirstseen + a <- getAddress "addr" + ch <- lift $ asks (storeChain . webStore . webConfig) + bb <- chainGetBest ch + let top = H.nodeHeight bb + bot = 0 + i <- go ch bb a bot top + setHeaders + addItemCount 1 + S.text . cs $ show i + where + go ch bb a bot top = do + let mid = bot + (top - bot) `div` 2 + n = top - bot < 2 + x <- hasone a bot + y <- hasone a mid + z <- hasone a top + if + | x -> getblocktime ch bb bot + | n -> getblocktime ch bb top + | y -> go ch bb a bot mid + | z -> go ch bb a mid top + | otherwise -> return 0 + getblocktime ch bb h = + H.blockTimestamp . H.nodeHeader . fromJust + <$> chainGetAncestor h bb ch + hasone a h = do + let l = Limits 1 0 (Just (AtBlock h)) + not . null <$> getAddressTxs a l + +scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyShortBal = do + setMetrics statBlockchainBalance + (xspecs, addrs) <- getBinfoActive + cashaddr <- getCashAddr + net <- lift $ asks (storeNetwork . webStore . webConfig) + abals <- + catMaybes + <$> mapM (get_addr_balance net cashaddr) (HashSet.toList addrs) + addItemCount (length abals) + xbals <- mapM (get_xspec_balance net) (HashSet.toList xspecs) + let res = HashMap.fromList (abals <> xbals) + setHeaders + streamEncoding $ toEncoding res + where + to_short_bal Balance {..} = + BinfoShortBal + { binfoShortBalFinal = balanceAmount + balanceZero, + binfoShortBalTxCount = balanceTxCount, + binfoShortBalReceived = balanceTotalReceived + } + get_addr_balance net cashaddr a = + let net' = + if + | cashaddr -> net + | net == bch -> btc + | net == bchTest -> btcTest + | net == bchTest4 -> btcTest + | otherwise -> net + in case addrToText net' a of + Nothing -> return Nothing + Just a' -> + getBalance a >>= \case + Nothing -> return $ Just (a', to_short_bal (zeroBalance a)) + Just b -> return $ Just (a', to_short_bal b) + is_ext XPubBal {xPubBalPath = 0 : _} = True + is_ext _ = False + get_xspec_balance net xpub = do + xbals <- xPubBals xpub + xts <- xPubTxCount xpub xbals + addItemCount (length xbals + 1) + let val = sum $ map (balanceAmount . xPubBal) xbals + zro = sum $ map (balanceZero . xPubBal) xbals + exs = filter is_ext xbals + rcv = sum $ map (balanceTotalReceived . xPubBal) exs + sbl = + BinfoShortBal + { binfoShortBalFinal = val + zro, + binfoShortBalTxCount = fromIntegral xts, + binfoShortBalReceived = rcv + } + return (xPubExport net (xPubSpecKey xpub), sbl) + +getBinfoHex :: Monad m => WebT m Bool +getBinfoHex = + (== ("hex" :: Text)) + <$> S.param "format" `S.rescue` const (return "json") + +scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlockHeight = do + numtxid <- getNumTxId + height <- S.param "height" + setMetrics statBlockchainBlockHeight + block_hashes <- getBlocksAtHeight height + block_headers <- catMaybes <$> mapM getBlock block_hashes + addItemCount (length block_headers) + next_block_hashes <- getBlocksAtHeight (height + 1) + next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes + addItemCount (length next_block_headers) + binfo_blocks <- + mapM (get_binfo_blocks numtxid next_block_headers) block_headers + setHeaders + net <- lift $ asks (storeNetwork . webStore . webConfig) + streamEncoding $ binfoBlocksToEncoding net binfo_blocks + where + get_tx th = + withRunInIO $ \run -> + unsafeInterleaveIO $ + run $ fromJust <$> getTransaction th + get_binfo_blocks numtxid next_block_headers block_header = do + let my_hash = H.headerHash (blockDataHeader block_header) + get_prev = H.prevBlock . blockDataHeader + get_hash = H.headerHash . blockDataHeader + txs <- lift $ mapM get_tx (blockDataTxs block_header) + addItemCount (length txs) + let next_blocks = + map get_hash $ + filter + ((== my_hash) . get_prev) + next_block_headers + binfo_txs = map (toBinfoTxSimple numtxid) txs + binfo_block = toBinfoBlock block_header binfo_txs next_blocks + return binfo_block + +scottyBinfoLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoLatest = do + numtxid <- getNumTxId + setMetrics statBlockchainLatestblock + best <- get_best_block + let binfoTxIndices = map (encodeBinfoTxId numtxid) (blockDataTxs best) + binfoHeaderHash = H.headerHash (blockDataHeader best) + binfoHeaderTime = H.blockTimestamp (blockDataHeader best) + binfoHeaderIndex = binfoHeaderTime + binfoHeaderHeight = blockDataHeight best + addItemCount 1 + streamEncoding $ toEncoding BinfoHeader {..} + where + get_best_block = + getBestBlock >>= \case + Nothing -> raise ThingNotFound + Just bh -> + getBlock bh >>= \case + Nothing -> raise ThingNotFound + Just b -> return b + +scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlock = do + numtxid <- getNumTxId + hex <- getBinfoHex + setMetrics statBlockchainRawblock + S.param "block" >>= \case + BinfoBlockHash bh -> go numtxid hex bh + BinfoBlockIndex i -> + getBlocksAtHeight i >>= \case + [] -> raise ThingNotFound + bh : _ -> go numtxid hex bh + where + get_tx th = + withRunInIO $ \run -> + unsafeInterleaveIO $ + run $ fromJust <$> getTransaction th + go numtxid hex bh = + getBlock bh >>= \case + Nothing -> raise ThingNotFound + Just b -> do + addItemCount 1 + txs <- lift $ mapM get_tx (blockDataTxs b) + addItemCount (length txs) + let my_hash = H.headerHash (blockDataHeader b) + get_prev = H.prevBlock . blockDataHeader + get_hash = H.headerHash . blockDataHeader + nxt_headers <- + fmap catMaybes $ + mapM getBlock + =<< getBlocksAtHeight (blockDataHeight b + 1) + addItemCount (length nxt_headers) + let nxt = + map get_hash $ + filter + ((== my_hash) . get_prev) + nxt_headers + if hex + then do + let x = H.Block (blockDataHeader b) (map transactionData txs) + setHeaders + S.text . encodeHexLazy . runPutL $ serialize x + else do + let btxs = map (toBinfoTxSimple numtxid) txs + y = toBinfoBlock b btxs nxt + setHeaders + net <- lift $ asks (storeNetwork . webStore . webConfig) + streamEncoding $ binfoBlockToEncoding net y + +getBinfoTx :: + (MonadLoggerIO m, MonadUnliftIO m) => + BinfoTxId -> + WebT m (Either Except Transaction) +getBinfoTx txid = do + tx <- case txid of + BinfoTxIdHash h -> maybeToList <$> getTransaction h + BinfoTxIdIndex i -> getNumTransaction i + case tx of + [t] -> return $ Right t + [] -> return $ Left ThingNotFound + ts -> + let tids = map (txHash . transactionData) ts + in return $ Left (TxIndexConflict tids) + +scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTx = do + numtxid <- getNumTxId + hex <- getBinfoHex + txid <- S.param "txid" + setMetrics statBlockchainRawtx + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + addItemCount 1 + if hex then hx tx else js numtxid tx + where + js numtxid t = do + net <- lift $ asks (storeNetwork . webStore . webConfig) + setHeaders + streamEncoding $ binfoTxToEncoding net $ toBinfoTxSimple numtxid t + hx t = do + setHeaders + S.text . encodeHexLazy . runPutL . serialize $ transactionData t + +scottyBinfoTotalOut :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTotalOut = do + txid <- S.param "txid" + setMetrics statBlockchainQtxtotalbtcoutput + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + addItemCount 1 + S.text . cs . show . sum . map outputAmount $ transactionOutputs tx + +scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTxFees = do + txid <- S.param "txid" + setMetrics statBlockchainQtxfee + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + let i = + sum . map inputAmount . filter f $ + transactionInputs tx + o = sum . map outputAmount $ transactionOutputs tx + addItemCount 1 + S.text . cs . show $ i - o + where + f StoreInput {} = True + f StoreCoinbase {} = False + +scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTxResult = do + txid <- S.param "txid" + addr <- getAddress "addr" + setMetrics statBlockchainQtxresult + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + let i = + toInteger . sum . map inputAmount . filter (f addr) $ + transactionInputs tx + o = + toInteger . sum . map outputAmount . filter (g addr) $ + transactionOutputs tx + addItemCount 1 + S.text . cs . show $ o - i + where + f addr StoreInput {inputAddress = Just a} = a == addr + f _ _ = False + g addr StoreOutput {outputAddr = Just a} = a == addr + g _ _ = False + +scottyBinfoTotalInput :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoTotalInput = do + txid <- S.param "txid" + setMetrics statBlockchainQtxtotalbtcinput + tx <- + getBinfoTx txid >>= \case + Right t -> return t + Left e -> raise e + addItemCount 1 + S.text . cs . show . sum . map inputAmount . filter f $ transactionInputs tx + where + f StoreInput {} = True + f StoreCoinbase {} = False + +scottyBinfoMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoMempool = do + setMetrics statBlockchainMempool + numtxid <- getNumTxId + offset <- getBinfoOffset + n <- getBinfoCount "limit" + mempool <- getMempool + let txids = map snd $ take n $ drop offset mempool + txs <- catMaybes <$> mapM getTransaction txids + net <- lift $ asks (storeNetwork . webStore . webConfig) + setHeaders + let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs + addItemCount (length txs) + streamEncoding $ binfoMempoolToEncoding net mem + +scottyBinfoGetBlockCount :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoGetBlockCount = do + setMetrics statBlockchainQgetblockcount + ch <- asks (storeChain . webStore . webConfig) + bn <- chainGetBest ch + setHeaders + addItemCount 1 + S.text . cs . show $ H.nodeHeight bn + +scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoLatestHash = do + setMetrics statBlockchainQlatesthash + ch <- asks (storeChain . webStore . webConfig) + bn <- chainGetBest ch + setHeaders + addItemCount 1 + S.text . TL.fromStrict . H.blockHashToHex . H.headerHash $ H.nodeHeader bn + +scottyBinfoSubsidy :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoSubsidy = do + setMetrics statBlockchainQbcperblock + ch <- asks (storeChain . webStore . webConfig) + net <- asks (storeNetwork . webStore . webConfig) + bn <- chainGetBest ch + setHeaders + addItemCount 1 + S.text . cs . show . (/ (100 * 1000 * 1000 :: Double)) . fromIntegral $ + H.computeSubsidy net (H.nodeHeight bn + 1) + +scottyBinfoAddrToHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoAddrToHash = do + setMetrics statBlockchainQaddresstohash + addr <- getAddress "addr" + setHeaders + addItemCount 1 + S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr + +scottyBinfoHashToAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoHashToAddr = do + setMetrics statBlockchainQhashtoaddress + bs <- maybe S.next return . decodeHex =<< S.param "hash" + net <- asks (storeNetwork . webStore . webConfig) + hash <- either (const S.next) return (decode bs) + addr <- maybe S.next return (addrToText net (PubKeyAddress hash)) + setHeaders + addItemCount 1 + S.text $ TL.fromStrict addr + +scottyBinfoAddrPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoAddrPubkey = do + setMetrics statBlockchainQaddrpubkey + hex <- S.param "pubkey" + pubkey <- + maybe S.next (return . pubKeyAddr) $ + eitherToMaybe . runGetS deserialize =<< decodeHex hex + net <- lift $ asks (storeNetwork . webStore . webConfig) + setHeaders + case addrToText net pubkey of + Nothing -> raise ThingNotFound + Just a -> do + addItemCount 1 + S.text $ TL.fromStrict a + +scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoPubKeyAddr = do + setMetrics statBlockchainQpubkeyaddr + addr <- getAddress "addr" + mi <- strm addr + i <- case mi of + Nothing -> raise ThingNotFound + Just i -> return i + pk <- case extr addr i of + Left e -> raise $ UserError e + Right t -> return t + setHeaders + S.text $ encodeHexLazy $ L.fromStrict pk + where + strm addr = do + counter <- getItemCounter + runConduit $ + streamThings + ( \l -> do + ts <- getAddressTxs addr l + counter (length ts) + return ts + ) + (Just txRefHash) + def {limit = 8} + .| concatMapMC (getTransaction . txRefHash) + .| iterMC (\_ -> counter 1) + .| concatMapC (filter (inp addr) . transactionInputs) + .| headC + inp addr StoreInput {inputAddress = Just a} = a == addr + inp _ _ = False + extr addr StoreInput {inputSigScript, inputPkScript, inputWitness} = do + Script sig <- decode inputSigScript + Script pks <- decode inputPkScript + case addr of + PubKeyAddress {} -> + case sig of + [OP_PUSHDATA _ _, OP_PUSHDATA pub _] -> + Right pub + [OP_PUSHDATA _ _] -> + case pks of + [OP_PUSHDATA pub _, OP_CHECKSIG] -> + Right pub + _ -> Left "Could not parse scriptPubKey" + _ -> Left "Could not parse scriptSig" + WitnessPubKeyAddress {} -> + case inputWitness of + [_, pub] -> return pub + _ -> Left "Could not parse scriptPubKey" + _ -> Left "Address does not have public key" + extr _ _ = Left "Incorrect input type" + +scottyBinfoHashPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoHashPubkey = do + setMetrics statBlockchainQhashpubkey + pkm <- (eitherToMaybe . runGetS deserialize <=< decodeHex) <$> S.param "pubkey" + addr <- case pkm of + Nothing -> raise $ UserError "Could not decode public key" + Just pk -> return $ pubKeyAddr pk + setHeaders + addItemCount 1 + S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr + +-- GET Network Information -- + +scottyPeers :: + (MonadUnliftIO m, MonadLoggerIO m) => + GetPeers -> + WebT m [PeerInformation] +scottyPeers _ = do + setMetrics statPeers + ps <- + lift $ + getPeersInformation + =<< asks (storeManager . webStore . webConfig) + addItemCount (length ps) + return ps + +-- | Obtain information about connected peers from peer manager process. +getPeersInformation :: + MonadLoggerIO m => PeerManager -> m [PeerInformation] +getPeersInformation mgr = + mapMaybe toInfo <$> getPeers mgr + where + toInfo op = do + ver <- onlinePeerVersion op + let as = onlinePeerAddress op + ua = getVarString $ userAgent ver + vs = version ver + sv = services ver + rl = relay ver + return + PeerInformation + { peerUserAgent = ua, + peerAddress = show as, + peerVersion = vs, + peerServices = sv, + peerRelay = rl + } + +scottyHealth :: + (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck +scottyHealth _ = do + setMetrics statHealth + h <- lift $ asks webConfig >>= healthCheck + unless (isOK h) $ S.status status503 + addItemCount 1 + return h + +blockHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m BlockHealth +blockHealthCheck cfg = do + let ch = storeChain $ webStore cfg + blockHealthMaxDiff = fromIntegral $ webMaxDiff cfg + blockHealthHeaders <- + H.nodeHeight <$> chainGetBest ch + blockHealthBlocks <- + maybe 0 blockDataHeight + <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock) + return BlockHealth {..} + +lastBlockHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + Chain -> + WebTimeouts -> + m TimeHealth +lastBlockHealthCheck ch tos = do + n <- fromIntegral . systemSeconds <$> liftIO getSystemTime + t <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch + let timeHealthAge = n - t + timeHealthMax = fromIntegral $ blockTimeout tos + return TimeHealth {..} + +lastTxHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m TimeHealth +lastTxHealthCheck WebConfig {..} = do + n <- fromIntegral . systemSeconds <$> liftIO getSystemTime + b <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch + t <- + getMempool >>= \case + t : _ -> + let x = fromIntegral $ fst t + in return $ max x b + [] -> return b + let timeHealthAge = n - t + timeHealthMax = fromIntegral to + return TimeHealth {..} + where + ch = storeChain webStore + to = + if webNoMempool + then blockTimeout webTimeouts + else txTimeout webTimeouts + +pendingTxsHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m MaxHealth +pendingTxsHealthCheck cfg = do + let maxHealthMax = fromIntegral $ webMaxPending cfg + maxHealthNum <- + fromIntegral + <$> blockStorePendingTxs (storeBlock (webStore cfg)) + return MaxHealth {..} + +peerHealthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + PeerManager -> + m CountHealth +peerHealthCheck mgr = do + let countHealthMin = 1 + countHealthNum <- fromIntegral . length <$> getPeers mgr + return CountHealth {..} + +healthCheck :: + (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => + WebConfig -> + m HealthCheck +healthCheck cfg@WebConfig {..} = do + healthBlocks <- blockHealthCheck cfg + healthLastBlock <- lastBlockHealthCheck (storeChain webStore) webTimeouts + healthLastTx <- lastTxHealthCheck cfg + healthPendingTxs <- pendingTxsHealthCheck cfg + healthPeers <- peerHealthCheck (storeManager webStore) + let healthNetwork = getNetworkName (storeNetwork webStore) + healthVersion = webVersion + hc = HealthCheck {..} + unless (isOK hc) $ do + let t = toStrict $ encodeToLazyText hc + $(logErrorS) "Web" $ "Health check failed: " <> t + return hc + +scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyDbStats = do + setMetrics statDbstats + setHeaders + db <- lift $ asks (databaseHandle . storeDB . webStore . webConfig) + statsM <- lift (getProperty db Stats) + addItemCount 1 + S.text $ maybe "Could not get stats" cs statsM + +----------------------- +-- Parameter Parsing -- +----------------------- + +-- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on +-- parse failure. +paramOptional :: (Param a, MonadIO m) => WebT m (Maybe a) +paramOptional = go Proxy + where + go :: (Param a, MonadIO m) => Proxy a -> WebT m (Maybe a) + go proxy = do + net <- lift $ asks (storeNetwork . webStore . webConfig) + tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing) + case tsM of + Nothing -> return Nothing -- Parameter was not supplied + Just ts -> maybe (raise err) (return . Just) $ parseParam net ts + where + l = proxyLabel proxy + p = Just <$> S.param (cs l) + err = UserError $ "Unable to parse param " <> cs l + +-- | Raises an exception if the parameter is not supplied +param :: (Param a, MonadIO m) => WebT m a +param = go Proxy + where + go :: (Param a, MonadIO m) => Proxy a -> WebT m a + go proxy = do + resM <- paramOptional + case resM of + Just res -> return res + _ -> + raise . UserError $ + "The param " <> cs (proxyLabel proxy) <> " was not defined" + +-- | Returns the default value of a parameter if it is not supplied. Raises an +-- exception on parse failure. +paramDef :: (Default a, Param a, MonadIO m) => WebT m a +paramDef = fromMaybe def <$> paramOptional + +-- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is +-- not supplied or if parsing fails. +paramLazy :: (Param a, MonadIO m) => WebT m a +paramLazy = do + resM <- paramOptional `S.rescue` const (return Nothing) + maybe S.next return resM + +parseBody :: (MonadIO m, Serial a) => WebT m a +parseBody = do + b <- L.toStrict <$> S.body + case hex b <> bin b of + Left _ -> raise $ UserError "Failed to parse request body" + Right x -> return x + where + bin = runGetS deserialize + hex b = case B16.decodeBase16 $ C.filter (not . isSpace) b of + Right x -> bin x + Left s -> Left (T.unpack s) + +parseOffset :: MonadIO m => WebT m OffsetParam +parseOffset = do + res@(OffsetParam o) <- paramDef + limits <- lift $ asks (webMaxLimits . webConfig) + when (maxLimitOffset limits > 0 && fromIntegral o > maxLimitOffset limits) $ + raise . UserError $ + "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits) + return res + +parseStart :: + (MonadUnliftIO m, MonadLoggerIO m) => + Maybe StartParam -> + WebT m (Maybe Start) +parseStart Nothing = return Nothing +parseStart (Just s) = + runMaybeT $ + case s of + StartParamHash {startParamHash = h} -> start_tx h <|> start_block h + StartParamHeight {startParamHeight = h} -> start_height h + StartParamTime {startParamTime = q} -> start_time q + where + start_height h = return $ AtBlock $ fromIntegral h + start_block h = do + b <- MaybeT $ getBlock (H.BlockHash h) + return $ AtBlock (blockDataHeight b) + start_tx h = do + _ <- MaybeT $ getTxData (TxHash h) + return $ AtTx (TxHash h) + start_time q = do + ch <- lift $ asks (storeChain . webStore . webConfig) + b <- MaybeT $ blockAtOrBefore ch q + let g = blockDataHeight b + return $ AtBlock g + +parseLimits :: MonadIO m => WebT m LimitsParam +parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional + +paramToLimits :: + (MonadUnliftIO m, MonadLoggerIO m) => + Bool -> + LimitsParam -> + WebT m Limits +paramToLimits full (LimitsParam limitM o startM) = do + wl <- lift $ asks (webMaxLimits . webConfig) + Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM + +validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32 +validateLimit wl full limitM = + f m $ maybe d (fromIntegral . getLimitParam) limitM + where + m + | full && maxLimitFull wl > 0 = maxLimitFull wl + | otherwise = maxLimitCount wl + d = maxLimitDefault wl + f a 0 = a + f 0 b = b + f a b = min a b + +--------------- +-- Utilities -- +--------------- + +runInWebReader :: + MonadIO m => + CacheT (DatabaseReaderT m) a -> + ReaderT WebState m a +runInWebReader f = do + bdb <- asks (storeDB . webStore . webConfig) + mc <- asks (storeCache . webStore . webConfig) + lift $ runReaderT (withCache mc f) bdb + +runNoCache :: MonadIO m => Bool -> ReaderT WebState m a -> ReaderT WebState m a +runNoCache False f = f +runNoCache True f = local g f + where + g s = s {webConfig = h (webConfig s)} + h c = c {webStore = i (webStore c)} + i s = s {storeCache = Nothing} + +logIt :: + (MonadUnliftIO m, MonadLoggerIO m) => + Maybe WebMetrics -> + m Middleware +logIt metrics = do + runner <- askRunInIO + return $ \app req respond -> do + var <- newTVarIO B.empty + req' <- + let rb = req_body var (getRequestBodyChunk req) + rq = req {requestBody = rb} + in case metrics of + Nothing -> return rq + Just m -> do + stat_var <- newTVarIO Nothing + let vt = + V.insert (statKey m) stat_var $ + vault rq + return rq {vault = vt} + bracket start (end var runner req') $ \_ -> + app req' $ \res -> do + b <- readTVarIO var + let s = responseStatus res + msg = fmtReq b req' <> ": " <> fmtStatus s + if statusIsSuccessful s + then runner $ $(logDebugS) "Web" msg + else runner $ $(logErrorS) "Web" msg + respond res + where + start = systemToUTCTime <$> getSystemTime + req_body var old_body = do + b <- old_body + unless (B.null b) . atomically $ modifyTVar var (<> b) + return b + add_stat d s = do + addStatQuery s + addStatTime s d + end var runner req t1 = do + t2 <- systemToUTCTime <$> getSystemTime + let diff = round $ diffUTCTime t2 t1 * 1000 + case metrics of + Nothing -> return () + Just m -> do + let m_stat_var = V.lookup (statKey m) (vault req) + add_stat diff (statAll m) + case m_stat_var of + Nothing -> return () + Just stat_var -> + readTVarIO stat_var >>= \case + Nothing -> return () + Just f -> add_stat diff (f m) + when (diff > 10000) $ do + b <- readTVarIO var + runner $ + $(logWarnS) "Web" $ + "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req + +reqSizeLimit :: Integral i => i -> Middleware +reqSizeLimit i = requestSizeLimitMiddleware lim + where + max_len _req = return (Just (fromIntegral i)) + lim = + setOnLengthExceeded too_big $ + setMaxLengthForRequest + max_len + defaultRequestSizeLimitSettings + too_big _ = \_app _req send -> + send $ + waiExcept requestEntityTooLarge413 RequestTooLarge + +fmtReq :: ByteString -> Request -> Text +fmtReq bs req = + let m = requestMethod req + v = httpVersion req + p = rawPathInfo req + q = rawQueryString req + txt = case T.decodeUtf8' bs of + Left _ -> " {invalid utf8}" + Right "" -> "" + Right t -> " [" <> t <> "]" + in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt fmtStatus :: Status -> Text fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s) 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 @@ -9,16 +9,16 @@ spec :: Spec spec = do - describe "Score for block reference" $ do - prop "sorts correctly" $ - forAll arbitraryBlockRefs $ \ts -> - let scores = map blockRefScore (sort ts) - in sort scores == reverse scores - prop "respects identity" $ - forAll arbitraryBlockRef $ \b -> - let score = blockRefScore b - ref = scoreBlockRef score - in ref == b + describe "Score for block reference" $ do + prop "sorts correctly" $ + forAll arbitraryBlockRefs $ \ts -> + let scores = map blockRefScore (sort ts) + in sort scores == reverse scores + prop "respects identity" $ + forAll arbitraryBlockRef $ \b -> + let score = blockRefScore b + ref = scoreBlockRef score + in ref == b arbitraryBlockRefs :: Gen [BlockRef] arbitraryBlockRefs = listOf arbitraryBlockRef @@ -27,9 +27,9 @@ arbitraryBlockRef = oneof [b, m] where b = do - h <- choose (0, 0x07ffffff) - p <- choose (0, 0x03ffffff) - return BlockRef{blockRefHeight = h, blockRefPos = p} + h <- choose (0, 0x07ffffff) + p <- choose (0, 0x03ffffff) + return BlockRef {blockRefHeight = h, blockRefPos = p} m = do - t <- choose (0, 0x001fffffffffffff) - return MemRef{memRefTime = t} + t <- choose (0, 0x001fffffffffffff) + return MemRef {memRefTime = t} diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -30,186 +30,186 @@ import UnliftIO data TestStore = TestStore - { testStoreDB :: !DatabaseReader - , testStoreBlockStore :: !BlockStore - , testStoreChain :: !Chain - , testStoreEvents :: !(Inbox StoreEvent) - } + { testStoreDB :: !DatabaseReader, + testStoreBlockStore :: !BlockStore, + testStoreChain :: !Chain, + testStoreEvents :: !(Inbox StoreEvent) + } spec :: Spec spec = do - describe "Download" $ do - it "gets 8 blocks" $ - withTestStore bchRegTest "eight-blocks" $ \TestStore{..} -> do - bs <- replicateM 8 . receiveMatch testStoreEvents $ \case - StoreBestBlock b -> Just b - _ -> Nothing - let bestHash = last bs - bestNodeM <- chainGetBlock bestHash testStoreChain - bestNodeM `shouldSatisfy` isJust - let bestNode = fromJust bestNodeM - bestHeight = nodeHeight bestNode - bestHeight `shouldBe` 8 - it "get a block and its transactions" $ - withTestStore bchRegTest "get-block-txs" $ \TestStore{..} -> - flip runReaderT testStoreDB $ do - let h1 = "5369ef2386c72acdf513ffd80aeba2a1774e2f004d120761e54a8bf614173f3e" - get_the_block h = - receive testStoreEvents >>= \case - StoreBestBlock b - | h <= 1 -> return b - | otherwise -> - get_the_block ((h :: Int) - 1) - _ -> get_the_block h - bh <- get_the_block 15 - m <- getBlock bh - let bd = fromMaybe (error "Could not get block") m - t1 <- getTransaction h1 - lift $ do - blockDataHeight bd `shouldBe` 15 - length (blockDataTxs bd) `shouldBe` 1 - head (blockDataTxs bd) `shouldBe` h1 - t1 `shouldSatisfy` isJust - txHash (transactionData (fromJust t1)) `shouldBe` h1 + describe "Download" $ do + it "gets 8 blocks" $ + withTestStore bchRegTest "eight-blocks" $ \TestStore {..} -> do + bs <- replicateM 8 . receiveMatch testStoreEvents $ \case + StoreBestBlock b -> Just b + _ -> Nothing + let bestHash = last bs + bestNodeM <- chainGetBlock bestHash testStoreChain + bestNodeM `shouldSatisfy` isJust + let bestNode = fromJust bestNodeM + bestHeight = nodeHeight bestNode + bestHeight `shouldBe` 8 + it "get a block and its transactions" $ + withTestStore bchRegTest "get-block-txs" $ \TestStore {..} -> + flip runReaderT testStoreDB $ do + let h1 = "5369ef2386c72acdf513ffd80aeba2a1774e2f004d120761e54a8bf614173f3e" + get_the_block h = + receive testStoreEvents >>= \case + StoreBestBlock b + | h <= 1 -> return b + | otherwise -> + get_the_block ((h :: Int) - 1) + _ -> get_the_block h + bh <- get_the_block 15 + m <- getBlock bh + let bd = fromMaybe (error "Could not get block") m + t1 <- getTransaction h1 + lift $ do + blockDataHeight bd `shouldBe` 15 + length (blockDataTxs bd) `shouldBe` 1 + head (blockDataTxs bd) `shouldBe` h1 + t1 `shouldSatisfy` isJust + txHash (transactionData (fromJust t1)) `shouldBe` h1 withTestStore :: - MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a + MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a withTestStore net t f = - withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> - runNoLoggingT $ do - let ad = - NetworkAddress - nodeNetwork - (sockToHostAddress (SockAddrInet 0 0)) - cfg = - StoreConfig - { storeConfMaxPeers = 20 - , storeConfInitPeers = [] - , storeConfDiscover = True - , storeConfDB = w - , storeConfNetwork = net - , storeConfCache = Nothing - , storeConfGap = gap - , storeConfInitialGap = 20 - , storeConfCacheMin = 100 - , storeConfMaxKeys = 100 * 1000 * 1000 - , storeConfNoMempool = False - , storeConfWipeMempool = False - , storeConfSyncMempool = False - , storeConfPeerTimeout = 60 - , storeConfPeerMaxLife = 48 * 3600 - , storeConfConnect = dummyPeerConnect net ad - , storeConfCacheRetryDelay = 100000 - , storeConfStats = Nothing - } - withStore cfg $ \Store{..} -> - withSubscription storePublisher $ \sub -> - lift $ - f - TestStore - { testStoreDB = storeDB - , testStoreBlockStore = storeBlock - , testStoreChain = storeChain - , testStoreEvents = sub - } + withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> + runNoLoggingT $ do + let ad = + NetworkAddress + nodeNetwork + (sockToHostAddress (SockAddrInet 0 0)) + cfg = + StoreConfig + { storeConfMaxPeers = 20, + storeConfInitPeers = [], + storeConfDiscover = True, + storeConfDB = w, + storeConfNetwork = net, + storeConfCache = Nothing, + storeConfGap = gap, + storeConfInitialGap = 20, + storeConfCacheMin = 100, + storeConfMaxKeys = 100 * 1000 * 1000, + storeConfNoMempool = False, + storeConfWipeMempool = False, + storeConfSyncMempool = False, + storeConfPeerTimeout = 60, + storeConfPeerMaxLife = 48 * 3600, + storeConfConnect = dummyPeerConnect net ad, + storeConfCacheRetryDelay = 100000, + storeConfStats = Nothing + } + withStore cfg $ \Store {..} -> + withSubscription storePublisher $ \sub -> + lift $ + f + TestStore + { testStoreDB = storeDB, + testStoreBlockStore = storeBlock, + testStoreChain = storeChain, + testStoreEvents = sub + } gap :: Word32 gap = 32 allBlocks :: [Block] allBlocks = - fromRight (error "Could not decode blocks") $ - runGet f (decodeBase64Lenient allBlocksBase64) + fromRight (error "Could not decode blocks") $ + runGet f (decodeBase64Lenient allBlocksBase64) where f = mapM (const get) [(1 :: Int) .. 15] allBlocksBase64 :: ByteString allBlocksBase64 = - "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\ - \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\ - \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\ - \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\ - \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\ - \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\ - \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\ - \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\ - \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\ - \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\ - \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\ - \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\ - \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\ - \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\ - \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\ - \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\ - \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\ - \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\ - \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\ - \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\ - \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\ - \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\ - \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\ - \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\ - \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\ - \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\ - \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\ - \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\ - \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\ - \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\ - \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\ - \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\ - \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\ - \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\ - \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\ - \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\ - \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\ - \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\ - \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\ - \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\ - \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA" + "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\ + \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\ + \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\ + \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\ + \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\ + \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\ + \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\ + \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\ + \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\ + \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\ + \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\ + \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\ + \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\ + \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\ + \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\ + \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\ + \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\ + \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\ + \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\ + \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\ + \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\ + \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\ + \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\ + \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\ + \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\ + \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\ + \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\ + \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\ + \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\ + \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\ + \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\ + \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\ + \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\ + \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\ + \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\ + \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\ + \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\ + \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\ + \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\ + \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\ + \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA" dummyPeerConnect :: Network -> NetworkAddress -> SockAddr -> WithConnection dummyPeerConnect net ad sa f = do - r <- newInbox - s <- newInbox - let s' = inboxToMailbox s - withAsync (go r s') $ \_ -> do - let o = awaitForever (`send` r) - i = forever (receive s >>= yield) - f (Conduits i o) :: IO () + r <- newInbox + s <- newInbox + let s' = inboxToMailbox s + withAsync (go r s') $ \_ -> do + let o = awaitForever (`send` r) + i = forever (receive s >>= yield) + f (Conduits i o) :: IO () where go :: Inbox ByteString -> Mailbox ByteString -> IO () go r s = do - nonce <- randomIO - now <- round <$> liftIO getPOSIXTime - let rmt = NetworkAddress 0 (sockToHostAddress sa) - ver = buildVersion net nonce 0 ad rmt now - runPut (putMessage net (MVersion ver)) `send` s - runConduit $ - forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact - .| outc - .| awaitForever (`send` s) + nonce <- randomIO + now <- round <$> liftIO getPOSIXTime + let rmt = NetworkAddress 0 (sockToHostAddress sa) + ver = buildVersion net nonce 0 ad rmt now + runPut (putMessage net (MVersion ver)) `send` s + runConduit $ + forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact + .| outc + .| awaitForever (`send` s) outc = mapMC $ \msg' -> return $ runPut (putMessage net msg') inc = forever $ do - x <- takeCE 24 .| foldC - case decode x of - Left _ -> - error "Dummy peer not decode message header" - Right (MessageHeader _ _ len _) -> do - y <- takeCE (fromIntegral len) .| foldC - case runGet (getMessage net) $ x `B.append` y of - Right msg' -> yield msg' - Left e -> - error $ - "Dummy peer could not decode payload: " <> show e + x <- takeCE 24 .| foldC + case decode x of + Left _ -> + error "Dummy peer not decode message header" + Right (MessageHeader _ _ len _) -> do + y <- takeCE (fromIntegral len) .| foldC + case runGet (getMessage net) $ x `B.append` y of + Right msg' -> yield msg' + Left e -> + error $ + "Dummy peer could not decode payload: " <> show e mockPeerReact :: Message -> [Message] mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]