diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/haskoin-store-data.cabal b/haskoin-store-data.cabal new file mode 100644 --- /dev/null +++ b/haskoin-store-data.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 29a625aa392b51b11b2748f657106ea091e81d146b899f31aaf6d45de6ac97d1 + +name: haskoin-store-data +version: 0.25.0 +synopsis: Data for Haskoin Store +category: Bitcoin, Finance, Network +homepage: http://github.com/haskoin/haskoin-store#readme +bug-reports: http://github.com/haskoin/haskoin-store/issues +author: Jean-Pierre Rupp +maintainer: jprupp@protonmail.ch +license: PublicDomain +license-file: UNLICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/haskoin/haskoin-store.git + +library + exposed-modules: + Haskoin.Store.Data + other-modules: + Paths_haskoin_store_data + hs-source-dirs: + src + build-depends: + aeson >=1.4.7.1 + , base >=4.9 && <5 + , bytestring >=0.10.10.0 + , cereal >=0.5.8.1 + , containers >=0.6.2.1 + , deepseq >=1.4.4.0 + , hashable >=1.3.0.0 + , haskoin-core >=0.13.3 + , network >=3.1.1.1 + , scotty >=0.11.5 + , string-conversions >=0.4.0.1 + , text >=1.2.4.0 + default-language: Haskell2010 + +test-suite haskoin-store-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Haskoin.Store.DataSpec + Haskoin.Store.Data + Paths_haskoin_store_data + hs-source-dirs: + test + src + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.13.2 + , aeson >=1.4.7.1 + , base >=4.9 && <5 + , bytestring >=0.10.10.0 + , cereal >=0.5.8.1 + , containers >=0.6.2.1 + , deepseq >=1.4.4.0 + , hashable >=1.3.0.0 + , haskoin-core >=0.13.3 + , hspec >=2.7.1 + , network >=3.1.1.1 + , scotty >=0.11.5 + , string-conversions >=0.4.0.1 + , text >=1.2.4.0 + default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover diff --git a/src/Haskoin/Store/Data.hs b/src/Haskoin/Store/Data.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Data.hs @@ -0,0 +1,1189 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.Store.Data + ( -- * Address Balances + Balance(..) + , balanceToJSON + , balanceToEncoding + , balanceParseJSON + , zeroBalance + , nullBalance + + -- * Block Data + , BlockData(..) + , confirmed + + -- * Transactions + , BlockTx(..) + , TxData(..) + , Transaction(..) + , transactionToJSON + , transactionToEncoding + , transactionData + , fromTransaction + , toTransaction + , StoreInput(..) + , storeInputToJSON + , storeInputToEncoding + , isCoinbase + , StoreOutput(..) + , storeOutputToJSON + , storeOutputToEncoding + , Prev(..) + , Spender(..) + , BlockRef(..) + , UnixTime + , getUnixTime + , putUnixTime + , BlockPos + + -- * Unspent Outputs + , Unspent(..) + , unspentToJSON + , unspentToEncoding + + -- * Extended Public Keys + , XPubSpec(..) + , XPubBal(..) + , xPubBalToJSON + , xPubBalToEncoding + , xPubBalParseJSON + , XPubUnspent(..) + , xPubUnspentToJSON + , xPubUnspentToEncoding + , XPubSummary(..) + , DeriveType(..) + + -- * Other Data + , TxId(..) + , GenericResult(..) + , PeerInformation(..) + , HealthCheck(..) + , Event(..) + , Except(..) + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData) +import Control.Exception (Exception) +import Control.Monad (guard, join) +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 +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as BSS +import Data.Hashable (Hashable (..)) +import qualified Data.IntMap as I +import Data.IntMap.Strict (IntMap) +import Data.Maybe (catMaybes, isJust, mapMaybe) +import Data.Serialize (Get, Put, Serialize (..), getWord32be, + getWord64be, getWord8, putWord32be, + putWord64be, putWord8) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import Haskoin (Address, BlockHash, BlockHeader (..), + BlockHeight, BlockWork, KeyIndex, + Network (..), OutPoint (..), + PubKeyI (..), Tx (..), TxHash (..), + TxIn (..), TxOut (..), WitnessStack, + XPubKey (..), addrFromJSON, + addrToEncoding, addrToJSON, + blockHashToHex, decodeHex, encodeHex, + headerHash, scriptToAddressBS, txHash, + txHashToHex, wrapPubKey) +import Web.Scotty.Trans (ScottyError (..)) + +data DeriveType + = DeriveNormal + | DeriveP2SH + | DeriveP2WPKH + deriving (Show, Eq, Generic, NFData, Serialize) + +data XPubSpec = + XPubSpec + { xPubSpecKey :: !XPubKey + , xPubDeriveType :: !DeriveType + } deriving (Show, Eq, Generic, NFData) + +instance Hashable XPubSpec where + hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} = + hashWithSalt i pubkey + +instance Serialize XPubSpec where + put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do + put (xPubDepth k) + put (xPubParent k) + put (xPubIndex k) + put (xPubChain k) + put (wrapPubKey True (xPubKey k)) + put t + get = do + d <- get + p <- get + i <- get + c <- get + k <- get + t <- get + let x = + XPubKey + { xPubDepth = d + , xPubParent = p + , xPubIndex = i + , xPubChain = c + , xPubKey = pubKeyPoint k + } + return XPubSpec {xPubSpecKey = x, xPubDeriveType = t} + +type UnixTime = Word64 +type BlockPos = Word32 + +-- | Serialize such that ordering is inverted. +putUnixTime :: Word64 -> Put +putUnixTime w = putWord64be $ maxBound - w + +getUnixTime :: Get Word64 +getUnixTime = (maxBound -) <$> getWord64be + +-- | Reference to a block where a transaction is stored. +data BlockRef + = BlockRef + { blockRefHeight :: !BlockHeight + -- ^ block height in the chain + , blockRefPos :: !Word32 + -- ^ position of transaction within the block + } + | MemRef + { memRefTime :: !UnixTime + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +-- | Serialized entities will sort in reverse order. +instance Serialize BlockRef where + put MemRef {memRefTime = t} = do + putWord8 0x00 + putUnixTime t + put BlockRef {blockRefHeight = h, blockRefPos = p} = do + putWord8 0x01 + putWord32be (maxBound - h) + putWord32be (maxBound - p) + get = getmemref <|> getblockref + where + getmemref = do + guard . (== 0x00) =<< getWord8 + MemRef <$> getUnixTime + getblockref = do + guard . (== 0x01) =<< getWord8 + h <- (maxBound -) <$> getWord32be + p <- (maxBound -) <$> getWord32be + return BlockRef {blockRefHeight = h, blockRefPos = p} + +confirmed :: BlockRef -> Bool +confirmed BlockRef {} = True +confirmed MemRef {} = False + +instance ToJSON BlockRef where + 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 + where + b o = do + height <- o .: "height" + position <- o .: "position" + return BlockRef {blockRefHeight = height, blockRefPos = position} + m o = do + mempool <- o .: "mempool" + return MemRef {memRefTime = mempool} + +-- | Transaction in relation to an address. +data BlockTx = BlockTx + { blockTxBlock :: !BlockRef + -- ^ block information + , blockTxHash :: !TxHash + -- ^ transaction hash + } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData) + +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 = + A.withObject "blocktx" $ \o -> do + txid <- o .: "txid" + block <- o .: "block" + return BlockTx {blockTxBlock = block, blockTxHash = txid} + +-- | Address balance information. +data Balance = + Balance + { balanceAddress :: !Address + -- ^ address balance + , balanceAmount :: !Word64 + -- ^ confirmed balance + , balanceZero :: !Word64 + -- ^ unconfirmed balance + , balanceUnspentCount :: !Word64 + -- ^ number of unspent outputs + , balanceTxCount :: !Word64 + -- ^ number of transactions + , balanceTotalReceived :: !Word64 + -- ^ total amount from all outputs in this address + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +zeroBalance :: Address -> Balance +zeroBalance a = + Balance + { balanceAddress = a + , balanceAmount = 0 + , balanceUnspentCount = 0 + , balanceZero = 0 + , balanceTxCount = 0 + , balanceTotalReceived = 0 + } + +nullBalance :: Balance -> Bool +nullBalance Balance { balanceAmount = 0 + , balanceUnspentCount = 0 + , balanceZero = 0 + , balanceTxCount = 0 + , balanceTotalReceived = 0 + } = True +nullBalance _ = False + +balanceToJSON :: Network -> Balance -> Value +balanceToJSON net b = + object $ + [ "address" .= addrToJSON net (balanceAddress b) + , "confirmed" .= balanceAmount b + , "unconfirmed" .= balanceZero b + , "utxo" .= balanceUnspentCount b + , "txs" .= balanceTxCount b + , "received" .= balanceTotalReceived b + ] + +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 + } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +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 = 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 + block <- o .: "block" + txid <- o .: "txid" + index <- o .: "index" + value <- o .: "value" + script <- BSS.toShort <$> (o .: "pkscript" >>= jsonHex) + return + Unspent + { unspentBlock = block + , unspentPoint = OutPoint txid index + , unspentAmount = value + , unspentScript = script + } + +-- | Database value for a block entry. +data BlockData = BlockData + { blockDataHeight :: !BlockHeight + -- ^ height of the block in the chain + , blockDataMainChain :: !Bool + -- ^ is this block in the main chain? + , blockDataWork :: !BlockWork + -- ^ accumulated work in that block + , blockDataHeader :: !BlockHeader + -- ^ block header + , blockDataSize :: !Word32 + -- ^ size of the block including witnesses + , blockDataWeight :: !Word32 + -- ^ weight of this block (for segwit networks) + , blockDataTxs :: ![TxHash] + -- ^ block transactions + , blockDataOutputs :: !Word64 + -- ^ sum of all transaction outputs + , blockDataFees :: !Word64 + -- ^ sum of all transaction fees + , blockDataSubsidy :: !Word64 + -- ^ block subsidy + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +instance ToJSON BlockData where + toJSON bv = + object + [ "hash" .= headerHash (blockDataHeader bv) + , "height" .= blockDataHeight bv + , "mainchain" .= blockDataMainChain bv + , "previous" .= prevBlock (blockDataHeader bv) + , "time" .= blockTimestamp (blockDataHeader bv) + , "version" .= blockVersion (blockDataHeader bv) + , "bits" .= blockBits (blockDataHeader bv) + , "nonce" .= bhNonce (blockDataHeader bv) + , "size" .= blockDataSize bv + , "tx" .= blockDataTxs bv + , "merkle" .= TxHash (merkleRoot (blockDataHeader bv)) + , "subsidy" .= blockDataSubsidy bv + , "fees" .= blockDataFees bv + , "outputs" .= blockDataOutputs bv + , "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 = + A.withObject "blockdata" $ \o -> do + height <- o .: "height" + mainchain <- o .: "mainchain" + previous <- o .: "previous" + time <- o .: "time" + version <- o .: "version" + bits <- o .: "bits" + nonce <- o .: "nonce" + size <- o .: "size" + tx <- o .: "tx" + TxHash merkle <- o .: "merkle" + subsidy <- o .: "subsidy" + fees <- o .: "fees" + outputs <- o .: "outputs" + work <- o .: "work" + weight <- o .: "weight" + return + BlockData + { blockDataHeader = + BlockHeader + { prevBlock = previous + , blockTimestamp = time + , blockVersion = version + , blockBits = bits + , bhNonce = nonce + , merkleRoot = merkle + } + , blockDataMainChain = mainchain + , blockDataWork = work + , blockDataSize = size + , blockDataWeight = weight + , blockDataTxs = tx + , blockDataOutputs = outputs + , blockDataFees = fees + , blockDataHeight = height + , blockDataSubsidy = subsidy + } + +data StoreInput + = StoreCoinbase { inputPoint :: !OutPoint + , inputSequence :: !Word32 + , inputSigScript :: !ByteString + , inputWitness :: !(Maybe WitnessStack) + } + | StoreInput { inputPoint :: !OutPoint + , inputSequence :: !Word32 + , inputSigScript :: !ByteString + , inputPkScript :: !ByteString + , inputAmount :: !Word64 + , inputWitness :: !(Maybe WitnessStack) + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +isCoinbase :: StoreInput -> Bool +isCoinbase StoreCoinbase {} = True +isCoinbase StoreInput {} = False + +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 + } = + 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 + coinbase <- o .: "coinbase" + outpoint <- OutPoint <$> o .: "txid" <*> o .: "output" + sequ <- o .: "sequence" + witness <- + o .:? "witness" >>= \mmxs -> + case join mmxs of + Nothing -> return Nothing + Just xs -> Just <$> mapM jsonHex xs + sigscript <- o .: "sigscript" >>= jsonHex + if coinbase + then return + StoreCoinbase + { inputPoint = outpoint + , inputSequence = sequ + , inputSigScript = sigscript + , inputWitness = witness + } + else do + pkscript <- o .: "pkscript" >>= jsonHex + value <- o .: "value" + return + StoreInput + { inputPoint = outpoint + , inputSequence = sequ + , inputSigScript = sigscript + , inputPkScript = pkscript + , inputAmount = value + , inputWitness = witness + } + +jsonHex :: Text -> Parser ByteString +jsonHex s = + case decodeHex s of + Nothing -> fail "Could not decode hex" + Just b -> return b + +-- | Information about input spending output. +data Spender = Spender + { spenderHash :: !TxHash + -- ^ input transaction hash + , spenderIndex :: !Word32 + -- ^ input position in transaction + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +instance ToJSON Spender where + 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 = + A.withObject "spender" $ \o -> Spender <$> o .: "txid" <*> o .: "input" + +-- | Output information. +data StoreOutput = StoreOutput + { outputAmount :: !Word64 + , outputScript :: !ByteString + , outputSpender :: !(Maybe Spender) + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +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 + value <- o .: "value" + pkscript <- o .: "pkscript" >>= jsonHex + spender <- o .: "spender" + return + StoreOutput + { outputAmount = value + , outputScript = pkscript + , outputSpender = spender + } + +data Prev = Prev + { prevScript :: !ByteString + , prevAmount :: !Word64 + } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput +toInput i Nothing w = + StoreCoinbase + { inputPoint = prevOutput i + , inputSequence = txInSequence i + , inputSigScript = scriptInput i + , inputWitness = w + } +toInput i (Just p) w = + StoreInput + { inputPoint = prevOutput i + , inputSequence = txInSequence i + , inputSigScript = scriptInput i + , inputPkScript = prevScript p + , inputAmount = prevAmount p + , inputWitness = w + } + +toOutput :: TxOut -> Maybe Spender -> StoreOutput +toOutput o s = + StoreOutput + { outputAmount = outValue o + , outputScript = scriptOutput o + , outputSpender = s + } + +data TxData = TxData + { txDataBlock :: !BlockRef + , txData :: !Tx + , txDataPrevs :: !(IntMap Prev) + , txDataDeleted :: !Bool + , txDataRBF :: !Bool + , txDataTime :: !Word64 + } deriving (Show, Eq, Ord, Generic, Serialize, NFData) + +toTransaction :: TxData -> IntMap Spender -> Transaction +toTransaction t sm = + Transaction + { transactionBlock = txDataBlock t + , transactionVersion = txVersion (txData t) + , transactionLockTime = txLockTime (txData t) + , transactionInputs = ins + , transactionOutputs = outs + , transactionDeleted = txDataDeleted t + , transactionRBF = txDataRBF t + , transactionTime = txDataTime t + } + where + ws = + take (length (txIn (txData t))) $ + map Just (txWitness (txData t)) <> repeat Nothing + f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n) + ins = zipWith f [0 ..] (txIn (txData t)) + g n o = toOutput o (I.lookup n sm) + outs = zipWith g [0 ..] (txOut (txData t)) + +fromTransaction :: Transaction -> (TxData, IntMap Spender) +fromTransaction t = (d, sm) + where + d = + TxData + { txDataBlock = transactionBlock t + , txData = transactionData t + , txDataPrevs = ps + , txDataDeleted = transactionDeleted t + , txDataRBF = transactionRBF t + , txDataTime = transactionTime t + } + f _ StoreCoinbase {} = Nothing + f n StoreInput {inputPkScript = s, inputAmount = v} = + Just (n, Prev {prevScript = s, prevAmount = v}) + ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t) + g _ StoreOutput {outputSpender = Nothing} = Nothing + g n StoreOutput {outputSpender = Just s} = Just (n, s) + sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) + +-- | Detailed transaction information. +data Transaction = Transaction + { transactionBlock :: !BlockRef + -- ^ block information for this transaction + , transactionVersion :: !Word32 + -- ^ transaction version + , transactionLockTime :: !Word32 + -- ^ lock time + , transactionInputs :: ![StoreInput] + -- ^ transaction inputs + , transactionOutputs :: ![StoreOutput] + -- ^ transaction outputs + , transactionDeleted :: !Bool + -- ^ this transaction has been deleted and is no longer valid + , transactionRBF :: !Bool + -- ^ this transaction can be replaced in the mempool + , transactionTime :: !Word64 + -- ^ time the transaction was first seen or time of block + } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +transactionData :: Transaction -> Tx +transactionData t = + Tx + { txVersion = transactionVersion t + , txIn = map i (transactionInputs t) + , txOut = map o (transactionOutputs t) + , txWitness = mapMaybe inputWitness (transactionInputs t) + , txLockTime = transactionLockTime t + } + where + i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} = + TxIn {prevOutput = p, scriptInput = s, txInSequence = q} + i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} = + TxIn {prevOutput = p, scriptInput = s, txInSequence = q} + o StoreOutput {outputAmount = v, outputScript = s} = + TxOut {outValue = v, scriptOutput = s} + +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 + version <- o .: "version" + locktime <- o .: "locktime" + inputs <- o .: "inputs" + outputs <- o .: "outputs" + block <- o .: "block" + deleted <- o .: "deleted" + time <- o .: "time" + rbf <- o .:? "rbf" .!= False + return + Transaction + { transactionBlock = block + , transactionVersion = version + , transactionLockTime = locktime + , transactionInputs = inputs + , transactionOutputs = outputs + , transactionDeleted = deleted + , transactionTime = time + , transactionRBF = rbf + } + +-- | Information about a connected peer. +data PeerInformation + = PeerInformation { peerUserAgent :: !ByteString + -- ^ user agent string + , peerAddress :: !String + -- ^ network address + , peerVersion :: !Word32 + -- ^ version number + , peerServices :: !Word64 + -- ^ services field + , peerRelay :: !Bool + -- ^ will relay transactions + } + deriving (Show, Eq, Ord, Generic, NFData, Serialize) + +instance ToJSON PeerInformation where + toJSON p = object + [ "useragent" .= String (cs (peerUserAgent p)) + , "address" .= peerAddress p + , "version" .= peerVersion p + , "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 = + A.withObject "peerinformation" $ \o -> do + String useragent <- o .: "useragent" + address <- o .: "address" + version <- o .: "version" + services <- + o .: "services" >>= jsonHex >>= \b -> + case S.decode b of + Left e -> fail $ "Could not decode services: " <> e + Right s -> return s + relay <- o .: "relay" + return + PeerInformation + { peerUserAgent = cs useragent + , peerAddress = address + , peerVersion = version + , peerServices = services + , peerRelay = relay + } + +-- | Address balances for an extended public key. +data XPubBal = XPubBal + { xPubBalPath :: ![KeyIndex] + , xPubBal :: !Balance + } deriving (Show, Ord, Eq, Generic, Serialize, NFData) + +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) + +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 + , xPubSummaryZero :: !Word64 + , xPubSummaryReceived :: !Word64 + , xPubUnspentCount :: !Word64 + , xPubExternalIndex :: !Word32 + , xPubChangeIndex :: !Word32 + } + deriving (Eq, Show, Generic, Serialize, NFData) + +instance ToJSON XPubSummary where + toJSON XPubSummary { xPubSummaryConfirmed = c + , xPubSummaryZero = z + , xPubSummaryReceived = r + , xPubUnspentCount = u + , xPubExternalIndex = ext + , xPubChangeIndex = ch + } = + object + [ "balance" .= + object + [ "confirmed" .= c + , "unconfirmed" .= z + , "received" .= r + , "utxo" .= u + ] + , "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 = + A.withObject "xpubsummary" $ \o -> do + b <- o .: "balance" + i <- o .: "indices" + conf <- b .: "confirmed" + unconfirmed <- b .: "unconfirmed" + received <- b .: "received" + utxo <- b .: "utxo" + change <- i .: "change" + external <- i .: "external" + return + XPubSummary + { xPubSummaryConfirmed = conf + , xPubSummaryZero = unconfirmed + , xPubSummaryReceived = received + , xPubUnspentCount = utxo + , xPubExternalIndex = external + , xPubChangeIndex = change + } + +data HealthCheck = + HealthCheck + { healthHeaderBest :: !(Maybe BlockHash) + , healthHeaderHeight :: !(Maybe BlockHeight) + , healthBlockBest :: !(Maybe BlockHash) + , healthBlockHeight :: !(Maybe BlockHeight) + , healthPeers :: !(Maybe Int) + , healthNetwork :: !String + , healthOK :: !Bool + , healthSynced :: !Bool + , healthLastBlock :: !(Maybe Word64) + , healthLastTx :: !(Maybe Word64) + , healthVersion :: !String + } + deriving (Show, Eq, Generic, Serialize, NFData) + +instance ToJSON HealthCheck where + toJSON h = + object + [ "headers" .= + object + [ "hash" .= healthHeaderBest h + , "height" .= healthHeaderHeight h + ] + , "blocks" .= + object + ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h] + , "peers" .= healthPeers h + , "net" .= healthNetwork h + , "ok" .= healthOK h + , "synced" .= healthSynced h + , "version" .= healthVersion h + , "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" .= healthVersion h + <> "lastblock" .= healthLastBlock h + <> "lasttx" .= healthLastTx h + ) + +instance FromJSON HealthCheck where + parseJSON = + A.withObject "healthcheck" $ \o -> do + headers <- o .: "headers" + headers_hash <- headers .: "hash" + headers_height <- headers .: "height" + blocks <- o .: "blocks" + blocks_hash <- blocks .: "hash" + blocks_height <- blocks .: "height" + peers <- o .: "peers" + net <- o .: "net" + ok <- o .: "ok" + synced <- o .: "synced" + lastblock <- o .: "lastblock" + lasttx <- o .: "lasttx" + ver <- o .: "version" + return + HealthCheck + { healthHeaderBest = headers_hash + , healthHeaderHeight = headers_height + , healthBlockBest = blocks_hash + , healthBlockHeight = blocks_height + , healthPeers = peers + , healthNetwork = net + , healthOK = ok + , healthSynced = synced + , healthLastBlock = lastblock + , healthLastTx = lasttx + , healthVersion = ver + } + +data Event + = EventBlock BlockHash + | EventTx TxHash + deriving (Show, Eq, Generic, Serialize, NFData) + +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 = + A.withObject "event" $ \o -> do + t <- o .: "type" + case t of + "tx" -> do + i <- o .: "id" + return $ EventTx i + "block" -> do + i <- o .: "id" + return $ EventBlock i + _ -> fail $ "Could not recognize event type: " <> t + +newtype GenericResult a = GenericResult + { getResult :: a + } deriving (Show, Eq, Generic, Serialize, NFData) + +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 = + A.withObject "result" $ \o -> GenericResult <$> o .: "result" + +newtype TxId = + TxId TxHash + deriving (Show, Eq, Generic, Serialize, NFData) + +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" + +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 + +data Except + = ThingNotFound + | ServerError + | BadRequest + | UserError String + | StringError String + | BlockTooLarge + deriving (Eq, Ord, Serialize, Generic, NFData) + +instance Show Except where + show ThingNotFound = "not found" + show ServerError = "you made me kill a unicorn" + show BadRequest = "bad request" + show (UserError s) = s + show (StringError _) = "you killed the dragon with your bare hands" + show BlockTooLarge = "block too large" + +instance Exception Except + +instance ScottyError Except where + stringError = StringError + showError = TL.pack . show + +instance ToJSON Except where + toJSON e = object ["error" .= TL.pack (show e)] diff --git a/test/Haskoin/Store/DataSpec.hs b/test/Haskoin/Store/DataSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/DataSpec.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haskoin.Store.DataSpec + ( spec + ) where + +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 (Address (..), BlockHash (..), + BlockHeader (..), Hash160 (..), + Hash256 (..), Network (..), + OutPoint (..), RejectCode (..), + Tx (..), TxHash (..), TxIn (..), + TxOut (..), XPubKey (..), bch, + bchRegTest, bchTest, btc, btcRegTest, + btcTest, ripemd160, sha256) +import Haskoin.Store.Data (Balance (..), BlockData (..), + BlockRef (..), BlockTx (..), + DeriveType (..), Event (..), + HealthCheck (..), + PeerInformation (..), Prev (..), + Spender (..), StoreInput (..), + StoreOutput (..), Transaction (..), + TxData (..), TxId (..), Unspent (..), + XPubBal (..), XPubSpec (..), + XPubSummary (..), XPubUnspent (..), + balanceParseJSON, balanceToEncoding, + balanceToJSON, transactionToEncoding, + transactionToJSON, unspentToEncoding, + unspentToJSON, xPubUnspentToEncoding, + xPubUnspentToJSON) +import Test.Hspec (Expectation, Spec, describe, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (..), Gen, + arbitraryPrintableChar, + arbitraryUnicodeChar, elements, + forAll, listOf, listOf1, oneof) + +spec :: Spec +spec = do + describe "Binary serialization" $ do + prop "identity for derivation type" $ \x -> testSerial (x :: DeriveType) + prop "identity for xpub spec" $ \x -> testSerial (x :: XPubSpec) + prop "identity for block ref" $ \x -> testSerial (x :: BlockRef) + prop "identity for block tx" $ \x -> testSerial (x :: BlockTx) + prop "identity for balance" $ \x -> testSerial (x :: Balance) + prop "identity for unspent" $ \x -> testSerial (x :: Unspent) + prop "identity for block data" $ \x -> testSerial (x :: BlockData) + prop "identity for input" $ \x -> testSerial (x :: StoreInput) + prop "identity for spender" $ \x -> testSerial (x :: Spender) + prop "identity for output" $ \x -> testSerial (x :: StoreOutput) + prop "identity for previous output" $ \x -> testSerial (x :: Prev) + prop "identity for tx data" $ \x -> testSerial (x :: TxData) + prop "identity for transaction" $ \x -> testSerial (x :: Transaction) + prop "identity for xpub balance" $ \x -> testSerial (x :: XPubBal) + prop "identity for xpub unspent" $ \x -> testSerial (x :: XPubUnspent) + prop "identity for xpub summary" $ \x -> testSerial (x :: XPubSummary) + prop "identity for health check" $ \x -> testSerial (x :: HealthCheck) + prop "identity for event" $ \x -> testSerial (x :: Event) + prop "identity for txid" $ \x -> testSerial (x :: TxId) + prop "identity for peer info" $ \x -> testSerial (x :: PeerInformation) + describe "JSON serialization" $ do + prop "identity for balance" . forAll arbitraryNetData $ \(net, x) -> + 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" . 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) -> + 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) + +testJSON :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Expectation +testJSON input = (A.decode . A.encode) input `shouldBe` Just input + +testNetJSON :: + (Eq a, Show a) + => (Value -> Parser a) + -> (a -> Value) + -> (a -> Encoding) + -> a + -> Expectation +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 + +arbitraryNetwork :: Gen Network +arbitraryNetwork = elements [bch, btc, bchTest, btcTest, bchRegTest, btcRegTest] + +arbitraryNetData :: Arbitrary a => Gen (Network, a) +arbitraryNetData = do + net <- arbitraryNetwork + x <- arbitrary + return (net, x) + +instance Arbitrary BlockRef where + arbitrary = + oneof [BlockRef <$> arbitrary <*> arbitrary, MemRef <$> arbitrary] + +instance Arbitrary Hash256 where + arbitrary = sha256 . pack <$> listOf1 arbitrary + +instance Arbitrary TxHash where + arbitrary = TxHash <$> arbitrary + +instance Arbitrary OutPoint where + arbitrary = OutPoint <$> arbitrary <*> arbitrary + +instance Arbitrary TxIn where + arbitrary = + TxIn <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*> + arbitrary + +instance Arbitrary TxOut where + arbitrary = TxOut <$> arbitrary <*> (pack <$> listOf1 arbitrary) + +instance Arbitrary Tx where + arbitrary = do + ver <- arbitrary + txin <- listOf1 arbitrary + txout <- listOf1 arbitrary + txlock <- arbitrary + return + Tx + { txVersion = ver + , txIn = txin + , txOut = txout + , txWitness = [] + , txLockTime = txlock + } + +instance Arbitrary Prev where + arbitrary = Prev <$> (pack <$> listOf1 arbitrary) <*> arbitrary + +instance Arbitrary TxData where + arbitrary = + TxData + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary StoreInput where + 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 <$> arbitrary <*> arbitrary + +instance Arbitrary StoreOutput where + arbitrary = + StoreOutput <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*> arbitrary + +instance Arbitrary Transaction where + arbitrary = + Transaction + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary PeerInformation where + arbitrary = do + PeerInformation + <$> (cs <$> listOf arbitraryUnicodeChar) + <*> listOf arbitraryPrintableChar + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary BlockHash where + arbitrary = BlockHash <$> arbitrary + +instance Arbitrary HealthCheck where + arbitrary = do + bh <- arbitrary + hh <- arbitrary + let mb = elements [Nothing, Just bh] + mh = elements [Nothing, Just hh] + HealthCheck + <$> mb + <*> arbitrary + <*> mh + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary RejectCode where + arbitrary = + elements + [ RejectMalformed + , RejectInvalid + , RejectObsolete + , RejectDuplicate + , RejectNonStandard + , RejectDust + , RejectInsufficientFee + , RejectCheckpoint + ] + +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 <$> 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/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}