diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -60,10 +60,10 @@ defMaxLimits :: MaxLimits defMaxLimits = MaxLimits - { maxLimitCount = 10000 - , maxLimitFull = 500 + { maxLimitCount = 20000 + , maxLimitFull = 5000 , maxLimitOffset = 50000 - , maxLimitDefault = 100 + , maxLimitDefault = 2000 } defTimeouts :: Timeouts diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -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 (..), diff --git a/src/Network/Haskoin/Store/Block.hs b/src/Network/Haskoin/Store/Block.hs --- a/src/Network/Haskoin/Store/Block.hs +++ b/src/Network/Haskoin/Store/Block.hs @@ -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 diff --git a/src/Network/Haskoin/Store/Common.hs b/src/Network/Haskoin/Store/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Common.hs @@ -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 diff --git a/src/Network/Haskoin/Store/Data/ImportDB.hs b/src/Network/Haskoin/Store/Data/ImportDB.hs --- a/src/Network/Haskoin/Store/Data/ImportDB.hs +++ b/src/Network/Haskoin/Store/Data/ImportDB.hs @@ -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 diff --git a/src/Network/Haskoin/Store/Data/KeyValue.hs b/src/Network/Haskoin/Store/Data/KeyValue.hs --- a/src/Network/Haskoin/Store/Data/KeyValue.hs +++ b/src/Network/Haskoin/Store/Data/KeyValue.hs @@ -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 diff --git a/src/Network/Haskoin/Store/Data/Memory.hs b/src/Network/Haskoin/Store/Data/Memory.hs --- a/src/Network/Haskoin/Store/Data/Memory.hs +++ b/src/Network/Haskoin/Store/Data/Memory.hs @@ -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 diff --git a/src/Network/Haskoin/Store/Data/RocksDB.hs b/src/Network/Haskoin/Store/Data/RocksDB.hs --- a/src/Network/Haskoin/Store/Data/RocksDB.hs +++ b/src/Network/Haskoin/Store/Data/RocksDB.hs @@ -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 diff --git a/src/Network/Haskoin/Store/Data/Types.hs b/src/Network/Haskoin/Store/Data/Types.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data/Types.hs +++ /dev/null @@ -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) diff --git a/src/Network/Haskoin/Store/Logic.hs b/src/Network/Haskoin/Store/Logic.hs --- a/src/Network/Haskoin/Store/Logic.hs +++ b/src/Network/Haskoin/Store/Logic.hs @@ -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] diff --git a/src/Network/Haskoin/Store/Web.hs b/src/Network/Haskoin/Store/Web.hs --- a/src/Network/Haskoin/Store/Web.hs +++ b/src/Network/Haskoin/Store/Web.hs @@ -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 diff --git a/test/Network/Haskoin/Store/CommonSpec.hs b/test/Network/Haskoin/Store/CommonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Haskoin/Store/CommonSpec.hs @@ -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}) diff --git a/test/Network/Haskoin/Store/Data/TypesSpec.hs b/test/Network/Haskoin/Store/Data/TypesSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Store/Data/TypesSpec.hs +++ /dev/null @@ -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