haskoin-store (empty) → 0.1.0
raw patch · 10 files changed
+3001/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, cereal, conduit, containers, directory, filepath, haskoin-core, haskoin-node, haskoin-store, hspec, http-types, monad-logger, mtl, network, nqe, optparse-applicative, random, rocksdb-haskell, rocksdb-query, scotty, string-conversions, text, time, transformers, unliftio
Files
- CHANGELOG.md +24/−0
- README.md +66/−0
- Setup.hs +2/−0
- UNLICENSE +24/−0
- app/Main.hs +446/−0
- haskoin-store.cabal +131/−0
- src/Network/Haskoin/Store.hs +275/−0
- src/Network/Haskoin/Store/Block.hs +1170/−0
- src/Network/Haskoin/Store/Types.hs +747/−0
- test/Spec.hs +116/−0
+ CHANGELOG.md view
@@ -0,0 +1,24 @@+# Changelog+All notable changes to this project will be documented in this file.++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.1.0+### Added+- New `CHANGELOG.md` file.+- Bitcoin (BTC) and Bitcoin Cash (BCH) compatibility.+- RocksDB database.+- Mempool support.+- HTTP streaming for events.+- CashAddr support.+- Bech32 support.+- Rate limits.++### Changed+- Split out of former `haskoin` repository.+- Use hpack and `package.yaml`.++### Removed+- Removed Stylish Haskell configuration file.+- Remvoed `haskoin-core` and `haskoin-wallet` packages from this repository.
+ README.md view
@@ -0,0 +1,66 @@+# Haskoin Store++Full blockchain index & store featuring:++- Address index.+- Mempool.+- Persistent storage using RocksDB.+- RESTful endpoints for blockchain data.+- Concurrent design.+- No blocking on database access.+- Guaranteed consistency within a request.+- Atomic updates to prevent corruption.+++## Install++* Get [Stack](https://haskell-lang.org/get-started).+* Get [Nix](https://nixos.org/nix/).+* Clone this repository `git clone https://github.com/haskoin/haskoin-store`.+* From the root of this repository run `stack --nix build --copy-bins`.+* File will usually be installed in `~/.local/bin/haskoin-store`.+++## API Documentation++* [Swagger API Documentation](https://btc.haskoin.com/).+++## Addresses & Balances++For every address Haskoin Store has a balance object that contains basic statistics about the address. These statistics are described below.++* `confirmed` balance is that which is in the blockchain. Will always be positive or zero.+* `unconfirmed` balance represent aggregate changes done by mempool transactions. Can be negative if the transactions currently in the mempool are expected to reduce the balance when all of them make it into the blockchain.+* `outputs` is the count of outputs that send funds to this address. It is just a count and not a monetary value.+* `utxo` is the count of outputs that send funds to this address that remain unspent, taking the mempool into account: if spent in the mempool it will *not* count as unspent.++## Limits++Various endpoints in the API will have both server and per-query limits to avoid overloading the server. Depending on the type of query being done the limits have varying effects.++### Multiple Objects in URI++If specifying multiple objects in the URI, for example when obtaining the balances for multiple addresses, no more than 500 elements may be requested.++If each object specified in the URI might lead to multiple results, these will be concatenated in the response, such that the first set of elements will correspond to the first requested item that yields any results, and the last set of elements will correspond to the last requested item that yields results, assuming that the number of returned items has not exceeded the count limit.++### Count Limit++The count limit is set by default at 10,000 server-wide. It may be changed via the server command line or for an individual request. The individual request limit may not be value larger than the server’s.++If the number of available results exceeds the count limit, and if stopping at exactly the limit would lead to a result set that would be partial for a block in the blockchain, any extra items that belong to the same block as the last element that fits within the limit will be appended to the results, exceeding the count limit.++When multiple objects are present in the URI and the result set exceeds the count limit, and stopping at the limit would lead to a partial result set for a requested item and block in the blockchain, any extra elements that pertain to the same item and block as the last element that fits within the limit will be appended.++The mempool is considered as a single block for count limit calculation purposes.++In short, a block worth of relevant data—or the mempool—will always be delivered in its entirety, regardless of the count limit.++### Height Limit++When delivering multiple results, Haskoin Store will start with data from the mempool, and then data from the highest block in the chain, followed by its parent, and so on until reaching the genesis block, or the count limit. Results are returned in reversed order from highest (latest) to lowest (earliest).++If the result set count matches or exceeds the count limit, it is possible that there are more entries available below the block height of the last result returned. By specifying a height limit in the query, the result set will start at the specified height, skipping any blocks above it.++Since block data is never delivered incomplete, it suffices to subtract one to the block height of the last returned element when performing the next request. If the last returned element is not in a block, then the height of the best block should be used for the next request.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ UNLICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org/>
+ app/Main.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+import Conduit+import Control.Arrow+import Control.Concurrent.NQE+import Control.Exception+import Control.Monad+import Control.Monad.Logger+import Data.Aeson (ToJSON (..), Value (..), encode,+ object, (.=))+import Data.Bits+import Data.ByteString.Builder (lazyByteString)+import Data.Function+import Data.List+import Data.Maybe+import Data.String.Conversions+import qualified Data.Text as T+import Data.Version+import Database.RocksDB hiding (get)+import Haskoin+import Network.Haskoin.Node+import Network.Haskoin.Store+import Network.HTTP.Types+import Options.Applicative+import Paths_haskoin_store as P+import System.Directory+import System.Exit+import System.FilePath+import System.IO.Unsafe+import Text.Read (readMaybe)+import UnliftIO+import Web.Scotty.Trans++data OptConfig = OptConfig+ { optConfigDir :: !(Maybe FilePath)+ , optConfigPort :: !(Maybe Int)+ , optConfigNetwork :: !(Maybe Network)+ , optConfigDiscover :: !(Maybe Bool)+ , optConfigPeers :: !(Maybe [(Host, Maybe Port)])+ , optConfigMaxReqs :: !(Maybe Int)+ , optConfigVersion :: !Bool+ }++data Config = Config+ { configDir :: !FilePath+ , configPort :: !Int+ , configNetwork :: !Network+ , configDiscover :: !Bool+ , configPeers :: ![(Host, Maybe Port)]+ , configMaxReqs :: !Int+ }++maxUriArgs :: Int+maxUriArgs = 500++maxPubSubQueue :: Int+maxPubSubQueue = 10000++defMaxReqs :: Int+defMaxReqs = 10000++defPort :: Int+defPort = 3000++defNetwork :: Network+defNetwork = btc++defDiscovery :: Bool+defDiscovery = False++defPeers :: [(Host, Maybe Port)]+defPeers = []++optToConfig :: OptConfig -> Config+optToConfig OptConfig {..} =+ Config+ { configDir = fromMaybe myDirectory optConfigDir+ , configPort = fromMaybe defPort optConfigPort+ , configNetwork = fromMaybe defNetwork optConfigNetwork+ , configDiscover = fromMaybe defDiscovery optConfigDiscover+ , configPeers = fromMaybe defPeers optConfigPeers+ , configMaxReqs = fromMaybe defMaxReqs optConfigMaxReqs+ }++instance Parsable BlockHash where+ parseParam =+ maybe (Left "could not decode block hash") Right . hexToBlockHash . cs++instance Parsable TxHash where+ parseParam =+ maybe (Left "could not decode tx hash") Right . hexToTxHash . cs++data Except+ = ThingNotFound+ | ServerError+ | BadRequest+ | UserError String+ | OutOfBounds+ | StringError String+ deriving (Show, Eq)++instance Exception Except++instance ScottyError Except where+ stringError = StringError+ showError = cs . show++instance ToJSON Except where+ toJSON ThingNotFound = object ["error" .= String "not found"]+ toJSON BadRequest = object ["error" .= String "bad request"]+ toJSON ServerError = object ["error" .= String "you made me kill a unicorn"]+ toJSON OutOfBounds = object ["error" .= String "too many elements requested"]+ toJSON (StringError _) = object ["error" .= String "you made me kill a unicorn"]+ toJSON (UserError s) = object ["error" .= s]++data JsonEvent+ = JsonEventTx TxHash+ | JsonEventBlock BlockHash+ deriving (Eq, Show)++instance ToJSON JsonEvent where+ toJSON (JsonEventTx tx_hash) =+ object ["type" .= String "tx", "id" .= tx_hash]+ toJSON (JsonEventBlock block_hash) =+ object ["type" .= String "block", "id" .= block_hash]++netNames :: String+netNames = intercalate "|" $ map getNetworkName allNets++config :: Parser OptConfig+config = do+ optConfigDir <-+ optional . option str $+ metavar "DIR" <> long "dir" <> short 'd' <>+ help ("Data directory (default: " <> myDirectory <> ")")+ optConfigPort <-+ optional . option auto $+ metavar "PORT" <> long "port" <> short 'p' <>+ help ("Port to listen (default: " <> show defPort <> ")")+ optConfigNetwork <-+ optional . option (eitherReader networkReader) $+ metavar "NETWORK" <> long "network" <> short 'n' <>+ help ("Network: " <> netNames <> " (default: " <> net <> ")")+ optConfigDiscover <-+ optional . switch $ long "discover" <> help "Enable peer discovery"+ optConfigPeers <-+ optional . option (eitherReader peerReader) $+ metavar "PEERS" <> long "peers" <>+ help "Network peers (i.e. localhost,peer.example.com:8333)"+ optConfigMaxReqs <-+ optional . option auto $+ metavar "MAXREQ" <> long "maxreq" <>+ help ("Maximum returned entries (default:" <> show defMaxReqs <> ")")+ optConfigVersion <-+ switch $ long "version" <> short 'v' <> help "Show version"+ return OptConfig {..}+ where+ net = getNetworkName defNetwork++networkReader :: String -> Either String Network+networkReader s+ | s == getNetworkName btc = Right btc+ | s == getNetworkName btcTest = Right btcTest+ | s == getNetworkName btcRegTest = Right btcRegTest+ | s == getNetworkName bch = Right bch+ | s == getNetworkName bchTest = Right bchTest+ | s == getNetworkName bchRegTest = Right bchRegTest+ | otherwise = Left "Network name invalid"++peerReader :: String -> Either String [(Host, Maybe Port)]+peerReader = mapM hp . ls+ where+ hp s = do+ let (host, p) = span (/= ':') s+ when (null host) (Left "Peer name or address not defined")+ port <-+ case p of+ [] -> return Nothing+ ':':p' ->+ case readMaybe p' of+ Nothing -> Left "Peer port number cannot be read"+ Just n -> return (Just n)+ _ -> Left "Peer information could not be parsed"+ return (host, port)+ ls = map T.unpack . T.split (== ',') . T.pack++defHandler :: Monad m => Except -> ActionT Except m ()+defHandler ServerError = json ServerError+defHandler OutOfBounds = status status413 >> json OutOfBounds+defHandler ThingNotFound = status status404 >> json ThingNotFound+defHandler BadRequest = status status400 >> json BadRequest+defHandler (UserError s) = status status400 >> json (UserError s)+defHandler e = status status400 >> json e++maybeJSON :: (Monad m, ToJSON a) => Maybe a -> ActionT Except m ()+maybeJSON Nothing = raise ThingNotFound+maybeJSON (Just x) = json x++myDirectory :: FilePath+myDirectory = unsafePerformIO $ getAppUserDataDirectory "haskoin-store"+{-# NOINLINE myDirectory #-}++main :: IO ()+main =+ runStderrLoggingT $ do+ opt <- liftIO (execParser opts)+ when (optConfigVersion opt) . liftIO $ do+ putStrLn $ showVersion P.version+ exitSuccess+ let conf = optToConfig opt+ when (null (configPeers conf) && not (configDiscover conf)) . liftIO $+ die "Specify: --discover | --peers PEER,..."+ let net = configNetwork conf+ b <- Inbox <$> newTQueueIO+ s <- Inbox <$> newTQueueIO+ let wdir = configDir conf </> getNetworkName net+ liftIO $ createDirectoryIfMissing True wdir+ db <-+ open+ (wdir </> "blocks")+ defaultOptions+ { createIfMissing = True+ , compression = SnappyCompression+ , maxOpenFiles = -1+ , writeBufferSize = 2 `shift` 30+ }+ mgr <- Inbox <$> newTQueueIO+ pub <- Inbox <$> newTQueueIO+ ch <- Inbox <$> newTQueueIO+ supervisor+ KillAll+ s+ [runWeb conf pub mgr ch b db, runStore conf pub mgr ch b db]+ where+ opts =+ info (helper <*> config) $+ fullDesc <> progDesc "Blockchain store and API" <>+ Options.Applicative.header ("haskoin-store version " <> showVersion P.version)++testLength :: Monad m => Int -> ActionT Except m ()+testLength l = when (l <= 0 || l > maxUriArgs) (raise OutOfBounds)++runWeb ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Config+ -> Publisher Inbox TBQueue StoreEvent+ -> Manager+ -> Chain+ -> BlockStore+ -> DB+ -> m ()+runWeb conf pub mgr ch bl db = do+ l <- askLoggerIO+ scottyT (configPort conf) (runner l) $ do+ defaultHandler defHandler+ get "/block/best" $ getBestBlock db Nothing >>= json+ get "/block/:block" $ do+ block <- param "block"+ getBlock block db Nothing >>= maybeJSON+ get "/block/height/:height" $ do+ height <- param "height"+ getBlockAtHeight height db Nothing >>= maybeJSON+ get "/block/heights" $ do+ heights <- param "heights"+ testLength (length heights)+ getBlocksAtHeights heights db Nothing >>= json+ get "/blocks" $ do+ blocks <- param "blocks"+ testLength (length blocks)+ getBlocks blocks db Nothing >>= json+ get "/mempool" $ lift (getMempool db Nothing) >>= json+ get "/transaction/:txid" $ do+ txid <- param "txid"+ lift (getTx net txid db Nothing) >>= maybeJSON+ get "/transactions" $ do+ txids <- param "txids"+ testLength (length txids)+ lift (getTxs net txids db Nothing) >>= json+ get "/address/:address/outputs" $ do+ address <- parse_address+ height <- parse_height+ x <- parse_max+ lift (addrTxsMax db x height address) >>= json+ get "/address/outputs" $ do+ addresses <- parse_addresses+ height <- parse_height+ x <- parse_max+ lift (addrsTxsMax db x height addresses) >>= json+ get "/address/:address/unspent" $ do+ address <- parse_address+ height <- parse_height+ x <- parse_max+ lift (addrUnspentMax db x height address) >>= json+ get "/address/unspent" $ do+ addresses <- parse_addresses+ height <- parse_height+ x <- parse_max+ lift (addrsUnspentMax db x height addresses) >>= json+ get "/address/:address/balance" $ do+ address <- parse_address+ getBalance address db Nothing >>= json+ get "/address/balances" $ do+ addresses <- parse_addresses+ getBalances addresses db Nothing >>= json+ post "/transactions" $ do+ NewTx tx <- jsonData+ lift (publishTx net pub mgr ch db bl tx) >>= \case+ Left PublishTimeout -> do+ status status500+ json (UserError (show PublishTimeout))+ Left e -> do+ status status400+ json (UserError (show e))+ Right j -> json j+ get "/dbstats" $ getProperty db Stats >>= text . cs . fromJust+ get "/events" $ do+ setHeader "Content-Type" "application/x-json-stream"+ stream $ \io flush ->+ withBoundedPubSub maxPubSubQueue pub $ \sub ->+ forever $+ flush >> receive sub >>= \case+ BestBlock block_hash -> do+ let bs = encode (JsonEventBlock block_hash) <> "\n"+ io (lazyByteString bs)+ MempoolNew tx_hash -> do+ let bs = encode (JsonEventTx tx_hash) <> "\n"+ io (lazyByteString bs)+ _ -> return ()+ notFound $ raise ThingNotFound+ where+ parse_address = do+ address <- param "address"+ case stringToAddr net address of+ Nothing -> next+ Just a -> return a+ parse_addresses = do+ addresses <- param "addresses"+ let as = mapMaybe (stringToAddr net) addresses+ if length as == length addresses+ then testLength (length as) >> return as+ else next+ parse_max = do+ x <- param "max" `rescue` const (return (configMaxReqs conf))+ when (x < 1 || x > configMaxReqs conf) (raise OutOfBounds)+ return x+ parse_height = (Just <$> param "height") `rescue` const (return Nothing)+ net = configNetwork conf+ runner f l = do+ u <- askUnliftIO+ unliftIO u (runLoggingT l f)++runStore ::+ (MonadLoggerIO m, MonadUnliftIO m)+ => Config+ -> Publisher Inbox TBQueue StoreEvent+ -> Manager+ -> Chain+ -> BlockStore+ -> DB+ -> m ()+runStore conf pub mgr ch b db = do+ s <- Inbox <$> newTQueueIO+ let net = configNetwork conf+ cfg =+ StoreConfig+ { storeConfBlocks = b+ , storeConfSupervisor = s+ , storeConfChain = ch+ , storeConfManager = mgr+ , storeConfPublisher = pub+ , storeConfMaxPeers = 20+ , storeConfInitPeers =+ map+ (second (fromMaybe (getDefaultPort net)))+ (configPeers conf)+ , storeConfDiscover = configDiscover conf+ , storeConfDB = db+ , storeConfNetwork = net+ }+ store cfg++addrTxsMax ::+ MonadUnliftIO m+ => DB+ -> Int+ -> Maybe BlockHeight+ -> Address+ -> m [AddrOutput]+addrTxsMax db c h = addrsTxsMax db c h . (: [])++addrsTxsMax ::+ MonadUnliftIO m+ => DB+ -> Int+ -> Maybe BlockHeight+ -> [Address]+ -> m [AddrOutput]+addrsTxsMax db c h as =+ runResourceT $+ runConduit $ getAddrsOutputs as h db Nothing .| capRecords f c .| sinkList+ where+ f = (==) `on` g+ g AddrOutput {..} =+ (addrOutputAddress addrOutputKey, blockRefHash <$> outBlock addrOutput)++addrUnspentMax ::+ MonadUnliftIO m+ => DB+ -> Int+ -> Maybe BlockHeight+ -> Address+ -> m [AddrOutput]+addrUnspentMax db c h = addrsUnspentMax db c h . (: [])++addrsUnspentMax ::+ MonadUnliftIO m+ => DB+ -> Int+ -> Maybe BlockHeight+ -> [Address]+ -> m [AddrOutput]+addrsUnspentMax db c h as =+ runResourceT $+ runConduit $ getUnspents as h db Nothing .| capRecords f c .| sinkList+ where+ f = (==) `on` g+ g AddrOutput {..} =+ (addrOutputAddress addrOutputKey, blockRefHash <$> outBlock addrOutput)++capRecords :: Monad m => (a -> a -> Bool) -> Int -> ConduitT a a m ()+capRecords f c = void $ mapAccumWhileC go (Nothing, c)+ where+ go x (acc, n)+ | n > 0 = Right ((Just x, n - 1), x)+ | otherwise =+ case acc of+ Nothing -> Left (Just x, n - 1)+ Just y ->+ if f x y+ then Right ((Just x, n - 1), x)+ else Left (Just x, n - 1)
+ haskoin-store.cabal view
@@ -0,0 +1,131 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 196c994ec9a01682cf61d0d95691b91207a2d002102b4d836bfa18586c832bd9++name: haskoin-store+version: 0.1.0+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+homepage: http://github.com/haskoin/haskoin#readme+bug-reports: http://github.com/haskoin/haskoin/issues+author: Jean-Pierre Rupp+maintainer: xenog@protonmail.com+license: PublicDomain+license-file: UNLICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/haskoin/haskoin.git++library+ exposed-modules:+ Network.Haskoin.Store+ other-modules:+ Network.Haskoin.Store.Block+ Network.Haskoin.Store.Types+ Paths_haskoin_store+ hs-source-dirs:+ src+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , cereal+ , conduit+ , containers+ , directory+ , filepath+ , haskoin-core+ , haskoin-node+ , hspec+ , http-types+ , monad-logger+ , mtl+ , network+ , nqe+ , optparse-applicative+ , random+ , rocksdb-haskell+ , rocksdb-query+ , scotty+ , string-conversions+ , text+ , time+ , transformers+ , unliftio+ default-language: Haskell2010++executable haskoin-store+ main-is: Main.hs+ other-modules:+ Paths_haskoin_store+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , cereal+ , conduit+ , directory+ , filepath+ , haskoin-core+ , haskoin-node+ , haskoin-store+ , hspec+ , http-types+ , monad-logger+ , mtl+ , nqe+ , optparse-applicative+ , random+ , rocksdb-haskell+ , scotty+ , string-conversions+ , text+ , time+ , unliftio+ default-language: Haskell2010++test-suite haskoin-store-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_haskoin_store+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , cereal+ , conduit+ , directory+ , filepath+ , haskoin-core+ , haskoin-node+ , haskoin-store+ , hspec+ , http-types+ , monad-logger+ , mtl+ , nqe+ , optparse-applicative+ , random+ , rocksdb-haskell+ , scotty+ , string-conversions+ , text+ , time+ , unliftio+ default-language: Haskell2010
+ src/Network/Haskoin/Store.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Haskoin.Store+ ( BlockStore+ , Output(..)+ , BlockRef(..)+ , StoreConfig(..)+ , StoreEvent(..)+ , BlockValue(..)+ , DetailedTx(..)+ , NewTx(..)+ , AddrOutputKey(..)+ , AddrOutput(..)+ , AddressBalance(..)+ , TxException(..)+ , store+ , getBestBlock+ , getBlockAtHeight+ , getBlocksAtHeights+ , getBlock+ , getBlocks+ , getTx+ , getTxs+ , getAddrOutputs+ , getAddrsOutputs+ , getUnspent+ , getUnspents+ , getBalance+ , getBalances+ , getMempool+ , publishTx+ ) where++import Control.Concurrent.NQE+import Control.Monad.Except+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Maybe+import Data.Serialize+import Data.String+import Data.String.Conversions+import Database.RocksDB+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Network+import Network.Haskoin.Node+import Network.Haskoin.Store.Block+import Network.Haskoin.Store.Types+import Network.Haskoin.Transaction+import Network.Socket (SockAddr (..))+import System.Random+import UnliftIO++type MonadStore m = (MonadLoggerIO m, MonadReader StoreRead m)++data StoreRead = StoreRead+ { myMailbox :: !(Inbox NodeEvent)+ , myBlockStore :: !BlockStore+ , myChain :: !Chain+ , myManager :: !Manager+ , myListener :: !(Listen StoreEvent)+ , myPublisher :: !(Publisher Inbox TBQueue StoreEvent)+ , myBlockDB :: !DB+ , myNetwork :: !Network+ }++store :: (MonadLoggerIO m, MonadUnliftIO m) => StoreConfig m -> m ()+store StoreConfig {..} = do+ $(logInfoS) "Store" "Launching..."+ ns <- Inbox <$> newTQueueIO+ sm <- Inbox <$> newTQueueIO+ ls <- Inbox <$> newTQueueIO+ let node_cfg =+ NodeConfig+ { maxPeers = storeConfMaxPeers+ , database = storeConfDB+ , initPeers = storeConfInitPeers+ , discover = storeConfDiscover+ , nodeEvents = (`sendSTM` sm)+ , netAddress = NetworkAddress 0 (SockAddrInet 0 0)+ , nodeSupervisor = ns+ , nodeChain = storeConfChain+ , nodeManager = storeConfManager+ , nodeNet = storeConfNetwork+ }+ let store_read =+ StoreRead+ { myMailbox = sm+ , myBlockStore = storeConfBlocks+ , myChain = storeConfChain+ , myManager = storeConfManager+ , myPublisher = storeConfPublisher+ , myListener = (`sendSTM` ls)+ , myBlockDB = storeConfDB+ , myNetwork = storeConfNetwork+ }+ let block_cfg =+ BlockConfig+ { blockConfMailbox = storeConfBlocks+ , blockConfChain = storeConfChain+ , blockConfManager = storeConfManager+ , blockConfListener = (`sendSTM` ls)+ , blockConfDB = storeConfDB+ , blockConfNet = storeConfNetwork+ }+ supervisor+ KillAll+ storeConfSupervisor+ [ runReaderT run store_read+ , node node_cfg+ , blockStore block_cfg+ , boundedPublisher storeConfPublisher ls+ ]+ where+ run =+ forever $ do+ sm <- asks myMailbox+ storeDispatch =<< receive sm++storeDispatch :: MonadStore m => NodeEvent -> m ()++storeDispatch (ManagerEvent (ManagerConnect p)) = do+ b <- asks myBlockStore+ l <- asks myListener+ atomically (l (PeerConnected p))+ BlockPeerConnect p `send` b++storeDispatch (ManagerEvent (ManagerDisconnect p)) = do+ b <- asks myBlockStore+ l <- asks myListener+ atomically (l (PeerDisconnected p))+ BlockPeerDisconnect p `send` b++storeDispatch (ChainEvent (ChainNewBest bn)) = do+ b <- asks myBlockStore+ BlockChainNew bn `send` b++storeDispatch (ChainEvent _) = return ()++storeDispatch (PeerEvent (p, GotBlock block)) = do+ b <- asks myBlockStore+ BlockReceived p block `send` b++storeDispatch (PeerEvent (p, BlockNotFound hash)) = do+ b <- asks myBlockStore+ BlockNotReceived p hash `send` b++storeDispatch (PeerEvent (p, TxAvail ts)) = do+ b <- asks myBlockStore+ TxAvailable p ts `send` b++storeDispatch (PeerEvent (p, GotTx tx)) = do+ b <- asks myBlockStore+ TxReceived p tx `send` b++storeDispatch (PeerEvent (p, Rejected Reject {..})) =+ void . runMaybeT $ do+ l <- asks myListener+ guard (rejectMessage == MCTx)+ pstr <- peerString p+ tx_hash <- decode_tx_hash pstr rejectData+ case rejectCode of+ RejectInvalid -> do+ $(logErrorS) "Store" $+ "Peer " <> pstr <> " rejected invalid tx hash: " <>+ cs (txHashToHex tx_hash)+ atomically (l (TxException tx_hash InvalidTx))+ RejectDuplicate -> do+ $(logErrorS) "Store" $+ "Peer " <> pstr <> " rejected double-spend tx hash: " <>+ cs (txHashToHex tx_hash)+ atomically (l (TxException tx_hash DoubleSpend))+ RejectNonStandard -> do+ $(logErrorS) "Store" $+ "Peer " <> pstr <> " rejected non-standard tx hash: " <>+ cs (txHashToHex tx_hash)+ atomically (l (TxException tx_hash NonStandard))+ RejectDust -> do+ $(logErrorS) "Store" $+ "Peer " <> pstr <> " rejected dust tx hash: " <>+ cs (txHashToHex tx_hash)+ atomically (l (TxException tx_hash Dust))+ RejectInsufficientFee -> do+ $(logErrorS) "Store" $+ "Peer " <> pstr <> " rejected low fee tx hash: " <>+ cs (txHashToHex tx_hash)+ atomically (l (TxException tx_hash LowFee))+ _ -> do+ $(logErrorS) "Store" $+ "Peer " <> pstr <> " rejected tx hash: " <>+ cs (show rejectCode)+ atomically (l (TxException tx_hash PeerRejectOther))+ where+ decode_tx_hash pstr bytes =+ case decode bytes of+ Left e -> do+ $(logErrorS) "Store" $+ "Could not decode rejection data from peer " <> pstr <> ": " <>+ cs e+ MaybeT (return Nothing)+ Right h -> return h++storeDispatch (PeerEvent (_, TxNotFound tx_hash)) = do+ l <- asks myListener+ atomically (l (TxException tx_hash CouldNotImport))++storeDispatch (PeerEvent _) = return ()++publishTx ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Network+ -> Publisher Inbox TBQueue StoreEvent+ -> Manager+ -> Chain+ -> DB+ -> BlockStore+ -> Tx+ -> m (Either TxException DetailedTx)+publishTx net pub mgr ch db bl tx =+ getTx net (txHash tx) db Nothing >>= \case+ Just d -> return (Right d)+ Nothing ->+ timeout 10000000 (runExceptT go) >>= \case+ Nothing -> return (Left PublishTimeout)+ Just e -> return e+ where+ go = do+ p <-+ managerGetPeers mgr >>= \case+ [] -> throwError NoPeers+ p:_ -> return (onlinePeerMailbox p)+ ExceptT . withBoundedPubSub 1000 pub $ \sub ->+ runExceptT (send_it sub p)+ send_it sub p = do+ h <- is_at_height+ unless h $ throwError NotAtHeight+ r <- liftIO randomIO+ MTx tx `sendMessage` p+ MPing (Ping r) `sendMessage` p+ recv_loop sub p r+ maybeToExceptT+ CouldNotImport+ (MaybeT (getTx net (txHash tx) db Nothing))+ recv_loop sub p r =+ receive sub >>= \case+ PeerPong p' n+ | p == p' && n == r -> do+ TxPublished tx `send` bl+ recv_loop sub p r+ MempoolNew h+ | h == txHash tx -> return ()+ PeerDisconnected p'+ | p' == p -> throwError PeerIsGone+ TxException h AlreadyImported+ | h == txHash tx -> return ()+ TxException h x+ | h == txHash tx -> throwError x+ _ -> recv_loop sub p r+ is_at_height = do+ bb <- getBestBlockHash db Nothing+ cb <- chainGetBest ch+ return (headerHash (nodeHeader cb) == bb)++peerString :: (MonadStore m, IsString a) => Peer -> m a+peerString p = do+ mgr <- asks myManager+ managerGetPeer mgr p >>= \case+ Nothing -> return "[unknown]"+ Just o -> return $ fromString $ show $ onlinePeerAddress o
+ src/Network/Haskoin/Store/Block.hs view
@@ -0,0 +1,1170 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module Network.Haskoin.Store.Block+ ( blockStore+ , getBestBlock+ , getBestBlockHash+ , getBlocksAtHeights+ , getBlockAtHeight+ , getBlock+ , getBlocks+ , getUnspent+ , getAddrOutputs+ , getAddrsOutputs+ , getBalance+ , getBalances+ , getTx+ , getTxs+ , getUnspents+ , getMempool+ ) where++import Conduit+import Control.Applicative+import Control.Concurrent.NQE+import Control.Monad.Except+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Trans.Maybe+import qualified Data.ByteString as B+import Data.Foldable+import Data.Function+import Data.List+import Data.Map (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Serialize (encode)+import Data.Set (Set)+import qualified Data.Set as S+import Data.String+import Data.String.Conversions+import Data.Text (Text)+import Data.Time.Clock.POSIX+import Database.RocksDB (BatchOp, DB, Snapshot)+import qualified Database.RocksDB as R+import Database.RocksDB.Query as R+import Haskoin+import Network.Haskoin.Node+import Network.Haskoin.Store.Types+import UnliftIO++data BlockRead = BlockRead+ { myBlockDB :: !DB+ , mySelf :: !BlockStore+ , myChain :: !Chain+ , myManager :: !Manager+ , myListener :: !(Listen StoreEvent)+ , myBaseHeight :: !(TVar BlockHeight)+ , myPeer :: !(TVar (Maybe Peer))+ , myNetwork :: !Network+ }++type MonadBlock m+ = (MonadLoggerIO m, MonadReader BlockRead m)++type OutputMap = Map OutPoint Output+type AddressMap = Map Address Balance+type TxMap = Map TxHash ImportTx++data TxStatus+ = TxValid+ | TxOrphan+ | TxLowFunds+ | TxInputSpent+ deriving (Eq, Show, Ord)++data ImportTx = ImportTx+ { importTx :: !Tx+ , importTxBlock :: !(Maybe BlockRef)+ }++data ImportState = ImportState+ { outputMap :: !OutputMap+ , addressMap :: !AddressMap+ , deleteTxs :: !(Set TxHash)+ , newTxs :: !TxMap+ , blockAction :: !(Maybe BlockAction)+ }++type MonadImport m = MonadState ImportState m++data BlockAction = RevertBlock | ImportBlock !Block++runMonadImport :: MonadBlock m => StateT ImportState m a -> m a+runMonadImport f =+ evalStateT+ (f >>= \a -> update_database >> return a)+ ImportState+ { outputMap = M.empty+ , addressMap = M.empty+ , deleteTxs = S.empty+ , newTxs = M.empty+ , blockAction = Nothing+ }+ where+ update_database = do+ oops <- purgeOrphanOps+ ops <-+ (<> oops) . concat <$>+ sequence+ [getBlockOps, getBalanceOps, getDeleteTxOps, getInsertTxOps]+ db <- asks myBlockDB+ writeBatch db ops+ l <- asks myListener+ gets blockAction >>= \case+ Just (ImportBlock Block {..}) ->+ atomically (l (BestBlock (headerHash blockHeader)))+ Just RevertBlock -> $(logWarnS) "Block" "Reverted best block"+ _ -> return ()++blockStore :: (MonadUnliftIO m, MonadLoggerIO m) => BlockConfig -> m ()+blockStore BlockConfig {..} = do+ base_height_box <- newTVarIO 0+ peer_box <- newTVarIO Nothing+ runReaderT+ (init_db >> syncBlocks >> run)+ BlockRead+ { mySelf = blockConfMailbox+ , myBlockDB = blockConfDB+ , myChain = blockConfChain+ , myManager = blockConfManager+ , myListener = blockConfListener+ , myBaseHeight = base_height_box+ , myPeer = peer_box+ , myNetwork = blockConfNet+ }+ where+ run =+ forever $ do+ msg <- receive blockConfMailbox+ processBlockMessage msg+ init_db =+ runResourceT $ do+ runConduit $+ matching blockConfDB Nothing OrphanKey .|+ mapM_C (\(k, Tx {}) -> remove blockConfDB k)+ retrieve blockConfDB Nothing BestBlockKey >>= \case+ Nothing -> addNewBlock (genesisBlock blockConfNet)+ Just (_ :: BlockHash) ->+ getBestBlock blockConfDB Nothing >>= \BlockValue {..} -> do+ base_height_box <- asks myBaseHeight+ atomically $ writeTVar base_height_box blockValueHeight++getBestBlockHash :: MonadIO m => DB -> Maybe Snapshot -> m BlockHash+getBestBlockHash db snapshot =+ retrieve db snapshot BestBlockKey >>= \case+ Nothing -> throwString "Best block hash not available"+ Just bh -> return bh++getBestBlock :: MonadIO m => DB -> Maybe Snapshot -> m BlockValue+getBestBlock db s =+ case s of+ Nothing -> R.withSnapshot db $ f . Just+ Just _ -> f s+ where+ f s' =+ getBestBlockHash db s' >>= \bh ->+ getBlock bh db s' >>= \case+ Nothing ->+ throwString $+ "Best block not available at hash: " <>+ cs (blockHashToHex bh)+ Just b -> return b++getBlocksAtHeights ::+ MonadIO m => [BlockHeight] -> DB -> Maybe Snapshot -> m [BlockValue]+getBlocksAtHeights bhs db s =+ case s of+ Nothing -> R.withSnapshot db $ f . Just+ Just _ -> f s+ where+ f s' =+ fmap catMaybes . forM (nub bhs) $ \bh ->+ getBlockAtHeight bh db s'++getBlockAtHeight ::+ MonadIO m => BlockHeight -> DB -> Maybe Snapshot -> m (Maybe BlockValue)+getBlockAtHeight height db s =+ case s of+ Nothing -> R.withSnapshot db $ f . Just+ Just _ -> f s+ where+ f s' = retrieve db s' (HeightKey height) >>= \case+ Nothing -> return Nothing+ Just h -> retrieve db s' (BlockKey h)++getBlocks :: MonadIO m => [BlockHash] -> DB -> Maybe Snapshot -> m [BlockValue]+getBlocks bids db s =+ case s of+ Nothing -> R.withSnapshot db $ f . Just+ Just _ -> f s+ where+ f s' =+ fmap catMaybes . forM (nub bids) $ \bid -> getBlock bid db s'++getBlock ::+ MonadIO m => BlockHash -> DB -> Maybe Snapshot -> m (Maybe BlockValue)+getBlock bh db snapshot = retrieve db snapshot (BlockKey bh)++getAddrSpent ::+ (MonadResource m, MonadUnliftIO m)+ => Address+ -> Maybe BlockHeight+ -> DB+ -> Maybe Snapshot+ -> ConduitT () (AddrOutputKey, Output) m ()+getAddrSpent addr h db snapshot =+ matchingSkip+ db+ snapshot+ (MultiAddrOutputKey True addr)+ (MultiAddrHeightKey True addr h)++getAddrUnspent ::+ (MonadUnliftIO m, MonadResource m)+ => Address+ -> Maybe BlockHeight+ -> DB+ -> Maybe Snapshot+ -> ConduitT () (AddrOutputKey, Output) m ()+getAddrUnspent addr h db snapshot =+ matchingSkip+ db+ snapshot+ (MultiAddrOutputKey False addr)+ (MultiAddrHeightKey False addr h)++getBalances ::+ MonadIO m => [Address] -> DB -> Maybe Snapshot -> m [AddressBalance]+getBalances addrs db s =+ case s of+ Nothing -> R.withSnapshot db $ f . Just+ Just _ -> f s+ where+ f s' = forM (nub addrs) $ \a -> getBalance a db s'++getBalance ::+ MonadIO m => Address -> DB -> Maybe Snapshot -> m AddressBalance+getBalance addr db s =+ retrieve db s (BalanceKey addr) >>= \case+ Just Balance {..} ->+ return+ AddressBalance+ { addressBalAddress = addr+ , addressBalConfirmed = balanceValue+ , addressBalUnconfirmed = balanceUnconfirmed+ , addressOutputCount = balanceOutputCount+ , addressSpentCount = balanceSpentCount+ }+ Nothing ->+ return+ AddressBalance+ { addressBalAddress = addr+ , addressBalConfirmed = 0+ , addressBalUnconfirmed = 0+ , addressOutputCount = 0+ , addressSpentCount = 0+ }++getMempool :: MonadUnliftIO m => DB -> Maybe Snapshot -> m [TxHash]+getMempool db snapshot = get_hashes <$> matchingAsList db snapshot MempoolKey+ where+ get_hashes mempool_txs = [tx_hash | (MempoolTx tx_hash, ()) <- mempool_txs]++getTxs :: MonadUnliftIO m => Network -> [TxHash] -> DB -> Maybe Snapshot -> m [DetailedTx]+getTxs net ths db s =+ case s of+ Nothing -> R.withSnapshot db $ f . Just+ Just _ -> f s+ where+ f s' = fmap catMaybes . forM (nub ths) $ \th -> getTx net th db s'++getTx ::+ MonadUnliftIO m => Network -> TxHash -> DB -> Maybe Snapshot -> m (Maybe DetailedTx)+getTx net th db s = do+ xs <- matchingAsList db s (BaseTxKey th)+ case find_tx xs of+ Just TxRecord {..} ->+ let os = map (uncurry output) (filter_outputs xs)+ is = map (input txValuePrevOuts) (txIn txValue)+ in return $+ Just+ DetailedTx+ { detailedTxData = txValue+ , detailedTxFee = fee is os+ , detailedTxBlock = txValueBlock+ , detailedTxInputs = is+ , detailedTxOutputs = os+ }+ Nothing -> return Nothing+ where+ fee is os =+ if any isCoinbase is+ then 0+ else sum (map detInValue is) - sum (map detOutValue os)+ input prevs TxIn {..} =+ if outPointHash prevOutput == zero+ then DetailedCoinbase+ { detInOutPoint = prevOutput+ , detInSequence = txInSequence+ , detInSigScript = scriptInput+ , detInNetwork = net+ }+ else let PrevOut {..} =+ fromMaybe+ (error+ ("Could not locate outpoint: " <>+ showOutPoint prevOutput))+ (lookup prevOutput prevs)+ in DetailedInput+ { detInOutPoint = prevOutput+ , detInSequence = txInSequence+ , detInSigScript = scriptInput+ , detInPkScript = prevOutScript+ , detInValue = prevOutValue+ , detInBlock = prevOutBlock+ , detInNetwork = net+ }+ output OutPoint {..} Output {..} =+ DetailedOutput+ { detOutValue = outputValue+ , detOutScript = outScript+ , detOutSpender = outSpender+ , detOutNetwork = net+ }+ find_tx xs =+ listToMaybe+ [ t+ | (k, v) <- xs+ , case k of+ MultiTxKey {} -> True+ _ -> False+ , let MultiTx t = v+ ]+ filter_outputs xs =+ [ (p, o)+ | (k, v) <- xs+ , case (k, v) of+ (MultiTxKeyOutput {}, MultiTxOutput {}) -> True+ _ -> False+ , let MultiTxKeyOutput (OutputKey p) = k+ , let MultiTxOutput o = v+ ]++getOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m (Maybe Output)+getOutput out_point = runMaybeT $ MaybeT map_lookup <|> MaybeT db_lookup+ where+ map_lookup = M.lookup out_point <$> gets outputMap+ db_key = OutputKey out_point+ db_lookup = asks myBlockDB >>= \db -> retrieve db Nothing db_key++getAddress :: (MonadBlock m, MonadImport m) => Address -> m Balance+getAddress address =+ fromMaybe emptyBalance <$>+ runMaybeT (MaybeT map_lookup <|> MaybeT db_lookup)+ where+ map_lookup = M.lookup address <$> gets addressMap+ db_key = BalanceKey address+ db_lookup = asks myBlockDB >>= \db -> retrieve db Nothing db_key++getDeleteTxs :: MonadImport m => m (Set TxHash)+getDeleteTxs = gets deleteTxs++shouldDelete :: MonadImport m => TxHash -> m Bool+shouldDelete tx_hash = S.member tx_hash <$> getDeleteTxs++addBlock :: MonadImport m => Block -> m ()+addBlock block = modify $ \s -> s {blockAction = Just (ImportBlock block)}++revertBlock :: MonadImport m => m ()+revertBlock = modify $ \s -> s {blockAction = Just RevertBlock}++deleteTx :: MonadImport m => TxHash -> m ()+deleteTx tx_hash =+ modify $ \s -> s {deleteTxs = S.insert tx_hash (deleteTxs s)}++insertTx :: MonadImport m => Tx -> Maybe BlockRef -> m ()+insertTx tx maybe_block_ref =+ modify $ \s -> s {newTxs = M.insert (txHash tx) import_tx (newTxs s)}+ where+ import_tx = ImportTx {importTx = tx, importTxBlock = maybe_block_ref}++updateOutput :: MonadImport m => OutPoint -> Output -> m ()+updateOutput out_point output =+ modify $ \s -> s {outputMap = M.insert out_point output (outputMap s)}++updateAddress :: MonadImport m => Address -> Balance -> m ()+updateAddress address balance =+ modify $ \s -> s {addressMap = M.insert address balance (addressMap s)}++spendOutput :: (MonadBlock m, MonadImport m) => OutPoint -> Spender -> m ()+spendOutput out_point spender@Spender {..} =+ void . runMaybeT $ do+ net <- asks myNetwork+ guard (out_point /= nullOutPoint)+ output@Output {..} <-+ getOutput out_point >>= \case+ Nothing ->+ throwString $+ "Could not get output to spend at outpoint: " <>+ showOutPoint out_point+ Just output -> return output+ when (isJust outSpender) . throwString $+ "Output to spend already spent at outpoint: " <> showOutPoint out_point+ updateOutput out_point output {outSpender = Just spender}+ address <- MaybeT (return (scriptToAddressBS net outScript))+ balance@Balance {..} <- getAddress address+ updateAddress address $+ if isJust spenderBlock+ then balance+ { balanceValue = balanceValue - outputValue+ , balanceSpentCount = balanceSpentCount + 1+ }+ else balance+ { balanceUnconfirmed =+ balanceUnconfirmed - fromIntegral outputValue+ , balanceSpentCount = balanceSpentCount + 1+ }++unspendOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m ()+unspendOutput out_point =+ void . runMaybeT $ do+ net <- asks myNetwork+ guard (out_point /= nullOutPoint)+ output@Output {..} <-+ getOutput out_point >>= \case+ Nothing ->+ throwString $+ "Could not get output to unspend at outpoint: " <>+ showOutPoint out_point+ Just output -> return output+ Spender {..} <- MaybeT (return outSpender)+ updateOutput out_point output {outSpender = Nothing}+ address <- MaybeT (return (scriptToAddressBS net outScript))+ balance@Balance {..} <- getAddress address+ updateAddress address $+ if isJust spenderBlock+ then balance+ { balanceValue = balanceValue + outputValue+ , balanceSpentCount = balanceSpentCount - 1+ }+ else balance+ { balanceUnconfirmed =+ balanceUnconfirmed + fromIntegral outputValue+ , balanceSpentCount = balanceSpentCount - 1+ }++removeOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m ()+removeOutput out_point@OutPoint {..} = do+ net <- asks myNetwork+ Output {..} <-+ getOutput out_point >>= \case+ Nothing ->+ throwString $+ "Could not get output to remove at outpoint: " <> show out_point+ Just o -> return o+ when (isJust outSpender) . throwString $+ "Cannot delete because spent outpoint: " <> show out_point+ case scriptToAddressBS net outScript of+ Nothing -> return ()+ Just address -> do+ balance@Balance {..} <- getAddress address+ updateAddress address $+ if isJust outBlock+ then balance+ { balanceValue = balanceValue - outputValue+ , balanceOutputCount = balanceOutputCount - 1+ }+ else balance+ { balanceUnconfirmed =+ balanceUnconfirmed - fromIntegral outputValue+ , balanceOutputCount = balanceOutputCount - 1+ }++addOutput :: (MonadBlock m, MonadImport m) => OutPoint -> Output -> m ()+addOutput out_point@OutPoint {..} output@Output {..} = do+ net <- asks myNetwork+ updateOutput out_point output+ case scriptToAddressBS net outScript of+ Nothing -> return ()+ Just address -> do+ balance@Balance {..} <- getAddress address+ updateAddress address $+ if isJust outBlock+ then balance+ { balanceValue = balanceValue + outputValue+ , balanceOutputCount = balanceOutputCount + 1+ }+ else balance+ { balanceUnconfirmed =+ balanceUnconfirmed + fromIntegral outputValue+ , balanceOutputCount = balanceOutputCount + 1+ }++getTxRecord :: MonadBlock m => TxHash -> m (Maybe TxRecord)+getTxRecord tx_hash =+ asks myBlockDB >>= \db -> retrieve db Nothing (TxKey tx_hash)++deleteTransaction ::+ (MonadBlock m, MonadImport m)+ => TxHash+ -> m ()+deleteTransaction tx_hash = shouldDelete tx_hash >>= \d -> unless d delete_it+ where+ delete_it = do+ TxRecord {..} <-+ getTxRecord tx_hash >>= \case+ Nothing ->+ throwString $+ "Could not get tx to delete at hash: " <>+ cs (txHashToHex tx_hash)+ Just r -> return r+ let n_out = length (txOut txValue)+ prevs = map prevOutput (txIn txValue)+ remove_spenders n_out+ remove_outputs n_out+ unspend_inputs prevs+ deleteTx tx_hash+ remove_spenders n_out =+ forM_ (take n_out [0 ..]) $ \i ->+ let out_point = OutPoint tx_hash i+ in getOutput out_point >>= \case+ Nothing ->+ throwString $+ "Could not get spent outpoint: " <> show out_point+ Just Output {outSpender = Just Spender {..}} ->+ deleteTransaction spenderHash+ Just _ -> return ()+ remove_outputs n_out =+ mapM_ (removeOutput . OutPoint tx_hash) (take n_out [0 ..])+ unspend_inputs = mapM_ unspendOutput++addNewBlock :: MonadBlock m => Block -> m ()+addNewBlock block@Block {..} =+ runMonadImport $ do+ new_height <- get_new_height+ $(logInfoS) "Block" $+ "Importing block height: " <> cs (show new_height)+ import_txs new_height+ addBlock block+ where+ import_txs new_height =+ mapM_+ (uncurry (import_tx (BlockRef new_hash new_height)))+ (zip [0 ..] blockTxns)+ import_tx block_ref i tx = importTransaction tx (Just (block_ref i))+ new_hash = headerHash blockHeader+ prev_block = prevBlock blockHeader+ get_new_height = do+ net <- asks myNetwork+ if blockHeader == getGenesisHeader net+ then return 0+ else do+ best <- asks myBlockDB >>= \db -> getBestBlock db Nothing+ when (prev_block /= headerHash (blockValueHeader best)) .+ throwString $+ "Block does not build on best at hash: " <> show new_hash+ return $ blockValueHeight best + 1++getBlockOps :: (MonadBlock m, MonadImport m) => m [BatchOp]+getBlockOps =+ gets blockAction >>= \case+ Nothing -> return []+ Just RevertBlock -> get_block_remove_ops+ Just (ImportBlock block) -> get_block_insert_ops block+ where+ get_block_insert_ops block@Block {..} = do+ let block_hash = headerHash blockHeader+ ch <- asks myChain+ bn <-+ chainGetBlock block_hash ch >>= \case+ Just bn -> return bn+ Nothing ->+ throwString $+ "Could not get block header for hash: " <>+ cs (blockHashToHex block_hash)+ let block_value =+ BlockValue+ { blockValueHeight = nodeHeight bn+ , blockValueWork = nodeWork bn+ , blockValueHeader = nodeHeader bn+ , blockValueSize = fromIntegral (B.length (encode block))+ , blockValueTxs = map txHash blockTxns+ }+ return+ [ insertOp (BlockKey block_hash) block_value+ , insertOp (HeightKey (nodeHeight bn)) block_hash+ , insertOp BestBlockKey block_hash+ ]+ get_block_remove_ops = do+ db <- asks myBlockDB+ BlockValue {..} <- getBestBlock db Nothing+ let block_hash = headerHash blockValueHeader+ block_key = BlockKey block_hash+ height_key = HeightKey blockValueHeight+ prev_block = prevBlock blockValueHeader+ return+ [ deleteOp block_key+ , deleteOp height_key+ , insertOp BestBlockKey prev_block+ ]++outputOps :: (MonadBlock m, MonadImport m) => OutPoint -> m [BatchOp]+outputOps out_point@OutPoint {..}+ | out_point == nullOutPoint = return []+ | otherwise = do+ net <- asks myNetwork+ output@Output {..} <-+ getOutput out_point >>= \case+ Nothing ->+ throwString $+ "Could not get output to unspend at outpoint: " <>+ show out_point+ Just o -> return o+ let output_op = insertOp (OutputKey out_point) output+ addr_ops = addressOutOps net out_point output False+ return $ output_op : addr_ops++addressOutOps :: Network -> OutPoint -> Output -> Bool -> [BatchOp]+addressOutOps net out_point output@Output {..} del =+ case scriptToAddressBS net outScript of+ Nothing -> []+ Just address ->+ let key =+ AddrOutputKey+ { addrOutputSpent = isJust outSpender+ , addrOutputAddress = address+ , addrOutputHeight = blockRefHeight <$> outBlock+ , addrOutputPos = blockRefPos <$> outBlock+ , addrOutPoint = out_point+ }+ key_mempool = key {addrOutputHeight = Nothing}+ key_delete = key {addrOutputSpent = isNothing outSpender}+ key_delete_mempool = key_delete {addrOutputHeight = Nothing}+ op =+ if del+ then deleteOp key+ else insertOp key output+ in if isJust outBlock+ then [ op+ , deleteOp key_delete+ , deleteOp key_mempool+ , deleteOp key_delete_mempool+ ]+ else [op, deleteOp key_delete]++deleteOutOps :: (MonadBlock m, MonadImport m) => OutPoint -> m [BatchOp]+deleteOutOps out_point@OutPoint {..} = do+ net <- asks myNetwork+ output@Output {..} <-+ getOutput out_point >>= \case+ Nothing ->+ throwString $+ "Could not get output to delete at outpoint: " <> show out_point+ Just o -> return o+ let output_op = deleteOp (OutputKey out_point)+ addr_ops = addressOutOps net out_point output True+ return $ output_op : addr_ops++deleteTxOps :: TxHash -> [BatchOp]+deleteTxOps tx_hash =+ [ deleteOp (TxKey tx_hash)+ , deleteOp (MempoolTx tx_hash)+ , deleteOp (OrphanTxKey tx_hash)+ ]++purgeOrphanOps :: (MonadBlock m, MonadImport m) => m [BatchOp]+purgeOrphanOps =+ fmap (fromMaybe []) . runMaybeT $ do+ db <- asks myBlockDB+ guard . isJust =<< gets blockAction+ liftIO . runResourceT . runConduit $+ matching db Nothing OrphanKey .| mapC (\(k, Tx {}) -> deleteOp k) .|+ sinkList+++getSimpleTx :: MonadBlock m => TxHash -> m Tx+getSimpleTx tx_hash =+ getTxRecord tx_hash >>= \case+ Nothing -> throwString $ "Cannot find tx hash: " <> show tx_hash+ Just TxRecord {..} -> return txValue++getTxOutPoints :: Tx -> [OutPoint]+getTxOutPoints tx@Tx {..} =+ let tx_hash = txHash tx+ in [OutPoint tx_hash i | i <- take (length txOut) [0 ..]]++getPrevOutPoints :: Tx -> [OutPoint]+getPrevOutPoints Tx {..} = map prevOutput txIn++getDeleteTxOps :: (MonadBlock m, MonadImport m) => m [BatchOp]+getDeleteTxOps = do+ del_txs <- S.toList <$> getDeleteTxs+ txs <- mapM getSimpleTx del_txs+ let prev_outs = concatMap getPrevOutPoints txs+ tx_outs = concatMap getTxOutPoints txs+ tx_ops = concatMap deleteTxOps del_txs+ prev_out_ops <- concat <$> mapM outputOps prev_outs+ tx_out_ops <- concat <$> mapM deleteOutOps tx_outs+ return $ prev_out_ops <> tx_out_ops <> tx_ops++insertTxOps :: (MonadBlock m, MonadImport m) => ImportTx -> m [BatchOp]+insertTxOps ImportTx {..} = do+ prev_outputs <- get_prev_outputs+ let key = TxKey (txHash importTx)+ mempool_key = MempoolTx (txHash importTx)+ orphan_key = OrphanTxKey (txHash importTx)+ value =+ TxRecord+ { txValueBlock = importTxBlock+ , txValue = importTx+ , txValuePrevOuts = prev_outputs+ }+ case importTxBlock of+ Nothing ->+ return+ [ insertOp key value+ , insertOp mempool_key ()+ , deleteOp orphan_key+ ]+ Just _ ->+ return+ [insertOp key value, deleteOp mempool_key, deleteOp orphan_key]+ where+ get_prev_outputs =+ let real_inputs =+ filter ((/= nullOutPoint) . prevOutput) (txIn importTx)+ in forM real_inputs $ \TxIn {..} -> do+ Output {..} <-+ getOutput prevOutput >>= \case+ Nothing ->+ throwString $+ "While importing tx hash: " <>+ cs (txHashToHex (txHash importTx)) <>+ "could not get outpoint: " <>+ showOutPoint prevOutput+ Just out -> return out+ return+ ( prevOutput+ , PrevOut+ { prevOutValue = outputValue+ , prevOutBlock = outBlock+ , prevOutScript = outScript+ })++getInsertTxOps :: (MonadBlock m, MonadImport m) => m [BatchOp]+getInsertTxOps = do+ new_txs <- M.elems <$> gets newTxs+ let txs = map importTx new_txs+ let prev_outs = concatMap getPrevOutPoints txs+ tx_outs = concatMap getTxOutPoints txs+ prev_out_ops <- concat <$> mapM outputOps prev_outs+ tx_out_ops <- concat <$> mapM outputOps tx_outs+ tx_ops <- concat <$> mapM insertTxOps new_txs+ return $ prev_out_ops <> tx_out_ops <> tx_ops++getBalanceOps :: MonadImport m => m [BatchOp]+getBalanceOps = do+ address_map <- gets addressMap+ return $ map (uncurry (insertOp . BalanceKey)) (M.toList address_map)++revertBestBlock :: MonadBlock m => m ()+revertBestBlock = do+ net <- asks myNetwork+ db <- asks myBlockDB+ BlockValue {..} <- getBestBlock db Nothing+ when (blockValueHeader == getGenesisHeader net) . throwString $+ "Attempted to revert genesis block"+ import_txs <- mapM getSimpleTx (tail blockValueTxs)+ runMonadImport $ do+ mapM_ deleteTransaction blockValueTxs+ revertBlock+ reset_peer (blockValueHeight - 1)+ runMonadImport $ mapM_ (`importTransaction` Nothing) import_txs+ where+ reset_peer height = do+ base_height_box <- asks myBaseHeight+ peer_box <- asks myPeer+ atomically $ do+ writeTVar base_height_box height+ writeTVar peer_box Nothing++validateTx :: Monad m => OutputMap -> Tx -> ExceptT TxException m ()+validateTx outputs tx = do+ prev_outs <-+ forM (txIn tx) $ \TxIn {..} ->+ case M.lookup prevOutput outputs of+ Nothing -> throwError OrphanTx+ Just o -> return o+ when (any (isJust . outSpender) prev_outs) (throwError DoubleSpend)+ let sum_inputs = sum (map outputValue prev_outs)+ sum_outputs = sum (map outValue (txOut tx))+ when (sum_outputs > sum_inputs) (throwError OverSpend)++importTransaction ::+ (MonadBlock m, MonadImport m) => Tx -> Maybe BlockRef -> m Bool+importTransaction tx maybe_block_ref =+ runExceptT validate_tx >>= \case+ Left e -> do+ ret <-+ case e of+ AlreadyImported ->+ return True+ OrphanTx -> do+ import_orphan+ return False+ _ -> do+ $(logErrorS) "Block" $+ "Could not import tx hash: " <>+ cs (txHashToHex (txHash tx)) <>+ " reason: " <>+ cs (show e)+ return False+ asks myListener >>= \l -> atomically (l (TxException (txHash tx) e))+ return ret+ Right () -> do+ delete_spenders+ spend_inputs+ insert_outputs+ insertTx tx maybe_block_ref+ return True+ where+ import_orphan = do+ $(logInfoS) "BlockStore " $+ "Got orphan tx hash: " <> cs (txHashToHex (txHash tx))+ db <- asks myBlockDB+ R.insert db (OrphanTxKey (txHash tx)) tx+ validate_tx+ | isJust maybe_block_ref = return () -- only validate unconfirmed+ | otherwise = do+ getTxRecord (txHash tx) >>= \maybe_tx ->+ when (isJust maybe_tx) (throwError AlreadyImported)+ prev_outs <-+ fmap (M.fromList . catMaybes) . forM (txIn tx) $ \TxIn {..} ->+ getOutput prevOutput >>= \case+ Nothing -> return Nothing+ Just o -> return $ Just (prevOutput, o)+ validateTx prev_outs tx+ delete_spenders =+ forM_ (txIn tx) $ \TxIn {..} ->+ getOutput prevOutput >>= \case+ Nothing ->+ unless (prevOutput == nullOutPoint) . throwString $+ "Could not get output spent by tx hash: " <>+ show (txHash tx)+ Just Output {outSpender = Just Spender {..}} ->+ deleteTransaction spenderHash+ _ -> return ()+ spend_inputs =+ forM_ (zip [0 ..] (txIn tx)) $ \(i, TxIn {..}) ->+ spendOutput+ prevOutput+ Spender+ { spenderHash = txHash tx+ , spenderIndex = i+ , spenderBlock = maybe_block_ref+ }+ insert_outputs =+ forM_ (zip [0 ..] (txOut tx)) $ \(i, TxOut {..}) ->+ addOutput+ OutPoint {outPointHash = txHash tx, outPointIndex = i}+ Output+ { outputValue = outValue+ , outBlock = maybe_block_ref+ , outScript = scriptOutput+ , outSpender = Nothing+ }++syncBlocks :: MonadBlock m => m ()+syncBlocks =+ void . runMaybeT $ do+ net <- asks myNetwork+ chain_best <- asks myChain >>= chainGetBest+ revert_if_needed chain_best+ let chain_height = nodeHeight chain_best+ base_height_box <- asks myBaseHeight+ db <- asks myBlockDB+ best_block <- getBestBlock db Nothing+ let best_height = blockValueHeight best_block+ when (best_height == chain_height) $ do+ reset_peer best_height+ empty+ base_height <- readTVarIO base_height_box+ p <- get_peer+ when (base_height > best_height + 500) empty+ when (base_height >= chain_height) empty+ ch <- asks myChain+ let sync_lowest = min chain_height (base_height + 1)+ sync_highest = min chain_height (base_height + 501)+ sync_top <-+ if sync_highest == chain_height+ then return chain_best+ else chainGetAncestor sync_highest chain_best ch >>= \case+ Nothing ->+ throwString+ "Could not get syncing header from chain"+ Just b -> return b+ sync_blocks <-+ (++ [sync_top]) <$>+ if sync_lowest == chain_height+ then return []+ else chainGetParents sync_lowest sync_top ch+ update_peer sync_highest (Just p)+ peerGetBlocks net p (map (headerHash . nodeHeader) sync_blocks)+ where+ get_peer =+ asks myPeer >>= readTVarIO >>= \case+ Just p -> return p+ Nothing ->+ asks myManager >>= managerGetPeers >>= \case+ [] -> empty+ p:_ -> return (onlinePeerMailbox p)+ reset_peer best_height = update_peer best_height Nothing+ update_peer height mp = do+ base_height_box <- asks myBaseHeight+ peer_box <- asks myPeer+ atomically $ do+ writeTVar base_height_box height+ writeTVar peer_box mp+ revert_if_needed chain_best = do+ db <- asks myBlockDB+ ch <- asks myChain+ best <- getBestBlock db Nothing+ let best_hash = headerHash (blockValueHeader best)+ chain_hash = headerHash (nodeHeader chain_best)+ when (best_hash /= chain_hash) $+ chainGetBlock best_hash ch >>= \case+ Nothing -> do+ revertBestBlock+ revert_if_needed chain_best+ Just best_node -> do+ split_hash <-+ headerHash . nodeHeader <$>+ chainGetSplitBlock chain_best best_node ch+ revert_until split_hash+ revert_until split = do+ best_hash <-+ asks myBlockDB >>= \db ->+ headerHash . blockValueHeader <$> getBestBlock db Nothing+ when (best_hash /= split) $ do+ revertBestBlock+ revert_until split++importBlock :: (MonadError String m, MonadBlock m) => Block -> m ()+importBlock block@Block {..} = do+ bn <- asks myChain >>= chainGetBlock (headerHash blockHeader)+ when (isNothing bn) $+ throwString $+ "Not in chain: block hash" <>+ cs (blockHashToHex (headerHash blockHeader))+ best <- asks myBlockDB >>= \db -> getBestBlock db Nothing+ let best_hash = headerHash (blockValueHeader best)+ prev_hash = prevBlock blockHeader+ when (prev_hash /= best_hash) (throwError "does not build on best")+ addNewBlock block++processBlockMessage :: (MonadUnliftIO m, MonadBlock m) => BlockMessage -> m ()++processBlockMessage (BlockChainNew _) = syncBlocks++processBlockMessage (BlockPeerConnect p) = syncBlocks >> syncMempool p++processBlockMessage (BlockReceived p b) =+ runExceptT (importBlock b) >>= \case+ Left e -> do+ pstr <- peerString p+ let hash = headerHash (blockHeader b)+ $(logErrorS) "Block" $+ "Could not import from peer" <> pstr <> " block hash:" <>+ cs (blockHashToHex hash) <>+ " error: " <>+ fromString e+ Right () -> syncBlocks >> syncMempool p++processBlockMessage (TxReceived _ tx) =+ isAtHeight >>= \x ->+ when x $ do+ _ <- runMonadImport $ importTransaction tx Nothing+ import_orphans+ where+ import_orphans = do+ db <- asks myBlockDB+ ret <-+ runResourceT . runConduit $+ matching db Nothing OrphanKey .| mapMC (import_tx . snd) .| anyC id+ when ret import_orphans+ import_tx tx' = runMonadImport $ importTransaction tx' Nothing++processBlockMessage (TxPublished tx) =+ void . runMonadImport $ importTransaction tx Nothing++processBlockMessage (BlockPeerDisconnect p) = do+ peer_box <- asks myPeer+ base_height_box <- asks myBaseHeight+ db <- asks myBlockDB+ best <- getBestBlock db Nothing+ is_my_peer <-+ atomically $+ readTVar peer_box >>= \x ->+ if x == Just p+ then do+ writeTVar peer_box Nothing+ writeTVar base_height_box (blockValueHeight best)+ return True+ else return False+ when is_my_peer syncBlocks++processBlockMessage (BlockNotReceived p h) = do+ pstr <- peerString p+ $(logErrorS) "Block" $+ "Peer " <> pstr <> " unable to serve block hash: " <> cs (show h)+ mgr <- asks myManager+ managerKill (PeerMisbehaving "Block not found") p mgr++processBlockMessage (TxAvailable p ts) =+ isAtHeight >>= \h ->+ when h $ do+ pstr <- peerString p+ $(logDebugS) "Block" $+ "Received " <> cs (show (length ts)) <>+ " tx inventory from peer " <> pstr+ net <- asks myNetwork+ db <- asks myBlockDB+ has <-+ fmap catMaybes . forM ts $ \t ->+ retrieve db Nothing (MempoolTx t) >>= \case+ Nothing -> return Nothing+ Just () -> return (Just t)+ ors <-+ map (\(OrphanTxKey k, Tx {}) -> k) <$>+ liftIO (matchingAsList db Nothing OrphanKey)+ let new = (ts \\ has) \\ ors+ unless (null new) $ do+ $(logDebugS) "Block" $+ "Requesting " <> cs (show (length new)) <>+ " new txs from peer " <> pstr+ peerGetTxs net p new++processBlockMessage (PongReceived p n) = do+ pstr <- peerString p+ $(logDebugS) "Block" $+ "Pong received with nonce " <> cs (show n) <> " from peer " <> pstr+ asks myListener >>= atomically . ($ PeerPong p n)++getAddrOutputs ::+ (MonadResource m, MonadUnliftIO m)+ => Address+ -> Maybe BlockHeight+ -> DB+ -> Maybe Snapshot+ -> ConduitT () AddrOutput m ()+getAddrOutputs a h db s =+ case s of+ Nothing -> R.withSnapshotBracket db $ f . Just+ Just _ -> f s+ where+ f s' = mergeSourcesBy (flip compare) [p s', u s']+ u s' = getAddrUnspent a h db s' .| mapC (uncurry AddrOutput)+ p s' = getAddrSpent a h db s' .| mapC (uncurry AddrOutput)+++getAddrsOutputs ::+ (MonadResource m, MonadUnliftIO m)+ => [Address]+ -> Maybe BlockHeight+ -> DB+ -> Maybe Snapshot+ -> ConduitT () AddrOutput m ()+getAddrsOutputs as h db s =+ if isJust s+ then f s+ else R.withSnapshotBracket db $ \s' -> f (Just s')+ where+ f s' = forM_ as $ \a -> getAddrOutputs a h db s'++getUnspents ::+ (MonadResource m, MonadUnliftIO m)+ => [Address]+ -> Maybe BlockHeight+ -> DB+ -> Maybe Snapshot+ -> ConduitT () AddrOutput m ()+getUnspents as h db s =+ case s of+ Nothing -> R.withSnapshotBracket db $ f . Just+ Just _ -> f s+ where+ f s' = forM_ as $ \a -> getUnspent a h db s'++getUnspent ::+ (MonadResource m, MonadUnliftIO m)+ => Address+ -> Maybe BlockHeight+ -> DB+ -> Maybe Snapshot+ -> ConduitT () AddrOutput m ()+getUnspent addr h db s =+ getAddrUnspent addr h db s .| mapC (uncurry AddrOutput)++syncMempool :: MonadBlock m => Peer -> m ()+syncMempool p =+ void . runMaybeT $ do+ guard =<< isAtHeight+ $(logInfoS) "Block" "Syncing mempool..."+ MMempool `sendMessage` p++isAtHeight :: MonadBlock m => m Bool+isAtHeight = do+ db <- asks myBlockDB+ bb <- getBestBlockHash db Nothing+ ch <- asks myChain+ cb <- chainGetBest ch+ time <- liftIO getPOSIXTime+ let recent = floor time - blockTimestamp (nodeHeader cb) < 60 * 60 * 4+ return (recent && headerHash (nodeHeader cb) == bb)++zero :: TxHash+zero = "0000000000000000000000000000000000000000000000000000000000000000"++showOutPoint :: (IsString a, ConvertibleStrings Text a) => OutPoint -> a+showOutPoint OutPoint {..} =+ cs $ txHashToHex outPointHash <> ":" <> cs (show outPointIndex)++peerString :: (MonadBlock m, IsString a) => Peer -> m a+peerString p = do+ mgr <- asks myManager+ managerGetPeer mgr p >>= \case+ Nothing -> return "[unknown]"+ Just o -> return $ fromString $ show $ onlinePeerAddress o++-- | Merge multiple sorted sources into one sorted producer using specified+-- sorting function. Adapted from: <https://github.com/cblp/conduit-merge>+mergeSourcesBy ::+ (Foldable f, Monad m)+ => (a -> a -> Ordering)+ -> f (ConduitT () a m ())+ -> ConduitT i a m ()+mergeSourcesBy f = mergeSealed . fmap sealConduitT . toList+ where+ mergeSealed sources = do+ prefetchedSources <- lift $ traverse ($$++ await) sources+ go [(a, s) | (s, Just a) <- prefetchedSources]+ go [] = pure ()+ go sources = do+ let (a, src1):sources1 = sortBy (f `on` fst) sources+ yield a+ (src2, mb) <- lift $ src1 $$++ await+ let sources2 =+ case mb of+ Nothing -> sources1+ Just b -> (b, src2) : sources1+ go sources2
+ src/Network/Haskoin/Store/Types.hs view
@@ -0,0 +1,747 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.Haskoin.Store.Types where++import Control.Applicative+import Control.Concurrent.NQE+import Control.Exception+import Control.Monad.Reader+import Data.Aeson as A+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Function+import Data.Int+import Data.Maybe+import Data.Serialize as S+import Data.String.Conversions+import Data.Word+import Database.RocksDB (DB)+import Database.RocksDB.Query as R+import Haskoin+import Network.Haskoin.Node+import UnliftIO++data TxException+ = DoubleSpend+ | OverSpend+ | OrphanTx+ | NonStandard+ | LowFee+ | Dust+ | NoPeers+ | InvalidTx+ | CouldNotImport+ | PeerIsGone+ | AlreadyImported+ | PublishTimeout+ | PeerRejectOther+ | NotAtHeight+ deriving (Eq)++instance Show TxException where+ show InvalidTx = "invalid"+ show DoubleSpend = "double-spend"+ show OverSpend = "not enough funds"+ show OrphanTx = "orphan"+ show AlreadyImported = "already imported"+ show NoPeers = "no peers"+ show NonStandard = "non-standard"+ show LowFee = "low fee"+ show Dust = "dust"+ show PeerIsGone = "peer disconnected"+ show CouldNotImport = "could not import"+ show PublishTimeout = "publish timeout"+ show PeerRejectOther = "peer rejected for unknown reason"+ show NotAtHeight = "not at height"++instance Exception TxException++newtype NewTx = NewTx+ { newTx :: Tx+ } deriving (Show, Eq, Ord)++data BlockConfig = BlockConfig+ { blockConfMailbox :: !BlockStore+ , blockConfManager :: !Manager+ , blockConfChain :: !Chain+ , blockConfListener :: !(Listen StoreEvent)+ , blockConfDB :: !DB+ , blockConfNet :: !Network+ }++data StoreEvent+ = BestBlock !BlockHash+ | MempoolNew !TxHash+ | TxException !TxHash+ !TxException+ | PeerConnected !Peer+ | PeerDisconnected !Peer+ | PeerPong !Peer+ !Word64++data BlockMessage+ = BlockChainNew !BlockNode+ | BlockPeerConnect !Peer+ | BlockPeerDisconnect !Peer+ | BlockReceived !Peer+ !Block+ | BlockNotReceived !Peer+ !BlockHash+ | TxReceived !Peer+ !Tx+ | TxAvailable !Peer+ ![TxHash]+ | TxPublished !Tx+ | PongReceived !Peer+ !Word64++type BlockStore = Inbox BlockMessage++data AddrOutputKey+ = AddrOutputKey { addrOutputSpent :: !Bool+ , addrOutputAddress :: !Address+ , addrOutputHeight :: !(Maybe BlockHeight)+ , addrOutputPos :: !(Maybe Word32)+ , addrOutPoint :: !OutPoint }+ | MultiAddrOutputKey { addrOutputSpent :: !Bool+ , addrOutputAddress :: !Address }+ | MultiAddrHeightKey { addrOutputSpent :: !Bool+ , addrOutputAddress :: !Address+ , addrOutputHeight :: !(Maybe BlockHeight) }+ deriving (Show, Eq)++instance Ord AddrOutputKey where+ compare = compare `on` f+ where+ f AddrOutputKey {..} =+ ( fromMaybe maxBound addrOutputHeight+ , fromMaybe maxBound addrOutputPos+ , outPointIndex addrOutPoint)+ f _ = undefined++data BlockValue = BlockValue+ { blockValueHeight :: !BlockHeight+ , blockValueWork :: !BlockWork+ , blockValueHeader :: !BlockHeader+ , blockValueSize :: !Word32+ , blockValueTxs :: ![TxHash]+ } deriving (Show, Eq, Ord)++data BlockRef = BlockRef+ { blockRefHash :: !BlockHash+ , blockRefHeight :: !BlockHeight+ , blockRefPos :: !Word32+ } deriving (Show, Eq)++instance Ord BlockRef where+ compare = compare `on` f+ where+ f BlockRef {..} = (blockRefHeight, blockRefPos)++data DetailedTx = DetailedTx+ { detailedTxData :: !Tx+ , detailedTxFee :: !Word64+ , detailedTxInputs :: ![DetailedInput]+ , detailedTxOutputs :: ![DetailedOutput]+ , detailedTxBlock :: !(Maybe BlockRef)+ } deriving (Show, Eq)++data DetailedInput+ = DetailedCoinbase { detInOutPoint :: !OutPoint+ , detInSequence :: !Word32+ , detInSigScript :: !ByteString+ , detInNetwork :: !Network }+ | DetailedInput { detInOutPoint :: !OutPoint+ , detInSequence :: !Word32+ , detInSigScript :: !ByteString+ , detInPkScript :: !ByteString+ , detInValue :: !Word64+ , detInBlock :: !(Maybe BlockRef)+ , detInNetwork :: !Network }+ deriving (Show, Eq)++isCoinbase :: DetailedInput -> Bool+isCoinbase DetailedCoinbase {} = True+isCoinbase _ = False++data DetailedOutput = DetailedOutput+ { detOutValue :: !Word64+ , detOutScript :: !ByteString+ , detOutSpender :: !(Maybe Spender)+ , detOutNetwork :: !Network+ } deriving (Show, Eq)++data AddressBalance = AddressBalance+ { addressBalAddress :: !Address+ , addressBalConfirmed :: !Word64+ , addressBalUnconfirmed :: !Int64+ , addressOutputCount :: !Word64+ , addressSpentCount :: !Word64+ } deriving (Show, Eq)++data TxRecord = TxRecord+ { txValueBlock :: !(Maybe BlockRef)+ , txValue :: !Tx+ , txValuePrevOuts :: [(OutPoint, PrevOut)]+ } deriving (Show, Eq, Ord)++newtype OutputKey = OutputKey+ { outPoint :: OutPoint+ } deriving (Show, Eq, Ord)++data PrevOut = PrevOut+ { prevOutValue :: !Word64+ , prevOutBlock :: !(Maybe BlockRef)+ , prevOutScript :: !ByteString+ } deriving (Show, Eq, Ord)++data Output = Output+ { outputValue :: !Word64+ , outBlock :: !(Maybe BlockRef)+ , outScript :: !ByteString+ , outSpender :: !(Maybe Spender)+ } deriving (Show, Eq, Ord)++outputToPrevOut :: Output -> PrevOut+outputToPrevOut Output {..} =+ PrevOut+ { prevOutValue = outputValue+ , prevOutBlock = outBlock+ , prevOutScript = outScript+ }++prevOutToOutput :: PrevOut -> Output+prevOutToOutput PrevOut {..} =+ Output+ { outputValue = prevOutValue+ , outBlock = prevOutBlock+ , outScript = prevOutScript+ , outSpender = Nothing+ }++data Spender = Spender+ { spenderHash :: !TxHash+ , spenderIndex :: !Word32+ , spenderBlock :: !(Maybe BlockRef)+ } deriving (Show, Eq, Ord)++data MultiTxKey+ = MultiTxKey !TxKey+ | MultiTxKeyOutput !OutputKey+ | BaseTxKey !TxHash+ deriving (Show, Eq, Ord)++data MultiTxValue+ = MultiTx !TxRecord+ | MultiTxOutput !Output+ deriving (Show, Eq, Ord)++newtype TxKey =+ TxKey TxHash+ deriving (Show, Eq, Ord)++data MempoolTx+ = MempoolTx TxHash+ | MempoolKey+ deriving (Show, Eq, Ord)++data OrphanTx+ = OrphanTxKey TxHash+ | OrphanKey+ deriving (Show, Eq, Ord)++newtype BlockKey =+ BlockKey BlockHash+ deriving (Show, Eq, Ord)++newtype HeightKey =+ HeightKey BlockHeight+ deriving (Show, Eq, Ord)++newtype BalanceKey = BalanceKey+ { balanceAddress :: Address+ } deriving (Show, Eq)++data Balance = Balance+ { balanceValue :: !Word64+ , balanceUnconfirmed :: !Int64+ , balanceOutputCount :: !Word64+ , balanceSpentCount :: !Word64+ } deriving (Show, Eq, Ord)++emptyBalance :: Balance+emptyBalance =+ Balance+ { balanceValue = 0+ , balanceUnconfirmed = 0+ , balanceOutputCount = 0+ , balanceSpentCount = 0+ }++data BestBlockKey = BestBlockKey deriving (Show, Eq, Ord)++data AddrOutput = AddrOutput+ { addrOutputKey :: !AddrOutputKey+ , addrOutput :: !Output+ } deriving (Eq, Show)++instance Ord AddrOutput where+ compare = compare `on` addrOutputKey++newtype StoreAddress = StoreAddress Address+ deriving (Show, Eq)++instance Key BlockKey+instance Key HeightKey+instance Key OutputKey+instance Key TxKey+instance Key MempoolTx+instance Key OrphanTx+instance Key AddrOutputKey+instance R.KeyValue BlockKey BlockValue+instance R.KeyValue TxKey TxRecord+instance R.KeyValue HeightKey BlockHash+instance R.KeyValue BestBlockKey BlockHash+instance R.KeyValue OutputKey Output+instance R.KeyValue MultiTxKey MultiTxValue+instance R.KeyValue AddrOutputKey Output+instance R.KeyValue BalanceKey Balance+instance R.KeyValue MempoolTx ()+instance R.KeyValue OrphanTx Tx++instance Serialize MempoolTx where+ put (MempoolTx h) = do+ putWord8 0x07+ put h+ put MempoolKey = putWord8 0x07+ get = do+ guard . (== 0x07) =<< getWord8+ record <|> return MempoolKey+ where+ record = MempoolTx <$> get++instance Serialize OrphanTx where+ put (OrphanTxKey h) = do+ putWord8 0x08+ put h+ put OrphanKey = putWord8 0x08+ get = do+ guard . (== 0x08) =<< getWord8+ record <|> return OrphanKey+ where+ record = OrphanTxKey <$> get++instance Serialize BalanceKey where+ put BalanceKey {..} = do+ putWord8 0x04+ put (StoreAddress balanceAddress)+ get = do+ guard . (== 0x04) =<< getWord8+ StoreAddress balanceAddress <- get+ return BalanceKey {..}++instance Serialize Balance where+ put Balance {..} = do+ put balanceValue+ put balanceUnconfirmed+ put balanceOutputCount+ put balanceSpentCount+ get = do+ balanceValue <- get+ balanceUnconfirmed <- get+ balanceOutputCount <- get+ balanceSpentCount <- get+ return Balance {..}++addrKeyStart :: Bool -> Address -> Put+addrKeyStart b a = do+ putWord8 $ if b then 0x03 else 0x05+ put (StoreAddress a)++instance Serialize AddrOutputKey where+ put AddrOutputKey {..} = do+ addrKeyStart addrOutputSpent addrOutputAddress+ put (maybe 0 (maxBound -) addrOutputHeight)+ put (maybe 0 (maxBound -) addrOutputPos)+ put addrOutPoint+ put MultiAddrOutputKey {..} = addrKeyStart addrOutputSpent addrOutputAddress+ put MultiAddrHeightKey {..} = do+ addrKeyStart addrOutputSpent addrOutputAddress+ put (maybe 0 (maxBound -) addrOutputHeight)+ get = do+ addrOutputSpent <-+ getWord8 >>= \case+ 0x03 -> return True+ 0x05 -> return False+ _ -> mzero+ StoreAddress addrOutputAddress <- get+ record addrOutputSpent addrOutputAddress+ where+ record addrOutputSpent addrOutputAddress = do+ h <- (maxBound -) <$> get+ let addrOutputHeight | h == 0 = Nothing+ | otherwise = Just h+ p <- (maxBound -) <$> get+ let addrOutputPos | p == 0 = Nothing+ | otherwise = Just p+ addrOutPoint <- get+ return AddrOutputKey {..}++instance Serialize MultiTxKey where+ put (MultiTxKey k) = put k+ put (MultiTxKeyOutput k) = put k+ put (BaseTxKey k) = putWord8 0x02 >> put k+ get = MultiTxKey <$> get <|> MultiTxKeyOutput <$> get <|> base+ where+ base = do+ guard . (== 0x02) =<< getWord8+ BaseTxKey <$> get++instance Serialize MultiTxValue where+ put (MultiTx v) = put v+ put (MultiTxOutput v) = put v+ get = (MultiTx <$> get) <|> (MultiTxOutput <$> get)++instance Serialize Spender where+ put Spender {..} = do+ put spenderHash+ put spenderIndex+ put spenderBlock+ get = do+ spenderHash <- get+ spenderIndex <- get+ spenderBlock <- get+ return Spender {..}++instance Serialize OutputKey where+ put OutputKey {..} = do+ putWord8 0x02+ put (outPointHash outPoint)+ putWord8 0x01+ put (outPointIndex outPoint)+ get = do+ guard . (== 0x02) =<< getWord8+ outPointHash <- get+ guard . (== 0x01) =<< getWord8+ outPointIndex <- get+ let outPoint = OutPoint {..}+ return OutputKey {..}++instance Serialize PrevOut where+ put PrevOut {..} = do+ put prevOutValue+ put prevOutBlock+ put (BS.length prevOutScript)+ putByteString prevOutScript+ get = do+ prevOutValue <- get+ prevOutBlock <- get+ prevOutScript <- getByteString =<< get+ return PrevOut {..}++instance Serialize Output where+ put Output {..} = do+ putWord8 0x01+ put outputValue+ put outBlock+ put outScript+ put outSpender+ get = do+ guard . (== 0x01) =<< getWord8+ outputValue <- get+ outBlock <- get+ outScript <- get+ outSpender <- get+ return Output {..}++instance Serialize BlockRef where+ put BlockRef {..} = do+ put blockRefHash+ put blockRefHeight+ put blockRefPos+ get = do+ blockRefHash <- get+ blockRefHeight <- get+ blockRefPos <- get+ return BlockRef {..}++instance Serialize TxRecord where+ put TxRecord {..} = do+ putWord8 0x00+ put txValueBlock+ put txValue+ put txValuePrevOuts+ get = do+ guard . (== 0x00) =<< getWord8+ txValueBlock <- get+ txValue <- get+ txValuePrevOuts <- get+ return TxRecord {..}++instance Serialize BestBlockKey where+ put BestBlockKey = put (BS.replicate 32 0x00)+ get = do+ guard . (== BS.replicate 32 0x00) =<< getBytes 32+ return BestBlockKey++instance Serialize BlockValue where+ put BlockValue {..} = do+ put blockValueHeight+ put blockValueWork+ put blockValueHeader+ put blockValueSize+ put blockValueTxs+ get = do+ blockValueHeight <- get+ blockValueWork <- get+ blockValueHeader <- get+ blockValueSize <- get+ blockValueTxs <- get+ return BlockValue {..}++netByte :: Network -> Word8+netByte net | net == btc = 0x00+ | net == btcTest = 0x01+ | net == btcRegTest = 0x02+ | net == bch = 0x04+ | net == bchTest = 0x05+ | net == bchRegTest = 0x06+ | otherwise = 0xff++byteNet :: Word8 -> Maybe Network+byteNet 0x00 = Just btc+byteNet 0x01 = Just btcTest+byteNet 0x02 = Just btcRegTest+byteNet 0x04 = Just bch+byteNet 0x05 = Just bchTest+byteNet 0x06 = Just bchRegTest+byteNet _ = Nothing++getByteNet :: Get Network+getByteNet =+ byteNet <$> getWord8 >>= \case+ Nothing -> fail "Could not decode network byte"+ Just net -> return net++instance Serialize StoreAddress where+ put (StoreAddress addr) =+ case addr of+ PubKeyAddress h net -> do+ putWord8 0x01+ putWord8 (netByte net)+ put h+ ScriptAddress h net -> do+ putWord8 0x02+ putWord8 (netByte net)+ put h+ WitnessPubKeyAddress h net -> do+ putWord8 0x03+ putWord8 (netByte net)+ put h+ WitnessScriptAddress h net -> do+ putWord8 0x04+ putWord8 (netByte net)+ put h+ get = fmap StoreAddress $ pk <|> sa <|> wa <|> ws+ where+ pk = do+ guard . (== 0x01) =<< getWord8+ net <- getByteNet+ h <- get+ return (PubKeyAddress h net)+ sa = do+ guard . (== 0x02) =<< getWord8+ net <- getByteNet+ h <- get+ return (ScriptAddress h net)+ wa = do+ guard . (== 0x03) =<< getWord8+ net <- getByteNet+ h <- get+ return (WitnessPubKeyAddress h net)+ ws = do+ guard . (== 0x04) =<< getWord8+ net <- getByteNet+ h <- get+ return (WitnessScriptAddress h net)++blockValuePairs :: A.KeyValue kv => BlockValue -> [kv]+blockValuePairs BlockValue {..} =+ [ "hash" .= headerHash blockValueHeader+ , "height" .= blockValueHeight+ , "previous" .= prevBlock blockValueHeader+ , "time" .= blockTimestamp blockValueHeader+ , "version" .= blockVersion blockValueHeader+ , "bits" .= blockBits blockValueHeader+ , "nonce" .= bhNonce blockValueHeader+ , "size" .= blockValueSize+ , "tx" .= blockValueTxs+ ]++instance ToJSON BlockValue where+ toJSON = object . blockValuePairs+ toEncoding = pairs . mconcat . blockValuePairs++instance ToJSON Spender where+ toJSON = object . spenderPairs+ toEncoding = pairs . mconcat . spenderPairs++blockRefPairs :: A.KeyValue kv => BlockRef -> [kv]+blockRefPairs BlockRef {..} =+ [ "hash" .= blockRefHash+ , "height" .= blockRefHeight+ , "position" .= blockRefPos+ ]++spenderPairs :: A.KeyValue kv => Spender -> [kv]+spenderPairs Spender {..} =+ ["txid" .= spenderHash, "input" .= spenderIndex, "block" .= spenderBlock]++detailedOutputPairs :: A.KeyValue kv => DetailedOutput -> [kv]+detailedOutputPairs DetailedOutput {..} =+ [ "address" .= scriptToAddressBS detOutNetwork detOutScript+ , "pkscript" .= String (cs (encodeHex detOutScript))+ , "value" .= detOutValue+ , "spent" .= isJust detOutSpender+ , "spender" .= detOutSpender+ ]++instance ToJSON DetailedOutput where+ toJSON = object . detailedOutputPairs+ toEncoding = pairs . mconcat . detailedOutputPairs++detailedInputPairs :: A.KeyValue kv => DetailedInput -> [kv]+detailedInputPairs DetailedInput {..} =+ [ "txid" .= outPointHash detInOutPoint+ , "output" .= outPointIndex detInOutPoint+ , "coinbase" .= False+ , "sequence" .= detInSequence+ , "sigscript" .= String (cs (encodeHex detInSigScript))+ , "pkscript" .= String (cs (encodeHex detInPkScript))+ , "address" .= scriptToAddressBS detInNetwork detInPkScript+ , "value" .= detInValue+ , "block" .= detInBlock+ ]+detailedInputPairs DetailedCoinbase {..} =+ [ "txid" .= outPointHash detInOutPoint+ , "output" .= outPointIndex detInOutPoint+ , "coinbase" .= True+ , "sequence" .= detInSequence+ , "sigscript" .= String (cs (encodeHex detInSigScript))+ , "pkscript" .= Null+ , "address" .= Null+ , "value" .= Null+ , "block" .= Null+ ]++instance ToJSON DetailedInput where+ toJSON = object . detailedInputPairs+ toEncoding = pairs . mconcat . detailedInputPairs++detailedTxPairs :: A.KeyValue kv => DetailedTx -> [kv]+detailedTxPairs DetailedTx {..} =+ [ "txid" .= txHash detailedTxData+ , "size" .= BS.length (S.encode detailedTxData)+ , "version" .= txVersion detailedTxData+ , "locktime" .= txLockTime detailedTxData+ , "fee" .= detailedTxFee+ , "inputs" .= detailedTxInputs+ , "outputs" .= detailedTxOutputs+ , "hex" .= String (cs (encodeHex (S.encode detailedTxData)))+ , "block" .= detailedTxBlock+ ]++instance ToJSON DetailedTx where+ toJSON = object . detailedTxPairs+ toEncoding = pairs . mconcat . detailedTxPairs++instance ToJSON BlockRef where+ toJSON = object . blockRefPairs+ toEncoding = pairs . mconcat . blockRefPairs++addrOutputPairs :: A.KeyValue kv => AddrOutput -> [kv]+addrOutputPairs AddrOutput {..} =+ [ "address" .= addrOutputAddress+ , "txid" .= outPointHash addrOutPoint+ , "index" .= outPointIndex addrOutPoint+ , "block" .= outBlock+ , "output" .= dout+ ]+ where+ Output {..} = addrOutput+ AddrOutputKey {..} = addrOutputKey+ dout =+ DetailedOutput+ { detOutValue = outputValue+ , detOutScript = outScript+ , detOutSpender = outSpender+ , detOutNetwork = getAddrNet addrOutputAddress+ }++instance ToJSON AddrOutput where+ toJSON = object . addrOutputPairs+ toEncoding = pairs . mconcat . addrOutputPairs++addressBalancePairs :: A.KeyValue kv => AddressBalance -> [kv]+addressBalancePairs AddressBalance {..} =+ [ "address" .= addressBalAddress+ , "confirmed" .= addressBalConfirmed+ , "unconfirmed" .= addressBalUnconfirmed+ , "outputs" .= addressOutputCount+ , "utxo" .= (addressOutputCount - addressSpentCount)+ ]++instance FromJSON NewTx where+ parseJSON = withObject "transaction" $ \v -> NewTx <$> v .: "transaction"++instance ToJSON AddressBalance where+ toJSON = object . addressBalancePairs+ toEncoding = pairs . mconcat . addressBalancePairs++instance Serialize HeightKey where+ put (HeightKey height) = do+ putWord8 0x03+ put (maxBound - height)+ put height+ get = do+ guard . (== 0x03) =<< getWord8+ iheight <- get+ return (HeightKey (maxBound - iheight))++instance Serialize BlockKey where+ put (BlockKey hash) = do+ putWord8 0x01+ put hash+ get = do+ guard . (== 0x01) =<< getWord8+ BlockKey <$> get++instance Serialize TxKey where+ put (TxKey hash) = do+ putWord8 0x02+ put hash+ putWord8 0x00+ get = do+ guard . (== 0x02) =<< getWord8+ hash <- get+ guard . (== 0x00) =<< getWord8+ return (TxKey hash)++type StoreSupervisor n = Inbox (SupervisorMessage n)++data StoreConfig n = StoreConfig+ { storeConfBlocks :: !BlockStore+ , storeConfSupervisor :: !(StoreSupervisor n)+ , storeConfManager :: !Manager+ , storeConfChain :: !Chain+ , storeConfPublisher :: !(Publisher Inbox TBQueue StoreEvent)+ , storeConfMaxPeers :: !Int+ , storeConfInitPeers :: ![HostPort]+ , storeConfDiscover :: !Bool+ , storeConfDB :: !DB+ , storeConfNetwork :: !Network+ }
+ test/Spec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+import Control.Concurrent.NQE+import Control.Monad+import Control.Monad.Logger+import Data.Maybe+import Database.RocksDB (DB)+import qualified Database.RocksDB as RocksDB+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Node+import Network.Haskoin.Store+import Network.Haskoin.Transaction+import Test.Hspec+import UnliftIO++data TestStore = TestStore+ { testStoreDB :: !DB+ , testStoreBlockStore :: !BlockStore+ , testStoreChain :: !Chain+ , testStoreEvents :: !(Inbox StoreEvent)+ }++main :: IO ()+main = do+ let net = btcTest+ hspec . describe "Download" $ do+ it "gets 8 blocks" $+ withTestStore net "eight-blocks" $ \TestStore {..} -> do+ bs <-+ replicateM 9 . receiveMatch testStoreEvents $ \case+ BestBlock b -> Just b+ _ -> Nothing+ withAsync (dummyEventHandler testStoreEvents) $ \_ -> do+ let bestHash = last bs+ bestNodeM <- chainGetBlock bestHash testStoreChain+ bestNodeM `shouldSatisfy` isJust+ let bestNode = fromJust bestNodeM+ bestHeight = nodeHeight bestNode+ bestHeight `shouldBe` 8+ it "get a block and its transactions" $+ withTestStore net "get-block-txs" $ \TestStore {..} -> do+ bs <-+ replicateM 382 $+ receiveMatch testStoreEvents $ \case+ BestBlock b -> Just b+ _ -> Nothing+ withAsync (dummyEventHandler testStoreEvents) $ \_ -> do+ let blockHash = last bs+ m <- getBlock blockHash testStoreDB Nothing+ let BlockValue {..} =+ fromMaybe (error "Could not get block") m+ blockValueHeight `shouldBe` 381+ length blockValueTxs `shouldBe` 2+ let h1 =+ "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22"+ h2 =+ "7e621eeb02874ab039a8566fd36f4591e65eca65313875221842c53de6907d6c"+ head blockValueTxs `shouldBe` h1+ last blockValueTxs `shouldBe` h2+ t1 <- getTx net h1 testStoreDB Nothing+ t1 `shouldSatisfy` isJust+ txHash (detailedTxData (fromJust t1)) `shouldBe` h1+ t2 <- getTx net h2 testStoreDB Nothing+ t2 `shouldSatisfy` isJust+ txHash (detailedTxData (fromJust t2)) `shouldBe` h2++dummyEventHandler :: (MonadIO m, Mailbox b) => b a -> m ()+dummyEventHandler = forever . void . receive++withTestStore ::+ Network -> String -> (TestStore -> IO ()) -> IO ()+withTestStore net t f =+ withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w ->+ runNoLoggingT $ do+ s <- Inbox <$> liftIO newTQueueIO+ c <- Inbox <$> liftIO newTQueueIO+ b <- Inbox <$> liftIO newTQueueIO+ m <- Inbox <$> liftIO newTQueueIO+ p <- Inbox <$> liftIO newTQueueIO+ db <-+ RocksDB.open+ w+ RocksDB.defaultOptions+ { RocksDB.createIfMissing = True+ , RocksDB.compression = RocksDB.SnappyCompression+ }+ let cfg =+ StoreConfig+ { storeConfBlocks = b+ , storeConfSupervisor = s+ , storeConfChain = c+ , storeConfPublisher = p+ , storeConfMaxPeers = 20+ , storeConfInitPeers = []+ , storeConfDiscover = True+ , storeConfDB = db+ , storeConfManager = m+ , storeConfNetwork = net+ }+ withAsync (store cfg) $ \a ->+ withBoundedPubSub 100 p $ \sub -> do+ link a+ x <-+ liftIO $+ f+ TestStore+ { testStoreDB = db+ , testStoreBlockStore = b+ , testStoreChain = c+ , testStoreEvents = Inbox sub+ }+ stopSupervisor s+ wait a+ return x