haskoin-store 0.23.23 → 0.24.0
raw patch · 14 files changed
+837/−424 lines, 14 filesdep +base64dep ~haskoin-coredep ~haskoin-node
Dependencies added: base64
Dependency ranges changed: haskoin-core, haskoin-node
Files
- CHANGELOG.md +10/−0
- app/Main.hs +2/−0
- haskoin-store.cabal +9/−7
- src/Haskoin/Store.hs +13/−1
- src/Haskoin/Store/Common.hs +345/−133
- src/Haskoin/Store/Database/Memory.hs +12/−21
- src/Haskoin/Store/Database/Reader.hs +2/−4
- src/Haskoin/Store/Database/Types.hs +10/−13
- src/Haskoin/Store/Database/Writer.hs +1/−2
- src/Haskoin/Store/Logic.hs +39/−56
- src/Haskoin/Store/Manager.hs +5/−1
- src/Haskoin/Store/Web.hs +39/−28
- test/Haskoin/Store/CommonSpec.hs +210/−136
- test/Haskoin/StoreSpec.hs +140/−22
CHANGELOG.md view
@@ -4,6 +4,16 @@ 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.24.0+### Changed+- Use mocking to simulate peers instead of connecting to the network while testing.+- Depend on latest version of Haskoin Core for faster JSON serialisation.+- Clean up confusing JSON encoding/decoding codebase.++## 0.23.24+### Changed+- Implement faster JSON encoding using toEncoding from the Aeson library.+ ## 0.23.23 ### Changed - Do not read full mempool so often from cache code.
app/Main.hs view
@@ -17,6 +17,7 @@ import Haskoin (Network (..), allNets, bch, bchRegTest, bchTest, btc, btcRegTest, btcTest)+import Haskoin.Node (withConnection) import Haskoin.Store (StoreConfig (..), WebConfig (..), WebLimits (..), WebTimeouts (..), runWeb, withStore)@@ -270,6 +271,7 @@ , storeConfWipeMempool = wipemempool , storeConfPeerTimeout = peertimeout , storeConfPeerTooOld = peerold+ , storeConfConnect = withConnection } in withStore scfg $ \st -> let wcfg =
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e389f53da7c91a8ac730b39e0edc1bd54dc05d5c0da6b6202ba42e40c332d09d+-- hash: f95fe3732d305938e74dde6fd2add6ccccc8f8ab25b96dce638ed21700a7e86d name: haskoin-store-version: 0.23.23+version: 0.24.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store and index Bitcoin or Bitcoin Cash blocks, transactions, balances and unspent outputs. All data is available via REST API in JSON or binary format.@@ -58,8 +58,8 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0- , haskoin-core >=0.12.0- , haskoin-node >=0.11.3+ , haskoin-core >=0.13.0+ , haskoin-node >=0.12.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32@@ -98,7 +98,8 @@ , deepseq >=1.4.4.0 , filepath , hashable >=1.3.0.0- , haskoin-core >=0.12.0+ , haskoin-core >=0.13.0+ , haskoin-node >=0.12.0 , haskoin-store , monad-logger >=0.3.32 , mtl >=2.2.2@@ -140,6 +141,7 @@ QuickCheck >=2.13.2 , aeson >=1.4.7.1 , base >=4.9 && <5+ , base64 >=0.4.1 , bytestring >=0.10.10.0 , cereal >=0.5.8.1 , conduit >=1.3.2@@ -147,8 +149,8 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0- , haskoin-core >=0.12.0- , haskoin-node >=0.11.3+ , haskoin-core >=0.13.0+ , haskoin-node >=0.12.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store.hs view
@@ -4,23 +4,35 @@ , TxData (..) , Spender (..) , Balance (..)+ , balanceToJSON+ , balanceToEncoding+ , balanceParseJSON , Unspent (..)+ , unspentToJSON+ , unspentToEncoding , BlockTx (..) , BlockRef (..) , XPubSpec (..) , XPubBal (..) , XPubSummary (..) , XPubUnspent (..)+ , xPubUnspentToJSON+ , xPubUnspentToEncoding , DeriveType (..)- , NetWrap (..) , UnixTime , Limit , Offset , BlockPos , Transaction (..)+ , transactionToJSON+ , transactionToEncoding , StoreInput (..)+ , storeInputToJSON+ , storeInputToEncoding , StoreOutput (..)+ , storeOutputToJSON+ , storeOutputToEncoding , getTransaction , transactionData , fromTransaction
src/Haskoin/Store/Common.hs view
@@ -14,7 +14,6 @@ , getUnixTime , putUnixTime , BlockPos- , NetWrap(..) , XPubSpec(..) , StoreRead(..) , StoreWrite(..)@@ -22,15 +21,26 @@ , BlockTx(..) , confirmed , Balance(..)+ , balanceToJSON+ , balanceToEncoding+ , balanceParseJSON , BlockData(..) , StoreInput(..)+ , storeInputToJSON+ , storeInputToEncoding , isCoinbase , Spender(..) , StoreOutput(..)+ , storeOutputToJSON+ , storeOutputToEncoding , Prev(..) , TxData(..) , Unspent(..)+ , unspentToJSON+ , unspentToEncoding , Transaction(..)+ , transactionToJSON+ , transactionToEncoding , transactionData , fromTransaction , toTransaction@@ -38,8 +48,13 @@ , TxId(..) , PeerInformation(..) , XPubBal(..)+ , xPubBalToJSON+ , xPubBalToEncoding+ , xPubBalParseJSON , xPubBalsTxs , XPubUnspent(..)+ , xPubUnspentToJSON+ , xPubUnspentToEncoding , xPubBalsUnspents , XPubSummary(..) , HealthCheck(..)@@ -57,7 +72,6 @@ , applyLimitC , applyOffsetLimitC , sortTxs- , scriptToStringAddr ) where import Conduit (ConduitT, dropC, mapC, takeC)@@ -67,10 +81,11 @@ import Control.Monad (guard, join, mzero) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Aeson (FromJSON (..), ToJSON (..),- Value (..), object, (.!=), (.:),- (.:?), (.=))+import Data.Aeson (Encoding, FromJSON (..),+ ToJSON (..), Value (..), object,+ pairs, (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as A+import Data.Aeson.Encoding (list, null_, pair, text) import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) import qualified Data.ByteString as B@@ -98,13 +113,14 @@ PubKeyI (..), RejectCode (..), Tx (..), TxHash (..), TxIn (..), TxOut (..), WitnessStack,- XPubKey (..), addrToString,- decodeHex, deriveAddr,- deriveCompatWitnessAddr,- deriveWitnessAddr, eitherToMaybe,- encodeHex, headerHash, pubSubKey,- scriptToAddressBS, stringToAddr,- txHash, wrapPubKey)+ XPubKey (..), addrFromJSON,+ addrToEncoding, addrToJSON,+ blockHashToHex, decodeHex,+ deriveAddr, deriveCompatWitnessAddr,+ deriveWitnessAddr, encodeHex,+ headerHash, pubSubKey,+ scriptToAddressBS, txHash,+ txHashToHex, wrapPubKey) import Haskoin.Node (Peer) import Network.Socket (SockAddr) import NQE (Listen, Mailbox)@@ -181,11 +197,6 @@ type Offset = Word32 type Limit = Word32 -data NetWrap a = NetWrap Network a--instance ToJSON (NetWrap a) => ToJSON (NetWrap [a]) where- toJSON (NetWrap net xs) = toJSON $ map (toJSON . NetWrap net) xs- class Monad m => StoreRead m where@@ -425,6 +436,9 @@ toJSON BlockRef {blockRefHeight = h, blockRefPos = p} = object ["height" .= h, "position" .= p] toJSON MemRef {memRefTime = t} = object ["mempool" .= t]+ toEncoding BlockRef {blockRefHeight = h, blockRefPos = p} =+ pairs ("height" .= h <> "position" .= p)+ toEncoding MemRef {memRefTime = t} = pairs ("mempool" .= t) instance FromJSON BlockRef where parseJSON = A.withObject "blockref" $ \o -> b o <|> m o@@ -447,6 +461,11 @@ instance ToJSON BlockTx where toJSON btx = object ["txid" .= blockTxHash btx, "block" .= blockTxBlock btx]+ toEncoding btx =+ pairs+ ( "txid" .= blockTxHash btx+ <> "block" .= blockTxBlock btx+ ) instance FromJSON BlockTx where parseJSON =@@ -493,10 +512,10 @@ } = True nullBalance _ = False -instance ToJSON (NetWrap Balance) where- toJSON (NetWrap net b) =+balanceToJSON :: Network -> Balance -> Value+balanceToJSON net b = object $- [ "address" .= addrToString net (balanceAddress b)+ [ "address" .= addrToJSON net (balanceAddress b) , "confirmed" .= balanceAmount b , "unconfirmed" .= balanceZero b , "utxo" .= balanceUnspentCount b@@ -504,50 +523,72 @@ , "received" .= balanceTotalReceived b ] -instance FromJSON (Network -> Maybe Balance) where- parseJSON =- A.withObject "balance" $ \o -> do- amount <- o .: "confirmed"- unconfirmed <- o .: "unconfirmed"- utxo <- o .: "utxo"- txs <- o .: "txs"- received <- o .: "received"- address <- o .: "address"- return $ \net ->- stringToAddr net address >>= \a ->- return- Balance- { balanceAddress = a- , balanceAmount = amount- , balanceUnspentCount = utxo- , balanceZero = unconfirmed- , balanceTxCount = txs- , balanceTotalReceived = received- }+balanceToEncoding :: Network -> Balance -> Encoding+balanceToEncoding net b =+ pairs+ ( "address" `pair` addrToEncoding net (balanceAddress b)+ <> "confirmed" .= balanceAmount b+ <> "unconfirmed" .= balanceZero b+ <> "utxo" .= balanceUnspentCount b+ <> "txs" .= balanceTxCount b+ <> "received" .= balanceTotalReceived b+ ) +balanceParseJSON :: Network -> Value -> Parser Balance+balanceParseJSON net =+ A.withObject "balance" $ \o -> do+ amount <- o .: "confirmed"+ unconfirmed <- o .: "unconfirmed"+ utxo <- o .: "utxo"+ txs <- o .: "txs"+ received <- o .: "received"+ address <- addrFromJSON net =<< o .: "address"+ return+ Balance+ { balanceAddress = address+ , balanceAmount = amount+ , balanceUnspentCount = utxo+ , balanceZero = unconfirmed+ , balanceTxCount = txs+ , balanceTotalReceived = received+ }+ -- | Unspent output. data Unspent = Unspent- { unspentBlock :: !BlockRef- , unspentPoint :: !OutPoint- , unspentAmount :: !Word64- , unspentScript :: !ShortByteString- , unspentAddress :: !(Maybe String)+ { unspentBlock :: !BlockRef+ , unspentPoint :: !OutPoint+ , unspentAmount :: !Word64+ , unspentScript :: !ShortByteString } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) -instance ToJSON Unspent where- toJSON u =- object $- [ "address" .= unspentAddress u+unspentToJSON :: Network -> Unspent -> Value+unspentToJSON net u =+ object+ [ "address" .= scriptToAddrJSON net bsscript , "block" .= unspentBlock u , "txid" .= outPointHash (unspentPoint u) , "index" .= outPointIndex (unspentPoint u) , "pkscript" .= script , "value" .= unspentAmount u ]- where- bsscript = BSS.fromShort (unspentScript u)- script = String (encodeHex bsscript)+ where+ bsscript = BSS.fromShort (unspentScript u)+ script = encodeHex bsscript +unspentToEncoding :: Network -> Unspent -> Encoding+unspentToEncoding net u =+ pairs+ ( "address" `pair` scriptToAddrEncoding net bsscript+ <> "block" .= unspentBlock u+ <> "txid" .= outPointHash (unspentPoint u)+ <> "index" .= outPointIndex (unspentPoint u)+ <> "pkscript" `pair` text script+ <> "value" .= unspentAmount u+ )+ where+ bsscript = BSS.fromShort (unspentScript u)+ script = encodeHex bsscript+ instance FromJSON Unspent where parseJSON = A.withObject "unspent" $ \o -> do@@ -556,14 +597,12 @@ index <- o .: "index" value <- o .: "value" script <- BSS.toShort <$> (o .: "pkscript" >>= jsonHex)- address <- o .: "address" return Unspent { unspentBlock = block , unspentPoint = OutPoint txid index , unspentAmount = value , unspentScript = script- , unspentAddress = address } -- | Database value for a block entry.@@ -607,9 +646,27 @@ , "subsidy" .= blockDataSubsidy bv , "fees" .= blockDataFees bv , "outputs" .= blockDataOutputs bv- , "work" .= String (cs (show (blockDataWork bv)))+ , "work" .= show (blockDataWork bv) , "weight" .= blockDataWeight bv ]+ toEncoding bv =+ pairs+ ( "hash" `pair` text (blockHashToHex (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" `pair` text (txHashToHex (TxHash (merkleRoot (blockDataHeader bv))))+ <> "subsidy" .= blockDataSubsidy bv+ <> "fees" .= blockDataFees bv+ <> "outputs" .= blockDataOutputs bv+ <> "work" .= blockDataWork bv+ <> "weight" .= blockDataWeight bv) instance FromJSON BlockData where parseJSON =@@ -641,7 +698,7 @@ , merkleRoot = merkle } , blockDataMainChain = mainchain- , blockDataWork = read work+ , blockDataWork = work , blockDataSize = size , blockDataWeight = weight , blockDataTxs = tx@@ -670,42 +727,79 @@ isCoinbase StoreCoinbase {} = True isCoinbase StoreInput {} = False -instance ToJSON (NetWrap StoreInput) where- toJSON (NetWrap net StoreInput { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputPkScript = ps- , inputAmount = val- , inputWitness = wit- }) =- object- [ "coinbase" .= False- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= String (encodeHex ps)- , "value" .= val- , "address" .= scriptToStringAddr net ps- , "witness" .= fmap (map encodeHex) wit- ]- toJSON (NetWrap _ StoreCoinbase { inputPoint = OutPoint oph opi+storeInputToJSON :: Network -> StoreInput -> Value+storeInputToJSON net StoreInput { inputPoint = OutPoint oph opi+ , inputSequence = sq+ , inputSigScript = ss+ , inputPkScript = ps+ , inputAmount = val+ , inputWitness = wit+ } =+ object+ [ "coinbase" .= False+ , "txid" .= oph+ , "output" .= opi+ , "sigscript" .= String (encodeHex ss)+ , "sequence" .= sq+ , "pkscript" .= String (encodeHex ps)+ , "value" .= val+ , "address" .= scriptToAddrJSON net ps+ , "witness" .= fmap (map encodeHex) wit+ ]+storeInputToJSON _ StoreCoinbase { inputPoint = OutPoint oph opi+ , inputSequence = sq+ , inputSigScript = ss+ , inputWitness = wit+ } =+ object+ [ "coinbase" .= True+ , "txid" .= oph+ , "output" .= opi+ , "sigscript" .= String (encodeHex ss)+ , "sequence" .= sq+ , "pkscript" .= Null+ , "value" .= Null+ , "address" .= Null+ , "witness" .= fmap (map encodeHex) wit+ ]++storeInputToEncoding :: Network -> StoreInput -> Encoding+storeInputToEncoding net StoreInput { inputPoint = OutPoint oph opi , inputSequence = sq , inputSigScript = ss+ , inputPkScript = ps+ , inputAmount = val , inputWitness = wit- }) =- object- [ "coinbase" .= True- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= Null- , "value" .= Null- , "address" .= Null- , "witness" .= fmap (map encodeHex) wit- ]+ } =+ pairs+ ( "coinbase" .= False+ <> "txid" .= oph+ <> "output" .= opi+ <> "sigscript" `pair` text (encodeHex ss)+ <> "sequence" .= sq+ <> "pkscript" `pair` text (encodeHex ps)+ <> "value" .= val+ <> "address" `pair` scriptToAddrEncoding net ps+ <> "witness" .= fmap (map encodeHex) wit+ ) +storeInputToEncoding _ StoreCoinbase { inputPoint = OutPoint oph opi+ , inputSequence = sq+ , inputSigScript = ss+ , inputWitness = wit+ } =+ pairs+ ( "coinbase" .= True+ <> "txid" `pair` text (txHashToHex oph)+ <> "output" .= opi+ <> "sigscript" `pair` text (encodeHex ss)+ <> "sequence" .= sq+ <> "pkscript" `pair` null_+ <> "value" `pair` null_+ <> "address" `pair` null_+ <> "witness" .= fmap (map encodeHex) wit+ )+ instance FromJSON StoreInput where parseJSON = A.withObject "storeinput" $ \o -> do@@ -754,7 +848,8 @@ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) instance ToJSON Spender where- toJSON n = object ["txid" .= spenderHash n, "input" .= spenderIndex n]+ toJSON n = object ["txid" .= txHashToHex (spenderHash n), "input" .= spenderIndex n]+ toEncoding n = pairs ("txid" .= txHashToHex (spenderHash n) <> "input" .= spenderIndex n) instance FromJSON Spender where parseJSON =@@ -767,16 +862,26 @@ , outputSpender :: !(Maybe Spender) } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) -instance ToJSON (NetWrap StoreOutput) where- toJSON (NetWrap net d) =- object- [ "address" .= scriptToStringAddr net (outputScript d)- , "pkscript" .= String (encodeHex (outputScript d))- , "value" .= outputAmount d- , "spent" .= isJust (outputSpender d)- , "spender" .= outputSpender d- ]+storeOutputToJSON :: Network -> StoreOutput -> Value+storeOutputToJSON net d =+ object+ [ "address" .= scriptToAddrJSON net (outputScript d)+ , "pkscript" .= encodeHex (outputScript d)+ , "value" .= outputAmount d+ , "spent" .= isJust (outputSpender d)+ , "spender" .= outputSpender d+ ] +storeOutputToEncoding :: Network -> StoreOutput -> Encoding+storeOutputToEncoding net d =+ pairs+ ( "address" `pair` scriptToAddrEncoding net (outputScript d)+ <> "pkscript" `pair` text (encodeHex (outputScript d))+ <> "value" .= outputAmount d+ <> "spent" .= isJust (outputSpender d)+ <> "spender" .= outputSpender d+ )+ instance FromJSON StoreOutput where parseJSON = A.withObject "storeoutput" $ \o -> do@@ -908,33 +1013,57 @@ o StoreOutput {outputAmount = v, outputScript = s} = TxOut {outValue = v, scriptOutput = s} -instance ToJSON (NetWrap Transaction) where- toJSON (NetWrap net dtx) =- object- [ "txid" .= txHash (transactionData dtx)- , "size" .= B.length (S.encode (transactionData dtx))- , "version" .= transactionVersion dtx- , "locktime" .= transactionLockTime dtx- , "fee" .=- if any isCoinbase (transactionInputs dtx)- then 0- else inv - outv- , "inputs" .= map (NetWrap net) (transactionInputs dtx)- , "outputs" .= map (NetWrap net) (transactionOutputs dtx)- , "block" .= transactionBlock dtx- , "deleted" .= transactionDeleted dtx- , "time" .= transactionTime dtx- , "rbf" .= transactionRBF dtx- , "weight" .= w- ]- where- inv = sum (map inputAmount (transactionInputs dtx))- outv = sum (map outputAmount (transactionOutputs dtx))- 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 dtx =+ object+ [ "txid" .= txHash (transactionData dtx)+ , "size" .= B.length (S.encode (transactionData dtx))+ , "version" .= transactionVersion dtx+ , "locktime" .= transactionLockTime dtx+ , "fee" .=+ if any isCoinbase (transactionInputs dtx)+ then 0+ else inv - outv+ , "inputs" .= map (storeInputToJSON net) (transactionInputs dtx)+ , "outputs" .= map (storeOutputToJSON net) (transactionOutputs dtx)+ , "block" .= transactionBlock dtx+ , "deleted" .= transactionDeleted dtx+ , "time" .= transactionTime dtx+ , "rbf" .= transactionRBF dtx+ , "weight" .= w+ ]+ where+ inv = sum (map inputAmount (transactionInputs dtx))+ outv = sum (map outputAmount (transactionOutputs dtx))+ w =+ let b = B.length $ S.encode (transactionData dtx) {txWitness = []}+ x = B.length $ S.encode (transactionData dtx)+ in b * 3 + x +transactionToEncoding :: Network -> Transaction -> Encoding+transactionToEncoding net dtx =+ pairs+ ( "txid" `pair` text (txHashToHex (txHash (transactionData dtx)))+ <> "size" .= B.length (S.encode (transactionData dtx))+ <> "version" .= transactionVersion dtx+ <> "locktime" .= transactionLockTime dtx+ <> "fee" .= (if any isCoinbase (transactionInputs dtx) then 0 else inv - outv)+ <> "inputs" `pair` list (storeInputToEncoding net) (transactionInputs dtx)+ <> "outputs" `pair` list (storeOutputToEncoding net) (transactionOutputs dtx)+ <> "block" .= transactionBlock dtx+ <> "deleted" .= transactionDeleted dtx+ <> "time" .= transactionTime dtx+ <> "rbf" .= transactionRBF dtx+ <> "weight" .= w+ )+ where+ inv = sum (map inputAmount (transactionInputs dtx))+ outv = sum (map outputAmount (transactionOutputs dtx))+ w =+ let b = B.length $ S.encode (transactionData dtx) {txWitness = []}+ x = B.length $ S.encode (transactionData dtx)+ in b * 3 + x+ instance FromJSON Transaction where parseJSON = A.withObject "transaction" $ \o -> do@@ -981,6 +1110,13 @@ , "services" .= String (encodeHex (S.encode (peerServices p))) , "relay" .= peerRelay p ]+ toEncoding p = pairs+ ( "useragent" `pair` text (cs (peerUserAgent p))+ <> "address" .= peerAddress p+ <> "version" .= peerVersion p+ <> "services" `pair` text (encodeHex (S.encode (peerServices p)))+ <> "relay" .= peerRelay p+ ) instance FromJSON PeerInformation where parseJSON =@@ -1009,20 +1145,42 @@ , xPubBal :: !Balance } deriving (Show, Ord, Eq, Generic, Serialize, NFData) -instance ToJSON (NetWrap XPubBal) where- toJSON (NetWrap net XPubBal {xPubBalPath = p, xPubBal = b}) =- object ["path" .= p, "balance" .= toJSON (NetWrap net b)]+xPubBalToJSON :: Network -> XPubBal -> Value+xPubBalToJSON net XPubBal {xPubBalPath = p, xPubBal = b} =+ object ["path" .= p, "balance" .= balanceToJSON net b] +xPubBalToEncoding :: Network -> XPubBal -> Encoding+xPubBalToEncoding net XPubBal {xPubBalPath = p, xPubBal = b} =+ pairs ("path" .= p <> "balance" `pair` balanceToEncoding net b)++xPubBalParseJSON :: Network -> Value -> Parser XPubBal+xPubBalParseJSON net =+ A.withObject "xpubbal" $ \o -> do+ path <- o .: "path"+ balance <- balanceParseJSON net =<< o .: "balance"+ return XPubBal {xPubBalPath = path, xPubBal = balance}+ -- | Unspent transaction for extended public key. data XPubUnspent = XPubUnspent { xPubUnspentPath :: ![KeyIndex] , xPubUnspent :: !Unspent } deriving (Show, Eq, Generic, Serialize, NFData) -instance ToJSON XPubUnspent where- toJSON XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} =- object ["path" .= p, "unspent" .= toJSON u]+xPubUnspentToJSON :: Network -> XPubUnspent -> Value+xPubUnspentToJSON net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} =+ object ["path" .= p, "unspent" .= unspentToJSON net u] +xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding+xPubUnspentToEncoding net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} =+ pairs ("path" .= p <> "unspent" `pair` unspentToEncoding net u)++instance FromJSON XPubUnspent where+ parseJSON =+ A.withObject "xpubunspent" $ \o -> do+ p <- o .: "path"+ u <- o .: "unspent"+ return XPubUnspent {xPubUnspentPath = p, xPubUnspent = u}+ data XPubSummary = XPubSummary { xPubSummaryConfirmed :: !Word64@@ -1052,6 +1210,25 @@ ] , "indices" .= object ["change" .= ch, "external" .= ext] ]+ toEncoding XPubSummary { xPubSummaryConfirmed = c+ , xPubSummaryZero = z+ , xPubSummaryReceived = r+ , xPubUnspentCount = u+ , xPubExternalIndex = ext+ , xPubChangeIndex = ch+ } =+ pairs+ ( "balance" `pair` pairs+ ( "confirmed" .= c+ <> "unconfirmed" .= z+ <> "received" .= r+ <> "utxo" .= u+ )+ <> "indices" `pair` pairs+ ( "change" .= ch+ <> "external" .= ext+ )+ ) instance FromJSON XPubSummary where parseJSON =@@ -1108,6 +1285,26 @@ , "lastblock" .= healthLastBlock h , "lasttx" .= healthLastTx h ]+ toEncoding h =+ pairs+ ( "headers" `pair`+ pairs+ ( "hash" .= healthHeaderBest h+ <> "height" .= healthHeaderHeight h+ )+ <> "blocks" `pair`+ pairs+ ( "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 FromJSON HealthCheck where parseJSON =@@ -1146,6 +1343,11 @@ instance ToJSON Event where toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h] toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h]+ toEncoding (EventTx h) =+ pairs ("type" `pair` text "tx" <> "id" `pair` text (txHashToHex h))+ toEncoding (EventBlock h) =+ pairs+ ("type" `pair` text "block" <> "id" `pair` text (blockHashToHex h)) instance FromJSON Event where parseJSON =@@ -1166,6 +1368,7 @@ instance ToJSON a => ToJSON (GenericResult a) where toJSON (GenericResult b) = object ["result" .= b]+ toEncoding (GenericResult b) = pairs ("result" .= b) instance FromJSON a => FromJSON (GenericResult a) where parseJSON =@@ -1177,6 +1380,7 @@ instance ToJSON TxId where toJSON (TxId h) = object ["txid" .= h]+ toEncoding (TxId h) = pairs ("txid" `pair` text (txHashToHex h)) instance FromJSON TxId where parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid"@@ -1260,6 +1464,14 @@ ts in is <> go ds -scriptToStringAddr :: Network -> ByteString -> Maybe String-scriptToStringAddr net bs =- cs <$> (addrToString net =<< eitherToMaybe (scriptToAddressBS bs))+scriptToAddrJSON :: Network -> ByteString -> Value+scriptToAddrJSON net bs =+ case scriptToAddressBS bs of+ Left _ -> Null+ Right a -> addrToJSON net a++scriptToAddrEncoding :: Network -> ByteString -> Encoding+scriptToAddrEncoding net bs =+ case scriptToAddressBS bs of+ Left _ -> null_+ Right a -> addrToEncoding net a
src/Haskoin/Store/Database/Memory.hs view
@@ -31,7 +31,7 @@ Spender, StoreRead (..), StoreWrite (..), TxData (..), Unspent (..), applyLimit,- scriptToStringAddr, zeroBalance)+ zeroBalance) import Haskoin.Store.Database.Types (BalVal, OutVal (..), UnspentVal, balanceToVal, unspentToVal, valToBalance, valToUnspent)@@ -133,21 +133,16 @@ Just br -> b > br getAddressesUnspentsH ::- Network- -> [Address]- -> Maybe BlockRef- -> Maybe Limit- -> MemoryDatabase- -> [Unspent]-getAddressesUnspentsH net addrs start limit db = applyLimit limit xs+ [Address] -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]+getAddressesUnspentsH addrs start limit db = applyLimit limit xs where xs = nub . sortBy (flip compare `on` unspentBlock) . concat $- map (\a -> getAddressUnspentsH net a start limit db) addrs+ map (\a -> getAddressUnspentsH a start limit db) addrs getAddressUnspentsH ::- Network -> Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]-getAddressUnspentsH net addr start limit db =+ Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]+getAddressUnspentsH addr start limit db = applyLimit limit . dropWhile h . sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $@@ -161,7 +156,6 @@ , unspentAmount = outValAmount u , unspentScript = B.Short.toShort (outValScript u) , unspentPoint = p- , unspentAddress = scriptToStringAddr net (outValScript u) } g _ _ Nothing = Nothing h Unspent {unspentBlock = b} =@@ -258,10 +252,10 @@ setMempoolH :: [BlockTx] -> MemoryDatabase -> MemoryDatabase setMempoolH xs db = db {hMempool = Just xs} -getUnspentH :: Network -> OutPoint -> MemoryDatabase -> Maybe (Maybe Unspent)-getUnspentH net op db = do+getUnspentH :: OutPoint -> MemoryDatabase -> Maybe (Maybe Unspent)+getUnspentH op db = do m <- M.lookup (outPointHash op) (hUnspent db)- fmap (valToUnspent net op) <$> I.lookup (fromIntegral (outPointIndex op)) m+ fmap (valToUnspent op) <$> I.lookup (fromIntegral (outPointIndex op)) m insertUnspentH :: Unspent -> MemoryDatabase -> MemoryDatabase insertUnspentH u db =@@ -308,8 +302,7 @@ return . I.map fromJust . I.filter isJust $ getSpendersH t v getUnspent p = do v <- R.asks memoryDatabase >>= readTVarIO- net <- R.asks memoryNetwork- return . join $ getUnspentH net p v+ return . join $ getUnspentH p v getBalance a = do v <- R.asks memoryDatabase >>= readTVarIO return $ getBalanceH a v@@ -321,15 +314,13 @@ return $ getAddressesTxsH addr start limit v getAddressesUnspents addr start limit = do v <- R.asks memoryDatabase >>= readTVarIO- net <- R.asks memoryNetwork- return $ getAddressesUnspentsH net addr start limit v+ return $ getAddressesUnspentsH addr start limit v getAddressTxs addr start limit = do v <- R.asks memoryDatabase >>= readTVarIO return $ getAddressTxsH addr start limit v getAddressUnspents addr start limit = do v <- R.asks memoryDatabase >>= readTVarIO- net <- R.asks memoryNetwork- return $ getAddressUnspentsH net addr start limit v+ return $ getAddressUnspentsH addr start limit v getMaxGap = R.asks memoryMaxGap getInitialGap = R.asks memoryInitialGap getNetwork = R.asks memoryNetwork
src/Haskoin/Store/Database/Reader.hs view
@@ -181,9 +181,8 @@ getUnspentDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Unspent) getUnspentDB p DatabaseReader { databaseReadOptions = opts , databaseHandle = db- , databaseNetwork = net } =- fmap (valToUnspent net p) <$> retrieve db opts (UnspentKey p)+ fmap (valToUnspent p) <$> retrieve db opts (UnspentKey p) getAddressesUnspentsDB :: MonadIO m@@ -206,10 +205,9 @@ -> m [Unspent] getAddressUnspentsDB a start limit DatabaseReader { databaseReadOptions = opts , databaseHandle = db- , databaseNetwork = net } = liftIO . runResourceT . runConduit $- x .| applyLimitC limit .| mapC (uncurry (toUnspent net)) .| sinkList+ x .| applyLimitC limit .| mapC (uncurry toUnspent) .| sinkList where x = case start of
src/Haskoin/Store/Database/Types.hs view
@@ -39,11 +39,11 @@ import Database.RocksDB.Query (Key, KeyValue) import GHC.Generics (Generic) import Haskoin (Address, BlockHash, BlockHeight,- Network, OutPoint (..), TxHash)+ OutPoint (..), TxHash) import Haskoin.Store.Common (Balance (..), BlockData, BlockRef, BlockTx (..), Spender, TxData, UnixTime, Unspent (..), getUnixTime,- putUnixTime, scriptToStringAddr)+ putUnixTime) -- | Database key for an address transaction. data AddrTxKey@@ -192,9 +192,8 @@ | UnspentKeyB deriving (Show, Read, Eq, Ord, Generic, Hashable) -instance Serialize UnspentKey+instance Serialize UnspentKey where -- 0x09 · TxHash · Index- where put UnspentKey {unspentKey = OutPoint {outPointHash = h, outPointIndex = i}} = do putWord8 0x09 put h@@ -214,14 +213,13 @@ instance Key UnspentKey instance KeyValue UnspentKey UnspentVal -toUnspent :: Network -> AddrOutKey -> OutVal -> Unspent-toUnspent net b v =+toUnspent :: AddrOutKey -> OutVal -> Unspent+toUnspent b v = Unspent { unspentBlock = addrOutKeyB b , unspentAmount = outValAmount v , unspentScript = BSS.toShort (outValScript v) , unspentPoint = addrOutKeyP b- , unspentAddress = scriptToStringAddr net (outValScript v) } -- | Mempool transaction database key.@@ -423,15 +421,14 @@ , UnspentVal {unspentValBlock = b, unspentValAmount = v, unspentValScript = s}) -valToUnspent :: Network -> OutPoint -> UnspentVal -> Unspent-valToUnspent net p UnspentVal { unspentValBlock = b- , unspentValAmount = v- , unspentValScript = s- } =+valToUnspent :: OutPoint -> UnspentVal -> Unspent+valToUnspent p UnspentVal { unspentValBlock = b+ , unspentValAmount = v+ , unspentValScript = s+ } = Unspent { unspentBlock = b , unspentPoint = p , unspentAmount = v , unspentScript = s- , unspentAddress = scriptToStringAddr net (BSS.fromShort s) }
src/Haskoin/Store/Database/Writer.hs view
@@ -291,8 +291,7 @@ , databaseWriterState = hm } = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where- net = databaseNetwork db- f = getUnspentH net op <$> readTVarIO (memoryDatabase hm)+ f = getUnspentH op <$> readTVarIO (memoryDatabase hm) g = Just <$> withDatabaseReader db (getUnspent op) insertUnspentI :: MonadIO m => Unspent -> DatabaseWriter -> m ()
src/Haskoin/Store/Logic.hs view
@@ -13,46 +13,42 @@ , deleteTx ) where -import Control.Monad (forM, forM_, unless, void, when,- zipWithM_)-import Control.Monad.Except (MonadError (..))-import Control.Monad.Logger (MonadLogger, logDebugS,- 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)-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 Haskoin.Store.Common (Balance (..), BlockData (..),- BlockRef (..), BlockTx (..),- Prev (..), Spender (..),- StoreInput (..),- StoreOutput (..),- StoreRead (..), StoreWrite (..),- Transaction (..), TxData (..),- UnixTime, Unspent (..),- confirmed, fromTransaction,- isCoinbase, nullBalance,- scriptToStringAddr, sortTxs,- toTransaction, transactionData)-import Network.Haskoin.Block.Headers (computeSubsidy)-import UnliftIO (Exception)+import Control.Monad (forM, forM_, unless, void, when,+ zipWithM_)+import Control.Monad.Except (MonadError (..))+import Control.Monad.Logger (MonadLogger, logDebugS, 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)+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,+ computeSubsidy, genesisBlock,+ genesisNode, headerHash, isGenesis,+ nullOutPoint, scriptToAddressBS,+ txHash, txHashToHex)+import 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@@ -375,14 +371,12 @@ s <- getSpender (OutPoint (txHash tx) n) when (isNothing s) $ do deleteUnspent op- net <- getNetwork insertUnspent Unspent { unspentBlock = br , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o)- , unspentAddress = scriptToStringAddr net (scriptOutput o) } case scriptToAddressBS (scriptOutput o) of Left _ -> return ()@@ -395,7 +389,6 @@ a BlockTx {blockTxBlock = br, blockTxHash = txHash tx} when (isNothing s) $ do- net <- getNetwork deleteAddrUnspent a Unspent@@ -403,8 +396,6 @@ , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o)- , unspentAddress =- scriptToStringAddr net (scriptOutput o) } insertAddrUnspent a@@ -413,8 +404,6 @@ , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o)- , unspentAddress =- scriptToStringAddr net (scriptOutput o) } reduceBalance False False a (outValue o) increaseBalance True False a (outValue o)@@ -529,24 +518,22 @@ -> TxOut -> m () newOutput br op to = do- net <- getNetwork- insertUnspent (u net)+ insertUnspent u case scriptToAddressBS (scriptOutput to) of Left _ -> return () Right a -> do- insertAddrUnspent a (u net)+ insertAddrUnspent a u insertAddrTx a BlockTx {blockTxHash = outPointHash op, blockTxBlock = br} increaseBalance (confirmed br) True a (outValue to) where- u net =+ u = Unspent { unspentBlock = br , unspentAmount = outValue to , unspentScript = B.Short.toShort (scriptOutput to) , unspentPoint = op- , unspentAddress = scriptToStringAddr net (scriptOutput to) } delOutput ::@@ -558,7 +545,6 @@ => OutPoint -> m () delOutput op = do- net <- getNetwork t <- getImportTx (outPointHash op) u <- getTxOutput (outPointIndex op) t deleteUnspent op@@ -572,7 +558,6 @@ , unspentBlock = transactionBlock t , unspentPoint = op , unspentAmount = outputAmount u- , unspentAddress = scriptToStringAddr net (outputScript u) } deleteAddrTx a@@ -669,14 +654,12 @@ Just s -> return s x <- getImportTx (spenderHash s) deleteSpender op- net <- getNetwork let u = Unspent { unspentAmount = outputAmount o , unspentBlock = transactionBlock t , unspentScript = B.Short.toShort (outputScript o) , unspentPoint = op- , unspentAddress = scriptToStringAddr net (outputScript o) } insertUnspent u case scriptToAddressBS (outputScript o) of
src/Haskoin/Store/Manager.hs view
@@ -20,7 +20,8 @@ import Haskoin.Node (Chain, ChainEvent (..), HostPort, NodeConfig (..), NodeEvent (..), PeerEvent (..),- PeerManager, node)+ PeerManager, WithConnection,+ node) import Haskoin.Store.BlockStore (BlockStoreConfig (..), blockStore) import Haskoin.Store.Cache (CacheConfig (..), CacheWriter,@@ -83,6 +84,8 @@ -- ^ disconnect peer if message not received for this many seconds , storeConfPeerTooOld :: !Int -- ^ disconnect peer if it has been connected this long+ , storeConfConnect :: !WithConnection+ -- ^ connect to peers using the function 'withConnection' } withStore ::@@ -138,6 +141,7 @@ , nodeConfNet = storeConfNetwork cfg , nodeConfTimeout = storeConfPeerTimeout cfg , nodeConfPeerOld = storeConfPeerTooOld cfg+ , nodeConfConnect = storeConfConnect cfg } withAsync (node nodeconfig managerinbox chaininbox) $ \nodeasync -> do link nodeasync
src/Haskoin/Store/Web.hs view
@@ -26,8 +26,9 @@ import Control.Monad.Reader (ReaderT, asks, runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Aeson (ToJSON (..), object, (.=))-import Data.Aeson.Encoding (encodingToLazyByteString)+import Data.Aeson (Encoding, ToJSON (..), object,+ (.=))+import Data.Aeson.Encoding (encodingToLazyByteString, list) import qualified Data.ByteString as B import Data.ByteString.Builder (lazyByteString) import qualified Data.ByteString.Lazy as L@@ -70,16 +71,21 @@ BlockTx (..), DeriveType (..), Event (..), GenericResult (..), HealthCheck (..), Limit,- NetWrap (..), Offset,+ Offset, PeerInformation (..), PubExcept (..), StoreEvent (..), StoreInput (..), StoreRead (..), Transaction (..), TxData (..), TxId (..), UnixTime, Unspent, XPubBal (..), XPubSpec (..),- applyOffset, blockAtOrBefore,- getTransaction, isCoinbase,- nullBalance, transactionData)+ applyOffset, balanceToEncoding,+ blockAtOrBefore, getTransaction,+ isCoinbase, nullBalance,+ transactionData,+ transactionToEncoding,+ unspentToEncoding,+ xPubBalToEncoding,+ xPubUnspentToEncoding) import Haskoin.Store.Database.Reader (DatabaseReader (..), DatabaseReaderT, withDatabaseReader)@@ -304,14 +310,15 @@ S.raw (serialAny proto x) maybeSerialNet ::- (Monad m, ToJSON (NetWrap a), Serialize a)+ (Monad m, Serialize a) => Bool+ -> (Network -> a -> Encoding) -> Maybe a -> WebT m ()-maybeSerialNet _ Nothing = S.raise ThingNotFound-maybeSerialNet proto (Just x) = do+maybeSerialNet _ _ Nothing = S.raise ThingNotFound+maybeSerialNet proto f (Just x) = do net <- lift $ asks (storeNetwork . webStore)- S.raw (serialAnyNet net proto x)+ S.raw (serialAnyNet proto (f net) x) protoSerial :: (Monad m, ToJSON a, Serialize a)@@ -322,13 +329,14 @@ S.raw (serialAny proto x) protoSerialNet ::- (Monad m, ToJSON (NetWrap a), Serialize a)+ (Monad m, Serialize a) => Bool+ -> (Network -> a -> Encoding) -> a -> WebT m ()-protoSerialNet proto x = do+protoSerialNet proto f x = do net <- lift $ asks (storeNetwork . webStore)- S.raw (serialAnyNet net proto x)+ S.raw (serialAnyNet proto (f net) x) scottyBestBlock :: (MonadUnliftIO m, MonadLoggerIO m, MonadIO m) => Bool -> WebT m ()@@ -460,7 +468,7 @@ MyTxHash txid <- S.param "txid" proto <- setupBin res <- getTransaction txid- maybeSerialNet proto res+ maybeSerialNet proto transactionToEncoding res scottyRawTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyRawTransaction = do@@ -485,7 +493,7 @@ txids <- map (\(MyTxHash h) -> h) <$> S.param "txids" proto <- setupBin txs <- catMaybes <$> mapM getTransaction (nub txids)- protoSerialNet proto txs+ protoSerialNet proto (list . transactionToEncoding) txs scottyBlockTransactions :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyBlockTransactions = do@@ -498,7 +506,7 @@ refuseLargeBlock limits b let ths = blockDataTxs b txs <- catMaybes <$> mapM getTransaction ths- protoSerialNet proto txs+ protoSerialNet proto (list . transactionToEncoding) txs Nothing -> S.raise ThingNotFound scottyRawTransactions ::@@ -542,7 +550,8 @@ proto <- setupBin if full then do- getAddressTxsFull o l s a >>= protoSerialNet proto+ getAddressTxsFull o l s a >>=+ protoSerialNet proto (list . transactionToEncoding) else do getAddressTxsLimit o l s a >>= protoSerial proto @@ -555,7 +564,8 @@ l <- getLimit full proto <- setupBin if full- then getAddressesTxsFull l s as >>= protoSerialNet proto+ then getAddressesTxsFull l s as >>=+ protoSerialNet proto (list . transactionToEncoding) else getAddressesTxsLimit l s as >>= protoSerial proto scottyAddressUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -567,7 +577,7 @@ l <- getLimit False proto <- setupBin uns <- getAddressUnspentsLimit o l s a- protoSerial proto uns+ protoSerialNet proto (list . unspentToEncoding) uns scottyAddressesUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyAddressesUnspent = do@@ -577,7 +587,7 @@ l <- getLimit False proto <- setupBin uns <- getAddressesUnspentsLimit l s as- protoSerial proto uns+ protoSerialNet proto (list . unspentToEncoding) uns scottyAddressBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyAddressBalance = do@@ -585,7 +595,7 @@ a <- parseAddress proto <- setupBin res <- getBalance a- protoSerialNet proto res+ protoSerialNet proto balanceToEncoding res scottyAddressesBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyAddressesBalances = do@@ -593,7 +603,7 @@ as <- parseAddresses proto <- setupBin res <- getBalances as- protoSerialNet proto res+ protoSerialNet proto (list . balanceToEncoding) res scottyXpubBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyXpubBalances = do@@ -606,7 +616,7 @@ if nocache then runNoCache (xPubBals xpub) else xPubBals xpub- protoSerialNet proto res+ protoSerialNet proto (list . xPubBalToEncoding) res scottyXpubTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m () scottyXpubTxs full = do@@ -624,7 +634,7 @@ if nocache then runNoCache (mapM (getTransaction . blockTxHash) txs) else mapM (getTransaction . blockTxHash) txs- protoSerialNet proto txs'+ protoSerialNet proto (list . transactionToEncoding) txs' else protoSerial proto txs scottyXpubEvict :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -651,7 +661,7 @@ if nocache then runNoCache (xPubUnspents xpub start 0 limit) else xPubUnspents xpub start 0 limit- protoSerial proto uns+ protoSerialNet proto (list . xPubUnspentToEncoding) uns scottyXpubSummary :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyXpubSummary = do@@ -926,9 +936,10 @@ serialAny True = runPutLazy . put serialAny False = encodingToLazyByteString . toEncoding -serialAnyNet :: (ToJSON (NetWrap a), Serialize a) => Network -> Bool -> a -> L.ByteString-serialAnyNet _ True = runPutLazy . put-serialAnyNet net False = encodingToLazyByteString . toEncoding . NetWrap net+serialAnyNet ::+ Serialize a => Bool -> (a -> Encoding) -> a -> L.ByteString+serialAnyNet True _ = runPutLazy . put+serialAnyNet False f = encodingToLazyByteString . f setupBin :: Monad m => ActionT Except m Bool setupBin =
test/Haskoin/Store/CommonSpec.hs view
@@ -5,31 +5,40 @@ ( spec ) where -import Control.Monad (join)-import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson (Encoding, FromJSON (..), ToJSON (..),+ Value) import qualified Data.Aeson as A+import Data.Aeson.Encoding (encodingToLazyByteString)+import Data.Aeson.Parser (decodeWith, json)+import Data.Aeson.Types (Parser, parse)+import Data.ByteString (pack) import qualified Data.ByteString.Short as BSS import Data.Serialize (Serialize (..), decode, encode) import Data.String.Conversions (cs)-import Haskoin (Network, bch, bchRegTest, bchTest,- btc, btcRegTest, btcTest)+import Haskoin (Address (..), BlockHash (..),+ BlockHeader (..), Hash160 (..),+ Hash256 (..), Network (..),+ OutPoint (..), RejectCode (..),+ Tx (..), TxHash (..), TxIn (..),+ TxOut (..), XPubKey (..), bch,+ bchRegTest, bchTest, btc, btcRegTest,+ btcTest, ripemd160, sha256) import Haskoin.Store.Common (Balance (..), BlockData (..), BlockRef (..), BlockTx (..), DeriveType (..), Event (..),- HealthCheck (..), NetWrap (..),+ HealthCheck (..), PeerInformation (..), Prev (..), PubExcept (..), Spender (..), StoreInput (..), StoreOutput (..), Transaction (..), TxData (..), TxId (..), Unspent (..), XPubBal (..), XPubSpec (..), XPubSummary (..),- XPubUnspent (..))-import Network.Haskoin.Test (arbitraryAddress, arbitraryBlockHash,- arbitraryBlockHeader,- arbitraryOutPoint,- arbitraryRejectCode, arbitraryScript,- arbitraryTx, arbitraryTxHash,- arbitraryXPubKey)+ XPubUnspent (..), balanceParseJSON,+ balanceToEncoding, balanceToJSON,+ transactionToEncoding,+ transactionToJSON, unspentToEncoding,+ unspentToJSON, xPubUnspentToEncoding,+ xPubUnspentToJSON) import NQE () import Test.Hspec (Expectation, Spec, describe, shouldBe) import Test.Hspec.QuickCheck (prop)@@ -65,171 +74,141 @@ prop "identity for peer info" $ \x -> testSerial (x :: PeerInformation) describe "JSON serialization" $ do prop "identity for balance" . forAll arbitraryNetData $ \(net, x) ->- testNetJSON2 net (x :: Balance)+ testNetJSON+ (balanceParseJSON net)+ (balanceToJSON net)+ (balanceToEncoding net)+ x prop "identity for block tx" $ \x -> testJSON (x :: BlockTx) prop "identity for block ref" $ \x -> testJSON (x :: BlockRef)- prop "identity for unspent" $ \x -> testJSON (x :: Unspent)+ prop "identity for unspent" . forAll arbitraryNetData $ \(net, x) ->+ testNetJSON parseJSON (unspentToJSON net) (unspentToEncoding net) x prop "identity for block data" $ \x -> testJSON (x :: BlockData) prop "identity for spender" $ \x -> testJSON (x :: Spender) prop "identity for transaction" . forAll arbitraryNetData $ \(net, x) ->- testNetJSON1 net (x :: Transaction)+ testNetJSON+ parseJSON+ (transactionToJSON net)+ (transactionToEncoding net)+ x prop "identity for xpub summary" $ \x -> testJSON (x :: XPubSummary)+ prop "identity for xpub unspent" . forAll arbitraryNetData $ \(net, x) ->+ testNetJSON+ parseJSON+ (xPubUnspentToJSON net)+ (xPubUnspentToEncoding net)+ x prop "identity for health check" $ \x -> testJSON (x :: HealthCheck) prop "identity for event" $ \x -> testJSON (x :: Event) prop "identity for txid" $ \x -> testJSON (x :: TxId) prop "identity for peer information" $ \x -> testJSON (x :: PeerInformation) -arbitraryNetData :: Arbitrary a => Gen (Network, a)-arbitraryNetData = do- net <- arbitraryNetwork- x <- arbitrary- return (net, x)- testJSON :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Expectation testJSON input = (A.decode . A.encode) input `shouldBe` Just input -testNetJSON1 ::- (Eq a, Show a, ToJSON (NetWrap a), FromJSON a) => Network -> a -> Expectation-testNetJSON1 net x =- let encoded = A.encode (NetWrap net x)- decoded = A.decode encoded- in decoded `shouldBe` Just x--testNetJSON2 ::- (Eq a, Show a, ToJSON (NetWrap a), FromJSON (Network -> Maybe a))- => Network+testNetJSON ::+ (Eq a, Show a)+ => (Value -> Parser a)+ -> (a -> Value)+ -> (a -> Encoding) -> a -> Expectation-testNetJSON2 net x =- let encoded = A.encode (NetWrap net x)- decoder = A.decode encoded- in join (($ net) <$> decoder) `shouldBe` Just x+testNetJSON parsejson tojson toenc x =+ let encval = A.encode (tojson x)+ encenc = encodingToLazyByteString (toenc x)+ decval = decodeWith json (parse parsejson) encval+ decenc = decodeWith json (parse parsejson) encenc+ in do+ decval `shouldBe` Just x+ decenc `shouldBe` Just x testSerial :: (Eq a, Show a, Serialize a) => a -> Expectation testSerial input = (decode . encode) input `shouldBe` Right input -instance Arbitrary DeriveType where- arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]+arbitraryNetwork :: Gen Network+arbitraryNetwork = elements [bch, btc, bchTest, btcTest, bchRegTest, btcRegTest] -instance Arbitrary XPubSpec where- arbitrary = do- (_, k) <- arbitraryXPubKey- t <- arbitrary- return XPubSpec {xPubSpecKey = k, xPubDeriveType = t}+arbitraryNetData :: Arbitrary a => Gen (Network, a)+arbitraryNetData = do+ net <- arbitraryNetwork+ x <- arbitrary+ return (net, x) -instance Arbitrary XPubBal where- arbitrary = XPubBal <$> arbitrary <*> arbitrary+instance Arbitrary BlockRef where+ arbitrary =+ oneof [BlockRef <$> arbitrary <*> arbitrary, MemRef <$> arbitrary] -instance Arbitrary XPubUnspent where- arbitrary = XPubUnspent <$> arbitrary <*> arbitrary+instance Arbitrary Hash256 where+ arbitrary = sha256 . pack <$> listOf1 arbitrary -instance Arbitrary Event where- arbitrary =- oneof [EventBlock <$> arbitraryBlockHash, EventTx <$> arbitraryTxHash]+instance Arbitrary TxHash where+ arbitrary = TxHash <$> arbitrary -instance Arbitrary XPubSummary where+instance Arbitrary OutPoint where+ arbitrary = OutPoint <$> arbitrary <*> arbitrary++instance Arbitrary TxIn where arbitrary =- XPubSummary- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary+ TxIn <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*>+ arbitrary -instance Arbitrary BlockRef where- arbitrary = oneof [br, mr]- where- br = BlockRef <$> arbitrary <*> arbitrary- mr = MemRef <$> arbitrary+instance Arbitrary TxOut where+ arbitrary = TxOut <$> arbitrary <*> (pack <$> listOf1 arbitrary) -instance Arbitrary BlockTx where+instance Arbitrary Tx where arbitrary = do- br <- arbitrary- th <- arbitraryTxHash- return BlockTx { blockTxBlock = br, blockTxHash = th}+ ver <- arbitrary+ txin <- listOf1 arbitrary+ txout <- listOf1 arbitrary+ txlock <- arbitrary+ return+ Tx+ { txVersion = ver+ , txIn = txin+ , txOut = txout+ , txWitness = []+ , txLockTime = txlock+ } -arbitraryNetwork :: Gen Network-arbitraryNetwork = elements [bch, btc, bchTest, btcTest, bchRegTest, btcRegTest]+instance Arbitrary Prev where+ arbitrary = Prev <$> (pack <$> listOf1 arbitrary) <*> arbitrary -instance Arbitrary Balance where+instance Arbitrary TxData where arbitrary =- Balance- <$> arbitraryAddress+ TxData+ <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary Unspent where- arbitrary =- Unspent- <$> arbitrary- <*> arbitraryOutPoint- <*> arbitrary- <*> (BSS.toShort . encode <$> arbitraryScript)- <*> arbitrary--instance Arbitrary BlockData where- arbitrary =- BlockData- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryBlockHeader- <*> arbitrary- <*> arbitrary- <*> listOf1 arbitraryTxHash- <*> arbitrary- <*> arbitrary- <*> arbitrary- instance Arbitrary StoreInput where- arbitrary = oneof [cb, si]- where- cb = do- st <- map encode <$> listOf arbitraryScript- ws <- elements [Just st, Nothing]- StoreCoinbase- <$> arbitraryOutPoint- <*> arbitrary- <*> (encode <$> arbitraryScript)- <*> pure ws- si = do- st <- map encode <$> listOf arbitraryScript- ws <- elements [Just st, Nothing]- StoreInput- <$> arbitraryOutPoint- <*> arbitrary- <*> (encode <$> arbitraryScript)- <*> (encode <$> arbitraryScript)- <*> arbitrary- <*> pure ws+ arbitrary =+ oneof+ [ StoreCoinbase <$> arbitrary <*> arbitrary <*>+ (pack <$> listOf1 arbitrary) <*>+ (oneof+ [ Just <$> (listOf $ pack <$> listOf1 arbitrary)+ , return Nothing+ ])+ , StoreInput <$> arbitrary <*> arbitrary <*>+ (pack <$> listOf1 arbitrary) <*>+ (pack <$> listOf1 arbitrary) <*>+ arbitrary <*>+ (oneof+ [ Just <$> (listOf $ pack <$> listOf1 arbitrary)+ , return Nothing+ ])+ ] instance Arbitrary Spender where- arbitrary = Spender <$> arbitraryTxHash <*> arbitrary--instance Arbitrary Prev where- arbitrary = Prev <$> (encode <$> arbitraryScript) <*> arbitrary+ arbitrary = Spender <$> arbitrary <*> arbitrary instance Arbitrary StoreOutput where arbitrary =- StoreOutput- <$> arbitrary- <*> (encode <$> arbitraryScript)- <*> arbitrary--instance Arbitrary TxData where- arbitrary =- TxData- <$> arbitrary- <*> (arbitraryTx =<< arbitraryNetwork)- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary+ StoreOutput <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*> arbitrary instance Arbitrary Transaction where arbitrary =@@ -252,10 +231,13 @@ <*> arbitrary <*> arbitrary +instance Arbitrary BlockHash where+ arbitrary = BlockHash <$> arbitrary+ instance Arbitrary HealthCheck where arbitrary = do- bh <- arbitraryBlockHash- hh <- arbitraryBlockHash+ bh <- arbitrary+ hh <- arbitrary let mb = elements [Nothing, Just bh] mh = elements [Nothing, Just hh] HealthCheck@@ -270,14 +252,106 @@ <*> arbitrary <*> arbitrary +instance Arbitrary RejectCode where+ arbitrary =+ elements+ [ RejectMalformed+ , RejectInvalid+ , RejectObsolete+ , RejectDuplicate+ , RejectNonStandard+ , RejectDust+ , RejectInsufficientFee+ , RejectCheckpoint+ ]+ instance Arbitrary PubExcept where arbitrary = oneof [ pure PubNoPeers- , PubReject <$> arbitraryRejectCode+ , PubReject <$> arbitrary , pure PubTimeout , pure PubPeerDisconnected ] +instance Arbitrary XPubKey where+ arbitrary =+ XPubKey <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>+ arbitrary++instance Arbitrary XPubSpec where+ arbitrary = XPubSpec <$> arbitrary <*> arbitrary++instance Arbitrary DeriveType where+ arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]+ instance Arbitrary TxId where- arbitrary = TxId <$> arbitraryTxHash+ arbitrary = TxId <$> arbitrary++instance Arbitrary BlockTx where+ arbitrary = BlockTx <$> arbitrary <*> arbitrary++instance Arbitrary Hash160 where+ arbitrary = ripemd160 . pack <$> listOf1 arbitrary++instance Arbitrary Address where+ arbitrary =+ oneof+ [ PubKeyAddress <$> arbitrary+ , ScriptAddress <$> arbitrary+ ]++instance Arbitrary Balance where+ arbitrary =+ Balance+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary Unspent where+ arbitrary =+ Unspent <$> arbitrary <*> arbitrary <*> arbitrary <*>+ (BSS.toShort . pack <$> listOf1 arbitrary)++instance Arbitrary BlockHeader where+ arbitrary =+ BlockHeader <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*>+ arbitrary <*>+ arbitrary++instance Arbitrary BlockData where+ arbitrary =+ BlockData+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> listOf1 arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary XPubBal where+ arbitrary = XPubBal <$> arbitrary <*> arbitrary++instance Arbitrary XPubUnspent where+ arbitrary = XPubUnspent <$> arbitrary <*> arbitrary++instance Arbitrary XPubSummary where+ arbitrary =+ XPubSummary+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary Event where+ arbitrary =+ oneof [EventBlock <$> arbitrary, EventTx <$> arbitrary]
test/Haskoin/StoreSpec.hs view
@@ -4,16 +4,25 @@ module Haskoin.StoreSpec (spec) where +import Conduit import Control.Monad import Control.Monad.Logger import Control.Monad.Trans+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Base64+import Data.Either import Data.Maybe+import Data.Serialize+import Data.Time.Clock.POSIX import Data.Word import Haskoin import Haskoin.Node import Haskoin.Store import Haskoin.Store.Common+import Network.Socket import NQE+import System.Random import Test.Hspec import UnliftIO @@ -26,7 +35,7 @@ spec :: Spec spec = do- let net = btcTest+ let net = bchRegTest describe "Download" $ do it "gets 8 blocks" $ withTestStore net "eight-blocks" $ \TestStore {..} -> do@@ -44,37 +53,35 @@ withTestStore net "get-block-txs" $ \TestStore {..} -> withDatabaseReader testStoreDB $ do let h1 =- "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22"- h2 =- "7e621eeb02874ab039a8566fd36f4591e65eca65313875221842c53de6907d6c"+ "5369ef2386c72acdf513ffd80aeba2a1774e2f004d120761e54a8bf614173f3e" get_the_block h = receive testStoreEvents >>= \case StoreBestBlock b- | h == 0 -> return b+ | h <= 1 -> return b | otherwise -> get_the_block ((h :: Int) - 1) _ -> get_the_block h- bh <- get_the_block 380+ bh <- get_the_block 15 m <- getBlock bh let bd = fromMaybe (error "Could not get block") m t1 <- getTransaction h1- t2 <- getTransaction h2 lift $ do- blockDataHeight bd `shouldBe` 381- length (blockDataTxs bd) `shouldBe` 2+ blockDataHeight bd `shouldBe` 15+ length (blockDataTxs bd) `shouldBe` 1 head (blockDataTxs bd) `shouldBe` h1- last (blockDataTxs bd) `shouldBe` h2 t1 `shouldSatisfy` isJust txHash (transactionData (fromJust t1)) `shouldBe` h1- t2 `shouldSatisfy` isJust- txHash (transactionData (fromJust t2)) `shouldBe` h2 withTestStore :: MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a withTestStore net t f = withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> runNoLoggingT $ do- let cfg =+ let ad =+ NetworkAddress+ nodeNetwork+ (sockToHostAddress (SockAddrInet 0 0))+ cfg = StoreConfig { storeConfMaxPeers = 20 , storeConfInitPeers = []@@ -89,16 +96,127 @@ , storeConfWipeMempool = False , storeConfPeerTimeout = 60 , storeConfPeerTooOld = 48 * 3600- }- withStore cfg $ \Store {..} -> withSubscription storePublisher $ \sub ->- lift $- f- TestStore- { testStoreDB = storeDB- , testStoreBlockStore = storeBlock- , testStoreChain = storeChain- , testStoreEvents = sub+ , storeConfConnect = dummyPeerConnect net ad }+ withStore cfg $ \Store {..} ->+ withSubscription storePublisher $ \sub ->+ lift $+ f+ TestStore+ { testStoreDB = storeDB+ , testStoreBlockStore = storeBlock+ , testStoreChain = storeChain+ , testStoreEvents = sub+ } gap :: Word32 gap = 32++allBlocks :: [Block]+allBlocks =+ fromRight (error "Could not decode blocks") $+ runGet f (decodeBase64Lenient allBlocksBase64)+ where+ f = mapM (const get) [1..15]++allBlocksBase64 :: ByteString+allBlocksBase64 =+ "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\+ \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\+ \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\+ \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\+ \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\+ \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\+ \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\+ \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\+ \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\+ \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\+ \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\+ \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\+ \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\+ \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\+ \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\+ \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\+ \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\+ \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\+ \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\+ \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\+ \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\+ \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\+ \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\+ \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\+ \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\+ \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\+ \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\+ \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\+ \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\+ \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\+ \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\+ \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\+ \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\+ \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\+ \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\+ \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\+ \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\+ \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\+ \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\+ \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\+ \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\+ \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA"++dummyPeerConnect :: Network -> NetworkAddress -> WithConnection+dummyPeerConnect net ad sa f = do+ r <- newInbox+ s <- newInbox+ let s' = inboxToMailbox s+ withAsync (go r s') $ \_ -> do+ let o = awaitForever (`send` r)+ i = forever (receive s >>= yield)+ f (Conduits i o) :: IO ()+ where+ go :: Inbox ByteString -> Mailbox ByteString -> IO ()+ go r s = do+ nonce <- randomIO+ now <- round <$> liftIO getPOSIXTime+ let rmt = NetworkAddress 0 (sockToHostAddress sa)+ ver = buildVersion net nonce 0 ad rmt now+ runPut (putMessage net (MVersion ver)) `send` s+ runConduit $+ forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact .|+ outc .|+ awaitForever (`send` s)+ outc = mapMC $ \msg -> return $ runPut (putMessage net msg)+ inc =+ forever $ do+ x <- takeCE 24 .| foldC+ case decode x of+ Left _ -> error "Dummy peer not decode message header"+ Right (MessageHeader _ _ len _) -> do+ y <- takeCE (fromIntegral len) .| foldC+ case runGet (getMessage net) $ x `B.append` y of+ Left e ->+ error $+ "Dummy peer could not decode payload: " <> show e+ Right msg -> yield msg++mockPeerReact :: Message -> [Message]+mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]+mockPeerReact (MVersion _) = [MVerAck]+mockPeerReact (MGetHeaders (GetHeaders _ _hs _)) = [MHeaders (Headers hs')]+ where+ f b = (blockHeader b, VarInt (fromIntegral (length (blockTxns b))))+ hs' = map f allBlocks+mockPeerReact (MGetData (GetData ivs)) = mapMaybe f ivs+ where+ f (InvVector InvBlock h) = MBlock <$> listToMaybe (filter (l h) allBlocks)+ f _ = Nothing+ l h b = headerHash (blockHeader b) == BlockHash h+mockPeerReact _ = []