haskoin-store 0.20.0 → 0.20.1
raw patch · 15 files changed
+2396/−2598 lines, 15 filesdep ~haskoin-node
Dependency ranges changed: haskoin-node
Files
- CHANGELOG.md +16/−7
- app/Main.hs +3/−3
- haskoin-store.cabal +8/−8
- src/Haskoin/Store.hs +10/−15
- src/Network/Haskoin/Store/Block.hs +215/−256
- src/Network/Haskoin/Store/Common.hs +1526/−0
- src/Network/Haskoin/Store/Data/ImportDB.hs +35/−25
- src/Network/Haskoin/Store/Data/KeyValue.hs +17/−18
- src/Network/Haskoin/Store/Data/Memory.hs +35/−49
- src/Network/Haskoin/Store/Data/RocksDB.hs +45/−57
- src/Network/Haskoin/Store/Data/Types.hs +0/−1341
- src/Network/Haskoin/Store/Logic.hs +219/−287
- src/Network/Haskoin/Store/Web.hs +205/−485
- test/Network/Haskoin/Store/CommonSpec.hs +62/−0
- test/Network/Haskoin/Store/Data/TypesSpec.hs +0/−47
CHANGELOG.md view
@@ -4,17 +4,26 @@ 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.20.1+### Changed+- Refactor code greatly.+- Depend on new Haskoin Store package to avoid missing tx broadcasts.+- Merge StoreStream class into StoreRead.+- Move former streaming functions to use lists instead of conduits.+- Remove excessively verbose debugging.+ ## 0.20.0 ### Added-- Low version bounds for some dependencies.-- Compatibility with GHC 8.8.-- Faster retrieval of extended public key balances and transactions.--### Removed-- In-memory RocksDB-based cache.+- Set minimum version bounds for some dependencies.+- Now compatible with GHC 8.8.+- Extended key caching system using Redis. ### Changed-- Refactor codebase.+- Massively refactored codebase.+- Less verbose debug logging.++### Removed+- Removed conduits for faster queries. ## 0.19.6 ### Added
app/Main.hs view
@@ -60,10 +60,10 @@ defMaxLimits :: MaxLimits defMaxLimits = MaxLimits- { maxLimitCount = 10000- , maxLimitFull = 500+ { maxLimitCount = 20000+ , maxLimitFull = 5000 , maxLimitOffset = 50000- , maxLimitDefault = 100+ , maxLimitDefault = 2000 } defTimeouts :: Timeouts
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 186caec51745ecbf3bd414752a0c036b2ba3827eb0639af8f70fa09fac6bd10f+-- hash: b3d80fe4a3c3b83bcc166865f4e64defe65034ed9969a2f79de8605982483af5 name: haskoin-store-version: 0.20.0+version: 0.20.1 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network@@ -32,11 +32,11 @@ Paths_haskoin_store other-modules: Network.Haskoin.Store.Block+ Network.Haskoin.Store.Common Network.Haskoin.Store.Data.ImportDB Network.Haskoin.Store.Data.KeyValue Network.Haskoin.Store.Data.Memory Network.Haskoin.Store.Data.RocksDB- Network.Haskoin.Store.Data.Types Network.Haskoin.Store.Logic Network.Haskoin.Store.Web autogen-modules:@@ -55,7 +55,7 @@ , deepseq , hashable , haskoin-core >=0.10.1- , haskoin-node >=0.9.16+ , haskoin-node >=0.9.21 , http-types , monad-logger , mtl@@ -96,7 +96,7 @@ , filepath , hashable , haskoin-core >=0.10.1- , haskoin-node >=0.9.16+ , haskoin-node >=0.9.21 , haskoin-store , http-types , monad-logger@@ -124,14 +124,14 @@ main-is: Spec.hs other-modules: Haskoin.StoreSpec- Network.Haskoin.Store.Data.TypesSpec+ Network.Haskoin.Store.CommonSpec Haskoin.Store Network.Haskoin.Store.Block+ Network.Haskoin.Store.Common Network.Haskoin.Store.Data.ImportDB Network.Haskoin.Store.Data.KeyValue Network.Haskoin.Store.Data.Memory Network.Haskoin.Store.Data.RocksDB- Network.Haskoin.Store.Data.Types Network.Haskoin.Store.Logic Network.Haskoin.Store.Web Paths_haskoin_store@@ -151,7 +151,7 @@ , deepseq , hashable , haskoin-core >=0.10.1- , haskoin-node >=0.9.16+ , haskoin-node >=0.9.21 , hspec , http-types , monad-logger
src/Haskoin/Store.hs view
@@ -4,7 +4,6 @@ , StoreConfig(..) , StoreRead(..) , StoreWrite(..)- , StoreStream(..) , StoreEvent(..) , BlockData(..) , Transaction(..)@@ -46,10 +45,6 @@ , getAddressesTxsFull , getAddressesTxsLimit , getPeersInformation- , xpubBals- , xpubUnspent- , xpubUnspentLimit- , xpubSummary , publishTx , isCoinbase , confirmed@@ -59,6 +54,8 @@ , withRocksDB , connectRocksDB , initRocksDB+ , zeroBalance+ , nullBalance ) where import Control.Monad (unless, when)@@ -81,10 +78,7 @@ NodeEvent (..), PeerEvent (..), node) import Network.Haskoin.Store.Block (blockStore)-import Network.Haskoin.Store.Data.Memory (withBlockMem)-import Network.Haskoin.Store.Data.RocksDB (connectRocksDB,- initRocksDB, withRocksDB)-import Network.Haskoin.Store.Data.Types (Balance (..),+import Network.Haskoin.Store.Common (Balance (..), BinSerial (..), BlockConfig (..), BlockDB (..),@@ -102,7 +96,6 @@ StoreConfig (..), StoreEvent (..), StoreRead (..),- StoreStream (..), StoreWrite (..), Transaction (..), TxAfterHeight (..),@@ -111,8 +104,12 @@ XPubUnspent (..), confirmed, fromTransaction, getTransaction, isCoinbase,- toTransaction,- transactionData)+ nullBalance, toTransaction,+ transactionData,+ zeroBalance)+import Network.Haskoin.Store.Data.Memory (withBlockMem)+import Network.Haskoin.Store.Data.RocksDB (connectRocksDB,+ initRocksDB, withRocksDB) import Network.Haskoin.Store.Web (Except (..), MaxLimits (..), Timeouts (..),@@ -126,9 +123,7 @@ getAddressesUnspentsLimit, getPeersInformation, healthCheck, publishTx,- runWeb, xpubBals,- xpubSummary, xpubUnspent,- xpubUnspentLimit)+ runWeb) import Network.Socket (SockAddr (..)) import NQE (Inbox, Listen, Process (..),
src/Network/Haskoin/Store/Block.hs view
@@ -9,11 +9,10 @@ ( blockStore ) where -import Conduit (MonadResource, runConduit,- runResourceT, sinkList,- transPipe, (.|))-import Control.Monad (forM, forever, guard,- mzero, unless, void, when)+import Control.Applicative ((<|>))+import Control.Monad (forM, forM_, forever,+ guard, mzero, unless,+ void, when) import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS,@@ -21,8 +20,10 @@ import Control.Monad.Reader (MonadReader, ReaderT (..), asks) import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (runMaybeT)-import Data.Maybe (catMaybes, isNothing)+import Control.Monad.Trans.Maybe (MaybeT (MaybeT),+ runMaybeT)+import Data.Maybe (catMaybes, isNothing,+ listToMaybe) import Data.String (fromString) import Data.String.Conversions (cs) import Data.Time.Clock.System (getSystemTime,@@ -49,15 +50,15 @@ chainGetParents, killPeer, managerGetPeers, sendMessage)-import Network.Haskoin.Store.Data.ImportDB (ImportDB, runImportDB)-import Network.Haskoin.Store.Data.Types (BlockConfig (..), BlockDB,+import Network.Haskoin.Store.Common (BlockConfig (..), BlockDB, BlockMessage (..), BlockStore, StoreEvent (..), StoreRead (..),- StoreStream (..), StoreWrite (..), UnixTime)-import Network.Haskoin.Store.Logic (ImportException,+import Network.Haskoin.Store.Data.ImportDB (ImportDB, runImportDB)+import Network.Haskoin.Store.Logic (ImportException, deleteTx,+ getOldMempool, getOldOrphans, importBlock, importOrphan, initBest, newMempoolTx,@@ -77,8 +78,6 @@ data BlockException = BlockNotInChain !BlockHash | Uninitialized- | UnexpectedGenesisNode- | SyncingPeerExpected | AncestorNotInChain !BlockHeight !BlockHash deriving (Show, Eq, Ord, Exception)@@ -125,14 +124,9 @@ runRocksDB (getAddressesTxs addrs start limit) getAddressesUnspents addrs start limit = runRocksDB (getAddressesUnspents addrs start limit)--instance (MonadResource m, MonadUnliftIO m) =>- StoreStream (ReaderT BlockRead m) where- getOrphans = transPipe runRocksDB getOrphans- getAddressUnspents a x = transPipe runRocksDB $ getAddressUnspents a x- getAddressTxs a x = transPipe runRocksDB $ getAddressTxs a x- getAddressBalances = transPipe runRocksDB getAddressBalances- getUnspents = transPipe runRocksDB getUnspents+ getOrphans = runRocksDB getOrphans+ getAddressUnspents a s = runRocksDB . getAddressUnspents a s+ getAddressTxs a s = runRocksDB . getAddressTxs a s -- | Run block store process. blockStore ::@@ -141,7 +135,6 @@ -> Inbox BlockMessage -> m () blockStore cfg inbox = do- $(logInfoS) "Block" "Initializing block store..." pb <- newTVarIO Nothing runReaderT (ini >> run)@@ -154,101 +147,69 @@ $(logErrorS) "Block" $ "Could not initialize block store: " <> fromString (show e) throwIO e- Right () -> $(logInfoS) "Block" "Initialization complete"+ Right () -> return () run = withAsync (pingMe (inboxToMailbox inbox)) . const . forever $ do- $(logDebugS) "Block" "Awaiting message..." receive inbox >>= \x ->- ReaderT $ \r ->- runResourceT (runReaderT (processBlockMessage x) r)+ ReaderT $ \r -> runReaderT (processBlockMessage x) r -isSynced :: (MonadLoggerIO m, MonadUnliftIO m) => ReaderT BlockRead m Bool-isSynced = do- ch <- asks (blockConfChain . myConfig)- $(logDebugS) "Block" "Testing if synced with header chain..."+isInSync ::+ (MonadLoggerIO m, StoreRead m, MonadReader BlockRead m)+ => m Bool+isInSync = getBestBlock >>= \case Nothing -> do $(logErrorS) "Block" "Block database uninitialized" throwIO Uninitialized- Just bb -> do- $(logDebugS) "Block" $ "Best block: " <> blockHashToHex bb- chainGetBest ch >>= \cb -> do- $(logDebugS) "Block" $- "Best chain block " <>- blockHashToHex (headerHash (nodeHeader cb)) <>- " at height " <>- cs (show (nodeHeight cb))- let s = headerHash (nodeHeader cb) == bb- $(logDebugS) "Block" $ "Synced: " <> cs (show s)- return s+ Just bb ->+ asks (blockConfChain . myConfig) >>= chainGetBest >>= \cb ->+ return (headerHash (nodeHeader cb) == bb) -mempool ::- (MonadUnliftIO m, MonadLoggerIO m) => Peer -> ReaderT BlockRead m ()-mempool p = MMempool `sendMessage` p+mempool :: MonadLoggerIO m => Peer -> m ()+mempool p = do+ $(logDebugS) "Block" "Requesting mempool from network peer"+ MMempool `sendMessage` p processBlock :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Block -> ReaderT BlockRead m ()-processBlock p b = do- $(logDebugS) "Block" ("Processing incoming block: " <> hex)+processBlock peer block = do void . runMaybeT $ do- iss >>= \x ->- unless x $ do- $(logErrorS) "Block" $- "Cannot accept block " <> hex <> " from non-syncing peer"- mzero- n <- cbn- upr- net <- blockConfNet <$> asks myConfig- lift (runImport (importBlock net b n)) >>= \case- Right ths -> do- l <- blockConfListener <$> asks myConfig- $(logInfoS) "Block" $- "Best block indexed: " <>- blockHashToHex (headerHash (blockHeader b)) <>- " at height " <>- cs (show (nodeHeight n))+ checkpeer+ blocknode <- getblocknode+ net <- asks (blockConfNet . myConfig)+ lift (runImport (importBlock net block blocknode)) >>= \case+ Right deletedtxids -> do+ listener <- asks (blockConfListener . myConfig)+ $(logInfoS) "Block" $ "Best block indexed: " <> hexhash atomically $ do- mapM_ (l . StoreTxDeleted) ths- l (StoreBestBlock (headerHash (blockHeader b)))- lift $ isSynced >>= \x -> when x (mempool p)+ mapM_ (listener . StoreTxDeleted) deletedtxids+ listener (StoreBestBlock blockhash)+ lift (syncMe peer) Left e -> do $(logErrorS) "Block" $- "Error importing block " <>- fromString (show $ headerHash (blockHeader b)) <>- ": " <>+ "Error importing block: " <> hexhash <> ": " <> fromString (show e)- killPeer (PeerMisbehaving (show e)) p- syncMe+ killPeer (PeerMisbehaving (show e)) peer where- hex = blockHashToHex (headerHash (blockHeader b))- upr =- asks myPeer >>= readTVarIO >>= \case- Nothing -> throwIO SyncingPeerExpected- Just s@Syncing {syncingHead = h} ->- if nodeHeader h == blockHeader b- then resetPeer- else do- now <-- fromIntegral . systemSeconds <$>- liftIO getSystemTime- asks myPeer >>=- atomically .- (`writeTVar` Just s {syncingTime = now})- iss =- asks myPeer >>= readTVarIO >>= \case- Just Syncing {syncingPeer = p'} -> return $ p == p'- Nothing -> return False- cbn =- blockConfChain <$> asks myConfig >>=- chainGetBlock (headerHash (blockHeader b)) >>= \case+ header = blockHeader block+ blockhash = headerHash header+ hexhash = blockHashToHex blockhash+ checkpeer =+ getSyncingState >>= \case+ Just Syncing {syncingPeer = syncingpeer}+ | peer == syncingpeer -> return ()+ _ -> do+ $(logErrorS) "Block" $ "Peer sent unexpected block: " <> hexhash+ killPeer (PeerMisbehaving "Sent unpexpected block") peer+ mzero+ getblocknode =+ asks (blockConfChain . myConfig) >>= chainGetBlock blockhash >>= \case Nothing -> do- killPeer (PeerMisbehaving "Sent unknown block") p- $(logErrorS)- "Block"- ("Block " <> hex <> " rejected as header not found")+ $(logErrorS) "Block" $ "Block header not found: " <> hexhash+ killPeer (PeerMisbehaving "Sent unknown block") peer mzero Just n -> return n @@ -261,63 +222,49 @@ $(logErrorS) "Block" (cs m) killPeer (PeerMisbehaving m) p where- m = "We do not like peers that cannot find them blocks"+ m = "I do not like peers that cannot find them blocks" processTx :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Tx -> BlockT m () processTx _p tx =- isSynced >>= \case- False ->- $(logDebugS) "Block" $- "Ignoring incoming tx (not synced yet): " <> txHashToHex (txHash tx)- True -> do- $(logInfoS) "Block" $ "Incoming tx: " <> txHashToHex (txHash tx)+ isInSync >>= \sync ->+ when sync $ do now <- fromIntegral . systemSeconds <$> liftIO getSystemTime net <- asks (blockConfNet . myConfig) runImport (newMempoolTx net tx now) >>= \case- Left e ->- $(logWarnS) "Block" $- "Error importing tx: " <> txHashToHex (txHash tx) <> ": " <>- fromString (show e)- Right (Just ths) -> do+ Right (Just deleted) -> do l <- blockConfListener <$> asks myConfig- $(logDebugS) "Block" $- "Received mempool tx: " <> txHashToHex (txHash tx)+ $(logInfoS) "Block" $+ "New mempool tx: " <> txHashToHex (txHash tx) atomically $ do- mapM_ (l . StoreTxDeleted) ths+ mapM_ (l . StoreTxDeleted) deleted l (StoreMempoolNew (txHash tx))- Right Nothing ->- $(logDebugS) "Block" $- "Not importing mempool tx: " <> txHashToHex (txHash tx)+ _ -> return () processOrphans ::- (MonadResource m, MonadUnliftIO m, MonadLoggerIO m) => BlockT m ()+ (MonadUnliftIO m, MonadLoggerIO m) => BlockT m () processOrphans =- isSynced >>= \case- False -> $(logDebugS) "Block" "Not importing orphans as not yet in sync"- True -> do+ isInSync >>= \sync ->+ when sync $ do now <- fromIntegral . systemSeconds <$> liftIO getSystemTime net <- asks (blockConfNet . myConfig)- $(logDebugS) "Block" "Getting expired orphan transactions..."- old <- runConduit $ getOldOrphans now .| sinkList+ old <- getOldOrphans now case old of- [] ->- $(logDebugS) "Block" "No old orphan transactions to remove"+ [] -> return () _ -> do- $(logDebugS) "Block" $+ $(logInfoS) "Block" $ "Removing " <> cs (show (length old)) <>- "expired orphan transactions..."+ " expired orphan transactions" void . runImport $ mapM_ deleteOrphanTx old- $(logDebugS) "Block" "Selecting orphan transactions to import..."- orphans <- runConduit $ getOrphans .| sinkList+ orphans <- getOrphans case orphans of- [] -> $(logDebugS) "Block" "No orphan tranasctions to import"+ [] -> return () _ ->- $(logDebugS) "Block" $- "Importing " <> cs (show (length orphans)) <>+ $(logInfoS) "Block" $+ "Attempting to import " <> cs (show (length orphans)) <> " orphan transactions" ops <- zip (map snd orphans) <$>- forM orphans (runImport . uncurry (importOrphan net))+ mapM (runImport . uncurry (importOrphan net)) orphans let tths = [ (txHash tx, hs) | (tx, emths) <- ops@@ -329,7 +276,6 @@ atomically $ do mapM_ (l . StoreTxDeleted) dhs mapM_ (l . StoreMempoolNew) ihs- $(logDebugS) "Block" "Finished importing orphans" processTxs ::@@ -338,13 +284,8 @@ -> [TxHash] -> ReaderT BlockRead m () processTxs p hs =- isSynced >>= \case- False ->- $(logDebugS) "Block" "Ignoring incoming tx inv (not synced yet)"- True -> do- $(logDebugS) "Block" $- "Received " <> fromString (show (length hs)) <>- " transaction inventory"+ isInSync >>= \sync ->+ when sync $ do xs <- fmap catMaybes . forM hs $ \h -> runMaybeT $ do@@ -352,7 +293,7 @@ guard (isNothing t) return (getTxHash h) unless (null xs) $ do- $(logDebugS) "Block" $+ $(logInfoS) "Block" $ "Requesting " <> fromString (show (length xs)) <> " new transactions" net <- blockConfNet <$> asks myConfig@@ -365,16 +306,13 @@ checkTime :: (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m () checkTime = asks myPeer >>= readTVarIO >>= \case- Nothing -> $(logDebugS) "Block" "Peer timeout check: no syncing peer"+ Nothing -> return () Just Syncing {syncingTime = t, syncingPeer = p} -> do n <- fromIntegral . systemSeconds <$> liftIO getSystemTime- if n > t + 60- then do- $(logErrorS) "Block" "Peer timeout"- resetPeer- killPeer PeerTimeout p- syncMe- else $(logDebugS) "Block" "Peer timeout not reached"+ when (n > t + 60) $ do+ $(logErrorS) "Block" "Syncing peer timeout"+ resetPeer+ killPeer PeerTimeout p processDisconnect :: (MonadUnliftIO m, MonadLoggerIO m)@@ -382,138 +320,148 @@ -> ReaderT BlockRead m () processDisconnect p = asks myPeer >>= readTVarIO >>= \case- Nothing ->- $(logDebugS) "Block" "Ignoring peer disconnection notification"+ Nothing -> return () Just Syncing {syncingPeer = p'} | p == p' -> do- $(logErrorS) "Block" "Syncing peer disconnected" resetPeer- syncMe- | otherwise -> $(logDebugS) "Block" "Non-syncing peer disconnected"+ getPeer >>= \case+ Nothing ->+ $(logWarnS)+ "Block"+ "No peers available after syncing peer disconnected"+ Just peer -> do+ $(logWarnS) "Block" "Selected another peer to sync"+ syncMe peer+ | otherwise -> return () -purgeMempool ::- (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m ()-purgeMempool = $(logErrorS) "Block" "Mempool purging not implemented"+pruneMempool :: (MonadUnliftIO m, MonadLoggerIO m) => BlockT m ()+pruneMempool =+ isInSync >>= \sync ->+ when sync $ do+ now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ getOldMempool now >>= \case+ [] -> return ()+ old -> deletetxs old+ where+ deletetxs old = do+ $(logInfoS) "Block" $+ "Removing " <> cs (show (length old)) <> " old mempool transactions"+ net <- asks (blockConfNet . myConfig)+ forM_ old $ \txid ->+ runImport (deleteTx net True txid) >>= \case+ Left _ -> return ()+ Right txids -> do+ listener <- asks (blockConfListener . myConfig)+ atomically $ mapM_ (listener . StoreTxDeleted) txids -syncMe :: (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m ()-syncMe =+syncMe :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()+syncMe peer = void . runMaybeT $ do- bths <- rev- l <- blockConfListener <$> asks myConfig- let dbs = map fst bths- ths = concatMap snd bths- atomically $ do- mapM_ (l . StoreTxDeleted) ths- mapM_ (l . StoreBlockReverted) dbs- p <-- gpr >>= \case- Nothing -> do- $(logWarnS)- "Block"- "Not syncing blocks as no peers available"- mzero- Just p -> return p- $(logDebugS) "Block" "Syncing blocks against network peer"- b <- mbn- d <- dbn- c <- cbn- when (end b d c) $ do- $(logDebugS) "Block" $- "Already requested up to block height: " <>- cs (show (nodeHeight b))- mzero- ns <- bls c b- setPeer p (last ns)- net <- blockConfNet <$> asks myConfig+ checksyncingpeer+ reverttomainchain+ syncbest <- syncbestnode+ bestblock <- bestblocknode+ chainbest <- chainbestnode+ end syncbest bestblock chainbest+ blocknodes <- selectblocks chainbest syncbest+ setPeer peer (last blocknodes)+ net <- asks (blockConfNet . myConfig) let inv = if getSegWit net then InvWitnessBlock else InvBlock- vs <- mapM (f inv) ns+ vectors =+ map+ (InvVector inv . getBlockHash . headerHash . nodeHeader)+ blocknodes $(logInfoS) "Block" $- "Requesting " <> fromString (show (length vs)) <> " blocks"- MGetData (GetData vs) `sendMessage` p+ "Requesting " <> fromString (show (length vectors)) <> " blocks"+ MGetData (GetData vectors) `sendMessage` peer where- gpr =- asks myPeer >>= readTVarIO >>= \case- Just Syncing {syncingPeer = p} -> return (Just p)- Nothing ->- blockConfManager <$> asks myConfig >>= managerGetPeers >>= \case- [] -> return Nothing- OnlinePeer {onlinePeerMailbox = p}:_ -> return (Just p)- cbn = chainGetBest =<< blockConfChain <$> asks myConfig- dbn = do+ checksyncingpeer =+ getSyncingState >>= \case+ Nothing -> return ()+ Just Syncing {syncingPeer = p}+ | p == peer -> return ()+ | otherwise -> do+ $(logInfoS) "Block" "Already syncing against another peer"+ mzero+ chainbestnode = chainGetBest =<< asks (blockConfChain . myConfig)+ bestblocknode = do bb <- lift getBestBlock >>= \case Nothing -> do- $(logErrorS) "Block" "Best block not in database"+ $(logErrorS) "Block" "No best block set" throwIO Uninitialized Just b -> return b- ch <- blockConfChain <$> asks myConfig+ ch <- asks (blockConfChain . myConfig) chainGetBlock bb ch >>= \case Nothing -> do $(logErrorS) "Block" $- "Block header not found for best block " <>- blockHashToHex bb+ "Header not found for best block: " <> blockHashToHex bb throwIO (BlockNotInChain bb) Just x -> return x- mbn =+ syncbestnode = asks myPeer >>= readTVarIO >>= \case Just Syncing {syncingHead = b} -> return b- Nothing -> dbn- end b d c- | nodeHeader b == nodeHeader c = True- | otherwise = nodeHeight b > nodeHeight d + 500- f _ GenesisNode {} = throwIO UnexpectedGenesisNode- f inv BlockNode {nodeHeader = bh} =- return $ InvVector inv (getBlockHash (headerHash bh))- bls c b = do- t <- top c (tts (nodeHeight c) (nodeHeight b))- ch <- blockConfChain <$> asks myConfig- ps <- chainGetParents (nodeHeight b + 1) t ch+ Nothing -> bestblocknode+ end syncbest bestblock chainbest+ | nodeHeader bestblock == nodeHeader chainbest = do+ resetPeer >> mempool peer >> mzero+ | nodeHeader syncbest == nodeHeader chainbest = do mzero+ | otherwise =+ when (nodeHeight syncbest > nodeHeight bestblock + 500) mzero+ selectblocks chainbest syncbest = do+ synctop <-+ top+ chainbest+ (maxsyncheight (nodeHeight chainbest) (nodeHeight syncbest))+ ch <- asks (blockConfChain . myConfig)+ parents <- chainGetParents (nodeHeight syncbest + 1) synctop ch return $- if length ps < 500- then ps <> [c]- else ps- tts c b- | c <= b + 501 = c- | otherwise = b + 501- top c t = do- ch <- blockConfChain <$> asks myConfig- if t == nodeHeight c- then return c- else chainGetAncestor t c ch >>= \case+ if length parents < 500+ then parents <> [chainbest]+ else parents+ maxsyncheight chainheight syncbestheight+ | chainheight <= syncbestheight + 501 = chainheight+ | otherwise = syncbestheight + 501+ top chainbest syncheight = do+ ch <- asks (blockConfChain . myConfig)+ if syncheight == nodeHeight chainbest+ then return chainbest+ else chainGetAncestor syncheight chainbest ch >>= \case Just x -> return x Nothing -> do $(logErrorS) "Block" $- "Unknown header for ancestor of block " <>- blockHashToHex (headerHash (nodeHeader c)) <>- " at height " <>- fromString (show t)+ "Could not find header for ancestor of block: " <>+ blockHashToHex (headerHash (nodeHeader chainbest)) throwIO $- AncestorNotInChain t (headerHash (nodeHeader c))- rev = do- d <- headerHash . nodeHeader <$> dbn- ch <- blockConfChain <$> asks myConfig- chainBlockMain d ch >>= \case- True -> return []- False -> do+ AncestorNotInChain+ syncheight+ (headerHash (nodeHeader chainbest))+ reverttomainchain = do+ bestblockhash <- headerHash . nodeHeader <$> bestblocknode+ ch <- asks (blockConfChain . myConfig)+ chainBlockMain bestblockhash ch >>= \y ->+ unless y $ do $(logErrorS) "Block" $- "Reverting best block " <> blockHashToHex d <>- " as it is not in main chain..."+ "Reverting best block: " <> blockHashToHex bestblockhash resetPeer net <- asks (blockConfNet . myConfig)- lift (runImport (revertBlock net d)) >>= \case+ lift (runImport (revertBlock net bestblockhash)) >>= \case Left e -> do $(logErrorS) "Block" $- "Could not revert best block: " <>- fromString (show e)+ "Could not revert best block: " <> cs (show e) throwIO e- Right ths -> ((d, ths) :) <$> rev+ Right txids -> do+ listener <- asks (blockConfListener . myConfig)+ atomically $ do+ mapM_ (listener . StoreTxDeleted) txids+ listener (StoreBlockReverted bestblockhash)+ reverttomainchain resetPeer :: (MonadLoggerIO m, MonadReader BlockRead m) => m () resetPeer = do- $(logDebugS) "Block" "Resetting syncing peer..." box <- asks myPeer atomically $ writeTVar box Nothing @@ -524,29 +472,40 @@ atomically . writeTVar box $ Just Syncing {syncingPeer = p, syncingHead = b, syncingTime = now} +getPeer :: (MonadIO m, MonadReader BlockRead m) => m (Maybe Peer)+getPeer = runMaybeT $ MaybeT syncingpeer <|> MaybeT onlinepeer+ where+ syncingpeer = fmap syncingPeer <$> getSyncingState+ onlinepeer =+ listToMaybe . map onlinePeerMailbox <$>+ (managerGetPeers =<< asks (blockConfManager . myConfig))++getSyncingState :: (MonadIO m, MonadReader BlockRead m) => m (Maybe Syncing)+getSyncingState = readTVarIO =<< asks myPeer+ processBlockMessage ::- (MonadResource m, MonadUnliftIO m, MonadLoggerIO m)+ (MonadUnliftIO m, MonadLoggerIO m) => BlockMessage -> BlockT m ()-processBlockMessage (BlockNewBest bn) = do- $(logDebugS) "Block" $- "New best block header " <> fromString (show (nodeHeight bn)) <> ": " <>- blockHashToHex (headerHash (nodeHeader bn))- syncMe-processBlockMessage (BlockPeerConnect _p sa) = do- $(logDebugS) "Block" $ "New peer connected: " <> fromString (show sa)- syncMe+processBlockMessage (BlockNewBest _) = do+ getPeer >>= \case+ Nothing -> do+ $(logErrorS) "Block" "New best block but no peer to sync from"+ Just p -> syncMe p+processBlockMessage (BlockPeerConnect p _) = syncMe p processBlockMessage (BlockPeerDisconnect p _sa) = processDisconnect p processBlockMessage (BlockReceived p b) = processBlock p b processBlockMessage (BlockNotFound p bs) = processNoBlocks p bs processBlockMessage (BlockTxReceived p tx) = processTx p tx processBlockMessage (BlockTxAvailable p ts) = processTxs p ts-processBlockMessage (BlockPing r) =- processOrphans >> checkTime >> atomically (r ())-processBlockMessage PurgeMempool = purgeMempool+processBlockMessage (BlockPing r) = do+ processOrphans+ checkTime+ pruneMempool+ atomically (r ()) pingMe :: MonadLoggerIO m => Mailbox BlockMessage -> m ()-pingMe mbox = forever $ do- threadDelay =<< liftIO (randomRIO (5 * 1000 * 1000, 10 * 1000 * 1000))- $(logDebugS) "BlockTimer" "Pinging block"- BlockPing `query` mbox+pingMe mbox =+ forever $ do+ threadDelay =<< liftIO (randomRIO (5 * 1000 * 1000, 10 * 1000 * 1000))+ BlockPing `query` mbox
+ src/Network/Haskoin/Store/Common.hs view
@@ -0,0 +1,1526 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Haskoin.Store.Common where++import Conduit (ConduitT, dropC, mapC, takeC)+import Control.Applicative ((<|>))+import Control.Arrow (first)+import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad (forM, guard, mzero)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Aeson (Encoding, ToJSON (..), Value (..),+ object, pairs, (.=))+import qualified Data.Aeson as A+import qualified Data.Aeson.Encoding as A+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Short (ShortByteString)+import qualified Data.ByteString.Short as B.Short+import Data.Default (Default (..))+import Data.Function (on)+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import qualified Data.IntMap as I+import Data.IntMap.Strict (IntMap)+import Data.List (nub, partition, sortBy)+import Data.Maybe (catMaybes, isJust, listToMaybe,+ mapMaybe)+import Data.Serialize (Get, Put, Putter, Serialize (..),+ getListOf, getShortByteString,+ getWord32be, getWord64be, getWord8,+ putListOf, putShortByteString,+ putWord32be, putWord64be, putWord8,+ runGet, runPut)+import qualified Data.Serialize as S+import Data.String.Conversions (cs)+import qualified Data.Text.Encoding as T+import Data.Word (Word32, Word64)+import Database.RocksDB (DB, ReadOptions)+import GHC.Generics (Generic)+import Haskoin (Address, Block, BlockHash,+ BlockHeader (..), BlockHeight,+ BlockNode, BlockWork, HostAddress,+ KeyIndex, Network (..),+ NetworkAddress (..), OutPoint (..),+ PubKeyI (..), RejectCode (..),+ Tx (..), TxHash (..), TxIn (..),+ TxOut (..), WitnessStack,+ XPubKey (..), addrToJSON,+ addrToString, deriveAddr,+ deriveCompatWitnessAddr,+ deriveWitnessAddr, eitherToMaybe,+ encodeHex, headerHash,+ hostToSockAddr, pubSubKey,+ scriptToAddressBS, stringToAddr,+ txHash, wrapPubKey, xPubAddr,+ xPubCompatWitnessAddr,+ xPubWitnessAddr)+import Haskoin.Node (Chain, HostPort, Manager, Peer)+import Network.Socket (SockAddr)+import NQE (Listen, Mailbox)+import qualified Paths_haskoin_store as P++data DeriveType+ = DeriveNormal+ | DeriveP2SH+ | DeriveP2WPKH+ deriving (Show, Eq, Generic, NFData, Serialize)++data XPubSpec =+ XPubSpec+ { xPubSpecKey :: !XPubKey+ , xPubDeriveType :: !DeriveType+ } deriving (Show, Eq, Generic, NFData)++instance Serialize XPubSpec where+ put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do+ put (xPubDepth k)+ put (xPubParent k)+ put (xPubIndex k)+ put (xPubChain k)+ put (wrapPubKey True (xPubKey k))+ put t+ get = do+ d <- get+ p <- get+ i <- get+ c <- get+ k <- get+ t <- get+ let x =+ XPubKey+ { xPubDepth = d+ , xPubParent = p+ , xPubIndex = i+ , xPubChain = c+ , xPubKey = pubKeyPoint k+ }+ return XPubSpec {xPubSpecKey = x, xPubDeriveType = t}++type DeriveAddr = XPubKey -> KeyIndex -> Address++-- | Mailbox for block store.+type BlockStore = Mailbox BlockMessage++-- | Store mailboxes.+data Store =+ Store+ { storeManager :: !Manager+ -- ^ peer manager mailbox+ , storeChain :: !Chain+ -- ^ chain header process mailbox+ , storeBlock :: !BlockStore+ -- ^ block storage mailbox+ }++-- | Configuration for a 'Store'.+data StoreConfig =+ StoreConfig+ { storeConfMaxPeers :: !Int+ -- ^ max peers to connect to+ , storeConfInitPeers :: ![HostPort]+ -- ^ static set of peers to connect to+ , storeConfDiscover :: !Bool+ -- ^ discover new peers?+ , storeConfDB :: !BlockDB+ -- ^ RocksDB database handler+ , storeConfNetwork :: !Network+ -- ^ network constants+ , storeConfListen :: !(Listen StoreEvent)+ -- ^ listen to store events+ }++-- | Configuration for a block store.+data BlockConfig =+ BlockConfig+ { blockConfManager :: !Manager+ -- ^ peer manager from running node+ , blockConfChain :: !Chain+ -- ^ chain from a running node+ , blockConfListener :: !(Listen StoreEvent)+ -- ^ listener for store events+ , blockConfDB :: !BlockDB+ -- ^ RocksDB database handle+ , blockConfNet :: !Network+ -- ^ network constants+ }++data BlockDB =+ BlockDB+ { blockDB :: !DB+ , blockDBopts :: !ReadOptions+ }++type UnixTime = Word64+type BlockPos = Word32++type Offset = Word32+type Limit = Word32++class Monad m =>+ StoreRead m+ where+ getBestBlock :: m (Maybe BlockHash)+ getBlocksAtHeight :: BlockHeight -> m [BlockHash]+ getBlock :: BlockHash -> m (Maybe BlockData)+ getTxData :: TxHash -> m (Maybe TxData)+ getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx))+ getOrphans :: m [(UnixTime, Tx)]+ getSpenders :: TxHash -> m (IntMap Spender)+ getSpender :: OutPoint -> m (Maybe Spender)+ getBalance :: Address -> m Balance+ getBalance a = head <$> getBalances [a]+ getBalances :: [Address] -> m [Balance]+ getBalances as = mapM getBalance as+ getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs :: Address -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs a = getAddressesTxs [a]+ getUnspent :: OutPoint -> m (Maybe Unspent)+ getAddressUnspents ::+ Address -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getAddressUnspents a = getAddressesUnspents [a]+ getAddressesUnspents ::+ [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getMempool :: m [BlockTx]+ xPubBals :: XPubSpec -> m [XPubBal]+ xPubBals xpub = do+ ext <-+ derive_until_gap+ 0+ (deriveAddresses+ (deriveFunction (xPubDeriveType xpub))+ (pubSubKey (xPubSpecKey xpub) 0)+ 0)+ chg <-+ derive_until_gap+ 1+ (deriveAddresses+ (deriveFunction (xPubDeriveType xpub))+ (pubSubKey (xPubSpecKey xpub) 1)+ 0)+ return (ext ++ chg)+ where+ xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+ derive_until_gap _ [] = return []+ derive_until_gap m as = do+ let n = 32+ let (as1, as2) = splitAt n 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 m as2+ xPubSummary :: XPubSpec -> m XPubSummary+ xPubSummary xpub = do+ bs <- xPubBals xpub+ let f XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}} =+ (a, p)+ pm = M.fromList $ map f bs+ ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]+ ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]+ uc =+ sum+ [ c+ | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-+ bs+ ]+ xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]+ rx =+ sum+ [ r+ | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-+ xt+ ]+ return+ XPubSummary+ { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)+ , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)+ , xPubSummaryReceived = rx+ , xPubUnspentCount = uc+ , xPubSummaryPaths = pm+ , xPubChangeIndex = ch+ , xPubExternalIndex = ex+ }+ xPubUnspents ::+ XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [XPubUnspent]+ xPubUnspents xpub start offset limit = do+ xs <- filter positive <$> xPubBals xpub+ applyOffsetLimit offset limit <$> go xs+ where+ positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0+ go [] = return []+ go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do+ uns <- getAddressUnspents a start limit+ let xuns =+ map+ (\t ->+ XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})+ uns+ (xuns <>) <$> go xs+ xPubTxs ::+ XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit -> m [BlockTx]+ xPubTxs xpub start offset limit = do+ bs <- xPubBals xpub+ let as = map (balanceAddress . xPubBal) bs+ ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyOffsetLimit offset limit ts'++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 -> BlockTx -> m ()+ deleteAddrTx :: Address -> BlockTx -> m ()+ insertAddrUnspent :: Address -> Unspent -> m ()+ deleteAddrUnspent :: Address -> Unspent -> m ()+ setMempool :: [BlockTx] -> m ()+ insertOrphanTx :: Tx -> UnixTime -> m ()+ deleteOrphanTx :: TxHash -> m ()+ setBalance :: Balance -> m ()+ insertUnspent :: Unspent -> m ()+ deleteUnspent :: OutPoint -> m ()++deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]+deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]++deriveFunction :: DeriveType -> DeriveAddr+deriveFunction DeriveNormal i = fst . deriveAddr i+deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i+deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i++xPubAddrFunction :: DeriveType -> XPubKey -> Address+xPubAddrFunction DeriveNormal = xPubAddr+xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr+xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr++encodeShort :: Serialize a => a -> ShortByteString+encodeShort = B.Short.toShort . S.encode++decodeShort :: Serialize a => ShortByteString -> a+decodeShort bs = case S.decode (B.Short.fromShort bs) of+ Left e -> error e+ Right a -> a++getTransaction ::+ (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction)+getTransaction h = runMaybeT $ do+ d <- MaybeT $ getTxData h+ sm <- lift $ getSpenders h+ return $ toTransaction d sm++blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData)+blockAtOrBefore q = runMaybeT $ do+ a <- g 0+ b <- MaybeT getBestBlock >>= MaybeT . getBlock+ f a b+ where+ f a b+ | t b <= q = return b+ | t a > q = mzero+ | h b - h a == 1 = return a+ | otherwise = do+ let x = h a + (h b - h a) `div` 2+ m <- g x+ if t m > q then f a m else f m b+ g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock+ h = blockDataHeight+ t = fromIntegral . blockTimestamp . blockDataHeader++-- | Serialize such that ordering is inverted.+putUnixTime :: Word64 -> Put+putUnixTime w = putWord64be $ maxBound - w++getUnixTime :: Get Word64+getUnixTime = (maxBound -) <$> getWord64be++class JsonSerial a where+ jsonSerial :: Network -> a -> Encoding+ jsonValue :: Network -> a -> Value++instance JsonSerial a => JsonSerial [a] where+ jsonSerial net = A.list (jsonSerial net)+ jsonValue net = toJSON . (jsonValue net)++instance JsonSerial TxHash where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial TxHash where+ binSerial _ = put+ binDeserial _ = get++instance BinSerial Address where+ binSerial net a =+ case addrToString net a of+ Nothing -> put B.empty+ Just x -> put $ T.encodeUtf8 x++ binDeserial net = do+ bs <- get+ guard (not (B.null bs))+ t <- case T.decodeUtf8' bs of+ Left _ -> mzero+ Right v -> return v+ case stringToAddr net t of+ Nothing -> mzero+ Just x -> return x++class BinSerial a where+ binSerial :: Network -> Putter a+ binDeserial :: Network -> Get a++instance BinSerial a => BinSerial [a] where+ binSerial net = putListOf (binSerial net)+ binDeserial net = getListOf (binDeserial net)++-- | Reference to a block where a transaction is stored.+data BlockRef+ = BlockRef+ { blockRefHeight :: !BlockHeight+ -- ^ block height in the chain+ , blockRefPos :: !Word32+ -- ^ position of transaction within the block+ }+ | MemRef+ { memRefTime :: !UnixTime+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)++-- | Serialized entities will sort in reverse order.+instance Serialize BlockRef where+ put MemRef {memRefTime = t} = do+ putWord8 0x00+ putUnixTime t+ put BlockRef {blockRefHeight = h, blockRefPos = p} = do+ putWord8 0x01+ putWord32be (maxBound - h)+ putWord32be (maxBound - p)+ get = getmemref <|> getblockref+ where+ getmemref = do+ guard . (== 0x00) =<< getWord8+ MemRef <$> getUnixTime+ getblockref = do+ guard . (== 0x01) =<< getWord8+ h <- (maxBound -) <$> getWord32be+ p <- (maxBound -) <$> getWord32be+ return BlockRef {blockRefHeight = h, blockRefPos = p}++instance BinSerial BlockRef where+ binSerial _ BlockRef {blockRefHeight = h, blockRefPos = p} = do+ putWord8 0x00+ putWord32be h+ putWord32be p+ binSerial _ MemRef {memRefTime = t} = do+ putWord8 0x01+ putWord64be t++ binDeserial _ = getWord8 >>=+ \case+ 0x00 -> BlockRef <$> getWord32be <*> getWord32be+ 0x01 -> MemRef <$> getUnixTime+ _ -> fail "Expected fst byte to be 0x00 or 0x01"++-- | JSON serialization for 'BlockRef'.+blockRefPairs :: A.KeyValue kv => BlockRef -> [kv]+blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} =+ ["height" .= h, "position" .= p]+blockRefPairs MemRef {memRefTime = t} = ["mempool" .= t]++confirmed :: BlockRef -> Bool+confirmed BlockRef {} = True+confirmed MemRef {} = False++instance ToJSON BlockRef where+ toJSON = object . blockRefPairs+ toEncoding = pairs . mconcat . blockRefPairs++-- | Transaction in relation to an address.+data BlockTx = BlockTx+ { blockTxBlock :: !BlockRef+ -- ^ block information+ , blockTxHash :: !TxHash+ -- ^ transaction hash+ } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData)++-- | JSON serialization for 'AddressTx'.+blockTxPairs :: A.KeyValue kv => BlockTx -> [kv]+blockTxPairs btx =+ [ "txid" .= blockTxHash btx+ , "block" .= blockTxBlock btx+ ]++instance ToJSON BlockTx where+ toJSON = object . blockTxPairs+ toEncoding = pairs . mconcat . blockTxPairs++instance JsonSerial BlockTx where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial BlockTx where+ binSerial net BlockTx { blockTxBlock = b, blockTxHash = h } = do+ binSerial net b+ binSerial net h++ binDeserial net = BlockTx <$> binDeserial net <*> binDeserial net++-- | Address balance information.+data Balance = Balance+ { balanceAddress :: !Address+ -- ^ address balance+ , balanceAmount :: !Word64+ -- ^ confirmed balance+ , balanceZero :: !Word64+ -- ^ unconfirmed balance+ , balanceUnspentCount :: !Word64+ -- ^ number of unspent outputs+ , balanceTxCount :: !Word64+ -- ^ number of transactions+ , balanceTotalReceived :: !Word64+ -- ^ total amount from all outputs in this address+ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++zeroBalance :: Address -> Balance+zeroBalance a =+ Balance+ { balanceAddress = a+ , balanceAmount = 0+ , balanceUnspentCount = 0+ , balanceZero = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0+ }++nullBalance :: Balance -> Bool+nullBalance Balance { balanceAmount = 0+ , balanceUnspentCount = 0+ , balanceZero = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0+ } = True+nullBalance _ = False++-- | JSON serialization for 'Balance'.+balancePairs :: A.KeyValue kv => Network -> Balance -> [kv]+balancePairs net ab =+ [ "address" .= addrToJSON net (balanceAddress ab)+ , "confirmed" .= balanceAmount ab+ , "unconfirmed" .= balanceZero ab+ , "utxo" .= balanceUnspentCount ab+ , "txs" .= balanceTxCount ab+ , "received" .= balanceTotalReceived ab+ ]++balanceToJSON :: Network -> Balance -> Value+balanceToJSON net = object . balancePairs net++balanceToEncoding :: Network -> Balance -> Encoding+balanceToEncoding net = pairs . mconcat . balancePairs net++instance JsonSerial Balance where+ jsonSerial = balanceToEncoding+ jsonValue = balanceToJSON++instance BinSerial Balance where+ binSerial net Balance { balanceAddress = a+ , balanceAmount = v+ , balanceZero = z+ , balanceUnspentCount = u+ , balanceTxCount = c+ , balanceTotalReceived = t+ } = do+ binSerial net a+ putWord64be v+ putWord64be z+ putWord64be u+ putWord64be c+ putWord64be t++ binDeserial net =+ Balance <$> binDeserial net+ <*> getWord64be+ <*> getWord64be+ <*> getWord64be+ <*> getWord64be+ <*> getWord64be+++-- | Unspent output.+data Unspent = Unspent+ { unspentBlock :: !BlockRef+ -- ^ block information for output+ , unspentPoint :: !OutPoint+ -- ^ txid and index where output located+ , unspentAmount :: !Word64+ -- ^ value of output in satoshi+ , unspentScript :: !ShortByteString+ -- ^ pubkey (output) script+ } deriving (Show, Eq, Ord, Generic, Hashable, NFData)++instance Serialize Unspent where+ put u = do+ put $ unspentBlock u+ put $ unspentPoint u+ put $ unspentAmount u+ put $ B.Short.length (unspentScript u)+ putShortByteString $ unspentScript u+ get =+ Unspent <$> get <*> get <*> get <*> (getShortByteString =<< get)++unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv]+unspentPairs net u =+ [ "address" .=+ eitherToMaybe+ (addrToJSON net <$>+ scriptToAddressBS (B.Short.fromShort (unspentScript u)))+ , "block" .= unspentBlock u+ , "txid" .= outPointHash (unspentPoint u)+ , "index" .= outPointIndex (unspentPoint u)+ , "pkscript" .= String (encodeHex (B.Short.fromShort (unspentScript u)))+ , "value" .= unspentAmount u+ ]++unspentToJSON :: Network -> Unspent -> Value+unspentToJSON net = object . unspentPairs net++unspentToEncoding :: Network -> Unspent -> Encoding+unspentToEncoding net = pairs . mconcat . unspentPairs net++instance JsonSerial Unspent where+ jsonSerial = unspentToEncoding+ jsonValue = unspentToJSON++instance BinSerial Unspent where+ binSerial net Unspent { unspentBlock = b+ , unspentPoint = p+ , unspentAmount = v+ , unspentScript = s+ } = do+ binSerial net b+ put p+ putWord64be v+ put s++ binDeserial net =+ Unspent+ <$> binDeserial net+ <*> get+ <*> getWord64be+ <*> get++-- | Database value for a block entry.+data BlockData = BlockData+ { blockDataHeight :: !BlockHeight+ -- ^ height of the block in the chain+ , blockDataMainChain :: !Bool+ -- ^ is this block in the main chain?+ , blockDataWork :: !BlockWork+ -- ^ accumulated work in that block+ , blockDataHeader :: !BlockHeader+ -- ^ block header+ , blockDataSize :: !Word32+ -- ^ size of the block including witnesses+ , blockDataWeight :: !Word32+ -- ^ weight of this block (for segwit networks)+ , blockDataTxs :: ![TxHash]+ -- ^ block transactions+ , blockDataOutputs :: !Word64+ -- ^ sum of all transaction outputs+ , blockDataFees :: !Word64+ -- ^ sum of all transaction fees+ , blockDataSubsidy :: !Word64+ -- ^ block subsidy+ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++-- | JSON serialization for 'BlockData'.+blockDataPairs :: A.KeyValue kv => Network -> BlockData -> [kv]+blockDataPairs net bv =+ [ "hash" .= headerHash (blockDataHeader bv)+ , "height" .= blockDataHeight bv+ , "mainchain" .= blockDataMainChain bv+ , "previous" .= prevBlock (blockDataHeader bv)+ , "time" .= blockTimestamp (blockDataHeader bv)+ , "version" .= blockVersion (blockDataHeader bv)+ , "bits" .= blockBits (blockDataHeader bv)+ , "nonce" .= bhNonce (blockDataHeader bv)+ , "size" .= blockDataSize bv+ , "tx" .= blockDataTxs bv+ , "merkle" .= TxHash (merkleRoot (blockDataHeader bv))+ , "subsidy" .= blockDataSubsidy bv+ , "fees" .= blockDataFees bv+ , "outputs" .= blockDataOutputs bv+ ] ++ ["weight" .= blockDataWeight bv | getSegWit net]++blockDataToJSON :: Network -> BlockData -> Value+blockDataToJSON net = object . blockDataPairs net++blockDataToEncoding :: Network -> BlockData -> Encoding+blockDataToEncoding net = pairs . mconcat . blockDataPairs net++instance JsonSerial BlockData where+ jsonSerial = blockDataToEncoding+ jsonValue = blockDataToJSON++instance BinSerial BlockData where+ binSerial _ BlockData { blockDataHeight = e+ , blockDataMainChain = m+ , blockDataWork = w+ , blockDataHeader = h+ , blockDataSize = z+ , blockDataWeight = g+ , blockDataTxs = t+ , blockDataOutputs = o+ , blockDataFees = f+ , blockDataSubsidy = y+ } = do+ put m+ putWord32be e+ put h+ put w+ putWord32be z+ putWord32be g+ putWord64be o+ putWord64be f+ putWord64be y+ put t++ binDeserial _ = do+ m <- get+ e <- getWord32be+ h <- get+ w <- get+ z <- getWord32be+ g <- getWord32be+ o <- getWord64be+ f <- getWord64be+ y <- getWord64be+ t <- get+ return $ BlockData e m w h z g t o f y++-- | Input information.+data StoreInput+ = StoreCoinbase { inputPoint :: !OutPoint+ -- ^ output being spent (should be null)+ , inputSequence :: !Word32+ -- ^ sequence+ , inputSigScript :: !ByteString+ -- ^ input script data (not valid script)+ , inputWitness :: !(Maybe WitnessStack)+ -- ^ witness data for this input (only segwit)+ }+ -- ^ coinbase details+ | StoreInput { inputPoint :: !OutPoint+ -- ^ output being spent+ , inputSequence :: !Word32+ -- ^ sequence+ , inputSigScript :: !ByteString+ -- ^ signature (input) script+ , inputPkScript :: !ByteString+ -- ^ pubkey (output) script from previous tx+ , inputAmount :: !Word64+ -- ^ amount in satoshi being spent spent+ , inputWitness :: !(Maybe WitnessStack)+ -- ^ witness data for this input (only segwit)+ }+ -- ^ input details+ deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++isCoinbase :: StoreInput -> Bool+isCoinbase StoreCoinbase {} = True+isCoinbase StoreInput {} = False++inputPairs :: A.KeyValue kv => Network -> StoreInput -> [kv]+inputPairs net StoreInput { inputPoint = OutPoint oph opi+ , inputSequence = sq+ , inputSigScript = ss+ , inputPkScript = ps+ , inputAmount = val+ , inputWitness = wit+ } =+ [ "coinbase" .= False+ , "txid" .= oph+ , "output" .= opi+ , "sigscript" .= String (encodeHex ss)+ , "sequence" .= sq+ , "pkscript" .= String (encodeHex ps)+ , "value" .= val+ , "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps)+ ] +++ ["witness" .= fmap (map encodeHex) wit | getSegWit net]++inputPairs net StoreCoinbase { inputPoint = OutPoint oph opi+ , inputSequence = sq+ , inputSigScript = ss+ , inputWitness = wit+ } =+ [ "coinbase" .= True+ , "txid" .= oph+ , "output" .= opi+ , "sigscript" .= String (encodeHex ss)+ , "sequence" .= sq+ , "pkscript" .= Null+ , "value" .= Null+ , "address" .= Null+ ] +++ ["witness" .= fmap (map encodeHex) wit | getSegWit net]++inputToJSON :: Network -> StoreInput -> Value+inputToJSON net = object . inputPairs net++inputToEncoding :: Network -> StoreInput -> Encoding+inputToEncoding net = pairs . mconcat . inputPairs net++-- | Information about input spending output.+data Spender = Spender+ { spenderHash :: !TxHash+ -- ^ input transaction hash+ , spenderIndex :: !Word32+ -- ^ input position in transaction+ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++-- | JSON serialization for 'Spender'.+spenderPairs :: A.KeyValue kv => Spender -> [kv]+spenderPairs n =+ ["txid" .= spenderHash n, "input" .= spenderIndex n]++instance ToJSON Spender where+ toJSON = object . spenderPairs+ toEncoding = pairs . mconcat . spenderPairs++-- | Output information.+data StoreOutput = StoreOutput+ { outputAmount :: !Word64+ -- ^ amount in satoshi+ , outputScript :: !ByteString+ -- ^ pubkey (output) script+ , outputSpender :: !(Maybe Spender)+ -- ^ input spending this transaction+ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++outputPairs :: A.KeyValue kv => Network -> StoreOutput -> [kv]+outputPairs net d =+ [ "address" .=+ eitherToMaybe (addrToJSON net <$> scriptToAddressBS (outputScript d))+ , "pkscript" .= String (encodeHex (outputScript d))+ , "value" .= outputAmount d+ , "spent" .= isJust (outputSpender d)+ ] +++ ["spender" .= outputSpender d | isJust (outputSpender d)]++outputToJSON :: Network -> StoreOutput -> Value+outputToJSON net = object . outputPairs net++outputToEncoding :: Network -> StoreOutput -> Encoding+outputToEncoding net = pairs . mconcat . outputPairs net++data Prev = Prev+ { prevScript :: !ByteString+ , prevAmount :: !Word64+ } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)++toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput+toInput i Nothing w =+ StoreCoinbase+ { inputPoint = prevOutput i+ , inputSequence = txInSequence i+ , inputSigScript = scriptInput i+ , inputWitness = w+ }+toInput i (Just p) w =+ StoreInput+ { inputPoint = prevOutput i+ , inputSequence = txInSequence i+ , inputSigScript = scriptInput i+ , inputPkScript = prevScript p+ , inputAmount = prevAmount p+ , inputWitness = w+ }++toOutput :: TxOut -> Maybe Spender -> StoreOutput+toOutput o s =+ StoreOutput+ { outputAmount = outValue o+ , outputScript = scriptOutput o+ , outputSpender = s+ }++data TxData = TxData+ { txDataBlock :: !BlockRef+ , txData :: !Tx+ , txDataPrevs :: !(IntMap Prev)+ , txDataDeleted :: !Bool+ , txDataRBF :: !Bool+ , txDataTime :: !Word64+ } deriving (Show, Eq, Ord, Generic, Serialize, NFData)++instance BinSerial TxData where+ binSerial _ TxData+ { txDataBlock = br+ , txData = tx+ , txDataPrevs = dp+ , txDataDeleted = dd+ , txDataRBF = dr+ , txDataTime = t+ } = do+ put br+ put tx+ put dp+ put dd+ put dr+ putWord64be t++ binDeserial _ = do br <- get+ tx <- get+ dp <- get+ dd <- get+ dr <- get+ TxData br tx dp dd dr <$> getWord64be++instance Serialize a => BinSerial (IntMap a) where+ binSerial _ = put+ binDeserial _ = get++toTransaction :: TxData -> IntMap Spender -> Transaction+toTransaction t sm =+ Transaction+ { transactionBlock = txDataBlock t+ , transactionVersion = txVersion (txData t)+ , transactionLockTime = txLockTime (txData t)+ , transactionInputs = ins+ , transactionOutputs = outs+ , transactionDeleted = txDataDeleted t+ , transactionRBF = txDataRBF t+ , transactionTime = txDataTime t+ }+ where+ ws =+ take (length (txIn (txData t))) $+ map Just (txWitness (txData t)) <> repeat Nothing+ f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n)+ ins = zipWith f [0 ..] (txIn (txData t))+ g n o = toOutput o (I.lookup n sm)+ outs = zipWith g [0 ..] (txOut (txData t))++fromTransaction :: Transaction -> (TxData, IntMap Spender)+fromTransaction t = (d, sm)+ where+ d =+ TxData+ { txDataBlock = transactionBlock t+ , txData = transactionData t+ , txDataPrevs = ps+ , txDataDeleted = transactionDeleted t+ , txDataRBF = transactionRBF t+ , txDataTime = transactionTime t+ }+ f _ StoreCoinbase {} = Nothing+ f n StoreInput {inputPkScript = s, inputAmount = v} =+ Just (n, Prev {prevScript = s, prevAmount = v})+ ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t)+ g _ StoreOutput {outputSpender = Nothing} = Nothing+ g n StoreOutput {outputSpender = Just s} = Just (n, s)+ sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t)++-- | Detailed transaction information.+data Transaction = Transaction+ { transactionBlock :: !BlockRef+ -- ^ block information for this transaction+ , transactionVersion :: !Word32+ -- ^ transaction version+ , transactionLockTime :: !Word32+ -- ^ lock time+ , transactionInputs :: ![StoreInput]+ -- ^ transaction inputs+ , transactionOutputs :: ![StoreOutput]+ -- ^ transaction outputs+ , transactionDeleted :: !Bool+ -- ^ this transaction has been deleted and is no longer valid+ , transactionRBF :: !Bool+ -- ^ this transaction can be replaced in the mempool+ , transactionTime :: !Word64+ -- ^ time the transaction was first seen or time of block+ } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)++transactionData :: Transaction -> Tx+transactionData t =+ Tx+ { txVersion = transactionVersion t+ , txIn = map i (transactionInputs t)+ , txOut = map o (transactionOutputs t)+ , txWitness = mapMaybe inputWitness (transactionInputs t)+ , txLockTime = transactionLockTime t+ }+ where+ i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} =+ TxIn {prevOutput = p, scriptInput = s, txInSequence = q}+ i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} =+ TxIn {prevOutput = p, scriptInput = s, txInSequence = q}+ o StoreOutput {outputAmount = v, outputScript = s} =+ TxOut {outValue = v, scriptOutput = s}++-- | JSON serialization for 'Transaction'.+transactionPairs :: A.KeyValue kv => Network -> Transaction -> [kv]+transactionPairs net dtx =+ [ "txid" .= txHash (transactionData dtx)+ , "size" .= B.length (S.encode (transactionData dtx))+ , "version" .= transactionVersion dtx+ , "locktime" .= transactionLockTime dtx+ , "fee" .=+ if all isCoinbase (transactionInputs dtx)+ then 0+ else sum (map inputAmount (transactionInputs dtx)) -+ sum (map outputAmount (transactionOutputs dtx))+ , "inputs" .= map (object . inputPairs net) (transactionInputs dtx)+ , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx)+ , "block" .= transactionBlock dtx+ , "deleted" .= transactionDeleted dtx+ , "time" .= transactionTime dtx+ ] +++ ["rbf" .= transactionRBF dtx | getReplaceByFee net] +++ ["weight" .= w | getSegWit net]+ where+ w = let b = B.length $ S.encode (transactionData dtx) {txWitness = []}+ x = B.length $ S.encode (transactionData dtx)+ in b * 3 + x++transactionToJSON :: Network -> Transaction -> Value+transactionToJSON net = object . transactionPairs net++transactionToEncoding :: Network -> Transaction -> Encoding+transactionToEncoding net = pairs . mconcat . transactionPairs net++instance JsonSerial Transaction where+ jsonSerial = transactionToEncoding+ jsonValue = transactionToJSON++instance BinSerial Transaction where+ binSerial net tx = do+ let (txd, sp) = fromTransaction tx+ binSerial net txd+ binSerial net sp++ binDeserial net = do+ txd <- binDeserial net+ sp <- binDeserial net+ return $ toTransaction txd sp++instance JsonSerial Tx where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial Tx where+ binSerial _ = put+ binDeserial _ = get++instance JsonSerial Block where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial Block where+ binSerial _ = put+ binDeserial _ = get++-- | Information about a connected peer.+data PeerInformation+ = PeerInformation { peerUserAgent :: !ByteString+ -- ^ user agent string+ , peerAddress :: !HostAddress+ -- ^ network address+ , peerVersion :: !Word32+ -- ^ version number+ , peerServices :: !Word64+ -- ^ services field+ , peerRelay :: !Bool+ -- ^ will relay transactions+ }+ deriving (Show, Eq, Ord, Generic, NFData)++-- | JSON serialization for 'PeerInformation'.+peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv]+peerInformationPairs p =+ [ "useragent" .= String (cs (peerUserAgent p))+ , "address" .= String (cs (show (hostToSockAddr (peerAddress p))))+ , "version" .= peerVersion p+ , "services" .= String (encodeHex (S.encode (peerServices p)))+ , "relay" .= peerRelay p+ ]++instance ToJSON PeerInformation where+ toJSON = object . peerInformationPairs+ toEncoding = pairs . mconcat . peerInformationPairs++instance JsonSerial PeerInformation where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial PeerInformation where+ binSerial _ PeerInformation { peerUserAgent = u+ , peerAddress = a+ , peerVersion = v+ , peerServices = s+ , peerRelay = b+ } = do+ putWord32be v+ put b+ put u+ put $ NetworkAddress s a++ binDeserial _ = do+ v <- getWord32be+ b <- get+ u <- get+ NetworkAddress { naServices = s, naAddress = a } <- get+ return $ PeerInformation u a v s b++-- | Address balances for an extended public key.+data XPubBal = XPubBal+ { xPubBalPath :: ![KeyIndex]+ , xPubBal :: !Balance+ } deriving (Show, Eq, Generic, NFData)++-- | JSON serialization for 'XPubBal'.+xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv]+xPubBalPairs net XPubBal {xPubBalPath = p, xPubBal = b} =+ [ "path" .= p+ , "balance" .= balanceToJSON net b+ ]++xPubBalToJSON :: Network -> XPubBal -> Value+xPubBalToJSON net = object . xPubBalPairs net++xPubBalToEncoding :: Network -> XPubBal -> Encoding+xPubBalToEncoding net = pairs . mconcat . xPubBalPairs net++instance JsonSerial XPubBal where+ jsonSerial = xPubBalToEncoding+ jsonValue = xPubBalToJSON++instance BinSerial XPubBal where+ binSerial net XPubBal {xPubBalPath = p, xPubBal = b} = do+ put p+ binSerial net b+ binDeserial net = do+ p <- get+ b <- binDeserial net+ return $ XPubBal p b++-- | Unspent transaction for extended public key.+data XPubUnspent = XPubUnspent+ { xPubUnspentPath :: ![KeyIndex]+ , xPubUnspent :: !Unspent+ } deriving (Show, Eq, Generic, Serialize, NFData)++-- | JSON serialization for 'XPubUnspent'.+xPubUnspentPairs :: A.KeyValue kv => Network -> XPubUnspent -> [kv]+xPubUnspentPairs net XPubUnspent { xPubUnspentPath = p+ , xPubUnspent = u+ } =+ [ "path" .= p+ , "unspent" .= unspentToJSON net u+ ]++xPubUnspentToJSON :: Network -> XPubUnspent -> Value+xPubUnspentToJSON net = object . xPubUnspentPairs net++xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding+xPubUnspentToEncoding net = pairs . mconcat . xPubUnspentPairs net++instance JsonSerial XPubUnspent where+ jsonSerial = xPubUnspentToEncoding+ jsonValue = xPubUnspentToJSON++instance BinSerial XPubUnspent where+ binSerial net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = do+ put p+ binSerial net u++ binDeserial net = do+ p <- get+ u <- binDeserial net+ return $ XPubUnspent p u++data XPubSummary =+ XPubSummary+ { xPubSummaryConfirmed :: !Word64+ , xPubSummaryZero :: !Word64+ , xPubSummaryReceived :: !Word64+ , xPubUnspentCount :: !Word64+ , xPubExternalIndex :: !Word32+ , xPubChangeIndex :: !Word32+ , xPubSummaryPaths :: !(HashMap Address [KeyIndex])+ }+ deriving (Eq, Show, Generic, NFData)++xPubSummaryPairs :: A.KeyValue kv => Network -> XPubSummary -> [kv]+xPubSummaryPairs net XPubSummary { xPubSummaryConfirmed = c+ , xPubSummaryZero = z+ , xPubSummaryReceived = r+ , xPubUnspentCount = u+ , xPubSummaryPaths = ps+ , xPubExternalIndex = ext+ , xPubChangeIndex = ch+ } =+ [ "balance" .=+ object+ [ "confirmed" .= c+ , "unconfirmed" .= z+ , "received" .= r+ , "utxo" .= u+ ]+ , "indices" .= object ["change" .= ch, "external" .= ext]+ , "paths" .= object (mapMaybe (uncurry f) (M.toList ps))+ ]+ where+ f a p = (.= p) <$> addrToString net a++xPubSummaryToJSON :: Network -> XPubSummary -> Value+xPubSummaryToJSON net = object . xPubSummaryPairs net++xPubSummaryToEncoding :: Network -> XPubSummary -> Encoding+xPubSummaryToEncoding net = pairs . mconcat . xPubSummaryPairs net++instance JsonSerial XPubSummary where+ jsonSerial = xPubSummaryToEncoding+ jsonValue = xPubSummaryToJSON++instance BinSerial XPubSummary where+ binSerial net XPubSummary { xPubSummaryConfirmed = c+ , xPubSummaryZero = z+ , xPubSummaryReceived = r+ , xPubUnspentCount = u+ , xPubExternalIndex = ext+ , xPubChangeIndex = ch+ , xPubSummaryPaths = ps+ } = do+ put c+ put z+ put r+ put u+ put ext+ put ch+ put (map (first (runPut . binSerial net)) (M.toList ps))+ binDeserial net = do+ c <- get+ z <- get+ r <- get+ u <- get+ ext <- get+ ch <- get+ ps <- get+ let xs = map (first (runGet (binDeserial net))) ps+ ys <-+ forM xs $ \(k, v) ->+ case k of+ Right a -> return (a, v)+ Left _ -> mzero+ return $ XPubSummary c z r u ext ch (M.fromList ys)++data HealthCheck =+ HealthCheck+ { healthHeaderBest :: !(Maybe BlockHash)+ , healthHeaderHeight :: !(Maybe BlockHeight)+ , healthBlockBest :: !(Maybe BlockHash)+ , healthBlockHeight :: !(Maybe BlockHeight)+ , healthPeers :: !(Maybe Int)+ , healthNetwork :: !String+ , healthOK :: !Bool+ , healthSynced :: !Bool+ , healthLastBlock :: !(Maybe Word64)+ , healthLastTx :: !(Maybe Word64)+ }+ deriving (Show, Eq, Generic, Serialize, NFData)++healthCheckPairs :: A.KeyValue kv => HealthCheck -> [kv]+healthCheckPairs h =+ [ "headers" .=+ object ["hash" .= healthHeaderBest h, "height" .= healthHeaderHeight h]+ , "blocks" .=+ object ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h]+ , "peers" .= healthPeers h+ , "net" .= healthNetwork h+ , "ok" .= healthOK h+ , "synced" .= healthSynced h+ , "version" .= P.version+ , "lastblock" .= healthLastBlock h+ , "lasttx" .= healthLastTx h+ ]++instance ToJSON HealthCheck where+ toJSON = object . healthCheckPairs+ toEncoding = pairs . mconcat . healthCheckPairs++instance JsonSerial HealthCheck where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial HealthCheck where+ binSerial _ HealthCheck { healthHeaderBest = hbest+ , healthHeaderHeight = hheight+ , healthBlockBest = bbest+ , healthBlockHeight = bheight+ , healthPeers = peers+ , healthNetwork = net+ , healthOK = ok+ , healthSynced = synced+ , healthLastBlock = lbk+ , healthLastTx = ltx+ } = do+ put hbest+ put hheight+ put bbest+ put bheight+ put peers+ put net+ put ok+ put synced+ put lbk+ put ltx+ binDeserial _ =+ HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*>+ get <*>+ get <*>+ get++data Event+ = EventBlock BlockHash+ | EventTx TxHash+ deriving (Show, Eq, Generic)++instance ToJSON Event where+ toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h]+ toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h]++instance JsonSerial Event where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial Event where+ binSerial _ (EventBlock bh) = putWord8 0x00 >> put bh+ binSerial _ (EventTx th) = putWord8 0x01 >> put th++ binDeserial _ = getWord8 >>=+ \case+ 0x00-> EventBlock <$> get+ 0x01 -> EventTx <$> get+ _ -> fail "Expected fst byte to be 0x00 or 0x01"+++newtype TxAfterHeight = TxAfterHeight+ { txAfterHeight :: Maybe Bool+ } deriving (Show, Eq, Generic, NFData)++instance ToJSON TxAfterHeight where+ toJSON (TxAfterHeight b) = object ["result" .= b]++instance JsonSerial TxAfterHeight where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial TxAfterHeight where+ binSerial _ TxAfterHeight {txAfterHeight = a} = put a+ binDeserial _ = TxAfterHeight <$> get++newtype TxId = TxId TxHash deriving (Show, Eq, Generic, NFData)++instance ToJSON TxId where+ toJSON (TxId h) = object ["txid" .= h]++instance JsonSerial TxId where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial TxId where+ binSerial _ (TxId th) = put th+ binDeserial _ = TxId <$> get++data BalVal = BalVal+ { 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+ }++balanceToVal :: Balance -> (Address, BalVal)+balanceToVal 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+ })++-- | Default balance for an address.+instance Default BalVal where+ def =+ BalVal+ { balValAmount = 0+ , balValZero = 0+ , balValUnspentCount = 0+ , balValTxCount = 0+ , balValTotalReceived = 0+ }++data UnspentVal = UnspentVal+ { unspentValBlock :: !BlockRef+ , unspentValAmount :: !Word64+ , unspentValScript :: !ShortByteString+ } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)++unspentToVal :: Unspent -> (OutPoint, UnspentVal)+unspentToVal Unspent { unspentBlock = b+ , unspentPoint = p+ , unspentAmount = v+ , unspentScript = s+ } =+ ( p+ , UnspentVal+ {unspentValBlock = b, unspentValAmount = v, unspentValScript = s})++valToUnspent :: OutPoint -> UnspentVal -> Unspent+valToUnspent p UnspentVal { unspentValBlock = b+ , unspentValAmount = v+ , unspentValScript = s+ } =+ Unspent+ { unspentBlock = b+ , unspentPoint = p+ , unspentAmount = v+ , unspentScript = s+ }++-- | Messages that a 'BlockStore' can accept.+data BlockMessage+ = BlockNewBest !BlockNode+ -- ^ new block header in chain+ | BlockPeerConnect !Peer !SockAddr+ -- ^ new peer connected+ | BlockPeerDisconnect !Peer !SockAddr+ -- ^ peer disconnected+ | BlockReceived !Peer !Block+ -- ^ new block received from a peer+ | BlockNotFound !Peer ![BlockHash]+ -- ^ block not found+ | BlockTxReceived !Peer !Tx+ -- ^ transaction received from peer+ | BlockTxAvailable !Peer ![TxHash]+ -- ^ peer has transactions available+ | BlockPing !(Listen ())+ -- ^ internal housekeeping ping++-- | Events that the store can generate.+data StoreEvent+ = StoreBestBlock !BlockHash+ -- ^ new best block+ | StoreMempoolNew !TxHash+ -- ^ new mempool transaction+ | StorePeerConnected !Peer !SockAddr+ -- ^ new peer connected+ | StorePeerDisconnected !Peer !SockAddr+ -- ^ peer has disconnected+ | StorePeerPong !Peer !Word64+ -- ^ peer responded 'Ping'+ | StoreTxAvailable !Peer ![TxHash]+ -- ^ peer inv transactions+ | StoreTxReject !Peer !TxHash !RejectCode !ByteString+ -- ^ peer rejected transaction+ | StoreTxDeleted !TxHash+ -- ^ transaction deleted from store+ | StoreBlockReverted !BlockHash+ -- ^ block no longer head of main chain++data PubExcept+ = PubNoPeers+ | PubReject RejectCode+ | PubTimeout+ | PubPeerDisconnected+ deriving Eq++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"++instance Exception PubExcept++applyOffsetLimit :: Offset -> Maybe Limit -> [a] -> [a]+applyOffsetLimit offset limit = applyLimit limit . applyOffset offset++applyOffset :: Offset -> [a] -> [a]+applyOffset = drop . fromIntegral++applyLimit :: Maybe Limit -> [a] -> [a]+applyLimit Nothing = id+applyLimit (Just l) = take (fromIntegral l)++applyOffsetLimitC :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()+applyOffsetLimitC offset limit = applyOffsetC offset >> applyLimitC limit++applyOffsetC :: Monad m => Offset -> ConduitT i i m ()+applyOffsetC = dropC . fromIntegral++applyLimitC :: Monad m => Maybe Limit -> ConduitT i i m ()+applyLimitC Nothing = mapC id+applyLimitC (Just l) = takeC (fromIntegral l)++sortTxs :: [Tx] -> [(Word32, Tx)]+sortTxs txs = go $ zip [0 ..] txs+ where+ go [] = []+ go ts =+ let (is, ds) =+ partition+ (all ((`notElem` map (txHash . snd) ts) .+ outPointHash . prevOutput) .+ txIn . snd)+ ts+ in is <> go ds
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -2,13 +2,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Store.Data.ImportDB where import Control.Applicative ((<|>)) import Control.Monad (join) import Control.Monad.Except (MonadError)-import Control.Monad.Logger (MonadLoggerIO, logDebugS) import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as R import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)@@ -17,14 +15,23 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I import Data.List (nub)-import Data.Maybe (fromJust, isJust,- maybeToList)+import Data.Maybe (fromJust, fromMaybe,+ isJust, maybeToList) import Database.RocksDB (BatchOp) import Database.RocksDB.Query (deleteOp, insertOp, writeBatch) import Haskoin (Address, BlockHash, BlockHeight, OutPoint (..), Tx, TxHash)+import Network.Haskoin.Store.Common (BalVal, Balance,+ BlockDB (..), BlockData,+ BlockRef (..),+ BlockTx (..), Spender,+ StoreRead (..),+ StoreWrite (..), TxData,+ UnixTime, Unspent,+ UnspentVal, nullBalance,+ zeroBalance) import Network.Haskoin.Store.Data.KeyValue (AddrOutKey (..), AddrTxKey (..), BalKey (..), BestKey (..),@@ -41,13 +48,6 @@ getSpenderH, getSpendersH, getUnspentH, withBlockMem) import Network.Haskoin.Store.Data.RocksDB (withRocksDB)-import Network.Haskoin.Store.Data.Types (BalVal, Balance,- BlockDB (..), BlockData,- BlockRef, BlockTx (..),- Spender, StoreRead (..),- StoreWrite (..), TxData,- UnixTime, Unspent,- UnspentVal) import UnliftIO (MonadIO, TVar, newTVarIO, readTVarIO) @@ -57,17 +57,12 @@ } runImportDB ::- (MonadError e m, MonadLoggerIO m)- => BlockDB- -> ReaderT ImportDB m a- -> m a+ (MonadIO m, MonadError e m) => BlockDB -> ReaderT ImportDB m a -> m a runImportDB bdb@BlockDB {blockDB = db} f = do hm <- newTVarIO emptyBlockMem x <- R.runReaderT f ImportDB {importDB = bdb, importHashMap = hm} ops <- hashMapOps <$> readTVarIO hm- $(logDebugS) "ImportDB" "Committing changes to database" writeBatch db ops- $(logDebugS) "ImportDB" "Finished committing changes to database" return x hashMapOps :: BlockMem -> [BatchOp]@@ -163,8 +158,10 @@ h a b p Nothing = deleteOp AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} -mempoolOp :: [(UnixTime, TxHash)] -> BatchOp-mempoolOp = insertOp MemKey+mempoolOp :: [BlockTx] -> BatchOp+mempoolOp =+ insertOp MemKey .+ map (\BlockTx {blockTxBlock = MemRef t, blockTxHash = h} -> (t, h)) orphanOps :: HashMap TxHash (Maybe (UnixTime, Tx)) -> [BatchOp] orphanOps = map (uncurry f) . M.toList@@ -219,7 +216,7 @@ deleteAddrUnspentI a u ImportDB {importHashMap = hm} = withBlockMem hm $ deleteAddrUnspent a u -setMempoolI :: MonadIO m => [(UnixTime, TxHash)] -> ImportDB -> m ()+setMempoolI :: MonadIO m => [BlockTx] -> ImportDB -> m () setMempoolI xs ImportDB {importHashMap = hm} = withBlockMem hm $ setMempool xs insertOrphanTxI :: MonadIO m => Tx -> UnixTime -> ImportDB -> m ()@@ -278,12 +275,24 @@ dsm <- I.map Just <$> withRocksDB db (getSpenders t) return . I.map fromJust . I.filter isJust $ hsm <> dsm -getBalanceI :: MonadIO m => Address -> ImportDB -> m (Maybe Balance)+getBalanceI :: MonadIO m => Address -> ImportDB -> m Balance getBalanceI a ImportDB {importDB = db, importHashMap = hm} =- runMaybeT $ MaybeT f <|> MaybeT g+ fromMaybe (zeroBalance a) <$> runMaybeT (MaybeT f <|> MaybeT g) where- f = withBlockMem hm $ getBalance a- g = withRocksDB db $ getBalance a+ f =+ withBlockMem hm $+ getBalance a >>= \b ->+ return $+ if nullBalance b+ then Nothing+ else Just b+ g =+ withRocksDB db $+ getBalance a >>= \b ->+ return $+ if nullBalance b+ then Nothing+ else Just b setBalanceI :: MonadIO m => Balance -> ImportDB -> m () setBalanceI b ImportDB {importHashMap = hm} =@@ -307,7 +316,7 @@ getMempoolI :: MonadIO m => ImportDB- -> m [(UnixTime, TxHash)]+ -> m [BlockTx] getMempoolI ImportDB {importHashMap = hm, importDB = db} = getMempoolH <$> readTVarIO hm >>= \case Just xs -> return xs@@ -326,6 +335,7 @@ getMempool = R.ask >>= getMempoolI getAddressesTxs = undefined getAddressesUnspents = undefined+ getOrphans = undefined instance MonadIO m => StoreWrite (ReaderT ImportDB m) where setBest h = R.ask >>= setBestI h
src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -4,24 +4,23 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Network.Haskoin.Store.Data.KeyValue where -import Control.Monad (guard)-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Short as B.Short-import Data.Hashable (Hashable)-import Data.Serialize (Serialize (..), getBytes,- getWord8, putWord8)-import Data.Word (Word32, Word64)-import qualified Database.RocksDB.Query as R-import GHC.Generics (Generic)-import Haskoin (Address, BlockHash,- BlockHeight, OutPoint (..),- Tx, TxHash)-import Network.Haskoin.Store.Data.Types (BalVal, BlockData, BlockRef,- BlockTx (..), Spender,- TxData, UnixTime,- Unspent (..), UnspentVal,- getUnixTime, putUnixTime)+import Control.Monad (guard)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Short as B.Short+import Data.Hashable (Hashable)+import Data.Serialize (Serialize (..), getBytes,+ getWord8, putWord8)+import Data.Word (Word32, Word64)+import qualified Database.RocksDB.Query as R+import GHC.Generics (Generic)+import Haskoin (Address, BlockHash, BlockHeight,+ OutPoint (..), Tx, TxHash)+import Network.Haskoin.Store.Common (BalVal, BlockData, BlockRef,+ BlockTx (..), Spender, TxData,+ UnixTime, Unspent (..),+ UnspentVal, getUnixTime,+ putUnixTime) -- | Database key for an address transaction. data AddrTxKey
src/Network/Haskoin/Store/Data/Memory.hs view
@@ -20,19 +20,18 @@ BlockHeight, OutPoint (..), Tx, TxHash, headerHash, txHash)-import Network.Haskoin.Store.Data.KeyValue (OutVal (..))-import Network.Haskoin.Store.Data.Types (BalVal, Balance,+import Network.Haskoin.Store.Common (BalVal, Balance, BlockData (..), BlockRef, BlockTx (..), Limit, Spender, StoreRead (..),- StoreStream (..), StoreWrite (..), TxData (..), UnixTime, Unspent (..), UnspentVal,- balanceToVal,+ applyLimit, balanceToVal, unspentToVal, valToBalance,- valToUnspent)+ valToUnspent, zeroBalance)+import Network.Haskoin.Store.Data.KeyValue (OutVal (..)) import UnliftIO withBlockMem :: MonadIO m => TVar BlockMem -> ReaderT (TVar BlockMem) m a -> m a@@ -48,7 +47,7 @@ , hBalance :: !(HashMap Address BalVal) , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool))) , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal))))- , hMempool :: !(Maybe [(UnixTime, TxHash)])+ , hMempool :: !(Maybe [BlockTx]) , hOrphans :: !(HashMap TxHash (Maybe (UnixTime, Tx))) } deriving (Eq, Show) @@ -88,14 +87,15 @@ getSpendersH :: TxHash -> BlockMem -> IntMap (Maybe Spender) getSpendersH t = M.lookupDefault I.empty t . hSpender -getBalanceH :: Address -> BlockMem -> Maybe Balance-getBalanceH a = fmap (valToBalance a) . M.lookup a . hBalance+getBalanceH :: Address -> BlockMem -> Balance+getBalanceH a =+ fromMaybe (zeroBalance a) . fmap (valToBalance a) . M.lookup a . hBalance -getMempoolH :: BlockMem -> Maybe [(UnixTime, TxHash)]+getMempoolH :: BlockMem -> Maybe [BlockTx] getMempoolH = hMempool -getOrphansH :: Monad m => BlockMem -> ConduitT i (UnixTime, Tx) m ()-getOrphansH = yieldMany . catMaybes . M.elems . hOrphans+getOrphansH :: BlockMem -> [(UnixTime, Tx)]+getOrphansH = catMaybes . M.elems . hOrphans getOrphanTxH :: TxHash -> BlockMem -> Maybe (Maybe (UnixTime, Tx)) getOrphanTxH h = M.lookup h . hOrphans@@ -113,29 +113,25 @@ getAddressesTxsH :: [Address] -> Maybe BlockRef -> Maybe Limit -> BlockMem -> [BlockTx]-getAddressesTxsH addrs start limit db =- case limit of- Nothing -> g- Just l -> take (fromIntegral l) g+getAddressesTxsH addrs start limit db = applyLimit limit xs where- g =+ xs = nub . sortBy (flip compare `on` blockTxBlock) . concat $- map (\a -> getAddressTxsH a start db) addrs+ map (\a -> getAddressTxsH a start limit db) addrs -getAddressTxsH :: Address -> Maybe BlockRef -> BlockMem -> [BlockTx]-getAddressTxsH a mbr db =+getAddressTxsH ::+ Address -> Maybe BlockRef -> Maybe Limit -> BlockMem -> [BlockTx]+getAddressTxsH addr start limit db =+ applyLimit limit . dropWhile h . sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $- M.lookupDefault M.empty a (hAddrTx db)+ M.lookupDefault M.empty addr (hAddrTx db) where f b hm = map (uncurry (g b)) $ M.toList hm- g b h' True =- Just- BlockTx- {blockTxBlock = b, blockTxHash = h'}+ g b h' True = Just BlockTx {blockTxBlock = b, blockTxHash = h'} g _ _ False = Nothing h BlockTx {blockTxBlock = b} =- case mbr of+ case start of Nothing -> False Just br -> b > br @@ -145,21 +141,19 @@ getAddressesUnspentsH :: [Address] -> Maybe BlockRef -> Maybe Limit -> BlockMem -> [Unspent]-getAddressesUnspentsH addrs start limit db =- case limit of- Nothing -> g- Just l -> take (fromIntegral l) g+getAddressesUnspentsH addrs start limit db = applyLimit limit xs where- g =+ xs = nub . sortBy (flip compare `on` unspentBlock) . concat $- map (\a -> getAddressUnspentsH a start db) addrs+ map (\a -> getAddressUnspentsH a start limit db) addrs getAddressUnspentsH ::- Address -> Maybe BlockRef -> BlockMem -> [Unspent]-getAddressUnspentsH a mbr db =+ Address -> Maybe BlockRef -> Maybe Limit -> BlockMem -> [Unspent]+getAddressUnspentsH addr start limit db =+ applyLimit limit . dropWhile h . sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $- M.lookupDefault M.empty a (hAddrOut db)+ M.lookupDefault M.empty addr (hAddrOut db) where f b hm = map (uncurry (g b)) $ M.toList hm g b p (Just u) =@@ -172,7 +166,7 @@ } g _ _ Nothing = Nothing h Unspent {unspentBlock = b} =- case mbr of+ case start of Nothing -> False Just br -> b > br @@ -261,7 +255,7 @@ (M.singleton (unspentPoint u) Nothing)) in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)} -setMempoolH :: [(UnixTime, TxHash)] -> BlockMem -> BlockMem+setMempoolH :: [BlockTx] -> BlockMem -> BlockMem setMempoolH xs db = db {hMempool = Just xs} insertOrphanTxH :: Tx -> UnixTime -> BlockMem -> BlockMem@@ -337,23 +331,15 @@ getAddressesUnspents addr start limit = do v <- R.ask >>= readTVarIO return $ getAddressesUnspentsH addr start limit v--instance MonadIO m => StoreStream (ReaderT (TVar BlockMem) m) where getOrphans = do v <- R.ask >>= readTVarIO- getOrphansH v- getAddressTxs a m = do- v <- R.ask >>= readTVarIO- yieldMany $ getAddressTxsH a m v- getAddressUnspents a m = do- v <- R.ask >>= readTVarIO- yieldMany $ getAddressUnspentsH a m v- getAddressBalances = do+ return $ getOrphansH v+ getAddressTxs addr start limit = do v <- R.ask >>= readTVarIO- getAddressBalancesH v- getUnspents = do+ return $ getAddressTxsH addr start limit v+ getAddressUnspents addr start limit = do v <- R.ask >>= readTVarIO- getUnspentsH v+ return $ getAddressUnspentsH addr start limit v instance (MonadIO m) => StoreWrite (ReaderT (TVar BlockMem) m) where setBest h = do
src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -7,7 +7,6 @@ mapC, runConduit, runResourceT, sinkList, (.|))-import Control.Monad (forM_) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Data.Function (on)@@ -26,6 +25,16 @@ import Haskoin (Address, BlockHash, BlockHeight, OutPoint (..), Tx, TxHash)+import Network.Haskoin.Store.Common (Balance, BlockDB (..),+ BlockData, BlockRef (..),+ BlockTx (..), Limit,+ Spender, StoreRead (..),+ TxData, UnixTime,+ Unspent (..),+ UnspentVal (..),+ applyLimit, applyLimitC,+ valToBalance,+ valToUnspent, zeroBalance) import Network.Haskoin.Store.Data.KeyValue (AddrOutKey (..), AddrTxKey (..), BalKey (..), BestKey (..),@@ -39,15 +48,6 @@ UnspentKey (..), VersionKey (..), toUnspent)-import Network.Haskoin.Store.Data.Types (Balance, BlockDB (..),- BlockData, BlockRef,- BlockTx (..), Limit,- Spender, StoreRead (..),- StoreStream (..), TxData,- UnixTime, Unspent (..),- UnspentVal (..),- applyLimit, valToBalance,- valToUnspent) import UnliftIO (MonadIO, liftIO) dataVersion :: Word32@@ -125,20 +125,24 @@ f (SpenderKey op) s = (fromIntegral (outPointIndex op), s) f _ _ = undefined -getBalanceDB :: MonadIO m => Address -> BlockDB -> m (Maybe Balance)+getBalanceDB :: MonadIO m => Address -> BlockDB -> m Balance getBalanceDB a BlockDB {blockDBopts = opts, blockDB = db} =- fmap (valToBalance a) <$> retrieve db opts (BalKey a)+ fromMaybe (zeroBalance a) . fmap (valToBalance a) <$>+ retrieve db opts (BalKey a) -getMempoolDB :: MonadIO m => BlockDB -> m [(UnixTime, TxHash)]+getMempoolDB :: MonadIO m => BlockDB -> m [BlockTx] getMempoolDB BlockDB {blockDBopts = opts, blockDB = db} =- fromMaybe [] <$> retrieve db opts MemKey+ fmap f . fromMaybe [] <$> retrieve db opts MemKey+ where+ f (t, h) = BlockTx {blockTxBlock = MemRef t, blockTxHash = h} getOrphansDB ::- (MonadIO m, MonadResource m)+ MonadIO m => BlockDB- -> ConduitT i (UnixTime, Tx) m ()+ -> m [(UnixTime, Tx)] getOrphansDB BlockDB {blockDBopts = opts, blockDB = db} =- matching db opts OrphanKeyS .| mapC snd+ liftIO . runResourceT . runConduit $+ matching db opts OrphanKeyS .| mapC snd .| sinkList getOrphanTxDB :: MonadIO m => TxHash -> BlockDB -> m (Maybe (UnixTime, Tx)) getOrphanTxDB h BlockDB {blockDBopts = opts, blockDB = db} =@@ -151,29 +155,24 @@ -> Maybe Limit -> BlockDB -> m [BlockTx]-getAddressesTxsDB addrs start limit db =- liftIO . runResourceT $ do- ts <-- runConduit $- forM_ addrs (\a -> getAddressTxsDB a start db .| applyLimit limit) .|- sinkList- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- return $- case limit of- Just l -> take (fromIntegral l) ts'- Nothing -> ts'+getAddressesTxsDB addrs start limit db = do+ ts <- concat <$> mapM (\a -> getAddressTxsDB a start limit db) addrs+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyLimit limit ts' getAddressTxsDB ::- (MonadIO m, MonadResource m)+ MonadIO m => Address -> Maybe BlockRef+ -> Maybe Limit -> BlockDB- -> ConduitT i BlockTx m ()-getAddressTxsDB a mbr BlockDB {blockDBopts = opts, blockDB = db} =- x .| mapC (uncurry f)+ -> m [BlockTx]+getAddressTxsDB a start limit BlockDB {blockDBopts = opts, blockDB = db} =+ liftIO . runResourceT . runConduit $+ x .| applyLimitC limit .| mapC (uncurry f) .| sinkList where x =- case mbr of+ case start of Nothing -> matching db opts (AddrTxKeyA a) Just br -> matchingSkip db opts (AddrTxKeyA a) (AddrTxKeyB a br) f AddrTxKey {addrTxKeyT = t} () = t@@ -205,31 +204,24 @@ -> Maybe Limit -> BlockDB -> m [Unspent]-getAddressesUnspentsDB addrs start limit bdb =- liftIO . runResourceT $ do- us <-- runConduit $- forM_- addrs- (\a -> getAddressUnspentsDB a start bdb .| applyLimit limit) .|- sinkList- let us' = nub $ sortBy (flip compare `on` unspentBlock) us- return $- case limit of- Just l -> take (fromIntegral l) us'- Nothing -> us'+getAddressesUnspentsDB addrs start limit bdb = do+ us <- concat <$> mapM (\a -> getAddressUnspentsDB a start limit bdb) addrs+ let us' = nub $ sortBy (flip compare `on` unspentBlock) us+ return $ applyLimit limit us' getAddressUnspentsDB ::- (MonadIO m, MonadResource m)+ MonadIO m => Address -> Maybe BlockRef+ -> Maybe Limit -> BlockDB- -> ConduitT i Unspent m ()-getAddressUnspentsDB a mbr BlockDB {blockDBopts = opts, blockDB = db} =- x .| mapC (uncurry toUnspent)+ -> m [Unspent]+getAddressUnspentsDB a start limit BlockDB {blockDBopts = opts, blockDB = db} =+ liftIO . runResourceT . runConduit $+ x .| applyLimitC limit .| mapC (uncurry toUnspent) .| sinkList where x =- case mbr of+ case start of Nothing -> matching db opts (AddrOutKeyA a) Just br -> matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a br) @@ -260,10 +252,6 @@ ask >>= getAddressesTxsDB addrs start limit getAddressesUnspents addrs start limit = ask >>= getAddressesUnspentsDB addrs start limit--instance (MonadResource m, MonadIO m) => StoreStream (ReaderT BlockDB m) where getOrphans = ask >>= getOrphansDB- getAddressUnspents a b = ask >>= getAddressUnspentsDB a b- getAddressTxs a b = ask >>= getAddressTxsDB a b- getAddressBalances = ask >>= getAddressBalancesDB- getUnspents = ask >>= getUnspentsDB+ getAddressUnspents a b c = ask >>= getAddressUnspentsDB a b c+ getAddressTxs a b c = ask >>= getAddressTxsDB a b c
− src/Network/Haskoin/Store/Data/Types.hs
@@ -1,1341 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.Haskoin.Store.Data.Types where--import Conduit (ConduitT, dropC, mapC, takeC)-import Control.Applicative ((<|>))-import Control.Arrow (first)-import Control.DeepSeq (NFData)-import Control.Exception (Exception)-import Control.Monad (forM, guard, mzero)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Aeson (Encoding, ToJSON (..), Value (..),- object, pairs, (.=))-import qualified Data.Aeson as A-import qualified Data.Aeson.Encoding as A-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Short (ShortByteString)-import qualified Data.ByteString.Short as B.Short-import Data.Default (Default (..))-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import qualified Data.IntMap as I-import Data.IntMap.Strict (IntMap)-import Data.Maybe (catMaybes, isJust, listToMaybe,- mapMaybe)-import Data.Serialize as S-import Data.String.Conversions (cs)-import qualified Data.Text.Encoding as T-import Data.Word (Word32, Word64)-import Database.RocksDB (DB, ReadOptions)-import GHC.Generics (Generic)-import Haskoin (Address, Block, BlockHash,- BlockHeader (..), BlockHeight,- BlockNode, BlockWork, HostAddress,- KeyIndex, Network (..),- NetworkAddress (..), OutPoint (..),- RejectCode (..), Tx (..),- TxHash (..), TxIn (..), TxOut (..),- WitnessStack, addrToJSON,- addrToString, eitherToMaybe,- encodeHex, headerHash,- hostToSockAddr, scriptToAddressBS,- stringToAddr, txHash)-import Haskoin.Node (Chain, HostPort, Manager, Peer)-import Network.Socket (SockAddr)-import NQE (Listen, Mailbox)-import qualified Paths_haskoin_store as P--encodeShort :: Serialize a => a -> ShortByteString-encodeShort = B.Short.toShort . S.encode--decodeShort :: Serialize a => ShortByteString -> a-decodeShort bs = case S.decode (B.Short.fromShort bs) of- Left e -> error e- Right a -> a---- | Mailbox for block store.-type BlockStore = Mailbox BlockMessage---- | Store mailboxes.-data Store =- Store- { storeManager :: !Manager- -- ^ peer manager mailbox- , storeChain :: !Chain- -- ^ chain header process mailbox- , storeBlock :: !BlockStore- -- ^ block storage mailbox- }---- | Configuration for a 'Store'.-data StoreConfig =- StoreConfig- { storeConfMaxPeers :: !Int- -- ^ max peers to connect to- , storeConfInitPeers :: ![HostPort]- -- ^ static set of peers to connect to- , storeConfDiscover :: !Bool- -- ^ discover new peers?- , storeConfDB :: !BlockDB- -- ^ RocksDB database handler- , storeConfNetwork :: !Network- -- ^ network constants- , storeConfListen :: !(Listen StoreEvent)- -- ^ listen to store events- }---- | Configuration for a block store.-data BlockConfig =- BlockConfig- { blockConfManager :: !Manager- -- ^ peer manager from running node- , blockConfChain :: !Chain- -- ^ chain from a running node- , blockConfListener :: !(Listen StoreEvent)- -- ^ listener for store events- , blockConfDB :: !BlockDB- -- ^ RocksDB database handle- , blockConfNet :: !Network- -- ^ network constants- }--data BlockDB =- BlockDB- { blockDB :: !DB- , blockDBopts :: !ReadOptions- }--type UnixTime = Word64-type BlockPos = Word32--type Offset = Word32-type Limit = Word32--class Monad m =>- StoreRead m- where- getBestBlock :: m (Maybe BlockHash)- getBlocksAtHeight :: BlockHeight -> m [BlockHash]- getBlock :: BlockHash -> m (Maybe BlockData)- getTxData :: TxHash -> m (Maybe TxData)- getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx))- getSpenders :: TxHash -> m (IntMap Spender)- getSpender :: OutPoint -> m (Maybe Spender)- getBalance :: Address -> m (Maybe Balance)- getBalance a = head <$> getBalances [a]- getBalances :: [Address] -> m [(Maybe Balance)]- getBalances as = mapM getBalance as- getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]- getUnspent :: OutPoint -> m (Maybe Unspent)- getAddressesUnspents ::- [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]- getMempool :: m [(UnixTime, TxHash)]--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 -> BlockTx -> m ()- deleteAddrTx :: Address -> BlockTx -> m ()- insertAddrUnspent :: Address -> Unspent -> m ()- deleteAddrUnspent :: Address -> Unspent -> m ()- setMempool :: [(UnixTime, TxHash)] -> m ()- insertOrphanTx :: Tx -> UnixTime -> m ()- deleteOrphanTx :: TxHash -> m ()- setBalance :: Balance -> m ()- insertUnspent :: Unspent -> m ()- deleteUnspent :: OutPoint -> m ()--class StoreStream m where- getOrphans :: ConduitT i (UnixTime, Tx) m ()- getAddressUnspents :: Address -> Maybe BlockRef -> ConduitT i Unspent m ()- getAddressTxs :: Address -> Maybe BlockRef -> ConduitT i BlockTx m ()- getAddressBalances :: ConduitT i Balance m ()- getUnspents :: ConduitT i Unspent m ()--getTransaction ::- (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction)-getTransaction h = runMaybeT $ do- d <- MaybeT $ getTxData h- sm <- lift $ getSpenders h- return $ toTransaction d sm--blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData)-blockAtOrBefore q = runMaybeT $ do- a <- g 0- b <- MaybeT getBestBlock >>= MaybeT . getBlock- f a b- where- f a b- | t b <= q = return b- | t a > q = mzero- | h b - h a == 1 = return a- | otherwise = do- let x = h a + (h b - h a) `div` 2- m <- g x- if t m > q then f a m else f m b- g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock- h = blockDataHeight- t = fromIntegral . blockTimestamp . blockDataHeader---- | Serialize such that ordering is inverted.-putUnixTime :: Word64 -> Put-putUnixTime w = putWord64be $ maxBound - w--getUnixTime :: Get Word64-getUnixTime = (maxBound -) <$> getWord64be--class JsonSerial a where- jsonSerial :: Network -> a -> Encoding- jsonValue :: Network -> a -> Value--instance JsonSerial a => JsonSerial [a] where- jsonSerial net = A.list (jsonSerial net)- jsonValue net = toJSON . (jsonValue net)--instance JsonSerial TxHash where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial TxHash where- binSerial _ = put- binDeserial _ = get--instance BinSerial Address where- binSerial net a =- case addrToString net a of- Nothing -> put B.empty- Just x -> put $ T.encodeUtf8 x-- binDeserial net = do- bs <- get- guard (not (B.null bs))- t <- case T.decodeUtf8' bs of- Left _ -> mzero- Right v -> return v- case stringToAddr net t of- Nothing -> mzero- Just x -> return x--class BinSerial a where- binSerial :: Network -> Putter a- binDeserial :: Network -> Get a--instance BinSerial a => BinSerial [a] where- binSerial net = putListOf (binSerial net)- binDeserial net = getListOf (binDeserial net)---- | Reference to a block where a transaction is stored.-data BlockRef- = BlockRef { blockRefHeight :: !BlockHeight- -- ^ block height in the chain- , blockRefPos :: !Word32- -- ^ position of transaction within the block- }- | MemRef { memRefTime :: !UnixTime }- deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)---- | Serialized entities will sort in reverse order.-instance Serialize BlockRef where- put MemRef {memRefTime = t} = do- putWord8 0x00- putUnixTime t- put BlockRef {blockRefHeight = h, blockRefPos = p} = do- putWord8 0x01- putWord32be (maxBound - h)- putWord32be (maxBound - p)- get = getmemref <|> getblockref- where- getmemref = do- guard . (== 0x00) =<< getWord8- MemRef <$> getUnixTime- getblockref = do- guard . (== 0x01) =<< getWord8- h <- (maxBound -) <$> getWord32be- p <- (maxBound -) <$> getWord32be- return BlockRef {blockRefHeight = h, blockRefPos = p}--instance BinSerial BlockRef where- binSerial _ BlockRef {blockRefHeight = h, blockRefPos = p} = do- putWord8 0x00- putWord32be h- putWord32be p- binSerial _ MemRef {memRefTime = t} = do- putWord8 0x01- putWord64be t-- binDeserial _ = getWord8 >>=- \case- 0x00 -> BlockRef <$> getWord32be <*> getWord32be- 0x01 -> MemRef <$> getUnixTime- _ -> fail "Expected fst byte to be 0x00 or 0x01"---- | JSON serialization for 'BlockRef'.-blockRefPairs :: A.KeyValue kv => BlockRef -> [kv]-blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} =- ["height" .= h, "position" .= p]-blockRefPairs MemRef {memRefTime = t} = ["mempool" .= t]--confirmed :: BlockRef -> Bool-confirmed BlockRef {} = True-confirmed MemRef {} = False--instance ToJSON BlockRef where- toJSON = object . blockRefPairs- toEncoding = pairs . mconcat . blockRefPairs---- | Transaction in relation to an address.-data BlockTx = BlockTx- { blockTxBlock :: !BlockRef- -- ^ block information- , blockTxHash :: !TxHash- -- ^ transaction hash- } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData)---- | JSON serialization for 'AddressTx'.-blockTxPairs :: A.KeyValue kv => BlockTx -> [kv]-blockTxPairs btx =- [ "txid" .= blockTxHash btx- , "block" .= blockTxBlock btx- ]--instance ToJSON BlockTx where- toJSON = object . blockTxPairs- toEncoding = pairs . mconcat . blockTxPairs--instance JsonSerial BlockTx where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial BlockTx where- binSerial net BlockTx { blockTxBlock = b, blockTxHash = h } = do- binSerial net b- binSerial net h-- binDeserial net = BlockTx <$> binDeserial net <*> binDeserial net---- | Address balance information.-data Balance = Balance- { balanceAddress :: !Address- -- ^ address balance- , balanceAmount :: !Word64- -- ^ confirmed balance- , balanceZero :: !Word64- -- ^ unconfirmed balance- , balanceUnspentCount :: !Word64- -- ^ number of unspent outputs- , balanceTxCount :: !Word64- -- ^ number of transactions- , balanceTotalReceived :: !Word64- -- ^ total amount from all outputs in this address- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--zeroBalance :: Address -> Balance-zeroBalance a =- Balance- { balanceAddress = a- , balanceAmount = 0- , balanceUnspentCount = 0- , balanceZero = 0- , balanceTxCount = 0- , balanceTotalReceived = 0- }---- | JSON serialization for 'Balance'.-balancePairs :: A.KeyValue kv => Network -> Balance -> [kv]-balancePairs net ab =- [ "address" .= addrToJSON net (balanceAddress ab)- , "confirmed" .= balanceAmount ab- , "unconfirmed" .= balanceZero ab- , "utxo" .= balanceUnspentCount ab- , "txs" .= balanceTxCount ab- , "received" .= balanceTotalReceived ab- ]--balanceToJSON :: Network -> Balance -> Value-balanceToJSON net = object . balancePairs net--balanceToEncoding :: Network -> Balance -> Encoding-balanceToEncoding net = pairs . mconcat . balancePairs net--instance JsonSerial Balance where- jsonSerial = balanceToEncoding- jsonValue = balanceToJSON--instance BinSerial Balance where- binSerial net Balance { balanceAddress = a- , balanceAmount = v- , balanceZero = z- , balanceUnspentCount = u- , balanceTxCount = c- , balanceTotalReceived = t- } = do- binSerial net a- putWord64be v- putWord64be z- putWord64be u- putWord64be c- putWord64be t-- binDeserial net =- Balance <$> binDeserial net- <*> getWord64be- <*> getWord64be- <*> getWord64be- <*> getWord64be- <*> getWord64be----- | Unspent output.-data Unspent = Unspent- { unspentBlock :: !BlockRef- -- ^ block information for output- , unspentPoint :: !OutPoint- -- ^ txid and index where output located- , unspentAmount :: !Word64- -- ^ value of output in satoshi- , unspentScript :: !ShortByteString- -- ^ pubkey (output) script- } deriving (Show, Eq, Ord, Generic, Hashable, NFData)--instance Serialize Unspent where- put u = do- put $ unspentBlock u- put $ unspentPoint u- put $ unspentAmount u- put $ B.Short.length (unspentScript u)- putShortByteString $ unspentScript u- get =- Unspent <$> get <*> get <*> get <*> (getShortByteString =<< get)--unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv]-unspentPairs net u =- [ "address" .=- eitherToMaybe- (addrToJSON net <$>- scriptToAddressBS (B.Short.fromShort (unspentScript u)))- , "block" .= unspentBlock u- , "txid" .= outPointHash (unspentPoint u)- , "index" .= outPointIndex (unspentPoint u)- , "pkscript" .= String (encodeHex (B.Short.fromShort (unspentScript u)))- , "value" .= unspentAmount u- ]--unspentToJSON :: Network -> Unspent -> Value-unspentToJSON net = object . unspentPairs net--unspentToEncoding :: Network -> Unspent -> Encoding-unspentToEncoding net = pairs . mconcat . unspentPairs net--instance JsonSerial Unspent where- jsonSerial = unspentToEncoding- jsonValue = unspentToJSON--instance BinSerial Unspent where- binSerial net Unspent { unspentBlock = b- , unspentPoint = p- , unspentAmount = v- , unspentScript = s- } = do- binSerial net b- put p- putWord64be v- put s-- binDeserial net =- Unspent- <$> binDeserial net- <*> get- <*> getWord64be- <*> get---- | Database value for a block entry.-data BlockData = BlockData- { blockDataHeight :: !BlockHeight- -- ^ height of the block in the chain- , blockDataMainChain :: !Bool- -- ^ is this block in the main chain?- , blockDataWork :: !BlockWork- -- ^ accumulated work in that block- , blockDataHeader :: !BlockHeader- -- ^ block header- , blockDataSize :: !Word32- -- ^ size of the block including witnesses- , blockDataWeight :: !Word32- -- ^ weight of this block (for segwit networks)- , blockDataTxs :: ![TxHash]- -- ^ block transactions- , blockDataOutputs :: !Word64- -- ^ sum of all transaction outputs- , blockDataFees :: !Word64- -- ^ sum of all transaction fees- , blockDataSubsidy :: !Word64- -- ^ block subsidy- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)---- | JSON serialization for 'BlockData'.-blockDataPairs :: A.KeyValue kv => Network -> BlockData -> [kv]-blockDataPairs net bv =- [ "hash" .= headerHash (blockDataHeader bv)- , "height" .= blockDataHeight bv- , "mainchain" .= blockDataMainChain bv- , "previous" .= prevBlock (blockDataHeader bv)- , "time" .= blockTimestamp (blockDataHeader bv)- , "version" .= blockVersion (blockDataHeader bv)- , "bits" .= blockBits (blockDataHeader bv)- , "nonce" .= bhNonce (blockDataHeader bv)- , "size" .= blockDataSize bv- , "tx" .= blockDataTxs bv- , "merkle" .= TxHash (merkleRoot (blockDataHeader bv))- , "subsidy" .= blockDataSubsidy bv- , "fees" .= blockDataFees bv- , "outputs" .= blockDataOutputs bv- ] ++ ["weight" .= blockDataWeight bv | getSegWit net]--blockDataToJSON :: Network -> BlockData -> Value-blockDataToJSON net = object . blockDataPairs net--blockDataToEncoding :: Network -> BlockData -> Encoding-blockDataToEncoding net = pairs . mconcat . blockDataPairs net--instance JsonSerial BlockData where- jsonSerial = blockDataToEncoding- jsonValue = blockDataToJSON--instance BinSerial BlockData where- binSerial _ BlockData { blockDataHeight = e- , blockDataMainChain = m- , blockDataWork = w- , blockDataHeader = h- , blockDataSize = z- , blockDataWeight = g- , blockDataTxs = t- , blockDataOutputs = o- , blockDataFees = f- , blockDataSubsidy = y- } = do- put m- putWord32be e- put h- put w- putWord32be z- putWord32be g- putWord64be o- putWord64be f- putWord64be y- put t-- binDeserial _ = do- m <- get- e <- getWord32be- h <- get- w <- get- z <- getWord32be- g <- getWord32be- o <- getWord64be- f <- getWord64be- y <- getWord64be- t <- get- return $ BlockData e m w h z g t o f y---- | Input information.-data StoreInput- = StoreCoinbase { inputPoint :: !OutPoint- -- ^ output being spent (should be null)- , inputSequence :: !Word32- -- ^ sequence- , inputSigScript :: !ByteString- -- ^ input script data (not valid script)- , inputWitness :: !(Maybe WitnessStack)- -- ^ witness data for this input (only segwit)- }- -- ^ coinbase details- | StoreInput { inputPoint :: !OutPoint- -- ^ output being spent- , inputSequence :: !Word32- -- ^ sequence- , inputSigScript :: !ByteString- -- ^ signature (input) script- , inputPkScript :: !ByteString- -- ^ pubkey (output) script from previous tx- , inputAmount :: !Word64- -- ^ amount in satoshi being spent spent- , inputWitness :: !(Maybe WitnessStack)- -- ^ witness data for this input (only segwit)- }- -- ^ input details- deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--isCoinbase :: StoreInput -> Bool-isCoinbase StoreCoinbase {} = True-isCoinbase StoreInput {} = False--inputPairs :: A.KeyValue kv => Network -> StoreInput -> [kv]-inputPairs net StoreInput { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputPkScript = ps- , inputAmount = val- , inputWitness = wit- } =- [ "coinbase" .= False- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= String (encodeHex ps)- , "value" .= val- , "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps)- ] ++- ["witness" .= fmap (map encodeHex) wit | getSegWit net]--inputPairs net StoreCoinbase { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputWitness = wit- } =- [ "coinbase" .= True- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= Null- , "value" .= Null- , "address" .= Null- ] ++- ["witness" .= fmap (map encodeHex) wit | getSegWit net]--inputToJSON :: Network -> StoreInput -> Value-inputToJSON net = object . inputPairs net--inputToEncoding :: Network -> StoreInput -> Encoding-inputToEncoding net = pairs . mconcat . inputPairs net---- | Information about input spending output.-data Spender = Spender- { spenderHash :: !TxHash- -- ^ input transaction hash- , spenderIndex :: !Word32- -- ^ input position in transaction- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)---- | JSON serialization for 'Spender'.-spenderPairs :: A.KeyValue kv => Spender -> [kv]-spenderPairs n =- ["txid" .= spenderHash n, "input" .= spenderIndex n]--instance ToJSON Spender where- toJSON = object . spenderPairs- toEncoding = pairs . mconcat . spenderPairs---- | Output information.-data StoreOutput = StoreOutput- { outputAmount :: !Word64- -- ^ amount in satoshi- , outputScript :: !ByteString- -- ^ pubkey (output) script- , outputSpender :: !(Maybe Spender)- -- ^ input spending this transaction- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--outputPairs :: A.KeyValue kv => Network -> StoreOutput -> [kv]-outputPairs net d =- [ "address" .=- eitherToMaybe (addrToJSON net <$> scriptToAddressBS (outputScript d))- , "pkscript" .= String (encodeHex (outputScript d))- , "value" .= outputAmount d- , "spent" .= isJust (outputSpender d)- ] ++- ["spender" .= outputSpender d | isJust (outputSpender d)]--outputToJSON :: Network -> StoreOutput -> Value-outputToJSON net = object . outputPairs net--outputToEncoding :: Network -> StoreOutput -> Encoding-outputToEncoding net = pairs . mconcat . outputPairs net--data Prev = Prev- { prevScript :: !ByteString- , prevAmount :: !Word64- } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)--toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput-toInput i Nothing w =- StoreCoinbase- { inputPoint = prevOutput i- , inputSequence = txInSequence i- , inputSigScript = scriptInput i- , inputWitness = w- }-toInput i (Just p) w =- StoreInput- { inputPoint = prevOutput i- , inputSequence = txInSequence i- , inputSigScript = scriptInput i- , inputPkScript = prevScript p- , inputAmount = prevAmount p- , inputWitness = w- }--toOutput :: TxOut -> Maybe Spender -> StoreOutput-toOutput o s =- StoreOutput- { outputAmount = outValue o- , outputScript = scriptOutput o- , outputSpender = s- }--data TxData = TxData- { txDataBlock :: !BlockRef- , txData :: !Tx- , txDataPrevs :: !(IntMap Prev)- , txDataDeleted :: !Bool- , txDataRBF :: !Bool- , txDataTime :: !Word64- } deriving (Show, Eq, Ord, Generic, Serialize, NFData)--instance BinSerial TxData where- binSerial _ TxData- { txDataBlock = br- , txData = tx- , txDataPrevs = dp- , txDataDeleted = dd- , txDataRBF = dr- , txDataTime = t- } = do- put br- put tx- put dp- put dd- put dr- putWord64be t-- binDeserial _ = do br <- get- tx <- get- dp <- get- dd <- get- dr <- get- TxData br tx dp dd dr <$> getWord64be--instance Serialize a => BinSerial (IntMap a) where- binSerial _ = put- binDeserial _ = get--toTransaction :: TxData -> IntMap Spender -> Transaction-toTransaction t sm =- Transaction- { transactionBlock = txDataBlock t- , transactionVersion = txVersion (txData t)- , transactionLockTime = txLockTime (txData t)- , transactionInputs = ins- , transactionOutputs = outs- , transactionDeleted = txDataDeleted t- , transactionRBF = txDataRBF t- , transactionTime = txDataTime t- }- where- ws =- take (length (txIn (txData t))) $- map Just (txWitness (txData t)) <> repeat Nothing- f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n)- ins = zipWith f [0 ..] (txIn (txData t))- g n o = toOutput o (I.lookup n sm)- outs = zipWith g [0 ..] (txOut (txData t))--fromTransaction :: Transaction -> (TxData, IntMap Spender)-fromTransaction t = (d, sm)- where- d =- TxData- { txDataBlock = transactionBlock t- , txData = transactionData t- , txDataPrevs = ps- , txDataDeleted = transactionDeleted t- , txDataRBF = transactionRBF t- , txDataTime = transactionTime t- }- f _ StoreCoinbase {} = Nothing- f n StoreInput {inputPkScript = s, inputAmount = v} =- Just (n, Prev {prevScript = s, prevAmount = v})- ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t)- g _ StoreOutput {outputSpender = Nothing} = Nothing- g n StoreOutput {outputSpender = Just s} = Just (n, s)- sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t)---- | Detailed transaction information.-data Transaction = Transaction- { transactionBlock :: !BlockRef- -- ^ block information for this transaction- , transactionVersion :: !Word32- -- ^ transaction version- , transactionLockTime :: !Word32- -- ^ lock time- , transactionInputs :: ![StoreInput]- -- ^ transaction inputs- , transactionOutputs :: ![StoreOutput]- -- ^ transaction outputs- , transactionDeleted :: !Bool- -- ^ this transaction has been deleted and is no longer valid- , transactionRBF :: !Bool- -- ^ this transaction can be replaced in the mempool- , transactionTime :: !Word64- -- ^ time the transaction was first seen or time of block- } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)--transactionData :: Transaction -> Tx-transactionData t =- Tx- { txVersion = transactionVersion t- , txIn = map i (transactionInputs t)- , txOut = map o (transactionOutputs t)- , txWitness = mapMaybe inputWitness (transactionInputs t)- , txLockTime = transactionLockTime t- }- where- i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} =- TxIn {prevOutput = p, scriptInput = s, txInSequence = q}- i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} =- TxIn {prevOutput = p, scriptInput = s, txInSequence = q}- o StoreOutput {outputAmount = v, outputScript = s} =- TxOut {outValue = v, scriptOutput = s}---- | JSON serialization for 'Transaction'.-transactionPairs :: A.KeyValue kv => Network -> Transaction -> [kv]-transactionPairs net dtx =- [ "txid" .= txHash (transactionData dtx)- , "size" .= B.length (S.encode (transactionData dtx))- , "version" .= transactionVersion dtx- , "locktime" .= transactionLockTime dtx- , "fee" .=- if all isCoinbase (transactionInputs dtx)- then 0- else sum (map inputAmount (transactionInputs dtx)) -- sum (map outputAmount (transactionOutputs dtx))- , "inputs" .= map (object . inputPairs net) (transactionInputs dtx)- , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx)- , "block" .= transactionBlock dtx- , "deleted" .= transactionDeleted dtx- , "time" .= transactionTime dtx- ] ++- ["rbf" .= transactionRBF dtx | getReplaceByFee net] ++- ["weight" .= w | getSegWit net]- where- w = let b = B.length $ S.encode (transactionData dtx) {txWitness = []}- x = B.length $ S.encode (transactionData dtx)- in b * 3 + x--transactionToJSON :: Network -> Transaction -> Value-transactionToJSON net = object . transactionPairs net--transactionToEncoding :: Network -> Transaction -> Encoding-transactionToEncoding net = pairs . mconcat . transactionPairs net--instance JsonSerial Transaction where- jsonSerial = transactionToEncoding- jsonValue = transactionToJSON--instance BinSerial Transaction where- binSerial net tx = do- let (txd, sp) = fromTransaction tx- binSerial net txd- binSerial net sp-- binDeserial net = do- txd <- binDeserial net- sp <- binDeserial net- return $ toTransaction txd sp--instance JsonSerial Tx where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Tx where- binSerial _ = put- binDeserial _ = get--instance JsonSerial Block where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Block where- binSerial _ = put- binDeserial _ = get---- | Information about a connected peer.-data PeerInformation- = PeerInformation { peerUserAgent :: !ByteString- -- ^ user agent string- , peerAddress :: !HostAddress- -- ^ network address- , peerVersion :: !Word32- -- ^ version number- , peerServices :: !Word64- -- ^ services field- , peerRelay :: !Bool- -- ^ will relay transactions- }- deriving (Show, Eq, Ord, Generic, NFData)---- | JSON serialization for 'PeerInformation'.-peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv]-peerInformationPairs p =- [ "useragent" .= String (cs (peerUserAgent p))- , "address" .= String (cs (show (hostToSockAddr (peerAddress p))))- , "version" .= peerVersion p- , "services" .= String (encodeHex (S.encode (peerServices p)))- , "relay" .= peerRelay p- ]--instance ToJSON PeerInformation where- toJSON = object . peerInformationPairs- toEncoding = pairs . mconcat . peerInformationPairs--instance JsonSerial PeerInformation where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial PeerInformation where- binSerial _ PeerInformation { peerUserAgent = u- , peerAddress = a- , peerVersion = v- , peerServices = s- , peerRelay = b- } = do- putWord32be v- put b- put u- put $ NetworkAddress s a-- binDeserial _ = do- v <- getWord32be- b <- get- u <- get- NetworkAddress { naServices = s, naAddress = a } <- get- return $ PeerInformation u a v s b---- | Address balances for an extended public key.-data XPubBal = XPubBal- { xPubBalPath :: ![KeyIndex]- , xPubBal :: !Balance- } deriving (Show, Eq, Generic, NFData)---- | JSON serialization for 'XPubBal'.-xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv]-xPubBalPairs net XPubBal {xPubBalPath = p, xPubBal = b} =- [ "path" .= p- , "balance" .= balanceToJSON net b- ]--xPubBalToJSON :: Network -> XPubBal -> Value-xPubBalToJSON net = object . xPubBalPairs net--xPubBalToEncoding :: Network -> XPubBal -> Encoding-xPubBalToEncoding net = pairs . mconcat . xPubBalPairs net--instance JsonSerial XPubBal where- jsonSerial = xPubBalToEncoding- jsonValue = xPubBalToJSON--instance BinSerial XPubBal where- binSerial net XPubBal {xPubBalPath = p, xPubBal = b} = do- put p- binSerial net b- binDeserial net = do- p <- get- b <- binDeserial net- return $ XPubBal p b---- | Unspent transaction for extended public key.-data XPubUnspent = XPubUnspent- { xPubUnspentPath :: ![KeyIndex]- , xPubUnspent :: !Unspent- } deriving (Show, Eq, Generic, NFData)---- | JSON serialization for 'XPubUnspent'.-xPubUnspentPairs :: A.KeyValue kv => Network -> XPubUnspent -> [kv]-xPubUnspentPairs net XPubUnspent { xPubUnspentPath = p- , xPubUnspent = u- } =- [ "path" .= p- , "unspent" .= unspentToJSON net u- ]--xPubUnspentToJSON :: Network -> XPubUnspent -> Value-xPubUnspentToJSON net = object . xPubUnspentPairs net--xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding-xPubUnspentToEncoding net = pairs . mconcat . xPubUnspentPairs net--instance JsonSerial XPubUnspent where- jsonSerial = xPubUnspentToEncoding- jsonValue = xPubUnspentToJSON--instance BinSerial XPubUnspent where- binSerial net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = do- put p- binSerial net u-- binDeserial net = do- p <- get- u <- binDeserial net- return $ XPubUnspent p u--data XPubSummary =- XPubSummary- { xPubSummaryConfirmed :: !Word64- , xPubSummaryZero :: !Word64- , xPubSummaryReceived :: !Word64- , xPubUnspentCount :: !Word64- , xPubExternalIndex :: !Word32- , xPubChangeIndex :: !Word32- , xPubSummaryPaths :: !(HashMap Address [KeyIndex])- }- deriving (Eq, Show, Generic, NFData)--xPubSummaryPairs :: A.KeyValue kv => Network -> XPubSummary -> [kv]-xPubSummaryPairs net XPubSummary { xPubSummaryConfirmed = c- , xPubSummaryZero = z- , xPubSummaryReceived = r- , xPubUnspentCount = u- , xPubSummaryPaths = ps- , xPubExternalIndex = ext- , xPubChangeIndex = ch- } =- [ "balance" .=- object- [ "confirmed" .= c- , "unconfirmed" .= z- , "received" .= r- , "utxo" .= u- ]- , "indices" .= object ["change" .= ch, "external" .= ext]- , "paths" .= object (mapMaybe (uncurry f) (M.toList ps))- ]- where- f a p = (.= p) <$> addrToString net a--xPubSummaryToJSON :: Network -> XPubSummary -> Value-xPubSummaryToJSON net = object . xPubSummaryPairs net--xPubSummaryToEncoding :: Network -> XPubSummary -> Encoding-xPubSummaryToEncoding net = pairs . mconcat . xPubSummaryPairs net--instance JsonSerial XPubSummary where- jsonSerial = xPubSummaryToEncoding- jsonValue = xPubSummaryToJSON--instance BinSerial XPubSummary where- binSerial net XPubSummary { xPubSummaryConfirmed = c- , xPubSummaryZero = z- , xPubSummaryReceived = r- , xPubUnspentCount = u- , xPubExternalIndex = ext- , xPubChangeIndex = ch- , xPubSummaryPaths = ps- } = do- put c- put z- put r- put u- put ext- put ch- put (map (first (runPut . binSerial net)) (M.toList ps))- binDeserial net = do- c <- get- z <- get- r <- get- u <- get- ext <- get- ch <- get- ps <- get- let xs = map (first (runGet (binDeserial net))) ps- ys <-- forM xs $ \(k, v) ->- case k of- Right a -> return (a, v)- Left _ -> mzero- return $ XPubSummary c z r u ext ch (M.fromList ys)--data HealthCheck =- HealthCheck- { healthHeaderBest :: !(Maybe BlockHash)- , healthHeaderHeight :: !(Maybe BlockHeight)- , healthBlockBest :: !(Maybe BlockHash)- , healthBlockHeight :: !(Maybe BlockHeight)- , healthPeers :: !(Maybe Int)- , healthNetwork :: !String- , healthOK :: !Bool- , healthSynced :: !Bool- , healthLastBlock :: !(Maybe Word64)- , healthLastTx :: !(Maybe Word64)- }- deriving (Show, Eq, Generic, Serialize, NFData)--healthCheckPairs :: A.KeyValue kv => HealthCheck -> [kv]-healthCheckPairs h =- [ "headers" .=- object ["hash" .= healthHeaderBest h, "height" .= healthHeaderHeight h]- , "blocks" .=- object ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h]- , "peers" .= healthPeers h- , "net" .= healthNetwork h- , "ok" .= healthOK h- , "synced" .= healthSynced h- , "version" .= P.version- , "lastblock" .= healthLastBlock h- , "lasttx" .= healthLastTx h- ]--instance ToJSON HealthCheck where- toJSON = object . healthCheckPairs- toEncoding = pairs . mconcat . healthCheckPairs--instance JsonSerial HealthCheck where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial HealthCheck where- binSerial _ HealthCheck { healthHeaderBest = hbest- , healthHeaderHeight = hheight- , healthBlockBest = bbest- , healthBlockHeight = bheight- , healthPeers = peers- , healthNetwork = net- , healthOK = ok- , healthSynced = synced- , healthLastBlock = lbk- , healthLastTx = ltx- } = do- put hbest- put hheight- put bbest- put bheight- put peers- put net- put ok- put synced- put lbk- put ltx- binDeserial _ =- HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*>- get <*>- get <*>- get--data Event- = EventBlock BlockHash- | EventTx TxHash- deriving (Show, Eq, Generic)--instance ToJSON Event where- toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h]- toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h]--instance JsonSerial Event where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Event where- binSerial _ (EventBlock bh) = putWord8 0x00 >> put bh- binSerial _ (EventTx th) = putWord8 0x01 >> put th-- binDeserial _ = getWord8 >>=- \case- 0x00-> EventBlock <$> get- 0x01 -> EventTx <$> get- _ -> fail "Expected fst byte to be 0x00 or 0x01"---newtype TxAfterHeight = TxAfterHeight- { txAfterHeight :: Maybe Bool- } deriving (Show, Eq, Generic, NFData)--instance ToJSON TxAfterHeight where- toJSON (TxAfterHeight b) = object ["result" .= b]--instance JsonSerial TxAfterHeight where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial TxAfterHeight where- binSerial _ TxAfterHeight {txAfterHeight = a} = put a- binDeserial _ = TxAfterHeight <$> get--newtype TxId = TxId TxHash deriving (Show, Eq, Generic, NFData)--instance ToJSON TxId where- toJSON (TxId h) = object ["txid" .= h]--instance JsonSerial TxId where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial TxId where- binSerial _ (TxId th) = put th- binDeserial _ = TxId <$> get--data BalVal = BalVal- { 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- }--balanceToVal :: Balance -> (Address, BalVal)-balanceToVal 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- })---- | Default balance for an address.-instance Default BalVal where- def =- BalVal- { balValAmount = 0- , balValZero = 0- , balValUnspentCount = 0- , balValTxCount = 0- , balValTotalReceived = 0- }--data UnspentVal = UnspentVal- { unspentValBlock :: !BlockRef- , unspentValAmount :: !Word64- , unspentValScript :: !ShortByteString- } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData)--unspentToVal :: Unspent -> (OutPoint, UnspentVal)-unspentToVal Unspent { unspentBlock = b- , unspentPoint = p- , unspentAmount = v- , unspentScript = s- } =- ( p- , UnspentVal- {unspentValBlock = b, unspentValAmount = v, unspentValScript = s})--valToUnspent :: OutPoint -> UnspentVal -> Unspent-valToUnspent p UnspentVal { unspentValBlock = b- , unspentValAmount = v- , unspentValScript = s- } =- Unspent- { unspentBlock = b- , unspentPoint = p- , unspentAmount = v- , unspentScript = s- }---- | Messages that a 'BlockStore' can accept.-data BlockMessage- = BlockNewBest !BlockNode- -- ^ new block header in chain- | BlockPeerConnect !Peer !SockAddr- -- ^ new peer connected- | BlockPeerDisconnect !Peer !SockAddr- -- ^ peer disconnected- | BlockReceived !Peer !Block- -- ^ new block received from a peer- | BlockNotFound !Peer ![BlockHash]- -- ^ block not found- | BlockTxReceived !Peer !Tx- -- ^ transaction received from peer- | BlockTxAvailable !Peer ![TxHash]- -- ^ peer has transactions available- | BlockPing !(Listen ())- -- ^ internal housekeeping ping- | PurgeMempool- -- ^ purge mempool transactions---- | Events that the store can generate.-data StoreEvent- = StoreBestBlock !BlockHash- -- ^ new best block- | StoreMempoolNew !TxHash- -- ^ new mempool transaction- | StorePeerConnected !Peer !SockAddr- -- ^ new peer connected- | StorePeerDisconnected !Peer !SockAddr- -- ^ peer has disconnected- | StorePeerPong !Peer !Word64- -- ^ peer responded 'Ping'- | StoreTxAvailable !Peer ![TxHash]- -- ^ peer inv transactions- | StoreTxReject !Peer !TxHash !RejectCode !ByteString- -- ^ peer rejected transaction- | StoreTxDeleted !TxHash- -- ^ transaction deleted from store- | StoreBlockReverted !BlockHash- -- ^ block no longer head of main chain--data PubExcept- = PubNoPeers- | PubReject RejectCode- | PubTimeout- | PubPeerDisconnected- deriving Eq--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"--instance Exception PubExcept--applyOffsetLimit :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()-applyOffsetLimit offset limit = applyOffset offset >> applyLimit limit--applyOffset :: Monad m => Offset -> ConduitT i i m ()-applyOffset = dropC . fromIntegral--applyLimit :: Monad m => Maybe Limit -> ConduitT i i m ()-applyLimit Nothing = mapC id-applyLimit (Just l) = takeC (fromIntegral l)
src/Network/Haskoin/Store/Logic.hs view
@@ -5,54 +5,47 @@ {-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Store.Logic where -import Conduit (ConduitT, filterC, mapC,- (.|))-import Control.Monad (forM, forM_, unless, void,- when, zipWithM_)-import Control.Monad.Except (MonadError, catchError,- throwError)-import Control.Monad.Logger (MonadLogger, logDebugS,- logErrorS, logInfoS,- logWarnS)-import qualified Data.ByteString as B-import qualified Data.ByteString.Short as B.Short-import Data.Either (rights)-import qualified Data.IntMap.Strict as I-import Data.List (nub, partition, sortBy)-import Data.Maybe (fromMaybe, isNothing,- mapMaybe)-import Data.Serialize (encode)-import Data.String (fromString)-import Data.String.Conversions (cs)-import Data.Text (Text)-import Data.Word (Word32, Word64)-import Haskoin (Address, Block (..),- BlockHash, BlockHeader (..),- BlockNode (..), Network (..),- OutPoint (..), Tx (..),- TxHash, TxIn (..),- TxOut (..), addrToString,- blockHashToHex, genesisBlock,- genesisNode, headerHash,- isGenesis, nullOutPoint,- scriptToAddressBS, txHash,- txHashToHex)-import Network.Haskoin.Block.Headers (computeSubsidy)-import Network.Haskoin.Store.Data.Types (Balance (..), BlockData (..),- BlockRef (..), BlockTx (..),- Prev (..), Spender (..),- StoreInput (..),- StoreOutput (..),- StoreRead (..),- StoreStream (..),- StoreWrite (..),- Transaction (..),- TxData (..), UnixTime,- Unspent (..), confirmed,- fromTransaction, isCoinbase,- toTransaction,- transactionData)-import UnliftIO (Exception)+import Control.Monad (forM, forM_, unless, void, when,+ zipWithM_)+import Control.Monad.Except (MonadError, catchError,+ throwError)+import Control.Monad.Logger (MonadLogger, logErrorS,+ logWarnS)+import qualified Data.ByteString as B+import qualified Data.ByteString.Short as B.Short+import Data.Either (rights)+import qualified Data.IntMap.Strict as I+import Data.List (nub, sort)+import Data.Maybe (fromMaybe, isNothing, mapMaybe)+import Data.Serialize (encode)+import Data.String (fromString)+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Word (Word32, Word64)+import Haskoin (Address, Block (..), BlockHash,+ BlockHeader (..),+ BlockNode (..), Network (..),+ OutPoint (..), Tx (..), TxHash,+ TxIn (..), TxOut (..),+ addrToString, blockHashToHex,+ genesisBlock, genesisNode,+ headerHash, isGenesis,+ nullOutPoint, scriptToAddressBS,+ txHash, txHashToHex)+import Network.Haskoin.Block.Headers (computeSubsidy)+import Network.Haskoin.Store.Common (Balance (..), BlockData (..),+ BlockRef (..), BlockTx (..),+ Prev (..), Spender (..),+ StoreInput (..),+ StoreOutput (..),+ StoreRead (..), StoreWrite (..),+ Transaction (..), TxData (..),+ UnixTime, Unspent (..),+ confirmed, fromTransaction,+ isCoinbase, nullBalance,+ sortTxs, toTransaction,+ transactionData)+import UnliftIO (Exception) data ImportException = PrevBlockNotBest !Text@@ -91,10 +84,15 @@ (isNothing m) (void (importBlock net (genesisBlock net) (genesisNode net))) -getOldOrphans :: (Monad m, StoreStream m) => UnixTime -> ConduitT () TxHash m ()+getOldOrphans :: StoreRead m => UnixTime -> m [TxHash] getOldOrphans now =- getOrphans .| filterC ((< now - 600) . fst) .| mapC (txHash . snd)+ map (txHash . snd) . filter ((< now - 600) . fst) <$> getOrphans +getOldMempool :: StoreRead m => UnixTime -> m [TxHash]+getOldMempool now =+ map blockTxHash . filter ((< now - 3600 * 72) . memRefTime . blockTxBlock) <$>+ getMempool+ importOrphan :: ( StoreRead m , StoreWrite m@@ -106,33 +104,20 @@ -> Tx -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed importOrphan net t tx = do- $(logDebugS) "Block" $- "Attempting to import orphan tx " <> txHashToHex (txHash tx) go `catchError` ex where go = do- ret <-+ maybetxids <- newMempoolTx net tx t >>= \case- Just ths -> do- $(logDebugS) "BlockLogic" $- "Succesfully imported orphan transaction: " <>- txHashToHex (txHash tx)- return (Just ths)- Nothing -> do- $(logDebugS) "BlockLogic" $- "Orphan transaction already imported: " <>- txHashToHex (txHash tx)- return Nothing+ Just ths -> return (Just ths)+ Nothing -> return Nothing deleteOrphanTx (txHash tx)- return ret+ return maybetxids ex (OrphanTx _) = do- $(logDebugS) "BlockLogic" $- "Transaction still orphan: " <> txHashToHex (txHash tx) return Nothing- ex e = do- $(logErrorS) "BlockLogic" $- "Error importing orphan tx: " <> txHashToHex (txHash tx) <> ": " <>- cs (show e)+ ex _ = do+ $(logWarnS) "Block" $+ "Deleted bad orphan tx: " <> txHashToHex (txHash tx) deleteOrphanTx (txHash tx) return Nothing @@ -146,17 +131,11 @@ -> Tx -> UnixTime -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed-newMempoolTx net tx w = do- $(logInfoS) "BlockLogic" $- "Adding transaction to mempool: " <> txHashToHex (txHash tx)- getTxData (txHash tx) >>= \case- Just x- | not (txDataDeleted x) -> do- $(logWarnS) "BlockLogic" $- "Transaction already exists: " <>- txHashToHex (txHash tx)- return Nothing- _ -> go+newMempoolTx net tx w =+ getTxData (txHash tx) >>= \case+ Just x+ | not (txDataDeleted x) -> return Nothing+ _ -> go where go = do orp <-@@ -164,8 +143,7 @@ mapM (getTxData . outPointHash . prevOutput) (txIn tx) if orp then do- $(logWarnS) "BlockLogic" $- "Transaction is orphan: " <> txHashToHex (txHash tx)+ $(logWarnS) "Block" $ "Orphan tx: " <> txHashToHex (txHash tx) insertOrphanTx tx w throwError $ OrphanTx (txHashToHex (txHash tx)) else f@@ -181,8 +159,6 @@ return (Just ths) else g ds g ds = do- $(logWarnS) "BlockLogic" $- "Transaction inputs already spent: " <> txHashToHex (txHash tx) rbf <- if getReplaceByFee net then and <$> mapM isrbf ds@@ -191,15 +167,12 @@ then r ds else n r ds = do- $(logWarnS) "BlockLogic" $- "Replacting RBF transaction with: " <> txHashToHex (txHash tx)+ $(logWarnS) "Block" $ "Replace by fee tx: " <> txHashToHex (txHash tx) ths <- concat <$> forM ds (deleteTx net True) dts <- importTx net (MemRef w) w tx return (Just (nub (ths <> dts))) n = do- $(logWarnS) "BlockLogic" $- "Inserting transaction with deleted flag: " <>- txHashToHex (txHash tx)+ $(logWarnS) "Block" $ "Conflicting tx: " <> txHashToHex (txHash tx) insertDeletedMempoolTx tx w return Nothing isrbf th = transactionRBF <$> getImportTx th@@ -214,31 +187,30 @@ -> BlockHash -> m [TxHash] revertBlock net bh = do- bd <-- getBestBlock >>= \case- Nothing -> do- $(logErrorS) "BlockLogic" "Best block unknown"- throwError BestBlockUnknown- Just h ->- getBlock h >>= \case- Nothing -> do- $(logErrorS) "BlockLogic" "Best block not found"- throwError (BestBlockNotFound (blockHashToHex h))- Just b- | h == bh -> return b- | otherwise -> do- $(logErrorS) "BlockLogic" $- "Attempted to delete block that isn't best: " <>- blockHashToHex h- throwError (BlockNotBest (blockHashToHex bh))- txs <-- mapM (fmap transactionData . getImportTx) (blockDataTxs bd)- ths <- nub . concat <$> mapM- (deleteTx net False . txHash . snd)- (reverse (sortTxs txs))- setBest (prevBlock (blockDataHeader bd))- insertBlock bd {blockDataMainChain = False}- return ths+ bd <-+ getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "Block" "Best block unknown"+ throwError BestBlockUnknown+ Just h ->+ getBlock h >>= \case+ Nothing -> do+ $(logErrorS) "Block" "Best block not found"+ throwError (BestBlockNotFound (blockHashToHex h))+ Just b+ | h == bh -> return b+ | otherwise -> do+ $(logErrorS) "Block" $+ "Cannot delete block that is not head: " <>+ blockHashToHex h+ throwError (BlockNotBest (blockHashToHex bh))+ txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd)+ ths <-+ nub . concat <$>+ mapM (deleteTx net False . txHash . snd) (reverse (sortTxs txs))+ setBest (prevBlock (blockDataHeader bd))+ insertBlock bd {blockDataMainChain = False}+ return ths importBlock :: ( StoreRead m@@ -251,29 +223,23 @@ -> BlockNode -> m [TxHash] -- ^ deleted transactions importBlock net b n = do- mp <- filter (`elem` bths) . map snd <$> getMempool+ mp <- filter (`elem` bths) . map blockTxHash <$> getMempool getBestBlock >>= \case Nothing- | isGenesis n -> do- $(logInfoS) "BlockLogic" $- "Importing genesis block: " <>- blockHashToHex (headerHash (nodeHeader n))- return ()+ | isGenesis n -> return () | otherwise -> do- $(logErrorS) "BlockLogic" $- "Importing non-genesis block when best block unknown: " <>+ $(logErrorS) "Block" $+ "Cannot import non-genesis block at this point: " <> blockHashToHex (headerHash (blockHeader b)) throwError BestBlockUnknown Just h | prevBlock (blockHeader b) == h -> return () | otherwise -> do- $(logErrorS) "BlockLogic" $- "Block " <> blockHashToHex (headerHash (blockHeader b)) <>- " does not build on current best " <>- blockHashToHex h- throwError- (PrevBlockNotBest- (blockHashToHex (prevBlock (nodeHeader n))))+ $(logErrorS) "Block" $+ "Block does not build on head: " <>+ blockHashToHex (headerHash (blockHeader b))+ throwError $+ PrevBlockNotBest (blockHashToHex (prevBlock (nodeHeader n))) insertBlock BlockData { blockDataHeight = nodeHeight n@@ -290,13 +256,9 @@ bs <- getBlocksAtHeight (nodeHeight n) setBlocksAtHeight (nub (headerHash (nodeHeader n) : bs)) (nodeHeight n) setBest (headerHash (nodeHeader n))- $(logDebugS) "Block" "Importing or confirming block transactions..." ths <- nub . concat <$> mapM (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b))- $(logDebugS) "Block" $- "Done importing transactions for block " <>- blockHashToHex (headerHash (nodeHeader n)) return ths where bths = map txHash (blockTxns b)@@ -305,9 +267,9 @@ then getTxData (txHash tx) >>= \case Just td -> confirmTx net td (br x) tx >> return [] Nothing -> do- $(logErrorS)- "Block"- "Cannot get data for transaction in mempool"+ $(logErrorS) "Block" $+ "Cannot get data for mempool tx: " <>+ txHashToHex (txHash tx) throwError $ TxNotFound (txHashToHex (txHash tx)) else importTx net@@ -329,19 +291,6 @@ x = B.length (encode b) in s * 3 + x -sortTxs :: [Tx] -> [(Word32, Tx)]-sortTxs txs = go $ zip [0 ..] txs- where- go [] = []- go ts =- let (is, ds) =- partition- (all ((`notElem` map (txHash . snd) ts) .- outPointHash . prevOutput) .- txIn . snd)- ts- in is <> go ds- importTx :: ( StoreRead m , StoreWrite m@@ -355,12 +304,12 @@ -> m [TxHash] -- ^ deleted transactions importTx net br tt tx = do when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do- $(logErrorS) "BlockLogic" $+ $(logErrorS) "Block" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx) throwError (DuplicatePrevOutput (txHashToHex (txHash tx))) when (iscb && not (confirmed br)) $ do- $(logErrorS) "BlockLogic" $- "Attempting to import coinbase to the mempool: " <>+ $(logErrorS) "Block" $+ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx) throwError (UnconfirmedCoinbase (txHashToHex (txHash tx))) us' <-@@ -372,8 +321,8 @@ when (not (confirmed br) && sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do- $(logErrorS) "BlockLogic" $- "Insufficient funds: " <> txHashToHex (txHash tx)+ $(logErrorS) "Block" $+ "Insufficient funds for tx: " <> txHashToHex (txHash tx) throwError (InsufficientFunds (txHashToHex th)) zipWithM_ (spendOutput net br (txHash tx)) [0 ..] us zipWithM_@@ -405,14 +354,15 @@ getUnspent op >>= \case Just u -> return (u, []) Nothing -> do- $(logWarnS) "BlockLogic" $- "No unspent output: " <> txHashToHex (outPointHash op) <>+ $(logWarnS) "Block" $+ "Unspent output not found: " <>+ txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op)) getSpender op >>= \case Nothing -> do- $(logErrorS) "BlockLogic" $- "No spent or unspent output: " <>+ $(logErrorS) "Block" $+ "Output not found: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))@@ -421,8 +371,8 @@ ths <- deleteTx net True s getUnspent op >>= \case Nothing -> do- $(logErrorS) "BlockLogic" $- "Could not unspend output: " <>+ $(logErrorS) "Block" $+ "Cannot unspend output: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))@@ -549,12 +499,13 @@ deleteFromMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> m () deleteFromMempool th = do mp <- getMempool- setMempool $ filter ((/= th) . snd) mp+ setMempool $ filter ((/= th) . blockTxHash) mp insertIntoMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> UnixTime -> m () insertIntoMempool th unixtime = do mp <- getMempool- setMempool $ sortBy (flip compare) ((unixtime, th) : mp)+ setMempool . reverse . sort $+ BlockTx {blockTxBlock = MemRef unixtime, blockTxHash = th} : mp deleteTx :: ( StoreRead m@@ -567,20 +518,17 @@ -> TxHash -> m [TxHash] -- ^ deleted transactions deleteTx net mo h = do- $(logDebugS) "BlockLogic" $ "Deleting transaction: " <> txHashToHex h getTxData h >>= \case Nothing -> do- $(logErrorS) "BlockLogic" $- "Transaciton not found: " <> txHashToHex h+ $(logErrorS) "Block" $ "Cannot find tx to delete: " <> txHashToHex h throwError (TxNotFound (txHashToHex h)) Just t | txDataDeleted t -> do- $(logWarnS) "BlockLogic" $- "Transaction already deleted: " <> txHashToHex h+ $(logWarnS) "Block" $ "Already deleted tx: " <> txHashToHex h return [] | mo && confirmed (txDataBlock t) -> do- $(logErrorS) "BlockLogic" $- "Will not delete confirmed transaction: " <> txHashToHex h+ $(logErrorS) "Block" $+ "Will not delete confirmed tx: " <> txHashToHex h throwError (TxConfirmed (txHashToHex h)) | otherwise -> go t where@@ -606,26 +554,23 @@ -> UnixTime -> m () insertDeletedMempoolTx tx w = do- us <-- forM (txIn tx) $ \TxIn {prevOutput = op} ->- getImportTx (outPointHash op) >>=- getTxOutput (outPointIndex op)- rbf <- getrbf- let (d, _) =- fromTransaction- Transaction- { transactionBlock = MemRef w- , transactionVersion = txVersion tx- , transactionLockTime = txLockTime tx- , transactionInputs = zipWith3 mkin us (txIn tx) ws- , transactionOutputs = map mkout (txOut tx)- , transactionDeleted = True- , transactionRBF = rbf- , transactionTime = w- }- $(logWarnS) "BlockLogic" $- "Inserting deleted mempool transaction: " <> txHashToHex (txHash tx)- insertTx d+ us <-+ forM (txIn tx) $ \TxIn {prevOutput = op} ->+ getImportTx (outPointHash op) >>= getTxOutput (outPointIndex op)+ rbf <- getrbf+ let (d, _) =+ fromTransaction+ Transaction+ { transactionBlock = MemRef w+ , transactionVersion = txVersion tx+ , transactionLockTime = txLockTime tx+ , transactionInputs = zipWith3 mkin us (txIn tx) ws+ , transactionOutputs = map mkout (txOut tx)+ , transactionDeleted = True+ , transactionRBF = rbf+ , transactionTime = w+ }+ insertTx d where ws = map Just (txWitness tx) <> repeat Nothing getrbf@@ -635,8 +580,8 @@ in fmap or . forM hs $ \h -> getTxData h >>= \case Nothing -> do- $(logErrorS) "BlockLogic" $- "Transaction not found: " <> txHashToHex h+ $(logErrorS) "Block" $+ "Tx not found: " <> txHashToHex h throwError (TxNotFound (txHashToHex h)) Just t | confirmed (txDataBlock t) -> return False@@ -731,13 +676,11 @@ getImportTx th = getTxData th >>= \case Nothing -> do- $(logErrorS) "BlockLogic" $- "Tranasction not found: " <> txHashToHex th+ $(logErrorS) "Block" $ "Tx not found: " <> txHashToHex th throwError $ TxNotFound (txHashToHex th) Just d | txDataDeleted d -> do- $(logErrorS) "BlockLogic" $- "Transaction deleted: " <> txHashToHex th+ $(logErrorS) "Block" $ "Tx deleted: " <> txHashToHex th throwError $ TxDeleted (txHashToHex th) | otherwise -> do sm <- getSpenders th@@ -750,8 +693,8 @@ -> m StoreOutput getTxOutput i tx = do unless (fromIntegral i < length (transactionOutputs tx)) $ do- $(logErrorS) "BlockLogic" $- "Output out of range " <> txHashToHex (txHash (transactionData tx)) <>+ $(logErrorS) "Block" $+ "Output out of range: " <> txHashToHex (txHash (transactionData tx)) <> " " <> fromString (show i) throwError . OutputOutOfRange . cs $@@ -799,43 +742,42 @@ -> OutPoint -> m () unspendOutput _ op = do- t <- getImportTx (outPointHash op)- o <- getTxOutput (outPointIndex op) t- s <-- case outputSpender o of- Nothing -> do- $(logErrorS) "BlockLogic" $- "Output already unspent: " <>- txHashToHex (outPointHash op) <>- " " <>- fromString (show (outPointIndex op))- throwError (AlreadyUnspent (cs (show op)))- Just s -> return s- x <- getImportTx (spenderHash s)- deleteSpender op- let u =- Unspent- { unspentAmount = outputAmount o- , unspentBlock = transactionBlock t- , unspentScript = B.Short.toShort (outputScript o)- , unspentPoint = op+ t <- getImportTx (outPointHash op)+ o <- getTxOutput (outPointIndex op) t+ s <-+ case outputSpender o of+ Nothing -> do+ $(logErrorS) "Block" $+ "Output already unspent: " <> txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (AlreadyUnspent (cs (show op)))+ Just s -> return s+ x <- getImportTx (spenderHash s)+ deleteSpender op+ let u =+ Unspent+ { unspentAmount = outputAmount o+ , unspentBlock = transactionBlock t+ , unspentScript = B.Short.toShort (outputScript o)+ , unspentPoint = op+ }+ insertUnspent u+ case scriptToAddressBS (outputScript o) of+ Left _ -> return ()+ Right a -> do+ insertAddrUnspent a u+ deleteAddrTx+ a+ BlockTx+ { blockTxHash = spenderHash s+ , blockTxBlock = transactionBlock x }- insertUnspent u- case scriptToAddressBS (outputScript o) of- Left _ -> return ()- Right a -> do- insertAddrUnspent a u- deleteAddrTx- a- BlockTx- { blockTxHash = spenderHash s- , blockTxBlock = transactionBlock x- }- increaseBalance- (confirmed (unspentBlock u))- False- a- (outputAmount o)+ increaseBalance+ (confirmed (unspentBlock u))+ False+ a+ (outputAmount o) reduceBalance :: ( StoreRead m@@ -850,43 +792,45 @@ -> Word64 -> m () reduceBalance net c t a v =- getBalance a >>= \case- Nothing -> do- $(logErrorS) "BlockLogic" $- "Balance not found for address " <> addrText net a- throwError (BalanceNotFound (addrText net a))- Just b -> do- when (v > amnt b) $ do- $(logErrorS) "BlockLogic" $- "Insufficient " <> conf <> " balance: " <> addrText net a <>- " (needs: " <>- cs (show v) <>- ", has: " <>- cs (show (amnt b)) <>- ")"- throwError $- if c- then InsufficientBalance (addrText net a)- else InsufficientZeroBalance (addrText net a)- setBalance- b- { balanceAmount =- balanceAmount b -- if c- then v- else 0- , balanceZero =- balanceZero b -- if c- then 0- else v- , balanceUnspentCount = balanceUnspentCount b - 1- , balanceTotalReceived =- balanceTotalReceived b -- if t- then v- else 0- }+ getBalance a >>= \b ->+ if nullBalance b+ then do+ $(logErrorS) "Block" $+ "Address balance not found: " <> addrText net a+ throwError (BalanceNotFound (addrText net a))+ else do+ when (v > amnt b) $ do+ $(logErrorS) "Block" $+ "Insufficient " <> conf <> " balance: " <>+ addrText net a <>+ " (needs: " <>+ cs (show v) <>+ ", has: " <>+ cs (show (amnt b)) <>+ ")"+ throwError $+ if c+ then InsufficientBalance (addrText net a)+ else InsufficientZeroBalance (addrText net a)+ setBalance+ b+ { balanceAmount =+ balanceAmount b -+ if c+ then v+ else 0+ , balanceZero =+ balanceZero b -+ if c+ then 0+ else v+ , balanceUnspentCount = balanceUnspentCount b - 1+ , balanceTotalReceived =+ balanceTotalReceived b -+ if t+ then v+ else 0+ } where amnt = if c@@ -908,19 +852,7 @@ -> Word64 -> m () increaseBalance c t a v = do- b <-- getBalance a >>= \case- Nothing ->- return- Balance- { balanceAddress = a- , balanceAmount = 0- , balanceZero = 0- , balanceUnspentCount = 0- , balanceTxCount = 0- , balanceTotalReceived = 0- }- Just b -> return b+ b <- getBalance a setBalance b { balanceAmount =@@ -950,9 +882,9 @@ updateAddressCounts net as f = forM_ as $ \a -> do b <-- getBalance a >>= \case- Nothing -> throwError (BalanceNotFound (addrText net a))- Just b -> return b+ getBalance a >>= \b -> if nullBalance b+ then throwError (BalanceNotFound (addrText net a))+ else return b setBalance b {balanceTxCount = f (balanceTxCount b)} txAddresses :: Transaction -> [Address]
src/Network/Haskoin/Store/Web.hs view
@@ -4,32 +4,28 @@ {-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Store.Web where -import Conduit hiding (runResourceT)+import Conduit () import Control.Applicative ((<|>))-import Control.Monad (forM_, forever, guard,- mzero, unless, when, (<=<))+import Control.Monad (forever, guard, mzero,+ unless, when, (<=<)) import Control.Monad.Logger (Loc, LogLevel, LogSource,- LogStr, LoggingT (..),- MonadLogger, MonadLoggerIO,- askLoggerIO, logInfoS,- monadLoggerLog,- runLoggingT)-import Control.Monad.Reader (ReaderT, ask, runReaderT)+ LogStr, MonadLogger,+ MonadLoggerIO, askLoggerIO,+ logInfoS, monadLoggerLog)+import Control.Monad.Reader (ReaderT, ask)+import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Aeson (ToJSON (..), object, (.=))-import Data.Aeson.Encoding (encodingToLazyByteString,- fromEncoding)+import Data.Aeson.Encoding (encodingToLazyByteString) import qualified Data.ByteString as B-import Data.ByteString.Builder (Builder, lazyByteString)+import Data.ByteString.Builder (lazyByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as C import Data.Char (isSpace)-import Data.Function (on)-import qualified Data.HashMap.Strict as H-import Data.List (nub, sortBy)+import Data.List (nub) import Data.Maybe (catMaybes, fromMaybe,- isJust, isNothing,- listToMaybe, mapMaybe)+ isJust, listToMaybe,+ mapMaybe) import Data.Serialize as Serialize import Data.String.Conversions (cs) import Data.Text (Text)@@ -50,18 +46,15 @@ BlockNode (..), GetData (..), Hash256, InvType (..),- InvVector (..), KeyIndex,+ InvVector (..), Message (..), Network (..), OutPoint (..), Tx, TxHash (..), VarString (..),- Version (..), XPubKey,- decodeHex, deriveAddr,- deriveCompatWitnessAddr,- deriveWitnessAddr,+ Version (..), decodeHex, eitherToMaybe, headerHash, hexToBlockHash,- hexToTxHash, pubSubKey,+ hexToTxHash, sockToHostAddress, stringToAddr, txHash, xPubImport)@@ -70,13 +63,13 @@ chainGetBest, managerGetPeers, sendMessage)-import Network.Haskoin.Store.Data.RocksDB (withRocksDB)-import Network.Haskoin.Store.Data.Types (Balance (..),- BinSerial (..),+import Network.Haskoin.Store.Common (BinSerial (..), BlockDB (..), BlockData (..), BlockRef (..),- BlockTx (..), Event (..),+ BlockTx (..),+ DeriveType (..),+ Event (..), HealthCheck (..), JsonSerial (..), Limit, Offset,@@ -85,34 +78,27 @@ StoreEvent (..), StoreInput (..), StoreRead (..),- StoreStream (..), Transaction (..), TxAfterHeight (..), TxData (..), TxId (..), UnixTime, Unspent,- XPubBal (..),- XPubSummary (..),- XPubUnspent (..),- applyLimit,- applyOffsetLimit,+ XPubSpec (..), applyOffset, blockAtOrBefore, getTransaction, isCoinbase,- transactionData,- zeroBalance)+ transactionData)+import Network.Haskoin.Store.Data.RocksDB (withRocksDB) import Network.HTTP.Types (Status (..), status400,- status404, status500,- status503)+ status403, status404,+ status500, status503) import Network.Wai (Middleware, Request (..), responseStatus) import NQE (Publisher, receive, withSubscription) import Text.Printf (printf) import Text.Read (readMaybe)-import UnliftIO (Exception, TBQueue,- askRunInIO, atomically,- readTBQueue, timeout,- writeTBQueue)-import UnliftIO.Resource (runResourceT)+import UnliftIO (Exception, MonadIO,+ MonadUnliftIO, askRunInIO,+ liftIO, timeout) import Web.Scotty.Internal.Types (ActionT) import Web.Scotty.Trans (Parsable, ScottyError) import qualified Web.Scotty.Trans as S@@ -121,14 +107,13 @@ type WebT m = ActionT Except (ReaderT BlockDB m) -type DeriveAddr = XPubKey -> KeyIndex -> Address- data Except = ThingNotFound | ServerError | BadRequest | UserError String | StringError String+ | BlockTooLarge deriving Eq instance Show Except where@@ -137,6 +122,7 @@ show BadRequest = "bad request" show (UserError s) = s show (StringError _) = "you killed the dragon with your bare hands"+ show BlockTooLarge = "block too large" instance Exception Except @@ -159,6 +145,7 @@ BadRequest -> putWord8 2 UserError s -> putWord8 3 >> Serialize.put s StringError s -> putWord8 4 >> Serialize.put s+ BlockTooLarge -> putWord8 5 binDeserial _ = getWord8 >>= \case 0 -> return ThingNotFound@@ -246,17 +233,7 @@ lift (getAddressesTxs addrs start limit) getAddressesUnspents addrs start limit = lift (getAddressesUnspents addrs start limit)--askDB :: Monad m => WebT m BlockDB-askDB = lift ask--runStream ::- MonadUnliftIO m- => LoggerIO- -> s- -> ReaderT s (ResourceT (LoggingT m)) a- -> m a-runStream l s f = runLoggingT (runResourceT (runReaderT f s)) l+ getOrphans = lift getOrphans defHandler :: Monad m => Network -> Except -> WebT m () defHandler net e = do@@ -267,6 +244,7 @@ UserError _ -> S.status status400 StringError _ -> S.status status400 ServerError -> S.status status500+ BlockTooLarge -> S.status status403 protoSerial net proto e maybeSerial ::@@ -287,8 +265,8 @@ protoSerial net proto = S.raw . serialAny net proto scottyBestBlock ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m ()-scottyBestBlock net raw = do+ (MonadLoggerIO m, MonadIO m) => Network -> MaxLimits -> Bool -> WebT m ()+scottyBestBlock net limits raw = do setHeaders n <- parseNoTx proto <- setupBin@@ -301,12 +279,13 @@ Nothing -> S.raise ThingNotFound Just b -> return b if raw- then rawBlock b >>= protoSerial net proto+ then do+ refuseLargeBlock limits b+ rawBlock b >>= protoSerial net proto else protoSerial net proto (pruneTx n b) -scottyBlock ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m ()-scottyBlock net raw = do+scottyBlock :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()+scottyBlock net limits raw = do setHeaders block <- myBlockHash <$> S.param "block" n <- parseNoTx@@ -316,34 +295,31 @@ Nothing -> S.raise ThingNotFound Just b -> return b if raw- then rawBlock b >>= protoSerial net proto+ then do+ refuseLargeBlock limits b+ rawBlock b >>= protoSerial net proto else protoSerial net proto (pruneTx n b) -scottyBlockHeight ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m ()-scottyBlockHeight net raw = do+scottyBlockHeight :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()+scottyBlockHeight net limits raw = do setHeaders height <- S.param "height" n <- parseNoTx proto <- setupBin hs <- getBlocksAtHeight height- db <- askDB- l <- askLoggerIO if raw- then S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany hs .| concatMapMC getBlock .| mapMC rawBlock .|- streamAny net proto io- flush'- else S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany hs .| concatMapMC getBlock .| mapC (pruneTx n) .|- streamAny net proto io- flush'+ then do+ blocks <- catMaybes <$> mapM getBlock hs+ mapM_ (refuseLargeBlock limits) blocks+ rawblocks <- mapM rawBlock blocks+ protoSerial net proto rawblocks+ else do+ blocks <- catMaybes <$> mapM getBlock hs+ let blocks' = map (pruneTx n) blocks+ protoSerial net proto blocks' -scottyBlockTime ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m ()-scottyBlockTime net raw = do+scottyBlockTime :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()+scottyBlockTime net limits raw = do setHeaders q <- S.param "time" n <- parseNoTx@@ -353,75 +329,59 @@ then maybeSerial net proto =<< case m of Nothing -> return Nothing- Just d -> Just <$> rawBlock d+ Just d -> do+ refuseLargeBlock limits d+ Just <$> rawBlock d else maybeSerial net proto m -scottyBlockHeights :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+scottyBlockHeights :: MonadLoggerIO m => Network -> WebT m () scottyBlockHeights net = do setHeaders heights <- S.param "heights" n <- parseNoTx proto <- setupBin- db <- askDB- l <- askLoggerIO- S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany (nub heights) .| concatMapMC getBlocksAtHeight .|- concatMapMC getBlock .|- mapC (pruneTx n) .|- streamAny net proto io- flush'+ bhs <- concat <$> mapM getBlocksAtHeight (heights :: [BlockHeight])+ blocks <- map (pruneTx n) . catMaybes <$> mapM getBlock bhs+ protoSerial net proto blocks -scottyBlockLatest :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+scottyBlockLatest :: MonadLoggerIO m => Network -> WebT m () scottyBlockLatest net = do setHeaders n <- parseNoTx proto <- setupBin- db <- askDB- l <- askLoggerIO getBestBlock >>= \case- Just h ->- S.stream $ \io flush' -> do- runStream l db . runConduit $- f n h 100 .| streamAny net proto io- flush'+ Just h -> do+ blocks <- reverse <$> go 100 n h+ protoSerial net proto blocks Nothing -> S.raise ThingNotFound where- f :: (Monad m, StoreRead m)- => Bool- -> BlockHash- -> Int- -> ConduitT () BlockData m ()- f _ _ 0 = return ()- f n h i =- lift (getBlock h) >>= \case- Nothing -> return ()- Just b -> do- yield $ pruneTx n b- if blockDataHeight b <= 0- then return ()- else f n (prevBlock (blockDataHeader b)) (i - 1)+ go 0 _ _ = return []+ go i n h =+ getBlock h >>= \case+ Nothing -> return []+ Just b ->+ let b' = pruneTx n b+ i' = i - 1 :: Int+ prev = prevBlock (blockDataHeader b)+ in if blockDataHeight b <= 0+ then return []+ else (b' :) <$> go i' n prev -scottyBlocks :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+scottyBlocks :: MonadLoggerIO m => Network -> WebT m () scottyBlocks net = do setHeaders- blocks <- map myBlockHash <$> S.param "blocks"+ bhs <- map myBlockHash <$> S.param "blocks" n <- parseNoTx proto <- setupBin- db <- askDB- l <- askLoggerIO- S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany (nub blocks) .| concatMapMC getBlock .| mapC (pruneTx n) .|- streamAny net proto io- flush'+ bks <- map (pruneTx n) . catMaybes <$> mapM getBlock (nub bhs)+ protoSerial net proto bks -scottyMempool :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+scottyMempool :: MonadLoggerIO m => Network -> WebT m () scottyMempool net = do setHeaders proto <- setupBin- txs <- map snd <$> getMempool+ txs <- map blockTxHash <$> getMempool protoSerial net proto txs scottyTransaction :: MonadLoggerIO m => Network -> WebT m ()@@ -449,85 +409,58 @@ res <- cbAfterHeight 10000 height txid protoSerial net proto res -scottyTransactions :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+scottyTransactions :: MonadLoggerIO m => Network -> WebT m () scottyTransactions net = do setHeaders txids <- map myTxHash <$> S.param "txids" proto <- setupBin- db <- askDB- l <- askLoggerIO- S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany (nub txids) .| concatMapMC getTransaction .|- streamAny net proto io- flush'+ txs <- catMaybes <$> mapM getTransaction (nub txids)+ protoSerial net proto txs -scottyBlockTransactions ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()-scottyBlockTransactions net = do+scottyBlockTransactions :: MonadLoggerIO m => Network -> MaxLimits -> WebT m ()+scottyBlockTransactions net limits = do setHeaders h <- myBlockHash <$> S.param "block" proto <- setupBin- db <- askDB- l <- askLoggerIO getBlock h >>= \case- Just b ->- S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany (blockDataTxs b) .| concatMapMC getTransaction .|- streamAny net proto io- flush'+ Just b -> do+ refuseLargeBlock limits b+ let ths = blockDataTxs b+ txs <- catMaybes <$> mapM getTransaction ths+ protoSerial net proto txs Nothing -> S.raise ThingNotFound scottyRawTransactions ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+ MonadLoggerIO m => Network -> WebT m () scottyRawTransactions net = do setHeaders txids <- map myTxHash <$> S.param "txids" proto <- setupBin- db <- askDB- l <- askLoggerIO- S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany (nub txids) .| concatMapMC getTransaction .|- mapC transactionData .|- streamAny net proto io- flush'+ txs <- map transactionData . catMaybes <$> mapM getTransaction (nub txids)+ protoSerial net proto txs rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block rawBlock b = do let h = blockDataHeader b- txs <-- runConduit $- yieldMany (blockDataTxs b) .| concatMapMC getTransaction .|- mapC transactionData .|- sinkList+ ths = blockDataTxs b+ txs <- map transactionData . catMaybes <$> mapM getTransaction ths return Block {blockHeader = h, blockTxns = txs} scottyRawBlockTransactions ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()-scottyRawBlockTransactions net = do+ MonadLoggerIO m => Network -> MaxLimits -> WebT m ()+scottyRawBlockTransactions net limits = do setHeaders h <- myBlockHash <$> S.param "block" proto <- setupBin- db <- askDB- l <- askLoggerIO getBlock h >>= \case- Just b ->- S.stream $ \io flush' -> do- runStream l db . runConduit $- yieldMany (blockDataTxs b) .| concatMapMC getTransaction .|- mapC transactionData .|- streamAny net proto io- flush'+ Just b -> do+ refuseLargeBlock limits b+ let ths = blockDataTxs b+ txs <- map transactionData . catMaybes <$> mapM getTransaction ths+ protoSerial net proto txs Nothing -> S.raise ThingNotFound -scottyAddressTxs ::- (MonadLoggerIO m, MonadUnliftIO m)- => Network- -> MaxLimits- -> Bool- -> WebT m ()+scottyAddressTxs :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m () scottyAddressTxs net limits full = do setHeaders a <- parseAddress net@@ -535,40 +468,25 @@ o <- getOffset limits l <- getLimit limits full proto <- setupBin- db <- askDB- lg <- askLoggerIO- S.stream $ \io flush' -> do- runStream lg db . runConduit $ f proto o l s a io- flush'- where- f proto o l s a io- | full = getAddressTxsFull o l s a .| streamAny net proto io- | otherwise = getAddressTxsLimit o l s a .| streamAny net proto io+ if full+ then do+ getAddressTxsFull o l s a >>= protoSerial net proto+ else do+ getAddressTxsLimit o l s a >>= protoSerial net proto scottyAddressesTxs ::- (MonadLoggerIO m, MonadUnliftIO m)- => Network- -> MaxLimits- -> Bool- -> WebT m ()+ MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m () scottyAddressesTxs net limits full = do setHeaders as <- parseAddresses net s <- getStart l <- getLimit limits full proto <- setupBin- db <- askDB- lg <- askLoggerIO- S.stream $ \io flush' -> do- runStream lg db . runConduit $ f proto l s as io- flush'- where- f proto l s as io- | full = getAddressesTxsFull l s as .| streamAny net proto io- | otherwise = getAddressesTxsLimit l s as .| streamAny net proto io+ if full+ then getAddressesTxsFull l s as >>= protoSerial net proto+ else getAddressesTxsLimit l s as >>= protoSerial net proto -scottyAddressUnspent ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m ()+scottyAddressUnspent :: MonadLoggerIO m => Network -> MaxLimits -> WebT m () scottyAddressUnspent net limits = do setHeaders a <- parseAddress net@@ -576,126 +494,73 @@ o <- getOffset limits l <- getLimit limits False proto <- setupBin- db <- askDB- lg <- askLoggerIO- S.stream $ \io flush' -> do- runStream lg db . runConduit $- getAddressUnspentsLimit o l s a .| streamAny net proto io- flush'+ uns <- getAddressUnspentsLimit o l s a+ protoSerial net proto uns -scottyAddressesUnspent ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m ()+scottyAddressesUnspent :: MonadLoggerIO m => Network -> MaxLimits -> WebT m () scottyAddressesUnspent net limits = do setHeaders as <- parseAddresses net s <- getStart l <- getLimit limits False proto <- setupBin- db <- askDB- lg <- askLoggerIO- S.stream $ \io flush' -> do- runStream lg db . runConduit $- getAddressesUnspentsLimit l s as .| streamAny net proto io- flush'+ uns <- getAddressesUnspentsLimit l s as+ protoSerial net proto uns scottyAddressBalance :: MonadLoggerIO m => Network -> WebT m () scottyAddressBalance net = do setHeaders a <- parseAddress net proto <- setupBin- res <- fromMaybe (zeroBalance a) <$> getBalance a+ res <- getBalance a protoSerial net proto res -scottyAddressesBalances ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+scottyAddressesBalances :: MonadLoggerIO m => Network -> WebT m () scottyAddressesBalances net = do setHeaders as <- parseAddresses net proto <- setupBin- res <- zipWith f as <$> getBalances as+ res <- getBalances as protoSerial net proto res- where- f a Nothing = zeroBalance a- f _ (Just b) = b -scottyXpubBalances ::- (MonadUnliftIO m, MonadLoggerIO m)- => Network- -> WebT m ()+scottyXpubBalances :: MonadLoggerIO m => Network -> WebT m () scottyXpubBalances net = do setHeaders xpub <- parseXpub net proto <- setupBin- derive <- parseDeriveAddrs net- res <- lift (xpubBals derive xpub)+ res <- xPubBals xpub protoSerial net proto res -scottyXpubTxs ::- (MonadLoggerIO m, MonadUnliftIO m)- => Network- -> MaxLimits- -> Bool- -> WebT m ()+scottyXpubTxs :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m () scottyXpubTxs net limits full = do setHeaders- x <- parseXpub net- s <- getStart- l <- getLimit limits full- derive <- parseDeriveAddrs net+ xpub <- parseXpub net+ start <- getStart+ limit <- getLimit limits full proto <- setupBin- db <- askDB- lg <- askLoggerIO- S.stream $ \io flush' -> do- runStream lg db . runConduit $ f proto l s derive io x- flush'- where- f proto l s derive io x- | full =- xpubTxs s l derive x .|- concatMapMC (getTransaction . blockTxHash) .|- streamAny net proto io- | otherwise = xpubTxs s l derive x .| streamAny net proto io--xpubTxs ::- (MonadUnliftIO m, StoreRead m, StoreStream m)- => Maybe BlockRef- -> Maybe Limit- -> DeriveAddr- -> XPubKey- -> ConduitT i BlockTx m ()-xpubTxs start limit derive xpub = do- bs <- lift (xpubBals derive xpub)- let as = map (balanceAddress . xPubBal) bs- ts <- mapM_ (\a -> getAddressTxs a start .| applyLimit limit) as .| sinkList- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- forM_ ts' yield .| applyLimit limit+ txs <- xPubTxs xpub start 0 limit+ if full+ then do+ txs' <- catMaybes <$> mapM (getTransaction . blockTxHash) txs+ protoSerial net proto txs'+ else protoSerial net proto txs -scottyXpubUnspents ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m ()+scottyXpubUnspents :: MonadLoggerIO m => Network -> MaxLimits -> WebT m () scottyXpubUnspents net limits = do setHeaders- x <- parseXpub net+ xpub <- parseXpub net proto <- setupBin- s <- getStart- l <- getLimit limits False- derive <- parseDeriveAddrs net- db <- askDB- lg <- askLoggerIO- S.stream $ \io flush' -> do- runStream lg db . runConduit $- xpubUnspentLimit l s derive x .| streamAny net proto io- flush'+ start <- getStart+ limit <- getLimit limits False+ uns <- xPubUnspents xpub start 0 limit+ protoSerial net proto uns -scottyXpubSummary ::- (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()+scottyXpubSummary :: MonadLoggerIO m => Network -> WebT m () scottyXpubSummary net = do setHeaders- x <- parseXpub net- derive <- parseDeriveAddrs net+ xpub <- parseXpub net proto <- setupBin- db <- askDB- lg <- askLoggerIO- res <- liftIO . runStream lg db $ xpubSummary derive x+ res <- xPubSummary xpub protoSerial net proto res scottyPostTx ::@@ -729,7 +594,7 @@ scottyDbStats :: MonadLoggerIO m => WebT m () scottyDbStats = do setHeaders- BlockDB {blockDB = db} <- askDB+ BlockDB {blockDB = db} <- lift ask stats <- lift (getProperty db Stats) case stats of Nothing -> do@@ -737,11 +602,7 @@ Just txt -> do S.text $ cs txt -scottyEvents ::- (MonadLoggerIO m, MonadUnliftIO m)- => Network- -> Publisher StoreEvent- -> WebT m ()+scottyEvents :: MonadLoggerIO m => Network -> Publisher StoreEvent -> WebT m () scottyEvents net pub = do setHeaders proto <- setupBin@@ -774,7 +635,7 @@ protoSerial net proto ps scottyHealth ::- (MonadLoggerIO m, MonadUnliftIO m)+ (MonadUnliftIO m, MonadLoggerIO m) => Network -> Store -> Timeouts@@ -782,11 +643,7 @@ scottyHealth net st tos = do setHeaders proto <- setupBin- db <- askDB- lg <- askLoggerIO- h <-- liftIO . runStream lg db $- healthCheck net (storeManager st) (storeChain st) tos+ h <- lift $ healthCheck net (storeManager st) (storeChain st) tos when (not (healthOK h) || not (healthSynced h)) $ S.status status503 protoSerial net proto h @@ -807,17 +664,17 @@ runner <- askRunInIO S.scottyT port (runner . withRocksDB bdb) $ do case req_logger of- Just m -> S.middleware m+ Just m -> S.middleware m Nothing -> return () S.defaultHandler (defHandler net)- S.get "/block/best" $ scottyBestBlock net False- S.get "/block/best/raw" $ scottyBestBlock net True- S.get "/block/:block" $ scottyBlock net False- S.get "/block/:block/raw" $ scottyBlock net True- S.get "/block/height/:height" $ scottyBlockHeight net False- S.get "/block/height/:height/raw" $ scottyBlockHeight net True- S.get "/block/time/:time" $ scottyBlockTime net False- S.get "/block/time/:time/raw" $ scottyBlockTime net True+ S.get "/block/best" $ scottyBestBlock net limits False+ S.get "/block/best/raw" $ scottyBestBlock net limits True+ S.get "/block/:block" $ scottyBlock net limits False+ S.get "/block/:block/raw" $ scottyBlock net limits True+ S.get "/block/height/:height" $ scottyBlockHeight net limits False+ S.get "/block/height/:height/raw" $ scottyBlockHeight net limits True+ S.get "/block/time/:time" $ scottyBlockTime net limits False+ S.get "/block/time/:time/raw" $ scottyBlockTime net limits True S.get "/block/heights" $ scottyBlockHeights net S.get "/block/latest" $ scottyBlockLatest net S.get "/blocks" $ scottyBlocks net@@ -827,8 +684,9 @@ S.get "/transaction/:txid/after/:height" $ scottyTxAfterHeight net S.get "/transactions" $ scottyTransactions net S.get "/transactions/raw" $ scottyRawTransactions net- S.get "/transactions/block/:block" $ scottyBlockTransactions net- S.get "/transactions/block/:block/raw" $ scottyRawBlockTransactions net+ S.get "/transactions/block/:block" $ scottyBlockTransactions net limits+ S.get "/transactions/block/:block/raw" $+ scottyRawBlockTransactions net limits S.get "/address/:address/transactions" $ scottyAddressTxs net limits False S.get "/address/:address/transactions/full" $@@ -851,7 +709,7 @@ S.get "/health" $ scottyHealth net st tos S.notFound $ S.raise ThingNotFound -getStart :: (MonadLoggerIO m, MonadUnliftIO m) => WebT m (Maybe BlockRef)+getStart :: MonadLoggerIO m => WebT m (Maybe BlockRef) getStart = runMaybeT $ do s <- MaybeT $ (Just <$> S.param "height") `S.rescue` const (return Nothing)@@ -925,22 +783,25 @@ unless (length as == length addresses) S.next return as -parseXpub :: (Monad m, ScottyError e) => Network -> ActionT e m XPubKey+parseXpub :: (Monad m, ScottyError e) => Network -> ActionT e m XPubSpec parseXpub net = do t <- S.param "xpub"+ d <- parseDeriveAddrs net case xPubImport net t of Nothing -> S.next- Just x -> return x+ Just x -> return XPubSpec {xPubSpecKey = x, xPubDeriveType = d} -parseDeriveAddrs :: (Monad m, ScottyError e) => Network -> ActionT e m DeriveAddr+parseDeriveAddrs ::+ (Monad m, ScottyError e) => Network -> ActionT e m DeriveType parseDeriveAddrs net | getSegWit net = do- t <- S.param "derive" `S.rescue` const (return "standard")- return $ case (t :: Text) of- "segwit" -> \i -> fst . deriveWitnessAddr i- "compat" -> \i -> fst . deriveCompatWitnessAddr i- _ -> \i -> fst . deriveAddr i- | otherwise = return (\i -> fst . deriveAddr i)+ t <- S.param "derive" `S.rescue` const (return "standard")+ return $+ case (t :: Text) of+ "segwit" -> DeriveP2WPKH+ "compat" -> DeriveP2SH+ _ -> DeriveNormal+ | otherwise = return DeriveNormal parseNoTx :: (Monad m, ScottyError e) => ActionT e m Bool parseNoTx = S.param "notx" `S.rescue` const (return False)@@ -962,25 +823,6 @@ serialAny net True = runPutLazy . binSerial net serialAny net False = encodingToLazyByteString . jsonSerial net -streamAny ::- (JsonSerial i, BinSerial i, MonadIO m)- => Network- -> Bool -- ^ protobuf- -> (Builder -> IO ())- -> ConduitT i o m ()-streamAny net True io = binConduit net .| mapC lazyByteString .| streamConduit io-streamAny net False io = jsonListConduit net .| streamConduit io--jsonListConduit :: (JsonSerial a, Monad m) => Network -> ConduitT a Builder m ()-jsonListConduit net =- yield "[" >> mapC (fromEncoding . jsonSerial net) .| intersperseC "," >> yield "]"--binConduit :: (BinSerial i, Monad m) => Network -> ConduitT i L.ByteString m ()-binConduit net = mapC (runPutLazy . binSerial net)--streamConduit :: MonadIO m => (i -> IO ()) -> ConduitT i o m ()-streamConduit io = mapM_C (liftIO . io)- setupBin :: Monad m => ActionT Except m Bool setupBin = let p = do@@ -1005,7 +847,7 @@ monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl healthCheck ::- (MonadUnliftIO m, StoreRead m, StoreStream m)+ (MonadUnliftIO m, StoreRead m) => Network -> Manager -> Chain@@ -1058,7 +900,7 @@ return $ compute_delta bt tm tx_time_delta tm bd ml = do bd' <- bd- tt <- fst <$> ml <|> bd+ tt <- memRefTime . blockTxBlock <$> ml <|> bd return $ min (compute_delta tt tm) bd' timeout_ok to td = fromMaybe False $ do td' <- td@@ -1093,101 +935,6 @@ , peerRelay = rl } -deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]-deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]--xpubBals ::- (MonadUnliftIO m, StoreRead m)- => DeriveAddr- -> XPubKey- -> m [XPubBal]-xpubBals derive xpub = do- ext <- derive_until_gap 0 (deriveAddresses derive (pubSubKey xpub 0) 0)- chg <- derive_until_gap 1 (deriveAddresses derive (pubSubKey xpub 1) 0)- return (ext ++ chg)- where- xbalance _ Nothing _ = Nothing- xbalance m (Just b) n = Just XPubBal {xPubBalPath = [m, n], xPubBal = b}- derive_until_gap _ [] = return []- derive_until_gap m as = do- let n = 32- let (as1, as2) = splitAt n as- mbs <- getBalances (map snd as1)- let xbs = zipWith (xbalance m) mbs (map fst as1)- if all isNothing mbs- then return (catMaybes xbs)- else (catMaybes xbs <>) <$> derive_until_gap m as2--xpubUnspent ::- ( MonadResource m- , MonadUnliftIO m- , StoreStream m- , StoreRead m- )- => Maybe BlockRef- -> DeriveAddr- -> XPubKey- -> ConduitT i XPubUnspent m ()-xpubUnspent start derive xpub = do- xs <- filter positive <$> lift (xpubBals derive xpub)- yieldMany xs .| go- where- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- go =- awaitForever $ \XPubBal { xPubBalPath = p- , xPubBal = Balance {balanceAddress = a}- } ->- getAddressUnspents a start .|- mapC (\t -> XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})--xpubUnspentLimit ::- ( MonadResource m- , MonadUnliftIO m- , StoreStream m- , StoreRead m- )- => Maybe Limit- -> Maybe BlockRef- -> DeriveAddr- -> XPubKey- -> ConduitT i XPubUnspent m ()-xpubUnspentLimit limit start derive xpub =- xpubUnspent start derive xpub .| applyLimit limit--xpubSummary ::- (MonadResource m, MonadUnliftIO m, StoreStream m, StoreRead m)- => DeriveAddr- -> XPubKey- -> m XPubSummary-xpubSummary derive x = do- bs <- xpubBals derive x- let f XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}} =- (a, p)- pm = H.fromList $ map f bs- ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]- ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]- uc =- sum- [ c- | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <- bs- ]- xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]- rx =- sum- [ r- | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <- xt- ]- return- XPubSummary- { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)- , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)- , xPubSummaryReceived = rx- , xPubUnspentCount = uc- , xPubSummaryPaths = pm- , xPubChangeIndex = ch- , xPubExternalIndex = ex- }- -- | 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.@@ -1231,95 +978,64 @@ else r e' ns getAddressTxsLimit ::- (Monad m, StoreStream m)+ (Monad m, StoreRead m) => Offset -> Maybe Limit -> Maybe BlockRef -> Address- -> ConduitT i BlockTx m ()+ -> m [BlockTx] getAddressTxsLimit offset limit start addr =- getAddressTxs addr start .| applyOffsetLimit offset limit+ applyOffset offset <$> getAddressTxs addr start limit getAddressTxsFull ::- (Monad m, StoreStream m, StoreRead m)+ (Monad m, StoreRead m) => Offset -> Maybe Limit -> Maybe BlockRef -> Address- -> ConduitT i Transaction m ()-getAddressTxsFull offset limit start addr =- getAddressTxsLimit offset limit start addr .|- concatMapMC (getTransaction . blockTxHash)+ -> m [Transaction]+getAddressTxsFull offset limit start addr = do+ txs <- getAddressTxsLimit offset limit start addr+ catMaybes <$> mapM (getTransaction . blockTxHash) txs getAddressesTxsLimit ::- (MonadUnliftIO m, StoreRead m)+ (Monad m, StoreRead m) => Maybe Limit -> Maybe BlockRef -> [Address]- -> ConduitT i BlockTx m ()-getAddressesTxsLimit limit start addrs = do- ts <- lift (getAddressesTxs addrs start limit)- forM_ ts yield+ -> m [BlockTx]+getAddressesTxsLimit limit start addrs =+ getAddressesTxs addrs start limit getAddressesTxsFull ::- (MonadResource m, MonadUnliftIO m, StoreStream m, StoreRead m)+ (Monad m, StoreRead m) => Maybe Limit -> Maybe BlockRef -> [Address]- -> ConduitT i Transaction m ()+ -> m [Transaction] getAddressesTxsFull limit start addrs =- getAddressesTxsLimit limit start addrs .|- concatMapMC (getTransaction . blockTxHash)+ fmap catMaybes $+ getAddressesTxsLimit limit start addrs >>=+ mapM (getTransaction . blockTxHash) getAddressUnspentsLimit ::- (Monad m, StoreStream m)+ (Monad m, StoreRead m) => Offset -> Maybe Limit -> Maybe BlockRef -> Address- -> ConduitT i Unspent m ()+ -> m [Unspent] getAddressUnspentsLimit offset limit start addr =- getAddressUnspents addr start .| applyOffsetLimit offset limit+ applyOffset offset <$> getAddressUnspents addr start limit getAddressesUnspentsLimit :: (Monad m, StoreRead m) => Maybe Limit -> Maybe BlockRef -> [Address]- -> ConduitT i Unspent m ()-getAddressesUnspentsLimit limit start addrs = do- uns <- lift (getAddressesUnspents addrs start limit)- forM_ uns yield--conduitToQueue :: MonadIO m => TBQueue (Maybe a) -> ConduitT a Void m ()-conduitToQueue q =- await >>= \case- Just x -> atomically (writeTBQueue q (Just x)) >> conduitToQueue q- Nothing -> atomically $ writeTBQueue q Nothing--queueToConduit :: MonadIO m => TBQueue (Maybe a) -> ConduitT i a m ()-queueToConduit q =- atomically (readTBQueue q) >>= \case- Just x -> yield x >> queueToConduit q- Nothing -> return ()--dedup :: (Eq i, Monad m) => ConduitT i i m ()-dedup =- let dd Nothing =- await >>= \case- Just x -> do- yield x- dd (Just x)- Nothing -> return ()- dd (Just x) =- await >>= \case- Just y- | x == y -> dd (Just x)- | otherwise -> do- yield y- dd (Just y)- Nothing -> return ()- in dd Nothing+ -> m [Unspent]+getAddressesUnspentsLimit limit start addrs =+ getAddressesUnspents addrs start limit -- | Publish a new transaction to the network. publishTx ::@@ -1364,7 +1080,7 @@ | h' == txHash tx -> return $ Right () _ -> g p s -logIt :: (MonadLoggerIO m, MonadUnliftIO m) => m Middleware+logIt :: (MonadUnliftIO m, MonadLoggerIO m) => m Middleware logIt = do runner <- askRunInIO return $ \app req respond -> do@@ -1392,3 +1108,7 @@ fmtStatus :: Status -> Text fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)++refuseLargeBlock :: Monad m => MaxLimits -> BlockData -> ActionT Except m ()+refuseLargeBlock MaxLimits {maxLimitFull = f} BlockData {blockDataTxs = txs} =+ when (length txs > fromIntegral f) $ S.raise BlockTooLarge
+ test/Network/Haskoin/Store/CommonSpec.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Haskoin.Store.CommonSpec+ ( spec+ ) where++import Data.Serialize (decode, encode, runGet, runPut)+import Data.Text (Text)+import Haskoin (Address, Network,+ TxHash (TxHash), bch, bchRegTest,+ bchTest, btc, btcRegTest,+ btcTest, stringToAddr)+import Network.Haskoin.Store.Common (BinSerial (..), DeriveType (..),+ XPubSpec (..))+import Network.Haskoin.Test (arbitraryXPubKey)+import NQE ()+import Test.Hspec (Expectation, Spec, describe, it,+ shouldBe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Gen, elements, forAll)++spec :: Spec+spec = do+ let net = btc+ describe "Extended keys" $ do+ prop "respect serialization identity identity" $+ forAll arbitraryXPubSpec $ \(_, xpub) ->+ Right xpub == (decode . encode) xpub+ describe "Transaction hash serialisation" $ do+ it "tx hash serialisation identity" $+ let tx =+ TxHash+ "0666939fb16533c8e5ebaf6052bb8c90d27ee53fe6035bb763de5253e0b1cd44"+ in testSerial net tx+ describe "Address serialisation" $ do+ it "address serialisation identity" $+ let Just addr =+ stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"+ in testSerial net addr+ it "address list serialisation identity" $+ let expected =+ toAddrList+ net+ [ "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"+ , "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF"+ ]+ in testSerial net expected++toAddrList :: Network -> [Text] -> [Address]+toAddrList net = map (\t -> let Just a = stringToAddr net t in a)++testSerial :: (Eq a, Show a, BinSerial a) => Network -> a -> Expectation+testSerial net input =+ let raw = runPut $ binSerial net input+ deser = runGet (binDeserial net) raw+ in deser `shouldBe` Right input++arbitraryXPubSpec :: Gen (Network, XPubSpec)+arbitraryXPubSpec = do+ (_, k) <- arbitraryXPubKey+ n <- elements [btc, bch, btcTest, bchTest, btcRegTest, bchRegTest]+ t <- elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]+ return (n, XPubSpec {xPubSpecKey = k, xPubDeriveType = t})
− test/Network/Haskoin/Store/Data/TypesSpec.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Network.Haskoin.Store.Data.TypesSpec- ( spec- ) where--import Data.Serialize (runGet, runPut)-import Data.Text (Text)-import qualified Data.Text as T ()-import Haskoin (Address, Network,- TxHash (TxHash), btc,- stringToAddr)-import Network.Haskoin.Store.Data.Types (BinSerial (..))-import NQE ()-import Test.Hspec (Expectation, Spec, describe,- it, shouldBe)--spec :: Spec-spec = do- let net = btc- describe "Transaction hash serialisation" $ do- it "tx hash serialisation identity" $- let tx =- TxHash- "0666939fb16533c8e5ebaf6052bb8c90d27ee53fe6035bb763de5253e0b1cd44"- in testSerial net tx- describe "Address serialisation" $ do- it "address serialisation identity" $- let Just addr =- stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"- in testSerial net addr- it "address list serialisation identity" $- let expected =- toAddrList- net- [ "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"- , "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF"- ]- in testSerial net expected--toAddrList :: Network -> [Text] -> [Address]-toAddrList net = map (\t -> let Just a = stringToAddr net t in a)--testSerial :: (Eq a, Show a, BinSerial a) => Network -> a -> Expectation-testSerial net input =- let raw = runPut $ binSerial net input- deser = runGet (binDeserial net) raw- in deser `shouldBe` Right input