diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 = diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 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 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -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 diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Memory.hs b/src/Haskoin/Store/Database/Memory.hs --- a/src/Haskoin/Store/Database/Memory.hs +++ b/src/Haskoin/Store/Database/Memory.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -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) } diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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 () diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -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 diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -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 diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -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 = diff --git a/test/Haskoin/Store/CommonSpec.hs b/test/Haskoin/Store/CommonSpec.hs --- a/test/Haskoin/Store/CommonSpec.hs +++ b/test/Haskoin/Store/CommonSpec.hs @@ -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] diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -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 _ = []