diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,15 @@ 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.64.8 +### Changed +- Use better Fourmolu format. +- Be more precise when counting retrieved items. + +### Fixed +- Avoid transactions duplicated in xpub data. +- Refactor some functions to make them more robust. + ## 0.64.7 ### Fixed - Optimisations for various Blockchain endpoints. diff --git a/haskoin-store-data.cabal b/haskoin-store-data.cabal --- a/haskoin-store-data.cabal +++ b/haskoin-store-data.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 76f274c78531ac5c9255daff075b1c2876704184a4879a99b06fff516cc97e1d +-- hash: 41ca12699b2d3f410e0363cfe334c04ecd3be2fda24904c674eb10868c770185 name: haskoin-store-data -version: 0.64.7 +version: 0.64.8 synopsis: Data for Haskoin Store description: Please see the README on GitHub at category: Bitcoin, Finance, Network diff --git a/src/Haskoin/Store/Data.hs b/src/Haskoin/Store/Data.hs --- a/src/Haskoin/Store/Data.hs +++ b/src/Haskoin/Store/Data.hs @@ -7,3594 +7,3595 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Haskoin.Store.Data ( - -- * Address Balances - Balance (..), - balanceToJSON, - balanceToEncoding, - balanceParseJSON, - zeroBalance, - nullBalance, - - -- * Block Data - BlockData (..), - blockDataToJSON, - blockDataToEncoding, - confirmed, - - -- * Transactions - TxRef (..), - TxData (..), - Transaction (..), - transactionToJSON, - transactionToEncoding, - transactionParseJSON, - transactionData, - fromTransaction, - toTransaction, - StoreInput (..), - storeInputToJSON, - storeInputToEncoding, - storeInputParseJSON, - isCoinbase, - StoreOutput (..), - storeOutputToJSON, - storeOutputToEncoding, - storeOutputParseJSON, - Prev (..), - Spender (..), - BlockRef (..), - UnixTime, - getUnixTime, - putUnixTime, - BlockPos, - - -- * Unspent Outputs - Unspent (..), - unspentToJSON, - unspentToEncoding, - unspentParseJSON, - - -- * Extended Public Keys - XPubSpec (..), - XPubBal (..), - xPubBalToJSON, - xPubBalToEncoding, - xPubBalParseJSON, - XPubUnspent (..), - xPubUnspentToJSON, - xPubUnspentToEncoding, - xPubUnspentParseJSON, - XPubSummary (..), - DeriveType (..), - textToDeriveType, - deriveTypeToText, - - -- * Other Data - TxId (..), - GenericResult (..), - SerialList (..), - RawResult (..), - RawResultList (..), - PeerInformation (..), - Healthy (..), - BlockHealth (..), - TimeHealth (..), - CountHealth (..), - MaxHealth (..), - HealthCheck (..), - Event (..), - Except (..), - - -- * Blockchain.info API - BinfoBlockId (..), - BinfoTxId (..), - encodeBinfoTxId, - BinfoFilter (..), - BinfoMultiAddr (..), - binfoMultiAddrToJSON, - binfoMultiAddrToEncoding, - binfoMultiAddrParseJSON, - BinfoShortBal (..), - BinfoBalance (..), - toBinfoAddrs, - binfoBalanceToJSON, - binfoBalanceToEncoding, - binfoBalanceParseJSON, - BinfoRawAddr (..), - binfoRawAddrToJSON, - binfoRawAddrToEncoding, - binfoRawAddrParseJSON, - BinfoAddr (..), - parseBinfoAddr, - BinfoWallet (..), - BinfoUnspent (..), - binfoUnspentToJSON, - binfoUnspentToEncoding, - binfoUnspentParseJSON, - binfoHexValue, - BinfoUnspents (..), - binfoUnspentsToJSON, - binfoUnspentsToEncoding, - binfoUnspentsParseJSON, - BinfoBlock (..), - toBinfoBlock, - binfoBlockToJSON, - binfoBlockToEncoding, - binfoBlockParseJSON, - binfoBlocksToJSON, - binfoBlocksToEncoding, - binfoBlocksParseJSON, - BinfoTx (..), - relevantTxs, - toBinfoTx, - toBinfoTxSimple, - binfoTxToJSON, - binfoTxToEncoding, - binfoTxParseJSON, - BinfoTxInput (..), - binfoTxInputToJSON, - binfoTxInputToEncoding, - binfoTxInputParseJSON, - BinfoTxOutput (..), - binfoTxOutputToJSON, - binfoTxOutputToEncoding, - binfoTxOutputParseJSON, - BinfoSpender (..), - BinfoXPubPath (..), - binfoXPubPathToJSON, - binfoXPubPathToEncoding, - binfoXPubPathParseJSON, - BinfoInfo (..), - BinfoBlockInfo (..), - toBinfoBlockInfo, - BinfoSymbol (..), - BinfoTicker (..), - BinfoRate (..), - BinfoHistory (..), - toBinfoHistory, - BinfoDate (..), - BinfoHeader (..), - BinfoMempool (..), - binfoMempoolToJSON, - binfoMempoolToEncoding, - binfoMempoolParseJSON, - BinfoBlocks (..), -) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) -import Control.Exception (Exception) -import Control.Monad (join, mzero, unless, (<=<)) -import Data.Aeson ( - Encoding, - FromJSON (..), - ToJSON (..), - Value (..), - (.!=), - (.:), - (.:?), - (.=), - ) -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as AE -import Data.Aeson.Types (Parser) -import Data.Binary (Binary (get, put)) -import Data.Bits (Bits (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BSB -import Data.Bytes.Get -import qualified Data.Bytes.Get as Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Default (Default (..)) -import Data.Foldable (toList) -import Data.Function (on) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.Hashable (Hashable (..)) -import Data.Int (Int32, Int64) -import qualified Data.IntMap as IntMap -import Data.IntMap.Strict (IntMap) -import Data.Maybe ( - catMaybes, - fromMaybe, - isJust, - isNothing, - mapMaybe, - maybeToList, - ) -import Data.Serialize (Serialize (..)) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import Data.Time.Clock.POSIX ( - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.Format ( - defaultTimeLocale, - formatTime, - parseTimeM, - ) -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) -import Haskoin hiding (inputAddress) -import Web.Scotty.Trans (Parsable (..), ScottyError (..)) - -data DeriveType - = DeriveNormal - | DeriveP2SH - | DeriveP2WPKH - deriving (Show, Eq, Generic, NFData) - -textToDeriveType :: Text -> Maybe DeriveType -textToDeriveType "normal" = Just DeriveNormal -textToDeriveType "compat" = Just DeriveP2SH -textToDeriveType "segwit" = Just DeriveP2WPKH -textToDeriveType _ = Nothing - -deriveTypeToText :: DeriveType -> Text -deriveTypeToText DeriveNormal = "normal" -deriveTypeToText DeriveP2SH = "compat" -deriveTypeToText DeriveP2WPKH = "segwit" - -instance Serial DeriveType where - serialize DeriveNormal = putWord8 0x00 - serialize DeriveP2SH = putWord8 0x01 - serialize DeriveP2WPKH = putWord8 0x02 - - deserialize = - getWord8 >>= \case - 0x00 -> return DeriveNormal - 0x01 -> return DeriveP2SH - 0x02 -> return DeriveP2WPKH - _ -> return DeriveNormal - -instance Binary DeriveType where - put = serialize - get = deserialize - -instance Serialize DeriveType where - put = serialize - get = deserialize - -instance Default DeriveType where - def = DeriveNormal - -instance Parsable DeriveType where - parseParam txt = - case textToDeriveType (TL.toStrict txt) of - Nothing -> Left "invalid derivation type" - Just x -> Right x - -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 Serial XPubSpec where - serialize XPubSpec{xPubSpecKey = k, xPubDeriveType = t} = do - putWord8 (xPubDepth k) - serialize (xPubParent k) - putWord32be (xPubIndex k) - serialize (xPubChain k) - serialize (wrapPubKey True (xPubKey k)) - serialize t - deserialize = do - d <- getWord8 - p <- deserialize - i <- getWord32be - c <- deserialize - k <- deserialize - t <- deserialize - let x = - XPubKey - { xPubDepth = d - , xPubParent = p - , xPubIndex = i - , xPubChain = c - , xPubKey = pubKeyPoint k - } - return XPubSpec{xPubSpecKey = x, xPubDeriveType = t} - -instance Serialize XPubSpec where - put = serialize - get = deserialize - -instance Binary XPubSpec where - put = serialize - get = deserialize - -type UnixTime = Word64 -type BlockPos = Word32 - --- | Binary such that ordering is inverted. -putUnixTime :: MonadPut m => Word64 -> m () -putUnixTime w = putWord64be $ maxBound - w - -getUnixTime :: MonadGet m => m Word64 -getUnixTime = (maxBound -) <$> getWord64be - --- | Reference to a block where a transaction is stored. -data BlockRef - = BlockRef - { -- | block height in the chain - blockRefHeight :: !BlockHeight - , -- | position of transaction within the block - blockRefPos :: !Word32 - } - | MemRef - { memRefTime :: !UnixTime - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - --- | Serial entities will sort in reverse order. -instance Serial BlockRef where - serialize MemRef{memRefTime = t} = do - putWord8 0x00 - putUnixTime t - serialize BlockRef{blockRefHeight = h, blockRefPos = p} = do - putWord8 0x01 - putWord32be (maxBound - h) - putWord32be (maxBound - p) - deserialize = - getWord8 >>= \case - 0x00 -> getmemref - 0x01 -> getblockref - _ -> fail "Cannot decode BlockRef" - where - getmemref = do - MemRef <$> getUnixTime - getblockref = do - h <- (maxBound -) <$> getWord32be - p <- (maxBound -) <$> getWord32be - return BlockRef{blockRefHeight = h, blockRefPos = p} - -instance Serialize BlockRef where - put = serialize - get = deserialize - -instance Binary BlockRef where - put = serialize - get = deserialize - -confirmed :: BlockRef -> Bool -confirmed BlockRef{} = True -confirmed MemRef{} = False - -instance ToJSON BlockRef where - toJSON BlockRef{blockRefHeight = h, blockRefPos = p} = - A.object ["height" .= h, "position" .= p] - toJSON MemRef{memRefTime = t} = A.object ["mempool" .= t] - toEncoding BlockRef{blockRefHeight = h, blockRefPos = p} = - AE.pairs ("height" .= h <> "position" .= p) - toEncoding MemRef{memRefTime = t} = AE.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 TxRef = TxRef - { -- | block information - txRefBlock :: !BlockRef - , -- | transaction hash - txRefHash :: !TxHash - } - deriving (Show, Eq, Ord, Generic, Hashable, NFData) - -instance Serial TxRef where - serialize (TxRef b h) = do - serialize b - serialize h - - deserialize = - TxRef <$> deserialize <*> deserialize - -instance Binary TxRef where - put = serialize - get = deserialize - -instance Serialize TxRef where - put = serialize - get = deserialize - -instance ToJSON TxRef where - toJSON btx = - A.object - [ "txid" .= txRefHash btx - , "block" .= txRefBlock btx - ] - toEncoding btx = - AE.pairs $ - "txid" .= txRefHash btx - <> "block" .= txRefBlock btx - -instance FromJSON TxRef where - parseJSON = - A.withObject "blocktx" $ \o -> do - txid <- o .: "txid" - block <- o .: "block" - return TxRef{txRefBlock = block, txRefHash = txid} - --- | Address balance information. -data Balance = Balance - { -- | address balance - balanceAddress :: !Address - , -- | confirmed balance - balanceAmount :: !Word64 - , -- | unconfirmed balance - balanceZero :: !Word64 - , -- | number of unspent outputs - balanceUnspentCount :: !Word64 - , -- | number of transactions - balanceTxCount :: !Word64 - , -- | total amount from all outputs in this address - balanceTotalReceived :: !Word64 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Balance where - serialize Balance{..} = do - serialize balanceAddress - putWord64be balanceAmount - putWord64be balanceZero - putWord64be balanceUnspentCount - putWord64be balanceTxCount - putWord64be balanceTotalReceived - - deserialize = do - balanceAddress <- deserialize - balanceAmount <- getWord64be - balanceZero <- getWord64be - balanceUnspentCount <- getWord64be - balanceTxCount <- getWord64be - balanceTotalReceived <- getWord64be - return Balance{..} - -instance Binary Balance where - put = serialize - get = deserialize - -instance Serialize Balance where - put = serialize - get = deserialize - -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 = - A.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 = - AE.pairs $ - "address" `AE.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 :: !ByteString - , unspentAddress :: !(Maybe Address) - } - deriving (Show, Eq, Generic, Hashable, NFData) - -{- | Follow same order as in database and cache by inverting outpoint sort - order. --} -instance Ord Unspent where - compare a b = - compare - (unspentBlock a, unspentPoint b) - (unspentBlock b, unspentPoint a) - -instance Serial Unspent where - serialize Unspent{..} = do - serialize unspentBlock - serialize unspentPoint - putWord64be unspentAmount - putLengthBytes unspentScript - putMaybe serialize unspentAddress - - deserialize = do - unspentBlock <- deserialize - unspentPoint <- deserialize - unspentAmount <- getWord64be - unspentScript <- getLengthBytes - unspentAddress <- getMaybe deserialize - return Unspent{..} - -instance Binary Unspent where - put = serialize - get = deserialize - -instance Serialize Unspent where - put = serialize - get = deserialize - -instance Coin Unspent where - coinValue = unspentAmount - -unspentToJSON :: Network -> Unspent -> Value -unspentToJSON net u = - A.object - [ "address" .= (addrToJSON net <$> unspentAddress u) - , "block" .= unspentBlock u - , "txid" .= outPointHash (unspentPoint u) - , "index" .= outPointIndex (unspentPoint u) - , "pkscript" .= encodeHex (unspentScript u) - , "value" .= unspentAmount u - ] - -unspentToEncoding :: Network -> Unspent -> Encoding -unspentToEncoding net u = - AE.pairs $ - "address" `AE.pair` maybe AE.null_ (addrToEncoding net) (unspentAddress u) - <> "block" .= unspentBlock u - <> "txid" .= outPointHash (unspentPoint u) - <> "index" .= outPointIndex (unspentPoint u) - <> "pkscript" `AE.pair` AE.text (encodeHex (unspentScript u)) - <> "value" .= unspentAmount u - -unspentParseJSON :: Network -> Value -> Parser Unspent -unspentParseJSON net = - A.withObject "unspent" $ \o -> do - block <- o .: "block" - txid <- o .: "txid" - index <- o .: "index" - value <- o .: "value" - script <- o .: "pkscript" >>= jsonHex - addr <- - o .: "address" >>= \case - Nothing -> return Nothing - Just a -> Just <$> addrFromJSON net a <|> return Nothing - return - Unspent - { unspentBlock = block - , unspentPoint = OutPoint txid index - , unspentAmount = value - , unspentScript = script - , unspentAddress = addr - } - --- | Database value for a block entry. -data BlockData = BlockData - { -- | height of the block in the chain - blockDataHeight :: !BlockHeight - , -- | is this block in the main chain? - blockDataMainChain :: !Bool - , -- | accumulated work in that block - blockDataWork :: !Integer - , -- | block header - blockDataHeader :: !BlockHeader - , -- | size of the block including witnesses - blockDataSize :: !Word32 - , -- | weight of this block (for segwit networks) - blockDataWeight :: !Word32 - , -- | block transactions - blockDataTxs :: ![TxHash] - , -- | sum of all transaction outputs - blockDataOutputs :: !Word64 - , -- | sum of all transaction fees - blockDataFees :: !Word64 - , -- | block subsidy - blockDataSubsidy :: !Word64 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial BlockData where - serialize BlockData{..} = do - putWord32be blockDataHeight - serialize blockDataMainChain - putInteger blockDataWork - serialize blockDataHeader - putWord32be blockDataSize - putWord32be blockDataWeight - putList serialize blockDataTxs - putWord64be blockDataOutputs - putWord64be blockDataFees - putWord64be blockDataSubsidy - - deserialize = do - blockDataHeight <- getWord32be - blockDataMainChain <- deserialize - blockDataWork <- getInteger - blockDataHeader <- deserialize - blockDataSize <- getWord32be - blockDataWeight <- getWord32be - blockDataTxs <- getList deserialize - blockDataOutputs <- getWord64be - blockDataFees <- getWord64be - blockDataSubsidy <- getWord64be - return BlockData{..} - -instance Serialize BlockData where - put = serialize - get = deserialize - -instance Binary BlockData where - put = serialize - get = deserialize - -blockDataToJSON :: Network -> BlockData -> Value -blockDataToJSON net bv = - A.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" .= blockDataWork bv - ] - <> ["weight" .= blockDataWeight bv | getSegWit net] - -blockDataToEncoding :: Network -> BlockData -> Encoding -blockDataToEncoding net bv = - AE.pairs $ - "hash" - `AE.pair` AE.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" - `AE.pair` AE.text - (txHashToHex (TxHash (merkleRoot (blockDataHeader bv)))) - <> "subsidy" .= blockDataSubsidy bv - <> "fees" .= blockDataFees bv - <> "outputs" .= blockDataOutputs bv - <> "work" .= blockDataWork bv - <> (if getSegWit net then "weight" .= blockDataWeight bv else mempty) - -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" .!= 0 - 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 :: !WitnessStack - } - | StoreInput - { inputPoint :: !OutPoint - , inputSequence :: !Word32 - , inputSigScript :: !ByteString - , inputPkScript :: !ByteString - , inputAmount :: !Word64 - , inputWitness :: !WitnessStack - , inputAddress :: !(Maybe Address) - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial StoreInput where - serialize StoreCoinbase{..} = do - putWord8 0x00 - serialize inputPoint - putWord32be inputSequence - putLengthBytes inputSigScript - putList putLengthBytes inputWitness - serialize StoreInput{..} = do - putWord8 0x01 - serialize inputPoint - putWord32be inputSequence - putLengthBytes inputSigScript - putLengthBytes inputPkScript - putWord64be inputAmount - putList putLengthBytes inputWitness - putMaybe serialize inputAddress - - deserialize = - getWord8 >>= \case - 0x00 -> do - inputPoint <- deserialize - inputSequence <- getWord32be - inputSigScript <- getLengthBytes - inputWitness <- getList getLengthBytes - return StoreCoinbase{..} - 0x01 -> do - inputPoint <- deserialize - inputSequence <- getWord32be - inputSigScript <- getLengthBytes - inputPkScript <- getLengthBytes - inputAmount <- getWord64be - inputWitness <- getList getLengthBytes - inputAddress <- getMaybe deserialize - return StoreInput{..} - x -> fail $ "Unknown input id: " <> cs (show x) - -instance Serialize StoreInput where - put = serialize - get = deserialize - -instance Binary StoreInput where - put = serialize - get = deserialize - -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 - , inputAddress = a - } = - A.object - [ "coinbase" .= False - , "txid" .= oph - , "output" .= opi - , "sigscript" .= String (encodeHex ss) - , "sequence" .= sq - , "pkscript" .= String (encodeHex ps) - , "value" .= val - , "address" .= (addrToJSON net <$> a) - , "witness" .= map encodeHex wit - ] -storeInputToJSON - _ - StoreCoinbase - { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputWitness = wit - } = - A.object - [ "coinbase" .= True - , "txid" .= oph - , "output" .= opi - , "sigscript" .= String (encodeHex ss) - , "sequence" .= sq - , "pkscript" .= Null - , "value" .= Null - , "address" .= Null - , "witness" .= map encodeHex wit - ] - -storeInputToEncoding :: Network -> StoreInput -> Encoding -storeInputToEncoding - net - StoreInput - { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputPkScript = ps - , inputAmount = val - , inputWitness = wit - , inputAddress = a - } = - AE.pairs $ - "coinbase" .= False - <> "txid" .= oph - <> "output" .= opi - <> "sigscript" `AE.pair` AE.text (encodeHex ss) - <> "sequence" .= sq - <> "pkscript" `AE.pair` AE.text (encodeHex ps) - <> "value" .= val - <> "address" `AE.pair` maybe AE.null_ (addrToEncoding net) a - <> "witness" .= map encodeHex wit -storeInputToEncoding - _ - StoreCoinbase - { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputWitness = wit - } = - AE.pairs $ - "coinbase" .= True - <> "txid" `AE.pair` AE.text (txHashToHex oph) - <> "output" .= opi - <> "sigscript" `AE.pair` AE.text (encodeHex ss) - <> "sequence" .= sq - <> "pkscript" `AE.pair` AE.null_ - <> "value" `AE.pair` AE.null_ - <> "address" `AE.pair` AE.null_ - <> "witness" .= map encodeHex wit - -storeInputParseJSON :: Network -> Value -> Parser StoreInput -storeInputParseJSON net = - A.withObject "storeinput" $ \o -> do - coinbase <- o .: "coinbase" - outpoint <- OutPoint <$> o .: "txid" <*> o .: "output" - sequ <- o .: "sequence" - witness <- mapM jsonHex =<< o .:? "witness" .!= [] - 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" - addr <- - o .: "address" >>= \case - Nothing -> return Nothing - Just a -> Just <$> addrFromJSON net a <|> return Nothing - return - StoreInput - { inputPoint = outpoint - , inputSequence = sequ - , inputSigScript = sigscript - , inputPkScript = pkscript - , inputAmount = value - , inputWitness = witness - , inputAddress = addr - } - -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 - { -- | input transaction hash - spenderHash :: !TxHash - , -- | input position in transaction - spenderIndex :: !Word32 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Spender where - serialize Spender{..} = do - serialize spenderHash - putWord32be spenderIndex - deserialize = Spender <$> deserialize <*> getWord32be - -instance Serialize Spender where - put = serialize - get = deserialize - -instance Binary Spender where - put = serialize - get = deserialize - -instance ToJSON Spender where - toJSON n = - A.object - [ "txid" .= txHashToHex (spenderHash n) - , "input" .= spenderIndex n - ] - toEncoding n = - AE.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) - , outputAddr :: !(Maybe Address) - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance Serial StoreOutput where - serialize StoreOutput{..} = do - putWord64be outputAmount - putLengthBytes outputScript - putMaybe serialize outputSpender - putMaybe serialize outputAddr - deserialize = do - outputAmount <- getWord64be - outputScript <- getLengthBytes - outputSpender <- getMaybe deserialize - outputAddr <- getMaybe deserialize - return StoreOutput{..} - -instance Serialize StoreOutput where - put = serialize - get = deserialize - -instance Binary StoreOutput where - put = serialize - get = deserialize - -storeOutputToJSON :: Network -> StoreOutput -> Value -storeOutputToJSON net d = - A.object - [ "address" .= (addrToJSON net <$> outputAddr d) - , "pkscript" .= encodeHex (outputScript d) - , "value" .= outputAmount d - , "spent" .= isJust (outputSpender d) - , "spender" .= outputSpender d - ] - -storeOutputToEncoding :: Network -> StoreOutput -> Encoding -storeOutputToEncoding net d = - AE.pairs $ - "address" `AE.pair` maybe AE.null_ (addrToEncoding net) (outputAddr d) - <> "pkscript" `AE.pair` AE.text (encodeHex (outputScript d)) - <> "value" .= outputAmount d - <> "spent" .= isJust (outputSpender d) - <> "spender" .= outputSpender d - -storeOutputParseJSON :: Network -> Value -> Parser StoreOutput -storeOutputParseJSON net = - A.withObject "storeoutput" $ \o -> do - value <- o .: "value" - pkscript <- o .: "pkscript" >>= jsonHex - spender <- o .: "spender" - addr <- - o .: "address" >>= \case - Nothing -> return Nothing - Just a -> Just <$> addrFromJSON net a <|> return Nothing - return - StoreOutput - { outputAmount = value - , outputScript = pkscript - , outputSpender = spender - , outputAddr = addr - } - -data Prev = Prev - { prevScript :: !ByteString - , prevAmount :: !Word64 - } - deriving (Show, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Prev where - serialize Prev{..} = do - putLengthBytes prevScript - putWord64be prevAmount - deserialize = do - prevScript <- getLengthBytes - prevAmount <- getWord64be - return Prev{..} - -instance Binary Prev where - put = serialize - get = deserialize - -instance Serialize Prev where - put = serialize - get = deserialize - -toInput :: TxIn -> Maybe Prev -> 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 - , inputAddress = eitherToMaybe (scriptToAddressBS (prevScript p)) - } - -toOutput :: TxOut -> Maybe Spender -> StoreOutput -toOutput o s = - StoreOutput - { outputAmount = outValue o - , outputScript = scriptOutput o - , outputSpender = s - , outputAddr = eitherToMaybe (scriptToAddressBS (scriptOutput o)) - } - -data TxData = TxData - { txDataBlock :: !BlockRef - , txData :: !Tx - , txDataPrevs :: !(IntMap Prev) - , txDataDeleted :: !Bool - , txDataRBF :: !Bool - , txDataTime :: !Word64 - } - deriving (Show, Eq, Ord, Generic, NFData) - -instance Serial TxData where - serialize TxData{..} = do - serialize txDataBlock - serialize txData - putIntMap (putWord64be . fromIntegral) serialize txDataPrevs - serialize txDataDeleted - serialize txDataRBF - putWord64be txDataTime - deserialize = do - txDataBlock <- deserialize - txData <- deserialize - txDataPrevs <- getIntMap (fromIntegral <$> getWord64be) deserialize - txDataDeleted <- deserialize - txDataRBF <- deserialize - txDataTime <- getWord64be - return TxData{..} - -instance Serialize TxData where - put = serialize - get = deserialize - -instance Binary TxData where - put = serialize - get = deserialize - -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 - , transactionId = txid - , transactionSize = txsize - , transactionWeight = txweight - , transactionFees = fees - } - where - txid = txHash (txData t) - txsize = fromIntegral $ BS.length (runPutS (serialize (txData t))) - txweight = - let b = BS.length $ runPutS $ serialize (txData t){txWitness = []} - x = BS.length $ runPutS $ serialize (txData t) - in fromIntegral $ b * 3 + x - inv = sum (map inputAmount ins) - outv = sum (map outputAmount outs) - fees = if any isCoinbase ins then 0 else inv - outv - ws = take (length (txIn (txData t))) $ txWitness (txData t) <> repeat [] - f n i = toInput i (IntMap.lookup n (txDataPrevs t)) (ws !! n) - ins = zipWith f [0 ..] (txIn (txData t)) - g n o = toOutput o (IntMap.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 = IntMap.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t) - g _ StoreOutput{outputSpender = Nothing} = Nothing - g n StoreOutput{outputSpender = Just s} = Just (n, s) - sm = IntMap.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) - --- | Detailed transaction information. -data Transaction = Transaction - { -- | block information for this transaction - transactionBlock :: !BlockRef - , -- | transaction version - transactionVersion :: !Word32 - , -- | lock time - transactionLockTime :: !Word32 - , -- | transaction inputs - transactionInputs :: ![StoreInput] - , -- | transaction outputs - transactionOutputs :: ![StoreOutput] - , -- | this transaction has been deleted and is no longer valid - transactionDeleted :: !Bool - , -- | this transaction can be replaced in the mempool - transactionRBF :: !Bool - , -- | time the transaction was first seen or time of block - transactionTime :: !Word64 - , -- | transaction id - transactionId :: !TxHash - , -- | serialized transaction size (includes witness data) - transactionSize :: !Word32 - , -- | transaction weight - transactionWeight :: !Word32 - , -- | fees that this transaction pays (0 for coinbase) - transactionFees :: !Word64 - } - deriving (Show, Eq, Ord, Generic, Hashable, NFData) - -instance Serial Transaction where - serialize Transaction{..} = do - serialize transactionBlock - putWord32be transactionVersion - putWord32be transactionLockTime - putList serialize transactionInputs - putList serialize transactionOutputs - serialize transactionDeleted - serialize transactionRBF - putWord64be transactionTime - serialize transactionId - putWord32be transactionSize - putWord32be transactionWeight - putWord64be transactionFees - deserialize = do - transactionBlock <- deserialize - transactionVersion <- getWord32be - transactionLockTime <- getWord32be - transactionInputs <- getList deserialize - transactionOutputs <- getList deserialize - transactionDeleted <- deserialize - transactionRBF <- deserialize - transactionTime <- getWord64be - transactionId <- deserialize - transactionSize <- getWord32be - transactionWeight <- getWord32be - transactionFees <- getWord64be - return Transaction{..} - -instance Serialize Transaction where - put = serialize - get = deserialize - -instance Binary Transaction where - put = serialize - get = deserialize - -transactionData :: Transaction -> Tx -transactionData t = - Tx - { txVersion = transactionVersion t - , txIn = map i (transactionInputs t) - , txOut = map o (transactionOutputs t) - , txWitness = w $ map 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} - w xs - | all null xs = [] - | otherwise = xs - -transactionToJSON :: Network -> Transaction -> Value -transactionToJSON net dtx = - A.object - [ "txid" .= transactionId dtx - , "size" .= transactionSize dtx - , "version" .= transactionVersion dtx - , "locktime" .= transactionLockTime dtx - , "fee" .= transactionFees dtx - , "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" .= transactionWeight dtx - ] - -transactionToEncoding :: Network -> Transaction -> Encoding -transactionToEncoding net dtx = - AE.pairs $ - "txid" .= transactionId dtx - <> "size" .= transactionSize dtx - <> "version" .= transactionVersion dtx - <> "locktime" .= transactionLockTime dtx - <> "fee" .= transactionFees dtx - <> "inputs" - `AE.pair` AE.list - (storeInputToEncoding net) - (transactionInputs dtx) - <> "outputs" - `AE.pair` AE.list - (storeOutputToEncoding net) - (transactionOutputs dtx) - <> "block" .= transactionBlock dtx - <> "deleted" .= transactionDeleted dtx - <> "time" .= transactionTime dtx - <> "rbf" .= transactionRBF dtx - <> "weight" .= transactionWeight dtx - -transactionParseJSON :: Network -> Value -> Parser Transaction -transactionParseJSON net = A.withObject "transaction" $ \o -> do - version <- o .: "version" - locktime <- o .: "locktime" - inputs <- o .: "inputs" >>= mapM (storeInputParseJSON net) - outputs <- o .: "outputs" >>= mapM (storeOutputParseJSON net) - block <- o .: "block" - deleted <- o .: "deleted" - time <- o .: "time" - rbf <- o .:? "rbf" .!= False - weight <- o .:? "weight" .!= 0 - size <- o .: "size" - txid <- o .: "txid" - fees <- o .: "fee" - return - Transaction - { transactionBlock = block - , transactionVersion = version - , transactionLockTime = locktime - , transactionInputs = inputs - , transactionOutputs = outputs - , transactionDeleted = deleted - , transactionTime = time - , transactionRBF = rbf - , transactionWeight = weight - , transactionSize = size - , transactionId = txid - , transactionFees = fees - } - --- | Information about a connected peer. -data PeerInformation = PeerInformation - { -- | user agent string - peerUserAgent :: !ByteString - , -- | network address - peerAddress :: !String - , -- | version number - peerVersion :: !Word32 - , -- | services field - peerServices :: !Word64 - , -- | will relay transactions - peerRelay :: !Bool - } - deriving (Show, Eq, Ord, Generic, NFData) - -instance Serial PeerInformation where - serialize PeerInformation{..} = do - putLengthBytes peerUserAgent - putLengthBytes (TE.encodeUtf8 (T.pack peerAddress)) - putWord32be peerVersion - putWord64be peerServices - serialize peerRelay - deserialize = do - peerUserAgent <- getLengthBytes - peerAddress <- T.unpack . TE.decodeUtf8 <$> getLengthBytes - peerVersion <- getWord32be - peerServices <- getWord64be - peerRelay <- deserialize - return PeerInformation{..} - -instance Serialize PeerInformation where - put = serialize - get = deserialize - -instance Binary PeerInformation where - put = serialize - get = deserialize - -instance ToJSON PeerInformation where - toJSON p = - A.object - [ "useragent" .= String (cs (peerUserAgent p)) - , "address" .= peerAddress p - , "version" .= peerVersion p - , "services" - .= String (encodeHex (runPutS (serialize (peerServices p)))) - , "relay" .= peerRelay p - ] - toEncoding p = - AE.pairs $ - "useragent" `AE.pair` AE.text (cs (peerUserAgent p)) - <> "address" .= peerAddress p - <> "version" .= peerVersion p - <> "services" - `AE.pair` AE.text - (encodeHex (runPutS (serialize (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 runGetS deserialize 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, NFData) - -instance Serial XPubBal where - serialize XPubBal{..} = do - putList putWord32be xPubBalPath - serialize xPubBal - deserialize = do - xPubBalPath <- getList getWord32be - xPubBal <- deserialize - return XPubBal{..} - -instance Serialize XPubBal where - put = serialize - get = deserialize - -instance Binary XPubBal where - put = serialize - get = deserialize - -xPubBalToJSON :: Network -> XPubBal -> Value -xPubBalToJSON net XPubBal{xPubBalPath = p, xPubBal = b} = - A.object ["path" .= p, "balance" .= balanceToJSON net b] - -xPubBalToEncoding :: Network -> XPubBal -> Encoding -xPubBalToEncoding net XPubBal{xPubBalPath = p, xPubBal = b} = - AE.pairs ("path" .= p <> "balance" `AE.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 - { xPubUnspent :: !Unspent - , xPubUnspentPath :: ![KeyIndex] - } - deriving (Show, Eq, Ord, Generic, NFData) - -instance Serial XPubUnspent where - serialize XPubUnspent{..} = do - putList putWord32be xPubUnspentPath - serialize xPubUnspent - deserialize = do - xPubUnspentPath <- getList getWord32be - xPubUnspent <- deserialize - return XPubUnspent{..} - -instance Serialize XPubUnspent where - put = serialize - get = deserialize - -instance Binary XPubUnspent where - put = serialize - get = deserialize - -xPubUnspentToJSON :: Network -> XPubUnspent -> Value -xPubUnspentToJSON net XPubUnspent{xPubUnspentPath = p, xPubUnspent = u} = - A.object ["unspent" .= unspentToJSON net u, "path" .= p] - -xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding -xPubUnspentToEncoding net XPubUnspent{xPubUnspentPath = p, xPubUnspent = u} = - AE.pairs $ "unspent" `AE.pair` unspentToEncoding net u <> "path" .= p - -xPubUnspentParseJSON :: Network -> Value -> Parser XPubUnspent -xPubUnspentParseJSON net = - A.withObject "xpubunspent" $ \o -> do - u <- o .: "unspent" >>= unspentParseJSON net - p <- o .: "path" - 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, NFData) - -instance Serial XPubSummary where - serialize XPubSummary{..} = do - putWord64be xPubSummaryConfirmed - putWord64be xPubSummaryZero - putWord64be xPubSummaryReceived - putWord64be xPubUnspentCount - putWord32be xPubExternalIndex - putWord32be xPubChangeIndex - deserialize = do - xPubSummaryConfirmed <- getWord64be - xPubSummaryZero <- getWord64be - xPubSummaryReceived <- getWord64be - xPubUnspentCount <- getWord64be - xPubExternalIndex <- getWord32be - xPubChangeIndex <- getWord32be - return XPubSummary{..} - -instance Binary XPubSummary where - put = serialize - get = deserialize - -instance Serialize XPubSummary where - put = serialize - get = deserialize - -instance ToJSON XPubSummary where - toJSON - XPubSummary - { xPubSummaryConfirmed = c - , xPubSummaryZero = z - , xPubSummaryReceived = r - , xPubUnspentCount = u - , xPubExternalIndex = ext - , xPubChangeIndex = ch - } = - A.object - [ "balance" - .= A.object - [ "confirmed" .= c - , "unconfirmed" .= z - , "received" .= r - , "utxo" .= u - ] - , "indices" - .= A.object - [ "change" .= ch - , "external" .= ext - ] - ] - toEncoding - XPubSummary - { xPubSummaryConfirmed = c - , xPubSummaryZero = z - , xPubSummaryReceived = r - , xPubUnspentCount = u - , xPubExternalIndex = ext - , xPubChangeIndex = ch - } = - AE.pairs $ - "balance" - `AE.pair` AE.pairs - ( "confirmed" .= c - <> "unconfirmed" .= z - <> "received" .= r - <> "utxo" .= u - ) - <> "indices" - `AE.pair` AE.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 - } - -class Healthy a where - isOK :: a -> Bool - -data BlockHealth = BlockHealth - { blockHealthHeaders :: !BlockHeight - , blockHealthBlocks :: !BlockHeight - , blockHealthMaxDiff :: !Int32 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial BlockHealth where - serialize h@BlockHealth{..} = do - serialize (isOK h) - putWord32be blockHealthHeaders - putWord32be blockHealthBlocks - putInt32be blockHealthMaxDiff - deserialize = do - k <- deserialize - blockHealthHeaders <- getWord32be - blockHealthBlocks <- getWord32be - blockHealthMaxDiff <- getInt32be - let h = BlockHealth{..} - unless (k == isOK h) $ fail "Inconsistent health check" - return h - -instance Serialize BlockHealth where - put = serialize - get = deserialize - -instance Binary BlockHealth where - put = serialize - get = deserialize - -instance Healthy BlockHealth where - isOK BlockHealth{..} = - h - b <= blockHealthMaxDiff - where - h = fromIntegral blockHealthHeaders - b = fromIntegral blockHealthBlocks - -instance ToJSON BlockHealth where - toJSON h@BlockHealth{..} = - A.object - [ "headers" .= blockHealthHeaders - , "blocks" .= blockHealthBlocks - , "diff" .= diff - , "max" .= blockHealthMaxDiff - , "ok" .= isOK h - ] - where - diff = toInteger blockHealthHeaders - toInteger blockHealthBlocks - -instance FromJSON BlockHealth where - parseJSON = - A.withObject "BlockHealth" $ \o -> do - blockHealthHeaders <- o .: "headers" - blockHealthBlocks <- o .: "blocks" - blockHealthMaxDiff <- o .: "max" - return BlockHealth{..} - -data TimeHealth = TimeHealth - { timeHealthAge :: !Int64 - , timeHealthMax :: !Int64 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial TimeHealth where - serialize h@TimeHealth{..} = do - serialize (isOK h) - putInt64be timeHealthAge - putInt64be timeHealthMax - deserialize = do - k <- deserialize - timeHealthAge <- getInt64be - timeHealthMax <- getInt64be - let t = TimeHealth{..} - unless (k == isOK t) $ fail "Inconsistent health check" - return t - -instance Binary TimeHealth where - put = serialize - get = deserialize - -instance Serialize TimeHealth where - put = serialize - get = deserialize - -instance Healthy TimeHealth where - isOK TimeHealth{..} = - timeHealthAge <= timeHealthMax - -instance ToJSON TimeHealth where - toJSON h@TimeHealth{..} = - A.object - [ "age" .= timeHealthAge - , "max" .= timeHealthMax - , "ok" .= isOK h - ] - -instance FromJSON TimeHealth where - parseJSON = - A.withObject "TimeHealth" $ \o -> do - timeHealthAge <- o .: "age" - timeHealthMax <- o .: "max" - return TimeHealth{..} - -data CountHealth = CountHealth - { countHealthNum :: !Int64 - , countHealthMin :: !Int64 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial CountHealth where - serialize h@CountHealth{..} = do - serialize (isOK h) - putInt64be countHealthNum - putInt64be countHealthMin - deserialize = do - k <- deserialize - countHealthNum <- getInt64be - countHealthMin <- getInt64be - let c = CountHealth{..} - unless (k == isOK c) $ fail "Inconsistent health check" - return c - -instance Serialize CountHealth where - put = serialize - get = deserialize - -instance Binary CountHealth where - put = serialize - get = deserialize - -instance Healthy CountHealth where - isOK CountHealth{..} = - countHealthMin <= countHealthNum - -instance ToJSON CountHealth where - toJSON h@CountHealth{..} = - A.object - [ "count" .= countHealthNum - , "min" .= countHealthMin - , "ok" .= isOK h - ] - -instance FromJSON CountHealth where - parseJSON = - A.withObject "CountHealth" $ \o -> do - countHealthNum <- o .: "count" - countHealthMin <- o .: "min" - return CountHealth{..} - -data MaxHealth = MaxHealth - { maxHealthNum :: !Int64 - , maxHealthMax :: !Int64 - } - deriving (Show, Eq, Generic, NFData) - -instance Serial MaxHealth where - serialize h@MaxHealth{..} = do - serialize $ isOK h - putInt64be maxHealthNum - putInt64be maxHealthMax - deserialize = do - k <- deserialize - maxHealthNum <- getInt64be - maxHealthMax <- getInt64be - let h = MaxHealth{..} - unless (k == isOK h) $ fail "Inconsistent health check" - return h - -instance Binary MaxHealth where - put = serialize - get = deserialize - -instance Serialize MaxHealth where - put = serialize - get = deserialize - -instance Healthy MaxHealth where - isOK MaxHealth{..} = maxHealthNum <= maxHealthMax - -instance ToJSON MaxHealth where - toJSON h@MaxHealth{..} = - A.object - [ "count" .= maxHealthNum - , "max" .= maxHealthMax - , "ok" .= isOK h - ] - -instance FromJSON MaxHealth where - parseJSON = - A.withObject "MaxHealth" $ \o -> do - maxHealthNum <- o .: "count" - maxHealthMax <- o .: "max" - return MaxHealth{..} - -data HealthCheck = HealthCheck - { healthBlocks :: !BlockHealth - , healthLastBlock :: !TimeHealth - , healthLastTx :: !TimeHealth - , healthPendingTxs :: !MaxHealth - , healthPeers :: !CountHealth - , healthNetwork :: !String - , healthVersion :: !String - } - deriving (Show, Eq, Generic, NFData) - -instance Serial HealthCheck where - serialize h@HealthCheck{..} = do - serialize (isOK h) - serialize healthBlocks - serialize healthLastBlock - serialize healthLastTx - serialize healthPendingTxs - serialize healthPeers - putLengthBytes ((TE.encodeUtf8 . T.pack) healthNetwork) - putLengthBytes ((TE.encodeUtf8 . T.pack) healthVersion) - deserialize = do - k <- deserialize - healthBlocks <- deserialize - healthLastBlock <- deserialize - healthLastTx <- deserialize - healthPendingTxs <- deserialize - healthPeers <- deserialize - healthNetwork <- T.unpack . TE.decodeUtf8 <$> getLengthBytes - healthVersion <- T.unpack . TE.decodeUtf8 <$> getLengthBytes - let h = HealthCheck{..} - unless (k == isOK h) $ fail "Inconsistent health check" - return h - -instance Binary HealthCheck where - put = serialize - get = deserialize - -instance Serialize HealthCheck where - put = serialize - get = deserialize - -instance Healthy HealthCheck where - isOK HealthCheck{..} = - isOK healthBlocks - && isOK healthLastBlock - && isOK healthLastTx - && isOK healthPendingTxs - && isOK healthPeers - -instance ToJSON HealthCheck where - toJSON h@HealthCheck{..} = - A.object - [ "blocks" .= healthBlocks - , "last-block" .= healthLastBlock - , "last-tx" .= healthLastTx - , "pending-txs" .= healthPendingTxs - , "peers" .= healthPeers - , "net" .= healthNetwork - , "version" .= healthVersion - , "ok" .= isOK h - ] - -instance FromJSON HealthCheck where - parseJSON = - A.withObject "HealthCheck" $ \o -> do - healthBlocks <- o .: "blocks" - healthLastBlock <- o .: "last-block" - healthLastTx <- o .: "last-tx" - healthPendingTxs <- o .: "pending-txs" - healthPeers <- o .: "peers" - healthNetwork <- o .: "net" - healthVersion <- o .: "version" - return HealthCheck{..} - -data Event - = EventBlock !BlockHash - | EventTx !TxHash - deriving (Show, Eq, Generic, NFData) - -instance Serial Event where - serialize (EventBlock bh) = putWord8 0x00 >> serialize bh - serialize (EventTx th) = putWord8 0x01 >> serialize th - deserialize = - getWord8 >>= \case - 0x00 -> EventBlock <$> deserialize - 0x01 -> EventTx <$> deserialize - _ -> fail "Not an Event" - -instance Serialize Event where - put = serialize - get = deserialize - -instance Binary Event where - put = serialize - get = deserialize - -instance ToJSON Event where - toJSON (EventTx h) = - A.object - [ "type" .= String "tx" - , "id" .= h - ] - toJSON (EventBlock h) = - A.object - [ "type" .= String "block" - , "id" .= h - ] - toEncoding (EventTx h) = - AE.pairs $ - "type" `AE.pair` AE.text "tx" - <> "id" `AE.pair` AE.text (txHashToHex h) - toEncoding (EventBlock h) = - AE.pairs $ - "type" `AE.pair` AE.text "block" - <> "id" `AE.pair` AE.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, NFData) - -instance Serial a => Serial (GenericResult a) where - serialize (GenericResult x) = serialize x - deserialize = GenericResult <$> deserialize - -instance Serial a => Serialize (GenericResult a) where - put = serialize - get = deserialize - -instance Serial a => Binary (GenericResult a) where - put = serialize - get = deserialize - -instance ToJSON a => ToJSON (GenericResult a) where - toJSON (GenericResult b) = A.object ["result" .= b] - toEncoding (GenericResult b) = AE.pairs ("result" .= b) - -instance FromJSON a => FromJSON (GenericResult a) where - parseJSON = - A.withObject "GenericResult" $ \o -> - GenericResult <$> o .: "result" - -newtype RawResult a = RawResult - { getRawResult :: a - } - deriving (Show, Eq, Generic, NFData) - -instance Serial a => Serial (RawResult a) where - serialize (RawResult x) = serialize x - deserialize = RawResult <$> deserialize - -instance Serial a => Serialize (RawResult a) where - put = serialize - get = deserialize - -instance Serial a => Binary (RawResult a) where - put = serialize - get = deserialize - -instance Serial a => ToJSON (RawResult a) where - toJSON (RawResult b) = - A.object ["result" .= x b] - where - x = - TLE.decodeUtf8 - . BSB.toLazyByteString - . BSB.lazyByteStringHex - . runPutL - . serialize - toEncoding (RawResult b) = - AE.pairs $ "result" `AE.pair` AE.unsafeToEncoding str - where - str = - BSB.char7 '"' - <> BSB.lazyByteStringHex (runPutL (serialize b)) - <> BSB.char7 '"' - -instance Serial a => FromJSON (RawResult a) where - parseJSON = - A.withObject "RawResult" $ \o -> do - res <- o .: "result" - let m = - eitherToMaybe . Bytes.Get.runGetS deserialize - =<< decodeHex res - maybe mzero (return . RawResult) m - -newtype SerialList a = SerialList {getSerialList :: [a]} - deriving (Show, Eq, Generic, NFData) - -instance Semigroup (SerialList a) where - SerialList a <> SerialList b = SerialList (a <> b) - -instance Monoid (SerialList a) where - mempty = SerialList mempty - -instance Serial a => Serial (SerialList a) where - serialize (SerialList ls) = putList serialize ls - deserialize = SerialList <$> getList deserialize - -instance ToJSON a => ToJSON (SerialList a) where - toJSON (SerialList ls) = toJSON ls - toEncoding (SerialList ls) = toEncoding ls - -instance FromJSON a => FromJSON (SerialList a) where - parseJSON = fmap SerialList . parseJSON - -newtype RawResultList a = RawResultList - { getRawResultList :: [a] - } - deriving (Show, Eq, Generic, NFData) - -instance Serial a => Serial (RawResultList a) where - serialize (RawResultList xs) = - mapM_ serialize xs - deserialize = RawResultList <$> go - where - go = - isEmpty >>= \case - True -> return [] - False -> (:) <$> deserialize <*> go - -instance Serial a => Serialize (RawResultList a) where - put = serialize - get = deserialize - -instance Serial a => Binary (RawResultList a) where - put = serialize - get = deserialize - -instance Semigroup (RawResultList a) where - (RawResultList a) <> (RawResultList b) = RawResultList $ a <> b - -instance Monoid (RawResultList a) where - mempty = RawResultList mempty - -instance Serial a => ToJSON (RawResultList a) where - toJSON (RawResultList xs) = - toJSON $ - TLE.decodeUtf8 - . BSB.toLazyByteString - . BSB.lazyByteStringHex - . runPutL - . serialize - <$> xs - toEncoding (RawResultList xs) = - AE.list (AE.unsafeToEncoding . str) xs - where - str x = - BSB.char7 '"' - <> BSB.lazyByteStringHex (runPutL (serialize x)) - <> BSB.char7 '"' - -instance Serial a => FromJSON (RawResultList a) where - parseJSON = - A.withArray "RawResultList" $ \vec -> - RawResultList <$> mapM parseElem (toList vec) - where - parseElem = A.withText "RawResultListElem" $ maybe mzero return . f - f = eitherToMaybe . Bytes.Get.runGetS deserialize <=< decodeHex - -newtype TxId - = TxId TxHash - deriving (Show, Eq, Generic, NFData) - -instance Serial TxId where - serialize (TxId h) = serialize h - deserialize = TxId <$> deserialize - -instance Serialize TxId where - put = serialize - get = deserialize - -instance Binary TxId where - put = serialize - get = deserialize - -instance ToJSON TxId where - toJSON (TxId h) = A.object ["txid" .= h] - toEncoding (TxId h) = AE.pairs ("txid" `AE.pair` AE.text (txHashToHex h)) - -instance FromJSON TxId where - parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid" - -data Except - = ThingNotFound - | ServerError - | BadRequest - | UserError !String - | StringError !String - | TxIndexConflict ![TxHash] - | ServerTimeout - | RequestTooLarge - deriving (Show, Eq, Ord, Generic, NFData) - -instance Exception Except - -instance ScottyError Except where - stringError = StringError - showError = TL.pack . show - -instance ToJSON Except where - toJSON e = - A.object $ - case e of - ThingNotFound -> - [ "error" .= String "not-found-or-invalid-arg" - , "message" .= String "Item not found or argument invalid" - ] - ServerError -> - [ "error" .= String "server-error" - , "message" .= String "Server error" - ] - BadRequest -> - [ "error" .= String "bad-request" - , "message" .= String "Invalid request" - ] - UserError msg' -> - [ "error" .= String "user-error" - , "message" .= String (cs msg') - ] - StringError msg' -> - [ "error" .= String "string-error" - , "message" .= String (cs msg') - ] - TxIndexConflict txids -> - [ "error" .= String "multiple-tx-index" - , "message" .= String "Multiple txs match that index" - , "txids" .= txids - ] - ServerTimeout -> - [ "error" .= String "server-timeout" - , "message" .= String "Request is taking too long" - ] - RequestTooLarge -> - [ "error" .= String "request-too-large" - , "message" .= String "Request body too large" - ] - -instance FromJSON Except where - parseJSON = - A.withObject "Except" $ \o -> do - ctr <- o .: "error" - msg' <- o .:? "message" .!= "" - case ctr of - String "not-found-or-invalid-arg" -> - return ThingNotFound - String "server-error" -> - return ServerError - String "bad-request" -> - return BadRequest - String "user-error" -> - return $ UserError msg' - String "string-error" -> - return $ StringError msg' - String "multiple-tx-index" -> do - txids <- o .: "txids" - return $ TxIndexConflict txids - String "server-timeout" -> - return ServerTimeout - String "request-too-large" -> - return RequestTooLarge - _ -> mzero - -toIntTxId :: TxHash -> Word64 -toIntTxId h = - let bs = runPutS (serialize h) - Right w64 = runGetS getWord64be bs - in w64 `shift` (-11) - ---------------------------------------- --- Blockchain.info API Compatibility -- ---------------------------------------- - -data BinfoBlockId - = BinfoBlockHash !BlockHash - | BinfoBlockIndex !Word32 - deriving (Eq, Show, Read, Generic, NFData) - -instance Parsable BinfoBlockId where - parseParam t = - hex <> igr - where - hex = case hexToBlockHash (TL.toStrict t) of - Nothing -> Left "could not decode txid" - Just h -> Right $ BinfoBlockHash h - igr = BinfoBlockIndex <$> parseParam t - -data BinfoTxId - = BinfoTxIdHash !TxHash - | BinfoTxIdIndex !Word64 - deriving (Eq, Show, Read, Generic, NFData) - -encodeBinfoTxId :: Bool -> TxHash -> BinfoTxId -encodeBinfoTxId False = BinfoTxIdHash -encodeBinfoTxId True = BinfoTxIdIndex . toIntTxId - -instance Parsable BinfoTxId where - parseParam t = - hex <> igr - where - hex = - case hexToTxHash (TL.toStrict t) of - Nothing -> Left "could not decode txid" - Just h -> Right $ BinfoTxIdHash h - igr = BinfoTxIdIndex <$> parseParam t - -instance ToJSON BinfoTxId where - toJSON (BinfoTxIdHash h) = toJSON h - toJSON (BinfoTxIdIndex i) = toJSON i - toEncoding (BinfoTxIdHash h) = toEncoding h - toEncoding (BinfoTxIdIndex i) = toEncoding i - -instance FromJSON BinfoTxId where - parseJSON v = - BinfoTxIdHash <$> parseJSON v - <|> BinfoTxIdIndex <$> parseJSON v - -data BinfoFilter - = BinfoFilterAll - | BinfoFilterSent - | BinfoFilterReceived - | BinfoFilterMoved - | BinfoFilterConfirmed - | BinfoFilterMempool - deriving (Eq, Show, Generic, NFData) - -instance Parsable BinfoFilter where - parseParam t = - parseParam t >>= \case - (0 :: Int) -> return BinfoFilterAll - 1 -> return BinfoFilterSent - 2 -> return BinfoFilterReceived - 3 -> return BinfoFilterMoved - 5 -> return BinfoFilterConfirmed - 6 -> return BinfoFilterAll - 7 -> return BinfoFilterMempool - _ -> Left "could not parse filter parameter" - -data BinfoMultiAddr = BinfoMultiAddr - { getBinfoMultiAddrAddresses :: ![BinfoBalance] - , getBinfoMultiAddrWallet :: !BinfoWallet - , getBinfoMultiAddrTxs :: ![BinfoTx] - , getBinfoMultiAddrInfo :: !BinfoInfo - , getBinfoMultiAddrRecommendFee :: !Bool - , getBinfoMultiAddrCashAddr :: !Bool - } - deriving (Eq, Show, Generic, NFData) - -binfoMultiAddrToJSON :: Network -> BinfoMultiAddr -> Value -binfoMultiAddrToJSON net' BinfoMultiAddr{..} = - A.object $ - [ "addresses" .= map (binfoBalanceToJSON net) getBinfoMultiAddrAddresses - , "wallet" .= getBinfoMultiAddrWallet - , "txs" .= map (binfoTxToJSON net) getBinfoMultiAddrTxs - , "info" .= getBinfoMultiAddrInfo - , "recommend_include_fee" .= getBinfoMultiAddrRecommendFee - ] - ++ ["cash_addr" .= True | getBinfoMultiAddrCashAddr] - where - net = if not getBinfoMultiAddrCashAddr && net' == bch then btc else net' - -binfoMultiAddrParseJSON :: Network -> Value -> Parser BinfoMultiAddr -binfoMultiAddrParseJSON net = A.withObject "multiaddr" $ \o -> do - getBinfoMultiAddrAddresses <- - mapM (binfoBalanceParseJSON net) =<< o .: "addresses" - getBinfoMultiAddrWallet <- o .: "wallet" - getBinfoMultiAddrTxs <- - mapM (binfoTxParseJSON net) =<< o .: "txs" - getBinfoMultiAddrInfo <- o .: "info" - getBinfoMultiAddrRecommendFee <- o .: "recommend_include_fee" - getBinfoMultiAddrCashAddr <- o .:? "cash_addr" .!= False - return BinfoMultiAddr{..} - -binfoMultiAddrToEncoding :: Network -> BinfoMultiAddr -> Encoding -binfoMultiAddrToEncoding net' BinfoMultiAddr{..} = - AE.pairs - ( "addresses" `AE.pair` as - <> "wallet" .= getBinfoMultiAddrWallet - <> "txs" `AE.pair` ts - <> "info" .= getBinfoMultiAddrInfo - <> "recommend_include_fee" .= getBinfoMultiAddrRecommendFee - <> if getBinfoMultiAddrCashAddr then "cash_addr" .= True else mempty - ) - where - as = AE.list (binfoBalanceToEncoding net) getBinfoMultiAddrAddresses - ts = AE.list (binfoTxToEncoding net) getBinfoMultiAddrTxs - net = if not getBinfoMultiAddrCashAddr && net' == bch then btc else net' - -data BinfoRawAddr = BinfoRawAddr - { binfoRawAddr :: !BinfoAddr - , binfoRawBalance :: !Word64 - , binfoRawTxCount :: !Word64 - , binfoRawUnredeemed :: !Word64 - , binfoRawReceived :: !Word64 - , binfoRawSent :: !Int64 - , binfoRawTxs :: ![BinfoTx] - } - deriving (Eq, Show, Generic, NFData) - -binfoRawAddrToJSON :: Network -> BinfoRawAddr -> Value -binfoRawAddrToJSON net BinfoRawAddr{..} = - A.object - [ "hash160" .= h160 - , "address" .= address - , "n_tx" .= binfoRawTxCount - , "n_unredeemed" .= binfoRawUnredeemed - , "total_received" .= binfoRawReceived - , "total_sent" .= binfoRawSent - , "final_balance" .= binfoRawBalance - , "txs" .= map (binfoTxToJSON net) binfoRawTxs - ] - where - address = case binfoRawAddr of - BinfoAddr a -> addrToJSON net a - BinfoXpub x -> xPubToJSON net x - h160 = - encodeHex . runPutS . serialize - <$> case binfoRawAddr of - BinfoAddr a -> case a of - PubKeyAddress h -> Just h - ScriptAddress h -> Just h - WitnessPubKeyAddress h -> Just h - _ -> Nothing - _ -> Nothing - -binfoRawAddrToEncoding :: Network -> BinfoRawAddr -> Encoding -binfoRawAddrToEncoding net BinfoRawAddr{..} = - AE.pairs $ - "hash160" .= h160 - <> "address" `AE.pair` address - <> "n_tx" .= binfoRawTxCount - <> "n_unredeemed" .= binfoRawUnredeemed - <> "total_received" .= binfoRawReceived - <> "total_sent" .= binfoRawSent - <> "final_balance" .= binfoRawBalance - <> "txs" `AE.pair` AE.list (binfoTxToEncoding net) binfoRawTxs - where - address = case binfoRawAddr of - BinfoAddr a -> addrToEncoding net a - BinfoXpub x -> xPubToEncoding net x - h160 = - encodeHex . runPutS . serialize - <$> case binfoRawAddr of - BinfoAddr a -> case a of - PubKeyAddress h -> Just h - ScriptAddress h -> Just h - WitnessPubKeyAddress h -> Just h - _ -> Nothing - _ -> Nothing - -binfoRawAddrParseJSON :: Network -> Value -> Parser BinfoRawAddr -binfoRawAddrParseJSON net = A.withObject "balancetxs" $ \o -> do - addr <- o .: "address" - binfoRawAddr <- - BinfoAddr <$> addrFromJSON net addr - <|> BinfoXpub <$> xPubFromJSON net addr - binfoRawBalance <- o .: "final_balance" - binfoRawUnredeemed <- o .: "n_unredeemed" - binfoRawTxCount <- o .: "n_tx" - binfoRawReceived <- o .: "total_received" - binfoRawSent <- o .: "total_sent" - binfoRawTxs <- mapM (binfoTxParseJSON net) =<< o .: "txs" - return BinfoRawAddr{..} - -data BinfoShortBal = BinfoShortBal - { binfoShortBalFinal :: !Word64 - , binfoShortBalTxCount :: !Word64 - , binfoShortBalReceived :: !Word64 - } - deriving (Eq, Show, Read, Generic, NFData) - -instance ToJSON BinfoShortBal where - toJSON BinfoShortBal{..} = - A.object - [ "final_balance" .= binfoShortBalFinal - , "n_tx" .= binfoShortBalTxCount - , "total_received" .= binfoShortBalReceived - ] - toEncoding BinfoShortBal{..} = - AE.pairs $ - "final_balance" .= binfoShortBalFinal - <> "n_tx" .= binfoShortBalTxCount - <> "total_received" .= binfoShortBalReceived - -instance FromJSON BinfoShortBal where - parseJSON = A.withObject "short_balance" $ \o -> do - binfoShortBalFinal <- o .: "final_balance" - binfoShortBalTxCount <- o .: "n_tx" - binfoShortBalReceived <- o .: "total_received" - return BinfoShortBal{..} - -data BinfoBalance - = BinfoAddrBalance - { getBinfoAddress :: !Address - , getBinfoAddrTxCount :: !Word64 - , getBinfoAddrReceived :: !Word64 - , getBinfoAddrSent :: !Word64 - , getBinfoAddrBalance :: !Word64 - } - | BinfoXPubBalance - { getBinfoXPubKey :: !XPubKey - , getBinfoAddrTxCount :: !Word64 - , getBinfoAddrReceived :: !Word64 - , getBinfoAddrSent :: !Word64 - , getBinfoAddrBalance :: !Word64 - , getBinfoXPubAccountIndex :: !Word32 - , getBinfoXPubChangeIndex :: !Word32 - } - deriving (Eq, Show, Generic, NFData) - -binfoBalanceToJSON :: Network -> BinfoBalance -> Value -binfoBalanceToJSON net BinfoAddrBalance{..} = - A.object - [ "address" .= addrToJSON net getBinfoAddress - , "final_balance" .= getBinfoAddrBalance - , "n_tx" .= getBinfoAddrTxCount - , "total_received" .= getBinfoAddrReceived - , "total_sent" .= getBinfoAddrSent - ] -binfoBalanceToJSON net BinfoXPubBalance{..} = - A.object - [ "address" .= xPubToJSON net getBinfoXPubKey - , "change_index" .= getBinfoXPubChangeIndex - , "account_index" .= getBinfoXPubAccountIndex - , "final_balance" .= getBinfoAddrBalance - , "n_tx" .= getBinfoAddrTxCount - , "total_received" .= getBinfoAddrReceived - , "total_sent" .= getBinfoAddrSent - ] - -binfoBalanceParseJSON :: Network -> Value -> Parser BinfoBalance -binfoBalanceParseJSON net = A.withObject "address" $ \o -> x o <|> a o - where - x o = do - getBinfoXPubKey <- xPubFromJSON net =<< o .: "address" - getBinfoXPubChangeIndex <- o .: "change_index" - getBinfoXPubAccountIndex <- o .: "account_index" - getBinfoAddrBalance <- o .: "final_balance" - getBinfoAddrTxCount <- o .: "n_tx" - getBinfoAddrReceived <- o .: "total_received" - getBinfoAddrSent <- o .: "total_sent" - return BinfoXPubBalance{..} - a o = do - getBinfoAddress <- addrFromJSON net =<< o .: "address" - getBinfoAddrBalance <- o .: "final_balance" - getBinfoAddrTxCount <- o .: "n_tx" - getBinfoAddrReceived <- o .: "total_received" - getBinfoAddrSent <- o .: "total_sent" - return BinfoAddrBalance{..} - -binfoBalanceToEncoding :: Network -> BinfoBalance -> Encoding -binfoBalanceToEncoding net BinfoAddrBalance{..} = - AE.pairs - ( "address" `AE.pair` addrToEncoding net getBinfoAddress - <> "final_balance" .= getBinfoAddrBalance - <> "n_tx" .= getBinfoAddrTxCount - <> "total_received" .= getBinfoAddrReceived - <> "total_sent" .= getBinfoAddrSent - ) -binfoBalanceToEncoding net BinfoXPubBalance{..} = - AE.pairs - ( "address" `AE.pair` xPubToEncoding net getBinfoXPubKey - <> "change_index" .= getBinfoXPubChangeIndex - <> "account_index" .= getBinfoXPubAccountIndex - <> "final_balance" .= getBinfoAddrBalance - <> "n_tx" .= getBinfoAddrTxCount - <> "total_received" .= getBinfoAddrReceived - <> "total_sent" .= getBinfoAddrSent - ) - -data BinfoWallet = BinfoWallet - { getBinfoWalletBalance :: !Word64 - , getBinfoWalletTxCount :: !Word64 - , getBinfoWalletFilteredCount :: !Word64 - , getBinfoWalletTotalReceived :: !Word64 - , getBinfoWalletTotalSent :: !Word64 - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoWallet where - toJSON BinfoWallet{..} = - A.object - [ "final_balance" .= getBinfoWalletBalance - , "n_tx" .= getBinfoWalletTxCount - , "n_tx_filtered" .= getBinfoWalletFilteredCount - , "total_received" .= getBinfoWalletTotalReceived - , "total_sent" .= getBinfoWalletTotalSent - ] - toEncoding BinfoWallet{..} = - AE.pairs - ( "final_balance" .= getBinfoWalletBalance - <> "n_tx" .= getBinfoWalletTxCount - <> "n_tx_filtered" .= getBinfoWalletFilteredCount - <> "total_received" .= getBinfoWalletTotalReceived - <> "total_sent" .= getBinfoWalletTotalSent - ) - -instance FromJSON BinfoWallet where - parseJSON = A.withObject "wallet" $ \o -> do - getBinfoWalletBalance <- o .: "final_balance" - getBinfoWalletTxCount <- o .: "n_tx" - getBinfoWalletFilteredCount <- o .: "n_tx_filtered" - getBinfoWalletTotalReceived <- o .: "total_received" - getBinfoWalletTotalSent <- o .: "total_sent" - return BinfoWallet{..} - -binfoHexValue :: Word64 -> Text -binfoHexValue w64 = - let bs = BS.dropWhile (== 0x00) (runPutS (serialize w64)) - in encodeHex $ - if BS.null bs || BS.head bs `testBit` 7 - then BS.cons 0x00 bs - else bs - -data BinfoUnspent = BinfoUnspent - { getBinfoUnspentHash :: !TxHash - , getBinfoUnspentOutputIndex :: !Word32 - , getBinfoUnspentScript :: !ByteString - , getBinfoUnspentValue :: !Word64 - , getBinfoUnspentConfirmations :: !Int32 - , getBinfoUnspentTxIndex :: !BinfoTxId - , getBinfoUnspentXPub :: !(Maybe BinfoXPubPath) - } - deriving (Eq, Show, Generic, NFData) - -binfoUnspentToJSON :: Network -> BinfoUnspent -> Value -binfoUnspentToJSON net BinfoUnspent{..} = - A.object $ - [ "tx_hash_big_endian" .= getBinfoUnspentHash - , "tx_hash" - .= encodeHex (runPutS (serialize (getTxHash getBinfoUnspentHash))) - , "tx_output_n" .= getBinfoUnspentOutputIndex - , "script" .= encodeHex getBinfoUnspentScript - , "value" .= getBinfoUnspentValue - , "value_hex" .= binfoHexValue getBinfoUnspentValue - , "confirmations" .= getBinfoUnspentConfirmations - , "tx_index" .= getBinfoUnspentTxIndex - ] - <> [ "xpub" .= binfoXPubPathToJSON net x - | x <- maybeToList getBinfoUnspentXPub - ] - -binfoUnspentToEncoding :: Network -> BinfoUnspent -> Encoding -binfoUnspentToEncoding net BinfoUnspent{..} = - AE.pairs $ - "tx_hash_big_endian" .= getBinfoUnspentHash - <> "tx_hash" - .= encodeHex (runPutS (serialize (getTxHash getBinfoUnspentHash))) - <> "tx_output_n" - .= getBinfoUnspentOutputIndex - <> "script" - .= encodeHex getBinfoUnspentScript - <> "value" - .= getBinfoUnspentValue - <> "value_hex" - .= binfoHexValue getBinfoUnspentValue - <> "confirmations" - .= getBinfoUnspentConfirmations - <> "tx_index" - .= getBinfoUnspentTxIndex - <> maybe - mempty - (("xpub" `AE.pair`) . binfoXPubPathToEncoding net) - getBinfoUnspentXPub - -binfoUnspentParseJSON :: Network -> Value -> Parser BinfoUnspent -binfoUnspentParseJSON net = A.withObject "unspent" $ \o -> do - getBinfoUnspentHash <- o .: "tx_hash_big_endian" - getBinfoUnspentOutputIndex <- o .: "tx_output_n" - getBinfoUnspentScript <- maybe mzero return . decodeHex =<< o .: "script" - getBinfoUnspentValue <- o .: "value" - getBinfoUnspentConfirmations <- o .: "confirmations" - getBinfoUnspentTxIndex <- o .: "tx_index" - getBinfoUnspentXPub <- mapM (binfoXPubPathParseJSON net) =<< o .:? "xpub" - return BinfoUnspent{..} - -newtype BinfoUnspents = BinfoUnspents [BinfoUnspent] - deriving (Eq, Show, Generic, NFData) - -binfoUnspentsToJSON :: Network -> BinfoUnspents -> Value -binfoUnspentsToJSON net (BinfoUnspents us) = - A.object - [ "notice" .= T.empty - , "unspent_outputs" .= map (binfoUnspentToJSON net) us - ] - -binfoUnspentsToEncoding :: Network -> BinfoUnspents -> Encoding -binfoUnspentsToEncoding net (BinfoUnspents us) = - AE.pairs $ - "notice" .= T.empty - <> "unspent_outputs" `AE.pair` AE.list (binfoUnspentToEncoding net) us - -binfoUnspentsParseJSON :: Network -> Value -> Parser BinfoUnspents -binfoUnspentsParseJSON net = A.withObject "unspents" $ \o -> do - us <- mapM (binfoUnspentParseJSON net) =<< o .: "unspent_outputs" - return (BinfoUnspents us) - -binfoBlocksToJSON :: Network -> [BinfoBlock] -> Value -binfoBlocksToJSON net blocks = - A.object ["blocks" .= map (binfoBlockToJSON net) blocks] - -binfoBlocksToEncoding :: Network -> [BinfoBlock] -> Encoding -binfoBlocksToEncoding net blocks = - AE.pairs $ "blocks" `AE.pair` AE.list (binfoBlockToEncoding net) blocks - -binfoBlocksParseJSON :: Network -> Value -> Parser [BinfoBlock] -binfoBlocksParseJSON net = - A.withObject "blocks" $ \o -> - mapM (binfoBlockParseJSON net) =<< o .: "blocks" - -toBinfoBlock :: BlockData -> [BinfoTx] -> [BlockHash] -> BinfoBlock -toBinfoBlock BlockData{..} txs next_blocks = - BinfoBlock - { getBinfoBlockHash = headerHash blockDataHeader - , getBinfoBlockVer = blockVersion blockDataHeader - , getBinfoPrevBlock = prevBlock blockDataHeader - , getBinfoMerkleRoot = merkleRoot blockDataHeader - , getBinfoBlockTime = blockTimestamp blockDataHeader - , getBinfoBlockBits = blockBits blockDataHeader - , getBinfoNextBlock = next_blocks - , getBinfoBlockFee = blockDataFees - , getBinfoBlockNonce = bhNonce blockDataHeader - , getBinfoBlockTxCount = fromIntegral (length txs) - , getBinfoBlockSize = blockDataSize - , getBinfoBlockIndex = blockDataHeight - , getBinfoBlockMain = blockDataMainChain - , getBinfoBlockHeight = blockDataHeight - , getBinfoBlockWeight = blockDataWeight - , getBinfoBlockTx = txs - } - -data BinfoBlock = BinfoBlock - { getBinfoBlockHash :: !BlockHash - , getBinfoBlockVer :: !Word32 - , getBinfoPrevBlock :: !BlockHash - , getBinfoMerkleRoot :: !Hash256 - , getBinfoBlockTime :: !Word32 - , getBinfoBlockBits :: !Word32 - , getBinfoNextBlock :: ![BlockHash] - , getBinfoBlockFee :: !Word64 - , getBinfoBlockNonce :: !Word32 - , getBinfoBlockTxCount :: !Word32 - , getBinfoBlockSize :: !Word32 - , getBinfoBlockIndex :: !Word32 - , getBinfoBlockMain :: !Bool - , getBinfoBlockHeight :: !Word32 - , getBinfoBlockWeight :: !Word32 - , getBinfoBlockTx :: ![BinfoTx] - } - deriving (Eq, Show, Generic, NFData) - -binfoBlockToJSON :: Network -> BinfoBlock -> Value -binfoBlockToJSON net BinfoBlock{..} = - A.object - [ "hash" .= getBinfoBlockHash - , "ver" .= getBinfoBlockVer - , "prev_block" .= getBinfoPrevBlock - , "mrkl_root" .= TxHash getBinfoMerkleRoot - , "time" .= getBinfoBlockTime - , "bits" .= getBinfoBlockBits - , "next_block" .= getBinfoNextBlock - , "fee" .= getBinfoBlockFee - , "nonce" .= getBinfoBlockNonce - , "n_tx" .= getBinfoBlockTxCount - , "size" .= getBinfoBlockSize - , "block_index" .= getBinfoBlockIndex - , "main_chain" .= getBinfoBlockMain - , "height" .= getBinfoBlockHeight - , "weight" .= getBinfoBlockWeight - , "tx" .= map (binfoTxToJSON net) getBinfoBlockTx - ] - -binfoBlockToEncoding :: Network -> BinfoBlock -> Encoding -binfoBlockToEncoding net BinfoBlock{..} = - AE.pairs $ - "hash" .= getBinfoBlockHash - <> "ver" .= getBinfoBlockVer - <> "prev_block" .= getBinfoPrevBlock - <> "mrkl_root" .= TxHash getBinfoMerkleRoot - <> "time" .= getBinfoBlockTime - <> "bits" .= getBinfoBlockBits - <> "next_block" .= getBinfoNextBlock - <> "fee" .= getBinfoBlockFee - <> "nonce" .= getBinfoBlockNonce - <> "n_tx" .= getBinfoBlockTxCount - <> "size" .= getBinfoBlockSize - <> "block_index" .= getBinfoBlockIndex - <> "main_chain" .= getBinfoBlockMain - <> "height" .= getBinfoBlockHeight - <> "weight" .= getBinfoBlockWeight - <> "tx" `AE.pair` AE.list (binfoTxToEncoding net) getBinfoBlockTx - -binfoBlockParseJSON :: Network -> Value -> Parser BinfoBlock -binfoBlockParseJSON net = A.withObject "block" $ \o -> do - getBinfoBlockHash <- o .: "hash" - getBinfoBlockVer <- o .: "ver" - getBinfoPrevBlock <- o .: "prev_block" - getBinfoMerkleRoot <- getTxHash <$> o .: "mrkl_root" - getBinfoBlockTime <- o .: "time" - getBinfoBlockBits <- o .: "bits" - getBinfoNextBlock <- o .: "next_block" - getBinfoBlockFee <- o .: "fee" - getBinfoBlockNonce <- o .: "nonce" - getBinfoBlockTxCount <- o .: "n_tx" - getBinfoBlockSize <- o .: "size" - getBinfoBlockIndex <- o .: "block_index" - getBinfoBlockMain <- o .: "main_chain" - getBinfoBlockHeight <- o .: "height" - getBinfoBlockWeight <- o .: "weight" - getBinfoBlockTx <- o .: "tx" >>= mapM (binfoTxParseJSON net) - return BinfoBlock{..} - -data BinfoTx = BinfoTx - { getBinfoTxHash :: !TxHash - , getBinfoTxVer :: !Word32 - , getBinfoTxVinSz :: !Word32 - , getBinfoTxVoutSz :: !Word32 - , getBinfoTxSize :: !Word32 - , getBinfoTxWeight :: !Word32 - , getBinfoTxFee :: !Word64 - , getBinfoTxRelayedBy :: !ByteString - , getBinfoTxLockTime :: !Word32 - , getBinfoTxIndex :: !BinfoTxId - , getBinfoTxDoubleSpend :: !Bool - , getBinfoTxRBF :: !Bool - , getBinfoTxResultBal :: !(Maybe (Int64, Int64)) - , getBinfoTxTime :: !Word64 - , getBinfoTxBlockIndex :: !(Maybe Word32) - , getBinfoTxBlockHeight :: !(Maybe Word32) - , getBinfoTxInputs :: [BinfoTxInput] - , getBinfoTxOutputs :: [BinfoTxOutput] - } - deriving (Eq, Show, Generic, NFData) - -binfoTxToJSON :: Network -> BinfoTx -> Value -binfoTxToJSON net BinfoTx{..} = - A.object $ - [ "hash" .= getBinfoTxHash - , "ver" .= getBinfoTxVer - , "vin_sz" .= getBinfoTxVinSz - , "vout_sz" .= getBinfoTxVoutSz - , "size" .= getBinfoTxSize - , "weight" .= getBinfoTxWeight - , "fee" .= getBinfoTxFee - , "relayed_by" .= TE.decodeUtf8 getBinfoTxRelayedBy - , "lock_time" .= getBinfoTxLockTime - , "tx_index" .= getBinfoTxIndex - , "double_spend" .= getBinfoTxDoubleSpend - , "time" .= getBinfoTxTime - , "block_index" .= getBinfoTxBlockIndex - , "block_height" .= getBinfoTxBlockHeight - , "inputs" .= map (binfoTxInputToJSON net) getBinfoTxInputs - , "out" .= map (binfoTxOutputToJSON net) getBinfoTxOutputs - ] - ++ bal - ++ rbf - where - bal = - case getBinfoTxResultBal of - Nothing -> [] - Just (res, bal') -> ["result" .= res, "balance" .= bal'] - rbf = ["rbf" .= True | getBinfoTxRBF] - -binfoTxToEncoding :: Network -> BinfoTx -> Encoding -binfoTxToEncoding net BinfoTx{..} = - AE.pairs $ - "hash" .= getBinfoTxHash - <> "ver" .= getBinfoTxVer - <> "vin_sz" .= getBinfoTxVinSz - <> "vout_sz" .= getBinfoTxVoutSz - <> "size" .= getBinfoTxSize - <> "weight" .= getBinfoTxWeight - <> "fee" .= getBinfoTxFee - <> "relayed_by" .= TE.decodeUtf8 getBinfoTxRelayedBy - <> "lock_time" .= getBinfoTxLockTime - <> "tx_index" .= getBinfoTxIndex - <> "double_spend" .= getBinfoTxDoubleSpend - <> "time" .= getBinfoTxTime - <> "block_index" .= getBinfoTxBlockIndex - <> "block_height" .= getBinfoTxBlockHeight - <> "inputs" `AE.pair` AE.list (binfoTxInputToEncoding net) getBinfoTxInputs - <> "out" `AE.pair` AE.list (binfoTxOutputToEncoding net) getBinfoTxOutputs - <> bal - <> rbf - where - bal = - case getBinfoTxResultBal of - Nothing -> mempty - Just (res, bal') -> "result" .= res <> "balance" .= bal' - rbf = if getBinfoTxRBF then "rbf" .= True else mempty - -binfoTxParseJSON :: Network -> Value -> Parser BinfoTx -binfoTxParseJSON net = A.withObject "tx" $ \o -> do - getBinfoTxHash <- o .: "hash" - getBinfoTxVer <- o .: "ver" - getBinfoTxVinSz <- o .: "vin_sz" - getBinfoTxVoutSz <- o .: "vout_sz" - getBinfoTxSize <- o .: "size" - getBinfoTxWeight <- o .: "weight" - getBinfoTxFee <- o .: "fee" - getBinfoTxRelayedBy <- TE.encodeUtf8 <$> o .: "relayed_by" - getBinfoTxLockTime <- o .: "lock_time" - getBinfoTxIndex <- o .: "tx_index" - getBinfoTxDoubleSpend <- o .: "double_spend" - getBinfoTxTime <- o .: "time" - getBinfoTxBlockIndex <- o .: "block_index" - getBinfoTxBlockHeight <- o .: "block_height" - getBinfoTxInputs <- o .: "inputs" >>= mapM (binfoTxInputParseJSON net) - getBinfoTxOutputs <- o .: "out" >>= mapM (binfoTxOutputParseJSON net) - getBinfoTxRBF <- o .:? "rbf" .!= False - res <- o .:? "result" - bal <- o .:? "balance" - let getBinfoTxResultBal = (,) <$> res <*> bal - return BinfoTx{..} - -data BinfoTxInput = BinfoTxInput - { getBinfoTxInputSeq :: !Word32 - , getBinfoTxInputWitness :: !ByteString - , getBinfoTxInputScript :: !ByteString - , getBinfoTxInputIndex :: !Word32 - , getBinfoTxInputPrevOut :: !BinfoTxOutput - } - deriving (Eq, Show, Generic, NFData) - -binfoTxInputToJSON :: Network -> BinfoTxInput -> Value -binfoTxInputToJSON net BinfoTxInput{..} = - A.object - [ "sequence" .= getBinfoTxInputSeq - , "witness" .= encodeHex getBinfoTxInputWitness - , "script" .= encodeHex getBinfoTxInputScript - , "index" .= getBinfoTxInputIndex - , "prev_out" .= binfoTxOutputToJSON net getBinfoTxInputPrevOut - ] - -binfoTxInputToEncoding :: Network -> BinfoTxInput -> Encoding -binfoTxInputToEncoding net BinfoTxInput{..} = - AE.pairs - ( "sequence" .= getBinfoTxInputSeq - <> "witness" .= encodeHex getBinfoTxInputWitness - <> "script" .= encodeHex getBinfoTxInputScript - <> "index" .= getBinfoTxInputIndex - <> "prev_out" .= binfoTxOutputToJSON net getBinfoTxInputPrevOut - ) - -binfoTxInputParseJSON :: Network -> Value -> Parser BinfoTxInput -binfoTxInputParseJSON net = A.withObject "txin" $ \o -> do - getBinfoTxInputSeq <- o .: "sequence" - getBinfoTxInputWitness <- - maybe mzero return . decodeHex - =<< o .: "witness" - getBinfoTxInputScript <- - maybe mzero return . decodeHex - =<< o .: "script" - getBinfoTxInputIndex <- o .: "index" - getBinfoTxInputPrevOut <- - o .: "prev_out" - >>= binfoTxOutputParseJSON net - return BinfoTxInput{..} - -data BinfoTxOutput = BinfoTxOutput - { getBinfoTxOutputType :: !Int - , getBinfoTxOutputSpent :: !Bool - , getBinfoTxOutputValue :: !Word64 - , getBinfoTxOutputIndex :: !Word32 - , getBinfoTxOutputTxIndex :: !BinfoTxId - , getBinfoTxOutputScript :: !ByteString - , getBinfoTxOutputSpenders :: ![BinfoSpender] - , getBinfoTxOutputAddress :: !(Maybe Address) - , getBinfoTxOutputXPub :: !(Maybe BinfoXPubPath) - } - deriving (Eq, Show, Generic, NFData) - -binfoTxOutputToJSON :: Network -> BinfoTxOutput -> Value -binfoTxOutputToJSON net BinfoTxOutput{..} = - A.object $ - [ "type" .= getBinfoTxOutputType - , "spent" .= getBinfoTxOutputSpent - , "value" .= getBinfoTxOutputValue - , "spending_outpoints" .= getBinfoTxOutputSpenders - , "n" .= getBinfoTxOutputIndex - , "tx_index" .= getBinfoTxOutputTxIndex - , "script" .= encodeHex getBinfoTxOutputScript - ] - <> [ "addr" .= addrToJSON net a - | a <- maybeToList getBinfoTxOutputAddress - ] - <> [ "xpub" .= binfoXPubPathToJSON net x - | x <- maybeToList getBinfoTxOutputXPub - ] - -binfoTxOutputToEncoding :: Network -> BinfoTxOutput -> Encoding -binfoTxOutputToEncoding net BinfoTxOutput{..} = - AE.pairs $ - mconcat $ - [ "type" .= getBinfoTxOutputType - , "spent" .= getBinfoTxOutputSpent - , "value" .= getBinfoTxOutputValue - , "spending_outpoints" .= getBinfoTxOutputSpenders - , "n" .= getBinfoTxOutputIndex - , "tx_index" .= getBinfoTxOutputTxIndex - , "script" .= encodeHex getBinfoTxOutputScript - ] - <> [ "addr" .= addrToJSON net a - | a <- maybeToList getBinfoTxOutputAddress - ] - <> [ "xpub" .= binfoXPubPathToJSON net x - | x <- maybeToList getBinfoTxOutputXPub - ] - -binfoTxOutputParseJSON :: Network -> Value -> Parser BinfoTxOutput -binfoTxOutputParseJSON net = A.withObject "txout" $ \o -> do - getBinfoTxOutputType <- o .: "type" - getBinfoTxOutputSpent <- o .: "spent" - getBinfoTxOutputValue <- o .: "value" - getBinfoTxOutputSpenders <- o .: "spending_outpoints" - getBinfoTxOutputIndex <- o .: "n" - getBinfoTxOutputTxIndex <- o .: "tx_index" - getBinfoTxOutputScript <- maybe mzero return . decodeHex =<< o .: "script" - getBinfoTxOutputAddress <- o .:? "addr" >>= mapM (addrFromJSON net) - getBinfoTxOutputXPub <- o .:? "xpub" >>= mapM (binfoXPubPathParseJSON net) - return BinfoTxOutput{..} - -data BinfoSpender = BinfoSpender - { getBinfoSpenderTxIndex :: !BinfoTxId - , getBinfoSpenderIndex :: !Word32 - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoSpender where - toJSON BinfoSpender{..} = - A.object - [ "tx_index" .= getBinfoSpenderTxIndex - , "n" .= getBinfoSpenderIndex - ] - toEncoding BinfoSpender{..} = - AE.pairs - ( "tx_index" .= getBinfoSpenderTxIndex - <> "n" .= getBinfoSpenderIndex - ) - -instance FromJSON BinfoSpender where - parseJSON = A.withObject "spender" $ \o -> do - getBinfoSpenderTxIndex <- o .: "tx_index" - getBinfoSpenderIndex <- o .: "n" - return BinfoSpender{..} - -data BinfoXPubPath = BinfoXPubPath - { getBinfoXPubPathKey :: !XPubKey - , getBinfoXPubPathDeriv :: !SoftPath - } - deriving (Eq, Show, Generic, NFData) - -instance Ord BinfoXPubPath where - compare = compare `on` f - where - f b = - ( xPubParent (getBinfoXPubPathKey b) - , getBinfoXPubPathDeriv b - ) - -binfoXPubPathToJSON :: Network -> BinfoXPubPath -> Value -binfoXPubPathToJSON net BinfoXPubPath{..} = - A.object - [ "m" .= xPubToJSON net getBinfoXPubPathKey - , "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) - ] - -binfoXPubPathToEncoding :: Network -> BinfoXPubPath -> Encoding -binfoXPubPathToEncoding net BinfoXPubPath{..} = - AE.pairs $ - "m" `AE.pair` xPubToEncoding net getBinfoXPubPathKey - <> "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) - -binfoXPubPathParseJSON :: Network -> Value -> Parser BinfoXPubPath -binfoXPubPathParseJSON net = A.withObject "xpub" $ \o -> do - getBinfoXPubPathKey <- o .: "m" >>= xPubFromJSON net - getBinfoXPubPathDeriv <- - fromMaybe "bad xpub path" . parseSoft <$> o .: "path" - return BinfoXPubPath{..} - -data BinfoInfo = BinfoInfo - { getBinfoConnected :: !Word32 - , getBinfoConversion :: !Double - , getBinfoLocal :: !BinfoSymbol - , getBinfoBTC :: !BinfoSymbol - , getBinfoLatestBlock :: !BinfoBlockInfo - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoInfo where - toJSON BinfoInfo{..} = - A.object - [ "nconnected" .= getBinfoConnected - , "conversion" .= getBinfoConversion - , "symbol_local" .= getBinfoLocal - , "symbol_btc" .= getBinfoBTC - , "latest_block" .= getBinfoLatestBlock - ] - toEncoding BinfoInfo{..} = - AE.pairs - ( "nconnected" .= getBinfoConnected - <> "conversion" .= getBinfoConversion - <> "symbol_local" .= getBinfoLocal - <> "symbol_btc" .= getBinfoBTC - <> "latest_block" .= getBinfoLatestBlock - ) - -instance FromJSON BinfoInfo where - parseJSON = A.withObject "info" $ \o -> do - getBinfoConnected <- o .: "nconnected" - getBinfoConversion <- o .: "conversion" - getBinfoLocal <- o .: "symbol_local" - getBinfoBTC <- o .: "symbol_btc" - getBinfoLatestBlock <- o .: "latest_block" - return BinfoInfo{..} - -data BinfoBlockInfo = BinfoBlockInfo - { getBinfoBlockInfoHash :: !BlockHash - , getBinfoBlockInfoHeight :: !BlockHeight - , getBinfoBlockInfoTime :: !Word32 - , getBinfoBlockInfoIndex :: !BlockHeight - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoBlockInfo where - toJSON BinfoBlockInfo{..} = - A.object - [ "hash" .= getBinfoBlockInfoHash - , "height" .= getBinfoBlockInfoHeight - , "time" .= getBinfoBlockInfoTime - , "block_index" .= getBinfoBlockInfoIndex - ] - toEncoding BinfoBlockInfo{..} = - AE.pairs - ( "hash" .= getBinfoBlockInfoHash - <> "height" .= getBinfoBlockInfoHeight - <> "time" .= getBinfoBlockInfoTime - <> "block_index" .= getBinfoBlockInfoIndex - ) - -instance FromJSON BinfoBlockInfo where - parseJSON = A.withObject "block_info" $ \o -> do - getBinfoBlockInfoHash <- o .: "hash" - getBinfoBlockInfoHeight <- o .: "height" - getBinfoBlockInfoTime <- o .: "time" - getBinfoBlockInfoIndex <- o .: "block_index" - return BinfoBlockInfo{..} - -toBinfoBlockInfo :: BlockData -> BinfoBlockInfo -toBinfoBlockInfo BlockData{..} = - BinfoBlockInfo - { getBinfoBlockInfoHash = headerHash blockDataHeader - , getBinfoBlockInfoHeight = blockDataHeight - , getBinfoBlockInfoTime = blockTimestamp blockDataHeader - , getBinfoBlockInfoIndex = blockDataHeight - } - -data BinfoRate = BinfoRate - { binfoRateTime :: !Word64 - , binfoRatePrice :: !Double - , binfoRateVol24 :: !Double - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoRate where - toJSON BinfoRate{..} = - A.object - [ "timestamp" .= binfoRateTime - , "price" .= binfoRatePrice - , "volume24h" .= binfoRateVol24 - ] - -instance FromJSON BinfoRate where - parseJSON = A.withObject "price" $ \o -> do - binfoRateTime <- o .: "timestamp" - binfoRatePrice <- o .: "price" - binfoRateVol24 <- o .: "volume24h" - return BinfoRate{..} - -data BinfoHistory = BinfoHistory - { binfoHistoryDate :: !Text - , binfoHistoryTime :: !Text - , binfoHistoryType :: !Text - , binfoHistoryAmount :: !Double - , binfoHistoryValueThen :: !Double - , binfoHistoryValueNow :: !Double - , binfoHistoryExchangeRateThen :: !Double - , binfoHistoryTx :: !TxHash - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoHistory where - toJSON BinfoHistory{..} = - A.object - [ "date" .= binfoHistoryDate - , "time" .= binfoHistoryTime - , "type" .= binfoHistoryType - , "amount" .= binfoHistoryAmount - , "value_then" .= binfoHistoryValueThen - , "value_now" .= binfoHistoryValueNow - , "exchange_rate_then" .= binfoHistoryExchangeRateThen - , "tx" .= binfoHistoryTx - ] - -instance FromJSON BinfoHistory where - parseJSON = A.withObject "history" $ \o -> do - binfoHistoryDate <- o .: "date" - binfoHistoryTime <- o .: "time" - binfoHistoryType <- o .: "type" - binfoHistoryAmount <- o .: "amount" - binfoHistoryValueThen <- o .: "value_then" - binfoHistoryValueNow <- o .: "value_now" - binfoHistoryExchangeRateThen <- o .: "exchange_rate_then" - binfoHistoryTx <- o .: "tx" - return BinfoHistory{..} - -toBinfoHistory :: - Int64 -> - Word64 -> - Double -> - Double -> - TxHash -> - BinfoHistory -toBinfoHistory satoshi timestamp rate_then rate_now txhash = - BinfoHistory - { binfoHistoryDate = - T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" t - , binfoHistoryTime = - T.pack $ formatTime defaultTimeLocale "%H:%M:%S GMT %Ez" t - , binfoHistoryType = - if satoshi <= 0 then "sent" else "received" - , binfoHistoryAmount = - fromRational v - , binfoHistoryValueThen = - fromRational v1 - , binfoHistoryValueNow = - fromRational v2 - , binfoHistoryExchangeRateThen = - rate_then - , binfoHistoryTx = - txhash - } - where - t = posixSecondsToUTCTime (realToFrac timestamp) - v = toRational satoshi / (100 * 1000 * 1000) - r1 = toRational rate_then - r2 = toRational rate_now - v1 = v * r1 - v2 = v * r2 - -newtype BinfoDate = BinfoDate Word64 - deriving (Eq, Show, Read, Generic, NFData) - -instance Parsable BinfoDate where - parseParam t = - maybeToEither "Cannot parse date" - . fmap (BinfoDate . round . utcTimeToPOSIXSeconds) - $ p "%d-%m-%Y" <|> p "%d/%m/%Y" - where - s = TL.unpack t - p fmt = parseTimeM False defaultTimeLocale fmt s - -data BinfoTicker = BinfoTicker - { binfoTicker15m :: !Double - , binfoTickerLast :: !Double - , binfoTickerBuy :: !Double - , binfoTickerSell :: !Double - , binfoTickerSymbol :: !Text - } - deriving (Eq, Show, Generic, NFData) - -instance Default BinfoTicker where - def = - BinfoTicker - { binfoTickerSymbol = "XXX" - , binfoTicker15m = 0.0 - , binfoTickerLast = 0.0 - , binfoTickerBuy = 0.0 - , binfoTickerSell = 0.0 - } - -instance ToJSON BinfoTicker where - toJSON BinfoTicker{..} = - A.object - [ "symbol" .= binfoTickerSymbol - , "sell" .= binfoTickerSell - , "buy" .= binfoTickerBuy - , "last" .= binfoTickerLast - , "15m" .= binfoTicker15m - ] - toEncoding BinfoTicker{..} = - AE.pairs $ - "symbol" .= binfoTickerSymbol - <> "sell" .= binfoTickerSell - <> "buy" .= binfoTickerBuy - <> "last" .= binfoTickerLast - <> "15m" .= binfoTicker15m - -instance FromJSON BinfoTicker where - parseJSON = A.withObject "ticker" $ \o -> do - binfoTickerSymbol <- o .: "symbol" - binfoTicker15m <- o .: "15m" - binfoTickerSell <- o .: "sell" - binfoTickerBuy <- o .: "buy" - binfoTickerLast <- o .: "last" - return BinfoTicker{..} - -data BinfoSymbol = BinfoSymbol - { getBinfoSymbolCode :: !Text - , getBinfoSymbolString :: !Text - , getBinfoSymbolName :: !Text - , getBinfoSymbolConversion :: !Double - , getBinfoSymbolAfter :: !Bool - , getBinfoSymbolLocal :: !Bool - } - deriving (Eq, Show, Generic, NFData) - -instance Default BinfoSymbol where - def = - BinfoSymbol - { getBinfoSymbolCode = "XXX" - , getBinfoSymbolString = "¤" - , getBinfoSymbolName = "No currency" - , getBinfoSymbolConversion = 0.0 - , getBinfoSymbolAfter = False - , getBinfoSymbolLocal = True - } - -instance ToJSON BinfoSymbol where - toJSON BinfoSymbol{..} = - A.object - [ "code" .= getBinfoSymbolCode - , "symbol" .= getBinfoSymbolString - , "name" .= getBinfoSymbolName - , "conversion" .= getBinfoSymbolConversion - , "symbolAppearsAfter" .= getBinfoSymbolAfter - , "local" .= getBinfoSymbolLocal - ] - toEncoding BinfoSymbol{..} = - AE.pairs - ( "code" .= getBinfoSymbolCode - <> "symbol" .= getBinfoSymbolString - <> "name" .= getBinfoSymbolName - <> "conversion" .= getBinfoSymbolConversion - <> "symbolAppearsAfter" .= getBinfoSymbolAfter - <> "local" .= getBinfoSymbolLocal - ) - -instance FromJSON BinfoSymbol where - parseJSON = A.withObject "symbol" $ \o -> do - getBinfoSymbolCode <- o .: "code" - getBinfoSymbolString <- o .: "symbol" - getBinfoSymbolName <- o .: "name" - getBinfoSymbolConversion <- o .: "conversion" - getBinfoSymbolAfter <- o .: "symbolAppearsAfter" - getBinfoSymbolLocal <- o .: "local" - return BinfoSymbol{..} - -relevantTxs :: - HashSet Address -> - Bool -> - Transaction -> - HashSet TxHash -relevantTxs addrs prune t@Transaction{..} = - let p a = prune && getTxResult addrs t > 0 && not (HashSet.member a addrs) - f StoreOutput{..} = - case outputSpender of - Nothing -> Nothing - Just Spender{..} -> - case outputAddr of - Nothing -> Nothing - Just a - | p a -> Nothing - | otherwise -> Just spenderHash - outs = mapMaybe f transactionOutputs - g StoreCoinbase{} = Nothing - g StoreInput{inputPoint = OutPoint{..}} = Just outPointHash - ins = mapMaybe g transactionInputs - in HashSet.fromList $ ins <> outs - -toBinfoAddrs :: - HashMap Address Balance -> - HashMap XPubSpec [XPubBal] -> - HashMap XPubSpec Word64 -> - [BinfoBalance] -toBinfoAddrs only_addrs only_xpubs xpub_txs = - xpub_bals <> addr_bals - where - xpub_bal k xs = - let f x = case xPubBalPath x of - [0, _] -> balanceTotalReceived (xPubBal x) - _ -> 0 - g x = balanceAmount (xPubBal x) + balanceZero (xPubBal x) - i m x = case xPubBalPath x of - [m', n] | m == m' -> n + 1 - _ -> 0 - received = sum (map f xs) - bal = fromIntegral (sum (map g xs)) - sent = if bal <= received then received - bal else 0 - count = HashMap.lookupDefault 0 k xpub_txs - ax = foldl max 0 (map (i 0) xs) - cx = foldl max 0 (map (i 1) xs) - in BinfoXPubBalance - { getBinfoXPubKey = xPubSpecKey k - , getBinfoAddrTxCount = count - , getBinfoAddrReceived = received - , getBinfoAddrSent = sent - , getBinfoAddrBalance = bal - , getBinfoXPubAccountIndex = ax - , getBinfoXPubChangeIndex = cx - } - xpub_bals = map (uncurry xpub_bal) (HashMap.toList only_xpubs) - addr_bals = - let f Balance{..} = - let addr = balanceAddress - sent = recv - bal - recv = balanceTotalReceived - tx_count = balanceTxCount - bal = balanceAmount + balanceZero - in BinfoAddrBalance - { getBinfoAddress = addr - , getBinfoAddrTxCount = tx_count - , getBinfoAddrReceived = recv - , getBinfoAddrSent = sent - , getBinfoAddrBalance = bal - } - in map f $ HashMap.elems only_addrs - -toBinfoTxSimple :: - Bool -> - Transaction -> - BinfoTx -toBinfoTxSimple numtxid = - toBinfoTx numtxid HashMap.empty False 0 - -toBinfoTxInputs :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Transaction -> - [BinfoTxInput] -toBinfoTxInputs numtxid abook t = - zipWith f [0 ..] (transactionInputs t) - where - f n i = - BinfoTxInput - { getBinfoTxInputIndex = n - , getBinfoTxInputSeq = inputSequence i - , getBinfoTxInputScript = inputSigScript i - , getBinfoTxInputWitness = wit i - , getBinfoTxInputPrevOut = prev n i - } - wit i = - case inputWitness i of - [] -> BS.empty - ws -> runPutS (put_witness ws) - prev = inputToBinfoTxOutput numtxid abook t - put_witness ws = do - putVarInt (length ws) - mapM_ put_item ws - put_item bs = do - putVarInt (BS.length bs) - putByteString bs - -toBinfoBlockIndex :: Transaction -> Maybe BlockHeight -toBinfoBlockIndex Transaction{transactionDeleted = True} = Nothing -toBinfoBlockIndex Transaction{transactionBlock = MemRef _} = Nothing -toBinfoBlockIndex Transaction{transactionBlock = BlockRef h _} = Just h - -toBinfoTx :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Bool -> - Int64 -> - Transaction -> - BinfoTx -toBinfoTx numtxid abook prune bal t@Transaction{..} = - BinfoTx - { getBinfoTxHash = txHash (transactionData t) - , getBinfoTxVer = transactionVersion - , getBinfoTxVinSz = fromIntegral (length transactionInputs) - , getBinfoTxVoutSz = fromIntegral (length transactionOutputs) - , getBinfoTxSize = transactionSize - , getBinfoTxWeight = transactionWeight - , getBinfoTxFee = transactionFees - , getBinfoTxRelayedBy = "0.0.0.0" - , getBinfoTxLockTime = transactionLockTime - , getBinfoTxIndex = - encodeBinfoTxId numtxid (txHash (transactionData t)) - , getBinfoTxDoubleSpend = transactionDeleted - , getBinfoTxRBF = transactionRBF - , getBinfoTxTime = transactionTime - , getBinfoTxBlockIndex = toBinfoBlockIndex t - , getBinfoTxBlockHeight = toBinfoBlockIndex t - , getBinfoTxInputs = toBinfoTxInputs numtxid abook t - , getBinfoTxOutputs = outs - , getBinfoTxResultBal = resbal - } - where - simple = HashMap.null abook && bal == 0 - resbal = if simple then Nothing else Just (getTxResult aset t, bal) - aset = HashMap.keysSet abook - outs = - let p = prune && getTxResult aset t > 0 - f = toBinfoTxOutput numtxid abook p t - in catMaybes $ zipWith f [0 ..] transactionOutputs - -getTxResult :: HashSet Address -> Transaction -> Int64 -getTxResult aset Transaction{..} = - let input_sum = sum $ map input_value transactionInputs - input_value StoreCoinbase{} = 0 - input_value StoreInput{..} = - case inputAddress of - Nothing -> 0 - Just a -> - if test_addr a - then negate $ fromIntegral inputAmount - else 0 - test_addr a = HashSet.member a aset - output_sum = sum $ map out_value transactionOutputs - out_value StoreOutput{..} = - case outputAddr of - Nothing -> 0 - Just a -> - if test_addr a - then fromIntegral outputAmount - else 0 - in input_sum + output_sum - -toBinfoTxOutput :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Bool -> - Transaction -> - Word32 -> - StoreOutput -> - Maybe BinfoTxOutput -toBinfoTxOutput numtxid abook prune t n StoreOutput{..} = - let getBinfoTxOutputType = 0 - getBinfoTxOutputSpent = isJust outputSpender - getBinfoTxOutputValue = outputAmount - getBinfoTxOutputIndex = n - getBinfoTxOutputTxIndex = - encodeBinfoTxId numtxid (txHash (transactionData t)) - getBinfoTxOutputScript = outputScript - getBinfoTxOutputSpenders = - maybeToList $ toBinfoSpender numtxid <$> outputSpender - getBinfoTxOutputAddress = outputAddr - getBinfoTxOutputXPub = - outputAddr >>= join . (`HashMap.lookup` abook) - in if prune && isNothing (outputAddr >>= (`HashMap.lookup` abook)) - then Nothing - else Just BinfoTxOutput{..} - -toBinfoSpender :: Bool -> Spender -> BinfoSpender -toBinfoSpender numtxid Spender{..} = - let getBinfoSpenderTxIndex = encodeBinfoTxId numtxid spenderHash - getBinfoSpenderIndex = spenderIndex - in BinfoSpender{..} - -inputToBinfoTxOutput :: - Bool -> - HashMap Address (Maybe BinfoXPubPath) -> - Transaction -> - Word32 -> - StoreInput -> - BinfoTxOutput -inputToBinfoTxOutput numtxid abook t n i = - BinfoTxOutput - { getBinfoTxOutputIndex = out_index - , getBinfoTxOutputType = 0 - , getBinfoTxOutputSpent = True - , getBinfoTxOutputValue = inputAmount - , getBinfoTxOutputTxIndex = encodeBinfoTxId numtxid out_hash - , getBinfoTxOutputScript = inputPkScript - , getBinfoTxOutputSpenders = [spender] - , getBinfoTxOutputAddress = inputAddress - , getBinfoTxOutputXPub = xpub - } - where - inputAmount = - case i of - StoreCoinbase{} -> 0 - StoreInput{..} -> inputAmount - inputPkScript = - case i of - StoreCoinbase{} -> BS.empty - StoreInput{..} -> inputPkScript - inputAddress = - case i of - StoreCoinbase{} -> Nothing - StoreInput{..} -> inputAddress - OutPoint out_hash out_index = inputPoint i - spender = - BinfoSpender - (encodeBinfoTxId numtxid (txHash (transactionData t))) - n - xpub = inputAddress >>= join . (`HashMap.lookup` abook) - -data BinfoAddr - = BinfoAddr !Address - | BinfoXpub !XPubKey - deriving (Eq, Show, Generic, Hashable, NFData) - -parseBinfoAddr :: Network -> Text -> Maybe [BinfoAddr] -parseBinfoAddr _ "" = Just [] -parseBinfoAddr net s = - mapM f $ - filter (not . T.null) $ - concatMap (T.splitOn ",") (T.splitOn "|" s) - where - f x = BinfoAddr <$> textToAddr net x <|> BinfoXpub <$> xPubImport net x - -data BinfoHeader = BinfoHeader - { binfoHeaderHash :: !BlockHash - , binfoHeaderTime :: !Timestamp - , binfoHeaderIndex :: !Word32 - , binfoHeaderHeight :: !BlockHeight - , binfoTxIndices :: ![BinfoTxId] - } - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoHeader where - toJSON BinfoHeader{..} = - A.object - [ "hash" .= binfoHeaderHash - , "time" .= binfoHeaderTime - , "block_index" .= binfoHeaderIndex - , "height" .= binfoHeaderHeight - , "txIndexes" .= binfoTxIndices - ] - -instance FromJSON BinfoHeader where - parseJSON = A.withObject "header" $ \o -> do - binfoHeaderHash <- o .: "hash" - binfoHeaderTime <- o .: "time" - binfoHeaderIndex <- o .: "block_index" - binfoHeaderHeight <- o .: "height" - binfoTxIndices <- o .: "txIndexes" - return BinfoHeader{..} - -newtype BinfoMempool = BinfoMempool {getBinfoMempool :: [BinfoTx]} - deriving (Eq, Show, Generic, NFData) - -binfoMempoolToJSON :: Network -> BinfoMempool -> Value -binfoMempoolToJSON net (BinfoMempool txs) = - A.object ["txs" .= map (binfoTxToJSON net) txs] - -binfoMempoolToEncoding :: Network -> BinfoMempool -> Encoding -binfoMempoolToEncoding net (BinfoMempool txs) = - AE.pairs $ AE.pair "txs" (AE.list (binfoTxToEncoding net) txs) - -binfoMempoolParseJSON :: Network -> Value -> Parser BinfoMempool -binfoMempoolParseJSON net = - A.withObject "mempool" $ \o -> - BinfoMempool <$> (mapM (binfoTxParseJSON net) =<< o .: "txs") - -newtype BinfoBlocks = BinfoBlocks {binfoBlocks :: [BinfoBlockInfo]} - deriving (Eq, Show, Generic, NFData) - -instance ToJSON BinfoBlocks where - toJSON BinfoBlocks{..} = A.object ["blocks" .= binfoBlocks] - -instance FromJSON BinfoBlocks where - parseJSON = A.withObject "blocks" $ \o -> BinfoBlocks <$> o .: "blocks" +module Haskoin.Store.Data + ( -- * Address Balances + Balance (..), + balanceToJSON, + balanceToEncoding, + balanceParseJSON, + zeroBalance, + nullBalance, + + -- * Block Data + BlockData (..), + blockDataToJSON, + blockDataToEncoding, + confirmed, + + -- * Transactions + TxRef (..), + TxData (..), + Transaction (..), + transactionToJSON, + transactionToEncoding, + transactionParseJSON, + transactionData, + fromTransaction, + toTransaction, + StoreInput (..), + storeInputToJSON, + storeInputToEncoding, + storeInputParseJSON, + isCoinbase, + StoreOutput (..), + storeOutputToJSON, + storeOutputToEncoding, + storeOutputParseJSON, + Prev (..), + Spender (..), + BlockRef (..), + UnixTime, + getUnixTime, + putUnixTime, + BlockPos, + + -- * Unspent Outputs + Unspent (..), + unspentToJSON, + unspentToEncoding, + unspentParseJSON, + + -- * Extended Public Keys + XPubSpec (..), + XPubBal (..), + xPubBalToJSON, + xPubBalToEncoding, + xPubBalParseJSON, + XPubUnspent (..), + xPubUnspentToJSON, + xPubUnspentToEncoding, + xPubUnspentParseJSON, + XPubSummary (..), + DeriveType (..), + textToDeriveType, + deriveTypeToText, + + -- * Other Data + TxId (..), + GenericResult (..), + SerialList (..), + RawResult (..), + RawResultList (..), + PeerInformation (..), + Healthy (..), + BlockHealth (..), + TimeHealth (..), + CountHealth (..), + MaxHealth (..), + HealthCheck (..), + Event (..), + Except (..), + + -- * Blockchain.info API + BinfoBlockId (..), + BinfoTxId (..), + encodeBinfoTxId, + BinfoFilter (..), + BinfoMultiAddr (..), + binfoMultiAddrToJSON, + binfoMultiAddrToEncoding, + binfoMultiAddrParseJSON, + BinfoShortBal (..), + BinfoBalance (..), + toBinfoAddrs, + binfoBalanceToJSON, + binfoBalanceToEncoding, + binfoBalanceParseJSON, + BinfoRawAddr (..), + binfoRawAddrToJSON, + binfoRawAddrToEncoding, + binfoRawAddrParseJSON, + BinfoAddr (..), + parseBinfoAddr, + BinfoWallet (..), + BinfoUnspent (..), + binfoUnspentToJSON, + binfoUnspentToEncoding, + binfoUnspentParseJSON, + binfoHexValue, + BinfoUnspents (..), + binfoUnspentsToJSON, + binfoUnspentsToEncoding, + binfoUnspentsParseJSON, + BinfoBlock (..), + toBinfoBlock, + binfoBlockToJSON, + binfoBlockToEncoding, + binfoBlockParseJSON, + binfoBlocksToJSON, + binfoBlocksToEncoding, + binfoBlocksParseJSON, + BinfoTx (..), + relevantTxs, + toBinfoTx, + toBinfoTxSimple, + binfoTxToJSON, + binfoTxToEncoding, + binfoTxParseJSON, + BinfoTxInput (..), + binfoTxInputToJSON, + binfoTxInputToEncoding, + binfoTxInputParseJSON, + BinfoTxOutput (..), + binfoTxOutputToJSON, + binfoTxOutputToEncoding, + binfoTxOutputParseJSON, + BinfoSpender (..), + BinfoXPubPath (..), + binfoXPubPathToJSON, + binfoXPubPathToEncoding, + binfoXPubPathParseJSON, + BinfoInfo (..), + BinfoBlockInfo (..), + toBinfoBlockInfo, + BinfoSymbol (..), + BinfoTicker (..), + BinfoRate (..), + BinfoHistory (..), + toBinfoHistory, + BinfoDate (..), + BinfoHeader (..), + BinfoMempool (..), + binfoMempoolToJSON, + binfoMempoolToEncoding, + binfoMempoolParseJSON, + BinfoBlocks (..), + ) +where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData) +import Control.Exception (Exception) +import Control.Monad (join, mzero, unless, (<=<)) +import Data.Aeson + ( Encoding, + FromJSON (..), + ToJSON (..), + Value (..), + (.!=), + (.:), + (.:?), + (.=), + ) +import qualified Data.Aeson as A +import qualified Data.Aeson.Encoding as AE +import Data.Aeson.Types (Parser) +import Data.Binary (Binary (get, put)) +import Data.Bits (Bits (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import Data.Bytes.Get +import qualified Data.Bytes.Get as Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Default (Default (..)) +import Data.Foldable (toList) +import Data.Function (on) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Hashable (Hashable (..)) +import Data.Int (Int32, Int64) +import qualified Data.IntMap as IntMap +import Data.IntMap.Strict (IntMap) +import Data.Maybe + ( catMaybes, + fromMaybe, + isJust, + isNothing, + mapMaybe, + maybeToList, + ) +import Data.Serialize (Serialize (..)) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.Format + ( defaultTimeLocale, + formatTime, + parseTimeM, + ) +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import Haskoin hiding (inputAddress) +import Web.Scotty.Trans (Parsable (..), ScottyError (..)) + +data DeriveType + = DeriveNormal + | DeriveP2SH + | DeriveP2WPKH + deriving (Show, Eq, Generic, NFData) + +textToDeriveType :: Text -> Maybe DeriveType +textToDeriveType "normal" = Just DeriveNormal +textToDeriveType "compat" = Just DeriveP2SH +textToDeriveType "segwit" = Just DeriveP2WPKH +textToDeriveType _ = Nothing + +deriveTypeToText :: DeriveType -> Text +deriveTypeToText DeriveNormal = "normal" +deriveTypeToText DeriveP2SH = "compat" +deriveTypeToText DeriveP2WPKH = "segwit" + +instance Serial DeriveType where + serialize DeriveNormal = putWord8 0x00 + serialize DeriveP2SH = putWord8 0x01 + serialize DeriveP2WPKH = putWord8 0x02 + + deserialize = + getWord8 >>= \case + 0x00 -> return DeriveNormal + 0x01 -> return DeriveP2SH + 0x02 -> return DeriveP2WPKH + _ -> return DeriveNormal + +instance Binary DeriveType where + put = serialize + get = deserialize + +instance Serialize DeriveType where + put = serialize + get = deserialize + +instance Default DeriveType where + def = DeriveNormal + +instance Parsable DeriveType where + parseParam txt = + case textToDeriveType (TL.toStrict txt) of + Nothing -> Left "invalid derivation type" + Just x -> Right x + +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 Serial XPubSpec where + serialize XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do + putWord8 (xPubDepth k) + serialize (xPubParent k) + putWord32be (xPubIndex k) + serialize (xPubChain k) + serialize (wrapPubKey True (xPubKey k)) + serialize t + deserialize = do + d <- getWord8 + p <- deserialize + i <- getWord32be + c <- deserialize + k <- deserialize + t <- deserialize + let x = + XPubKey + { xPubDepth = d, + xPubParent = p, + xPubIndex = i, + xPubChain = c, + xPubKey = pubKeyPoint k + } + return XPubSpec {xPubSpecKey = x, xPubDeriveType = t} + +instance Serialize XPubSpec where + put = serialize + get = deserialize + +instance Binary XPubSpec where + put = serialize + get = deserialize + +type UnixTime = Word64 + +type BlockPos = Word32 + +-- | Binary such that ordering is inverted. +putUnixTime :: MonadPut m => Word64 -> m () +putUnixTime w = putWord64be $ maxBound - w + +getUnixTime :: MonadGet m => m Word64 +getUnixTime = (maxBound -) <$> getWord64be + +-- | Reference to a block where a transaction is stored. +data BlockRef + = BlockRef + { -- | block height in the chain + blockRefHeight :: !BlockHeight, + -- | position of transaction within the block + blockRefPos :: !Word32 + } + | MemRef + { memRefTime :: !UnixTime + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +-- | Serial entities will sort in reverse order. +instance Serial BlockRef where + serialize MemRef {memRefTime = t} = do + putWord8 0x00 + putUnixTime t + serialize BlockRef {blockRefHeight = h, blockRefPos = p} = do + putWord8 0x01 + putWord32be (maxBound - h) + putWord32be (maxBound - p) + deserialize = + getWord8 >>= \case + 0x00 -> getmemref + 0x01 -> getblockref + _ -> fail "Cannot decode BlockRef" + where + getmemref = do + MemRef <$> getUnixTime + getblockref = do + h <- (maxBound -) <$> getWord32be + p <- (maxBound -) <$> getWord32be + return BlockRef {blockRefHeight = h, blockRefPos = p} + +instance Serialize BlockRef where + put = serialize + get = deserialize + +instance Binary BlockRef where + put = serialize + get = deserialize + +confirmed :: BlockRef -> Bool +confirmed BlockRef {} = True +confirmed MemRef {} = False + +instance ToJSON BlockRef where + toJSON BlockRef {blockRefHeight = h, blockRefPos = p} = + A.object ["height" .= h, "position" .= p] + toJSON MemRef {memRefTime = t} = A.object ["mempool" .= t] + toEncoding BlockRef {blockRefHeight = h, blockRefPos = p} = + AE.pairs ("height" .= h <> "position" .= p) + toEncoding MemRef {memRefTime = t} = AE.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 TxRef = TxRef + { -- | block information + txRefBlock :: !BlockRef, + -- | transaction hash + txRefHash :: !TxHash + } + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance Serial TxRef where + serialize (TxRef b h) = do + serialize b + serialize h + + deserialize = + TxRef <$> deserialize <*> deserialize + +instance Binary TxRef where + put = serialize + get = deserialize + +instance Serialize TxRef where + put = serialize + get = deserialize + +instance ToJSON TxRef where + toJSON btx = + A.object + [ "txid" .= txRefHash btx, + "block" .= txRefBlock btx + ] + toEncoding btx = + AE.pairs $ + "txid" .= txRefHash btx + <> "block" .= txRefBlock btx + +instance FromJSON TxRef where + parseJSON = + A.withObject "blocktx" $ \o -> do + txid <- o .: "txid" + block <- o .: "block" + return TxRef {txRefBlock = block, txRefHash = txid} + +-- | Address balance information. +data Balance = Balance + { -- | address balance + balanceAddress :: !Address, + -- | confirmed balance + balanceAmount :: !Word64, + -- | unconfirmed balance + balanceZero :: !Word64, + -- | number of unspent outputs + balanceUnspentCount :: !Word64, + -- | number of transactions + balanceTxCount :: !Word64, + -- | total amount from all outputs in this address + balanceTotalReceived :: !Word64 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Balance where + serialize Balance {..} = do + serialize balanceAddress + putWord64be balanceAmount + putWord64be balanceZero + putWord64be balanceUnspentCount + putWord64be balanceTxCount + putWord64be balanceTotalReceived + + deserialize = do + balanceAddress <- deserialize + balanceAmount <- getWord64be + balanceZero <- getWord64be + balanceUnspentCount <- getWord64be + balanceTxCount <- getWord64be + balanceTotalReceived <- getWord64be + return Balance {..} + +instance Binary Balance where + put = serialize + get = deserialize + +instance Serialize Balance where + put = serialize + get = deserialize + +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 = + A.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 = + AE.pairs $ + "address" `AE.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 :: !ByteString, + unspentAddress :: !(Maybe Address) + } + deriving (Show, Eq, Generic, Hashable, NFData) + +-- | Follow same order as in database and cache by inverting outpoint sort +-- order. +instance Ord Unspent where + compare a b = + compare + (unspentBlock a, unspentPoint b) + (unspentBlock b, unspentPoint a) + +instance Serial Unspent where + serialize Unspent {..} = do + serialize unspentBlock + serialize unspentPoint + putWord64be unspentAmount + putLengthBytes unspentScript + putMaybe serialize unspentAddress + + deserialize = do + unspentBlock <- deserialize + unspentPoint <- deserialize + unspentAmount <- getWord64be + unspentScript <- getLengthBytes + unspentAddress <- getMaybe deserialize + return Unspent {..} + +instance Binary Unspent where + put = serialize + get = deserialize + +instance Serialize Unspent where + put = serialize + get = deserialize + +instance Coin Unspent where + coinValue = unspentAmount + +unspentToJSON :: Network -> Unspent -> Value +unspentToJSON net u = + A.object + [ "address" .= (addrToJSON net <$> unspentAddress u), + "block" .= unspentBlock u, + "txid" .= outPointHash (unspentPoint u), + "index" .= outPointIndex (unspentPoint u), + "pkscript" .= encodeHex (unspentScript u), + "value" .= unspentAmount u + ] + +unspentToEncoding :: Network -> Unspent -> Encoding +unspentToEncoding net u = + AE.pairs $ + "address" `AE.pair` maybe AE.null_ (addrToEncoding net) (unspentAddress u) + <> "block" .= unspentBlock u + <> "txid" .= outPointHash (unspentPoint u) + <> "index" .= outPointIndex (unspentPoint u) + <> "pkscript" `AE.pair` AE.text (encodeHex (unspentScript u)) + <> "value" .= unspentAmount u + +unspentParseJSON :: Network -> Value -> Parser Unspent +unspentParseJSON net = + A.withObject "unspent" $ \o -> do + block <- o .: "block" + txid <- o .: "txid" + index <- o .: "index" + value <- o .: "value" + script <- o .: "pkscript" >>= jsonHex + addr <- + o .: "address" >>= \case + Nothing -> return Nothing + Just a -> Just <$> addrFromJSON net a <|> return Nothing + return + Unspent + { unspentBlock = block, + unspentPoint = OutPoint txid index, + unspentAmount = value, + unspentScript = script, + unspentAddress = addr + } + +-- | Database value for a block entry. +data BlockData = BlockData + { -- | height of the block in the chain + blockDataHeight :: !BlockHeight, + -- | is this block in the main chain? + blockDataMainChain :: !Bool, + -- | accumulated work in that block + blockDataWork :: !Integer, + -- | block header + blockDataHeader :: !BlockHeader, + -- | size of the block including witnesses + blockDataSize :: !Word32, + -- | weight of this block (for segwit networks) + blockDataWeight :: !Word32, + -- | block transactions + blockDataTxs :: ![TxHash], + -- | sum of all transaction outputs + blockDataOutputs :: !Word64, + -- | sum of all transaction fees + blockDataFees :: !Word64, + -- | block subsidy + blockDataSubsidy :: !Word64 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial BlockData where + serialize BlockData {..} = do + putWord32be blockDataHeight + serialize blockDataMainChain + putInteger blockDataWork + serialize blockDataHeader + putWord32be blockDataSize + putWord32be blockDataWeight + putList serialize blockDataTxs + putWord64be blockDataOutputs + putWord64be blockDataFees + putWord64be blockDataSubsidy + + deserialize = do + blockDataHeight <- getWord32be + blockDataMainChain <- deserialize + blockDataWork <- getInteger + blockDataHeader <- deserialize + blockDataSize <- getWord32be + blockDataWeight <- getWord32be + blockDataTxs <- getList deserialize + blockDataOutputs <- getWord64be + blockDataFees <- getWord64be + blockDataSubsidy <- getWord64be + return BlockData {..} + +instance Serialize BlockData where + put = serialize + get = deserialize + +instance Binary BlockData where + put = serialize + get = deserialize + +blockDataToJSON :: Network -> BlockData -> Value +blockDataToJSON net bv = + A.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" .= blockDataWork bv + ] + <> ["weight" .= blockDataWeight bv | getSegWit net] + +blockDataToEncoding :: Network -> BlockData -> Encoding +blockDataToEncoding net bv = + AE.pairs $ + "hash" + `AE.pair` AE.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" + `AE.pair` AE.text + (txHashToHex (TxHash (merkleRoot (blockDataHeader bv)))) + <> "subsidy" .= blockDataSubsidy bv + <> "fees" .= blockDataFees bv + <> "outputs" .= blockDataOutputs bv + <> "work" .= blockDataWork bv + <> (if getSegWit net then "weight" .= blockDataWeight bv else mempty) + +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" .!= 0 + 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 :: !WitnessStack + } + | StoreInput + { inputPoint :: !OutPoint, + inputSequence :: !Word32, + inputSigScript :: !ByteString, + inputPkScript :: !ByteString, + inputAmount :: !Word64, + inputWitness :: !WitnessStack, + inputAddress :: !(Maybe Address) + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial StoreInput where + serialize StoreCoinbase {..} = do + putWord8 0x00 + serialize inputPoint + putWord32be inputSequence + putLengthBytes inputSigScript + putList putLengthBytes inputWitness + serialize StoreInput {..} = do + putWord8 0x01 + serialize inputPoint + putWord32be inputSequence + putLengthBytes inputSigScript + putLengthBytes inputPkScript + putWord64be inputAmount + putList putLengthBytes inputWitness + putMaybe serialize inputAddress + + deserialize = + getWord8 >>= \case + 0x00 -> do + inputPoint <- deserialize + inputSequence <- getWord32be + inputSigScript <- getLengthBytes + inputWitness <- getList getLengthBytes + return StoreCoinbase {..} + 0x01 -> do + inputPoint <- deserialize + inputSequence <- getWord32be + inputSigScript <- getLengthBytes + inputPkScript <- getLengthBytes + inputAmount <- getWord64be + inputWitness <- getList getLengthBytes + inputAddress <- getMaybe deserialize + return StoreInput {..} + x -> fail $ "Unknown input id: " <> cs (show x) + +instance Serialize StoreInput where + put = serialize + get = deserialize + +instance Binary StoreInput where + put = serialize + get = deserialize + +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, + inputAddress = a + } = + A.object + [ "coinbase" .= False, + "txid" .= oph, + "output" .= opi, + "sigscript" .= String (encodeHex ss), + "sequence" .= sq, + "pkscript" .= String (encodeHex ps), + "value" .= val, + "address" .= (addrToJSON net <$> a), + "witness" .= map encodeHex wit + ] +storeInputToJSON + _ + StoreCoinbase + { inputPoint = OutPoint oph opi, + inputSequence = sq, + inputSigScript = ss, + inputWitness = wit + } = + A.object + [ "coinbase" .= True, + "txid" .= oph, + "output" .= opi, + "sigscript" .= String (encodeHex ss), + "sequence" .= sq, + "pkscript" .= Null, + "value" .= Null, + "address" .= Null, + "witness" .= map encodeHex wit + ] + +storeInputToEncoding :: Network -> StoreInput -> Encoding +storeInputToEncoding + net + StoreInput + { inputPoint = OutPoint oph opi, + inputSequence = sq, + inputSigScript = ss, + inputPkScript = ps, + inputAmount = val, + inputWitness = wit, + inputAddress = a + } = + AE.pairs $ + "coinbase" .= False + <> "txid" .= oph + <> "output" .= opi + <> "sigscript" `AE.pair` AE.text (encodeHex ss) + <> "sequence" .= sq + <> "pkscript" `AE.pair` AE.text (encodeHex ps) + <> "value" .= val + <> "address" `AE.pair` maybe AE.null_ (addrToEncoding net) a + <> "witness" .= map encodeHex wit +storeInputToEncoding + _ + StoreCoinbase + { inputPoint = OutPoint oph opi, + inputSequence = sq, + inputSigScript = ss, + inputWitness = wit + } = + AE.pairs $ + "coinbase" .= True + <> "txid" `AE.pair` AE.text (txHashToHex oph) + <> "output" .= opi + <> "sigscript" `AE.pair` AE.text (encodeHex ss) + <> "sequence" .= sq + <> "pkscript" `AE.pair` AE.null_ + <> "value" `AE.pair` AE.null_ + <> "address" `AE.pair` AE.null_ + <> "witness" .= map encodeHex wit + +storeInputParseJSON :: Network -> Value -> Parser StoreInput +storeInputParseJSON net = + A.withObject "storeinput" $ \o -> do + coinbase <- o .: "coinbase" + outpoint <- OutPoint <$> o .: "txid" <*> o .: "output" + sequ <- o .: "sequence" + witness <- mapM jsonHex =<< o .:? "witness" .!= [] + 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" + addr <- + o .: "address" >>= \case + Nothing -> return Nothing + Just a -> Just <$> addrFromJSON net a <|> return Nothing + return + StoreInput + { inputPoint = outpoint, + inputSequence = sequ, + inputSigScript = sigscript, + inputPkScript = pkscript, + inputAmount = value, + inputWitness = witness, + inputAddress = addr + } + +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 + { -- | input transaction hash + spenderHash :: !TxHash, + -- | input position in transaction + spenderIndex :: !Word32 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Spender where + serialize Spender {..} = do + serialize spenderHash + putWord32be spenderIndex + deserialize = Spender <$> deserialize <*> getWord32be + +instance Serialize Spender where + put = serialize + get = deserialize + +instance Binary Spender where + put = serialize + get = deserialize + +instance ToJSON Spender where + toJSON n = + A.object + [ "txid" .= txHashToHex (spenderHash n), + "input" .= spenderIndex n + ] + toEncoding n = + AE.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), + outputAddr :: !(Maybe Address) + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance Serial StoreOutput where + serialize StoreOutput {..} = do + putWord64be outputAmount + putLengthBytes outputScript + putMaybe serialize outputSpender + putMaybe serialize outputAddr + deserialize = do + outputAmount <- getWord64be + outputScript <- getLengthBytes + outputSpender <- getMaybe deserialize + outputAddr <- getMaybe deserialize + return StoreOutput {..} + +instance Serialize StoreOutput where + put = serialize + get = deserialize + +instance Binary StoreOutput where + put = serialize + get = deserialize + +storeOutputToJSON :: Network -> StoreOutput -> Value +storeOutputToJSON net d = + A.object + [ "address" .= (addrToJSON net <$> outputAddr d), + "pkscript" .= encodeHex (outputScript d), + "value" .= outputAmount d, + "spent" .= isJust (outputSpender d), + "spender" .= outputSpender d + ] + +storeOutputToEncoding :: Network -> StoreOutput -> Encoding +storeOutputToEncoding net d = + AE.pairs $ + "address" `AE.pair` maybe AE.null_ (addrToEncoding net) (outputAddr d) + <> "pkscript" `AE.pair` AE.text (encodeHex (outputScript d)) + <> "value" .= outputAmount d + <> "spent" .= isJust (outputSpender d) + <> "spender" .= outputSpender d + +storeOutputParseJSON :: Network -> Value -> Parser StoreOutput +storeOutputParseJSON net = + A.withObject "storeoutput" $ \o -> do + value <- o .: "value" + pkscript <- o .: "pkscript" >>= jsonHex + spender <- o .: "spender" + addr <- + o .: "address" >>= \case + Nothing -> return Nothing + Just a -> Just <$> addrFromJSON net a <|> return Nothing + return + StoreOutput + { outputAmount = value, + outputScript = pkscript, + outputSpender = spender, + outputAddr = addr + } + +data Prev = Prev + { prevScript :: !ByteString, + prevAmount :: !Word64 + } + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Prev where + serialize Prev {..} = do + putLengthBytes prevScript + putWord64be prevAmount + deserialize = do + prevScript <- getLengthBytes + prevAmount <- getWord64be + return Prev {..} + +instance Binary Prev where + put = serialize + get = deserialize + +instance Serialize Prev where + put = serialize + get = deserialize + +toInput :: TxIn -> Maybe Prev -> 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, + inputAddress = eitherToMaybe (scriptToAddressBS (prevScript p)) + } + +toOutput :: TxOut -> Maybe Spender -> StoreOutput +toOutput o s = + StoreOutput + { outputAmount = outValue o, + outputScript = scriptOutput o, + outputSpender = s, + outputAddr = eitherToMaybe (scriptToAddressBS (scriptOutput o)) + } + +data TxData = TxData + { txDataBlock :: !BlockRef, + txData :: !Tx, + txDataPrevs :: !(IntMap Prev), + txDataDeleted :: !Bool, + txDataRBF :: !Bool, + txDataTime :: !Word64 + } + deriving (Show, Eq, Ord, Generic, NFData) + +instance Serial TxData where + serialize TxData {..} = do + serialize txDataBlock + serialize txData + putIntMap (putWord64be . fromIntegral) serialize txDataPrevs + serialize txDataDeleted + serialize txDataRBF + putWord64be txDataTime + deserialize = do + txDataBlock <- deserialize + txData <- deserialize + txDataPrevs <- getIntMap (fromIntegral <$> getWord64be) deserialize + txDataDeleted <- deserialize + txDataRBF <- deserialize + txDataTime <- getWord64be + return TxData {..} + +instance Serialize TxData where + put = serialize + get = deserialize + +instance Binary TxData where + put = serialize + get = deserialize + +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, + transactionId = txid, + transactionSize = txsize, + transactionWeight = txweight, + transactionFees = fees + } + where + txid = txHash (txData t) + txsize = fromIntegral $ BS.length (runPutS (serialize (txData t))) + txweight = + let b = BS.length $ runPutS $ serialize (txData t) {txWitness = []} + x = BS.length $ runPutS $ serialize (txData t) + in fromIntegral $ b * 3 + x + inv = sum (map inputAmount ins) + outv = sum (map outputAmount outs) + fees = if any isCoinbase ins then 0 else inv - outv + ws = take (length (txIn (txData t))) $ txWitness (txData t) <> repeat [] + f n i = toInput i (IntMap.lookup n (txDataPrevs t)) (ws !! n) + ins = zipWith f [0 ..] (txIn (txData t)) + g n o = toOutput o (IntMap.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 = IntMap.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t) + g _ StoreOutput {outputSpender = Nothing} = Nothing + g n StoreOutput {outputSpender = Just s} = Just (n, s) + sm = IntMap.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) + +-- | Detailed transaction information. +data Transaction = Transaction + { -- | block information for this transaction + transactionBlock :: !BlockRef, + -- | transaction version + transactionVersion :: !Word32, + -- | lock time + transactionLockTime :: !Word32, + -- | transaction inputs + transactionInputs :: ![StoreInput], + -- | transaction outputs + transactionOutputs :: ![StoreOutput], + -- | this transaction has been deleted and is no longer valid + transactionDeleted :: !Bool, + -- | this transaction can be replaced in the mempool + transactionRBF :: !Bool, + -- | time the transaction was first seen or time of block + transactionTime :: !Word64, + -- | transaction id + transactionId :: !TxHash, + -- | serialized transaction size (includes witness data) + transactionSize :: !Word32, + -- | transaction weight + transactionWeight :: !Word32, + -- | fees that this transaction pays (0 for coinbase) + transactionFees :: !Word64 + } + deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance Serial Transaction where + serialize Transaction {..} = do + serialize transactionBlock + putWord32be transactionVersion + putWord32be transactionLockTime + putList serialize transactionInputs + putList serialize transactionOutputs + serialize transactionDeleted + serialize transactionRBF + putWord64be transactionTime + serialize transactionId + putWord32be transactionSize + putWord32be transactionWeight + putWord64be transactionFees + deserialize = do + transactionBlock <- deserialize + transactionVersion <- getWord32be + transactionLockTime <- getWord32be + transactionInputs <- getList deserialize + transactionOutputs <- getList deserialize + transactionDeleted <- deserialize + transactionRBF <- deserialize + transactionTime <- getWord64be + transactionId <- deserialize + transactionSize <- getWord32be + transactionWeight <- getWord32be + transactionFees <- getWord64be + return Transaction {..} + +instance Serialize Transaction where + put = serialize + get = deserialize + +instance Binary Transaction where + put = serialize + get = deserialize + +transactionData :: Transaction -> Tx +transactionData t = + Tx + { txVersion = transactionVersion t, + txIn = map i (transactionInputs t), + txOut = map o (transactionOutputs t), + txWitness = w $ map 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} + w xs + | all null xs = [] + | otherwise = xs + +transactionToJSON :: Network -> Transaction -> Value +transactionToJSON net dtx = + A.object + [ "txid" .= transactionId dtx, + "size" .= transactionSize dtx, + "version" .= transactionVersion dtx, + "locktime" .= transactionLockTime dtx, + "fee" .= transactionFees dtx, + "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" .= transactionWeight dtx + ] + +transactionToEncoding :: Network -> Transaction -> Encoding +transactionToEncoding net dtx = + AE.pairs $ + "txid" .= transactionId dtx + <> "size" .= transactionSize dtx + <> "version" .= transactionVersion dtx + <> "locktime" .= transactionLockTime dtx + <> "fee" .= transactionFees dtx + <> "inputs" + `AE.pair` AE.list + (storeInputToEncoding net) + (transactionInputs dtx) + <> "outputs" + `AE.pair` AE.list + (storeOutputToEncoding net) + (transactionOutputs dtx) + <> "block" .= transactionBlock dtx + <> "deleted" .= transactionDeleted dtx + <> "time" .= transactionTime dtx + <> "rbf" .= transactionRBF dtx + <> "weight" .= transactionWeight dtx + +transactionParseJSON :: Network -> Value -> Parser Transaction +transactionParseJSON net = A.withObject "transaction" $ \o -> do + version <- o .: "version" + locktime <- o .: "locktime" + inputs <- o .: "inputs" >>= mapM (storeInputParseJSON net) + outputs <- o .: "outputs" >>= mapM (storeOutputParseJSON net) + block <- o .: "block" + deleted <- o .: "deleted" + time <- o .: "time" + rbf <- o .:? "rbf" .!= False + weight <- o .:? "weight" .!= 0 + size <- o .: "size" + txid <- o .: "txid" + fees <- o .: "fee" + return + Transaction + { transactionBlock = block, + transactionVersion = version, + transactionLockTime = locktime, + transactionInputs = inputs, + transactionOutputs = outputs, + transactionDeleted = deleted, + transactionTime = time, + transactionRBF = rbf, + transactionWeight = weight, + transactionSize = size, + transactionId = txid, + transactionFees = fees + } + +-- | Information about a connected peer. +data PeerInformation = PeerInformation + { -- | user agent string + peerUserAgent :: !ByteString, + -- | network address + peerAddress :: !String, + -- | version number + peerVersion :: !Word32, + -- | services field + peerServices :: !Word64, + -- | will relay transactions + peerRelay :: !Bool + } + deriving (Show, Eq, Ord, Generic, NFData) + +instance Serial PeerInformation where + serialize PeerInformation {..} = do + putLengthBytes peerUserAgent + putLengthBytes (TE.encodeUtf8 (T.pack peerAddress)) + putWord32be peerVersion + putWord64be peerServices + serialize peerRelay + deserialize = do + peerUserAgent <- getLengthBytes + peerAddress <- T.unpack . TE.decodeUtf8 <$> getLengthBytes + peerVersion <- getWord32be + peerServices <- getWord64be + peerRelay <- deserialize + return PeerInformation {..} + +instance Serialize PeerInformation where + put = serialize + get = deserialize + +instance Binary PeerInformation where + put = serialize + get = deserialize + +instance ToJSON PeerInformation where + toJSON p = + A.object + [ "useragent" .= String (cs (peerUserAgent p)), + "address" .= peerAddress p, + "version" .= peerVersion p, + "services" + .= String (encodeHex (runPutS (serialize (peerServices p)))), + "relay" .= peerRelay p + ] + toEncoding p = + AE.pairs $ + "useragent" `AE.pair` AE.text (cs (peerUserAgent p)) + <> "address" .= peerAddress p + <> "version" .= peerVersion p + <> "services" + `AE.pair` AE.text + (encodeHex (runPutS (serialize (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 runGetS deserialize 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, NFData) + +instance Serial XPubBal where + serialize XPubBal {..} = do + putList putWord32be xPubBalPath + serialize xPubBal + deserialize = do + xPubBalPath <- getList getWord32be + xPubBal <- deserialize + return XPubBal {..} + +instance Serialize XPubBal where + put = serialize + get = deserialize + +instance Binary XPubBal where + put = serialize + get = deserialize + +xPubBalToJSON :: Network -> XPubBal -> Value +xPubBalToJSON net XPubBal {xPubBalPath = p, xPubBal = b} = + A.object ["path" .= p, "balance" .= balanceToJSON net b] + +xPubBalToEncoding :: Network -> XPubBal -> Encoding +xPubBalToEncoding net XPubBal {xPubBalPath = p, xPubBal = b} = + AE.pairs ("path" .= p <> "balance" `AE.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 + { xPubUnspent :: !Unspent, + xPubUnspentPath :: ![KeyIndex] + } + deriving (Show, Eq, Ord, Generic, NFData) + +instance Serial XPubUnspent where + serialize XPubUnspent {..} = do + putList putWord32be xPubUnspentPath + serialize xPubUnspent + deserialize = do + xPubUnspentPath <- getList getWord32be + xPubUnspent <- deserialize + return XPubUnspent {..} + +instance Serialize XPubUnspent where + put = serialize + get = deserialize + +instance Binary XPubUnspent where + put = serialize + get = deserialize + +xPubUnspentToJSON :: Network -> XPubUnspent -> Value +xPubUnspentToJSON net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = + A.object ["unspent" .= unspentToJSON net u, "path" .= p] + +xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding +xPubUnspentToEncoding net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = + AE.pairs $ "unspent" `AE.pair` unspentToEncoding net u <> "path" .= p + +xPubUnspentParseJSON :: Network -> Value -> Parser XPubUnspent +xPubUnspentParseJSON net = + A.withObject "xpubunspent" $ \o -> do + u <- o .: "unspent" >>= unspentParseJSON net + p <- o .: "path" + 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, NFData) + +instance Serial XPubSummary where + serialize XPubSummary {..} = do + putWord64be xPubSummaryConfirmed + putWord64be xPubSummaryZero + putWord64be xPubSummaryReceived + putWord64be xPubUnspentCount + putWord32be xPubExternalIndex + putWord32be xPubChangeIndex + deserialize = do + xPubSummaryConfirmed <- getWord64be + xPubSummaryZero <- getWord64be + xPubSummaryReceived <- getWord64be + xPubUnspentCount <- getWord64be + xPubExternalIndex <- getWord32be + xPubChangeIndex <- getWord32be + return XPubSummary {..} + +instance Binary XPubSummary where + put = serialize + get = deserialize + +instance Serialize XPubSummary where + put = serialize + get = deserialize + +instance ToJSON XPubSummary where + toJSON + XPubSummary + { xPubSummaryConfirmed = c, + xPubSummaryZero = z, + xPubSummaryReceived = r, + xPubUnspentCount = u, + xPubExternalIndex = ext, + xPubChangeIndex = ch + } = + A.object + [ "balance" + .= A.object + [ "confirmed" .= c, + "unconfirmed" .= z, + "received" .= r, + "utxo" .= u + ], + "indices" + .= A.object + [ "change" .= ch, + "external" .= ext + ] + ] + toEncoding + XPubSummary + { xPubSummaryConfirmed = c, + xPubSummaryZero = z, + xPubSummaryReceived = r, + xPubUnspentCount = u, + xPubExternalIndex = ext, + xPubChangeIndex = ch + } = + AE.pairs $ + "balance" + `AE.pair` AE.pairs + ( "confirmed" .= c + <> "unconfirmed" .= z + <> "received" .= r + <> "utxo" .= u + ) + <> "indices" + `AE.pair` AE.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 + } + +class Healthy a where + isOK :: a -> Bool + +data BlockHealth = BlockHealth + { blockHealthHeaders :: !BlockHeight, + blockHealthBlocks :: !BlockHeight, + blockHealthMaxDiff :: !Int32 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial BlockHealth where + serialize h@BlockHealth {..} = do + serialize (isOK h) + putWord32be blockHealthHeaders + putWord32be blockHealthBlocks + putInt32be blockHealthMaxDiff + deserialize = do + k <- deserialize + blockHealthHeaders <- getWord32be + blockHealthBlocks <- getWord32be + blockHealthMaxDiff <- getInt32be + let h = BlockHealth {..} + unless (k == isOK h) $ fail "Inconsistent health check" + return h + +instance Serialize BlockHealth where + put = serialize + get = deserialize + +instance Binary BlockHealth where + put = serialize + get = deserialize + +instance Healthy BlockHealth where + isOK BlockHealth {..} = + h - b <= blockHealthMaxDiff + where + h = fromIntegral blockHealthHeaders + b = fromIntegral blockHealthBlocks + +instance ToJSON BlockHealth where + toJSON h@BlockHealth {..} = + A.object + [ "headers" .= blockHealthHeaders, + "blocks" .= blockHealthBlocks, + "diff" .= diff, + "max" .= blockHealthMaxDiff, + "ok" .= isOK h + ] + where + diff = toInteger blockHealthHeaders - toInteger blockHealthBlocks + +instance FromJSON BlockHealth where + parseJSON = + A.withObject "BlockHealth" $ \o -> do + blockHealthHeaders <- o .: "headers" + blockHealthBlocks <- o .: "blocks" + blockHealthMaxDiff <- o .: "max" + return BlockHealth {..} + +data TimeHealth = TimeHealth + { timeHealthAge :: !Int64, + timeHealthMax :: !Int64 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial TimeHealth where + serialize h@TimeHealth {..} = do + serialize (isOK h) + putInt64be timeHealthAge + putInt64be timeHealthMax + deserialize = do + k <- deserialize + timeHealthAge <- getInt64be + timeHealthMax <- getInt64be + let t = TimeHealth {..} + unless (k == isOK t) $ fail "Inconsistent health check" + return t + +instance Binary TimeHealth where + put = serialize + get = deserialize + +instance Serialize TimeHealth where + put = serialize + get = deserialize + +instance Healthy TimeHealth where + isOK TimeHealth {..} = + timeHealthAge <= timeHealthMax + +instance ToJSON TimeHealth where + toJSON h@TimeHealth {..} = + A.object + [ "age" .= timeHealthAge, + "max" .= timeHealthMax, + "ok" .= isOK h + ] + +instance FromJSON TimeHealth where + parseJSON = + A.withObject "TimeHealth" $ \o -> do + timeHealthAge <- o .: "age" + timeHealthMax <- o .: "max" + return TimeHealth {..} + +data CountHealth = CountHealth + { countHealthNum :: !Int64, + countHealthMin :: !Int64 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial CountHealth where + serialize h@CountHealth {..} = do + serialize (isOK h) + putInt64be countHealthNum + putInt64be countHealthMin + deserialize = do + k <- deserialize + countHealthNum <- getInt64be + countHealthMin <- getInt64be + let c = CountHealth {..} + unless (k == isOK c) $ fail "Inconsistent health check" + return c + +instance Serialize CountHealth where + put = serialize + get = deserialize + +instance Binary CountHealth where + put = serialize + get = deserialize + +instance Healthy CountHealth where + isOK CountHealth {..} = + countHealthMin <= countHealthNum + +instance ToJSON CountHealth where + toJSON h@CountHealth {..} = + A.object + [ "count" .= countHealthNum, + "min" .= countHealthMin, + "ok" .= isOK h + ] + +instance FromJSON CountHealth where + parseJSON = + A.withObject "CountHealth" $ \o -> do + countHealthNum <- o .: "count" + countHealthMin <- o .: "min" + return CountHealth {..} + +data MaxHealth = MaxHealth + { maxHealthNum :: !Int64, + maxHealthMax :: !Int64 + } + deriving (Show, Eq, Generic, NFData) + +instance Serial MaxHealth where + serialize h@MaxHealth {..} = do + serialize $ isOK h + putInt64be maxHealthNum + putInt64be maxHealthMax + deserialize = do + k <- deserialize + maxHealthNum <- getInt64be + maxHealthMax <- getInt64be + let h = MaxHealth {..} + unless (k == isOK h) $ fail "Inconsistent health check" + return h + +instance Binary MaxHealth where + put = serialize + get = deserialize + +instance Serialize MaxHealth where + put = serialize + get = deserialize + +instance Healthy MaxHealth where + isOK MaxHealth {..} = maxHealthNum <= maxHealthMax + +instance ToJSON MaxHealth where + toJSON h@MaxHealth {..} = + A.object + [ "count" .= maxHealthNum, + "max" .= maxHealthMax, + "ok" .= isOK h + ] + +instance FromJSON MaxHealth where + parseJSON = + A.withObject "MaxHealth" $ \o -> do + maxHealthNum <- o .: "count" + maxHealthMax <- o .: "max" + return MaxHealth {..} + +data HealthCheck = HealthCheck + { healthBlocks :: !BlockHealth, + healthLastBlock :: !TimeHealth, + healthLastTx :: !TimeHealth, + healthPendingTxs :: !MaxHealth, + healthPeers :: !CountHealth, + healthNetwork :: !String, + healthVersion :: !String + } + deriving (Show, Eq, Generic, NFData) + +instance Serial HealthCheck where + serialize h@HealthCheck {..} = do + serialize (isOK h) + serialize healthBlocks + serialize healthLastBlock + serialize healthLastTx + serialize healthPendingTxs + serialize healthPeers + putLengthBytes ((TE.encodeUtf8 . T.pack) healthNetwork) + putLengthBytes ((TE.encodeUtf8 . T.pack) healthVersion) + deserialize = do + k <- deserialize + healthBlocks <- deserialize + healthLastBlock <- deserialize + healthLastTx <- deserialize + healthPendingTxs <- deserialize + healthPeers <- deserialize + healthNetwork <- T.unpack . TE.decodeUtf8 <$> getLengthBytes + healthVersion <- T.unpack . TE.decodeUtf8 <$> getLengthBytes + let h = HealthCheck {..} + unless (k == isOK h) $ fail "Inconsistent health check" + return h + +instance Binary HealthCheck where + put = serialize + get = deserialize + +instance Serialize HealthCheck where + put = serialize + get = deserialize + +instance Healthy HealthCheck where + isOK HealthCheck {..} = + isOK healthBlocks + && isOK healthLastBlock + && isOK healthLastTx + && isOK healthPendingTxs + && isOK healthPeers + +instance ToJSON HealthCheck where + toJSON h@HealthCheck {..} = + A.object + [ "blocks" .= healthBlocks, + "last-block" .= healthLastBlock, + "last-tx" .= healthLastTx, + "pending-txs" .= healthPendingTxs, + "peers" .= healthPeers, + "net" .= healthNetwork, + "version" .= healthVersion, + "ok" .= isOK h + ] + +instance FromJSON HealthCheck where + parseJSON = + A.withObject "HealthCheck" $ \o -> do + healthBlocks <- o .: "blocks" + healthLastBlock <- o .: "last-block" + healthLastTx <- o .: "last-tx" + healthPendingTxs <- o .: "pending-txs" + healthPeers <- o .: "peers" + healthNetwork <- o .: "net" + healthVersion <- o .: "version" + return HealthCheck {..} + +data Event + = EventBlock !BlockHash + | EventTx !TxHash + deriving (Show, Eq, Generic, NFData) + +instance Serial Event where + serialize (EventBlock bh) = putWord8 0x00 >> serialize bh + serialize (EventTx th) = putWord8 0x01 >> serialize th + deserialize = + getWord8 >>= \case + 0x00 -> EventBlock <$> deserialize + 0x01 -> EventTx <$> deserialize + _ -> fail "Not an Event" + +instance Serialize Event where + put = serialize + get = deserialize + +instance Binary Event where + put = serialize + get = deserialize + +instance ToJSON Event where + toJSON (EventTx h) = + A.object + [ "type" .= String "tx", + "id" .= h + ] + toJSON (EventBlock h) = + A.object + [ "type" .= String "block", + "id" .= h + ] + toEncoding (EventTx h) = + AE.pairs $ + "type" `AE.pair` AE.text "tx" + <> "id" `AE.pair` AE.text (txHashToHex h) + toEncoding (EventBlock h) = + AE.pairs $ + "type" `AE.pair` AE.text "block" + <> "id" `AE.pair` AE.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, NFData) + +instance Serial a => Serial (GenericResult a) where + serialize (GenericResult x) = serialize x + deserialize = GenericResult <$> deserialize + +instance Serial a => Serialize (GenericResult a) where + put = serialize + get = deserialize + +instance Serial a => Binary (GenericResult a) where + put = serialize + get = deserialize + +instance ToJSON a => ToJSON (GenericResult a) where + toJSON (GenericResult b) = A.object ["result" .= b] + toEncoding (GenericResult b) = AE.pairs ("result" .= b) + +instance FromJSON a => FromJSON (GenericResult a) where + parseJSON = + A.withObject "GenericResult" $ \o -> + GenericResult <$> o .: "result" + +newtype RawResult a = RawResult + { getRawResult :: a + } + deriving (Show, Eq, Generic, NFData) + +instance Serial a => Serial (RawResult a) where + serialize (RawResult x) = serialize x + deserialize = RawResult <$> deserialize + +instance Serial a => Serialize (RawResult a) where + put = serialize + get = deserialize + +instance Serial a => Binary (RawResult a) where + put = serialize + get = deserialize + +instance Serial a => ToJSON (RawResult a) where + toJSON (RawResult b) = + A.object ["result" .= x b] + where + x = + TLE.decodeUtf8 + . BSB.toLazyByteString + . BSB.lazyByteStringHex + . runPutL + . serialize + toEncoding (RawResult b) = + AE.pairs $ "result" `AE.pair` AE.unsafeToEncoding str + where + str = + BSB.char7 '"' + <> BSB.lazyByteStringHex (runPutL (serialize b)) + <> BSB.char7 '"' + +instance Serial a => FromJSON (RawResult a) where + parseJSON = + A.withObject "RawResult" $ \o -> do + res <- o .: "result" + let m = + eitherToMaybe . Bytes.Get.runGetS deserialize + =<< decodeHex res + maybe mzero (return . RawResult) m + +newtype SerialList a = SerialList {getSerialList :: [a]} + deriving (Show, Eq, Generic, NFData) + +instance Semigroup (SerialList a) where + SerialList a <> SerialList b = SerialList (a <> b) + +instance Monoid (SerialList a) where + mempty = SerialList mempty + +instance Serial a => Serial (SerialList a) where + serialize (SerialList ls) = putList serialize ls + deserialize = SerialList <$> getList deserialize + +instance ToJSON a => ToJSON (SerialList a) where + toJSON (SerialList ls) = toJSON ls + toEncoding (SerialList ls) = toEncoding ls + +instance FromJSON a => FromJSON (SerialList a) where + parseJSON = fmap SerialList . parseJSON + +newtype RawResultList a = RawResultList + { getRawResultList :: [a] + } + deriving (Show, Eq, Generic, NFData) + +instance Serial a => Serial (RawResultList a) where + serialize (RawResultList xs) = + mapM_ serialize xs + deserialize = RawResultList <$> go + where + go = + isEmpty >>= \case + True -> return [] + False -> (:) <$> deserialize <*> go + +instance Serial a => Serialize (RawResultList a) where + put = serialize + get = deserialize + +instance Serial a => Binary (RawResultList a) where + put = serialize + get = deserialize + +instance Semigroup (RawResultList a) where + (RawResultList a) <> (RawResultList b) = RawResultList $ a <> b + +instance Monoid (RawResultList a) where + mempty = RawResultList mempty + +instance Serial a => ToJSON (RawResultList a) where + toJSON (RawResultList xs) = + toJSON $ + TLE.decodeUtf8 + . BSB.toLazyByteString + . BSB.lazyByteStringHex + . runPutL + . serialize + <$> xs + toEncoding (RawResultList xs) = + AE.list (AE.unsafeToEncoding . str) xs + where + str x = + BSB.char7 '"' + <> BSB.lazyByteStringHex (runPutL (serialize x)) + <> BSB.char7 '"' + +instance Serial a => FromJSON (RawResultList a) where + parseJSON = + A.withArray "RawResultList" $ \vec -> + RawResultList <$> mapM parseElem (toList vec) + where + parseElem = A.withText "RawResultListElem" $ maybe mzero return . f + f = eitherToMaybe . Bytes.Get.runGetS deserialize <=< decodeHex + +newtype TxId + = TxId TxHash + deriving (Show, Eq, Generic, NFData) + +instance Serial TxId where + serialize (TxId h) = serialize h + deserialize = TxId <$> deserialize + +instance Serialize TxId where + put = serialize + get = deserialize + +instance Binary TxId where + put = serialize + get = deserialize + +instance ToJSON TxId where + toJSON (TxId h) = A.object ["txid" .= h] + toEncoding (TxId h) = AE.pairs ("txid" `AE.pair` AE.text (txHashToHex h)) + +instance FromJSON TxId where + parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid" + +data Except + = ThingNotFound + | ServerError + | BadRequest + | UserError !String + | StringError !String + | TxIndexConflict ![TxHash] + | ServerTimeout + | RequestTooLarge + deriving (Show, Eq, Ord, Generic, NFData) + +instance Exception Except + +instance ScottyError Except where + stringError = StringError + showError = TL.pack . show + +instance ToJSON Except where + toJSON e = + A.object $ + case e of + ThingNotFound -> + [ "error" .= String "not-found-or-invalid-arg", + "message" .= String "Item not found or argument invalid" + ] + ServerError -> + [ "error" .= String "server-error", + "message" .= String "Server error" + ] + BadRequest -> + [ "error" .= String "bad-request", + "message" .= String "Invalid request" + ] + UserError msg' -> + [ "error" .= String "user-error", + "message" .= String (cs msg') + ] + StringError msg' -> + [ "error" .= String "string-error", + "message" .= String (cs msg') + ] + TxIndexConflict txids -> + [ "error" .= String "multiple-tx-index", + "message" .= String "Multiple txs match that index", + "txids" .= txids + ] + ServerTimeout -> + [ "error" .= String "server-timeout", + "message" .= String "Request is taking too long" + ] + RequestTooLarge -> + [ "error" .= String "request-too-large", + "message" .= String "Request body too large" + ] + +instance FromJSON Except where + parseJSON = + A.withObject "Except" $ \o -> do + ctr <- o .: "error" + msg' <- o .:? "message" .!= "" + case ctr of + String "not-found-or-invalid-arg" -> + return ThingNotFound + String "server-error" -> + return ServerError + String "bad-request" -> + return BadRequest + String "user-error" -> + return $ UserError msg' + String "string-error" -> + return $ StringError msg' + String "multiple-tx-index" -> do + txids <- o .: "txids" + return $ TxIndexConflict txids + String "server-timeout" -> + return ServerTimeout + String "request-too-large" -> + return RequestTooLarge + _ -> mzero + +toIntTxId :: TxHash -> Word64 +toIntTxId h = + let bs = runPutS (serialize h) + Right w64 = runGetS getWord64be bs + in w64 `shift` (-11) + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- + +data BinfoBlockId + = BinfoBlockHash !BlockHash + | BinfoBlockIndex !Word32 + deriving (Eq, Show, Read, Generic, NFData) + +instance Parsable BinfoBlockId where + parseParam t = + hex <> igr + where + hex = case hexToBlockHash (TL.toStrict t) of + Nothing -> Left "could not decode txid" + Just h -> Right $ BinfoBlockHash h + igr = BinfoBlockIndex <$> parseParam t + +data BinfoTxId + = BinfoTxIdHash !TxHash + | BinfoTxIdIndex !Word64 + deriving (Eq, Show, Read, Generic, NFData) + +encodeBinfoTxId :: Bool -> TxHash -> BinfoTxId +encodeBinfoTxId False = BinfoTxIdHash +encodeBinfoTxId True = BinfoTxIdIndex . toIntTxId + +instance Parsable BinfoTxId where + parseParam t = + hex <> igr + where + hex = + case hexToTxHash (TL.toStrict t) of + Nothing -> Left "could not decode txid" + Just h -> Right $ BinfoTxIdHash h + igr = BinfoTxIdIndex <$> parseParam t + +instance ToJSON BinfoTxId where + toJSON (BinfoTxIdHash h) = toJSON h + toJSON (BinfoTxIdIndex i) = toJSON i + toEncoding (BinfoTxIdHash h) = toEncoding h + toEncoding (BinfoTxIdIndex i) = toEncoding i + +instance FromJSON BinfoTxId where + parseJSON v = + BinfoTxIdHash <$> parseJSON v + <|> BinfoTxIdIndex <$> parseJSON v + +data BinfoFilter + = BinfoFilterAll + | BinfoFilterSent + | BinfoFilterReceived + | BinfoFilterMoved + | BinfoFilterConfirmed + | BinfoFilterMempool + deriving (Eq, Show, Generic, NFData) + +instance Parsable BinfoFilter where + parseParam t = + parseParam t >>= \case + (0 :: Int) -> return BinfoFilterAll + 1 -> return BinfoFilterSent + 2 -> return BinfoFilterReceived + 3 -> return BinfoFilterMoved + 5 -> return BinfoFilterConfirmed + 6 -> return BinfoFilterAll + 7 -> return BinfoFilterMempool + _ -> Left "could not parse filter parameter" + +data BinfoMultiAddr = BinfoMultiAddr + { getBinfoMultiAddrAddresses :: ![BinfoBalance], + getBinfoMultiAddrWallet :: !BinfoWallet, + getBinfoMultiAddrTxs :: ![BinfoTx], + getBinfoMultiAddrInfo :: !BinfoInfo, + getBinfoMultiAddrRecommendFee :: !Bool, + getBinfoMultiAddrCashAddr :: !Bool + } + deriving (Eq, Show, Generic, NFData) + +binfoMultiAddrToJSON :: Network -> BinfoMultiAddr -> Value +binfoMultiAddrToJSON net' BinfoMultiAddr {..} = + A.object $ + [ "addresses" .= map (binfoBalanceToJSON net) getBinfoMultiAddrAddresses, + "wallet" .= getBinfoMultiAddrWallet, + "txs" .= map (binfoTxToJSON net) getBinfoMultiAddrTxs, + "info" .= getBinfoMultiAddrInfo, + "recommend_include_fee" .= getBinfoMultiAddrRecommendFee + ] + ++ ["cash_addr" .= True | getBinfoMultiAddrCashAddr] + where + net = if not getBinfoMultiAddrCashAddr && net' == bch then btc else net' + +binfoMultiAddrParseJSON :: Network -> Value -> Parser BinfoMultiAddr +binfoMultiAddrParseJSON net = A.withObject "multiaddr" $ \o -> do + getBinfoMultiAddrAddresses <- + mapM (binfoBalanceParseJSON net) =<< o .: "addresses" + getBinfoMultiAddrWallet <- o .: "wallet" + getBinfoMultiAddrTxs <- + mapM (binfoTxParseJSON net) =<< o .: "txs" + getBinfoMultiAddrInfo <- o .: "info" + getBinfoMultiAddrRecommendFee <- o .: "recommend_include_fee" + getBinfoMultiAddrCashAddr <- o .:? "cash_addr" .!= False + return BinfoMultiAddr {..} + +binfoMultiAddrToEncoding :: Network -> BinfoMultiAddr -> Encoding +binfoMultiAddrToEncoding net' BinfoMultiAddr {..} = + AE.pairs + ( "addresses" `AE.pair` as + <> "wallet" .= getBinfoMultiAddrWallet + <> "txs" `AE.pair` ts + <> "info" .= getBinfoMultiAddrInfo + <> "recommend_include_fee" .= getBinfoMultiAddrRecommendFee + <> if getBinfoMultiAddrCashAddr then "cash_addr" .= True else mempty + ) + where + as = AE.list (binfoBalanceToEncoding net) getBinfoMultiAddrAddresses + ts = AE.list (binfoTxToEncoding net) getBinfoMultiAddrTxs + net = if not getBinfoMultiAddrCashAddr && net' == bch then btc else net' + +data BinfoRawAddr = BinfoRawAddr + { binfoRawAddr :: !BinfoAddr, + binfoRawBalance :: !Word64, + binfoRawTxCount :: !Word64, + binfoRawUnredeemed :: !Word64, + binfoRawReceived :: !Word64, + binfoRawSent :: !Int64, + binfoRawTxs :: ![BinfoTx] + } + deriving (Eq, Show, Generic, NFData) + +binfoRawAddrToJSON :: Network -> BinfoRawAddr -> Value +binfoRawAddrToJSON net BinfoRawAddr {..} = + A.object + [ "hash160" .= h160, + "address" .= address, + "n_tx" .= binfoRawTxCount, + "n_unredeemed" .= binfoRawUnredeemed, + "total_received" .= binfoRawReceived, + "total_sent" .= binfoRawSent, + "final_balance" .= binfoRawBalance, + "txs" .= map (binfoTxToJSON net) binfoRawTxs + ] + where + address = case binfoRawAddr of + BinfoAddr a -> addrToJSON net a + BinfoXpub x -> xPubToJSON net x + h160 = + encodeHex . runPutS . serialize + <$> case binfoRawAddr of + BinfoAddr a -> case a of + PubKeyAddress h -> Just h + ScriptAddress h -> Just h + WitnessPubKeyAddress h -> Just h + _ -> Nothing + _ -> Nothing + +binfoRawAddrToEncoding :: Network -> BinfoRawAddr -> Encoding +binfoRawAddrToEncoding net BinfoRawAddr {..} = + AE.pairs $ + "hash160" .= h160 + <> "address" `AE.pair` address + <> "n_tx" .= binfoRawTxCount + <> "n_unredeemed" .= binfoRawUnredeemed + <> "total_received" .= binfoRawReceived + <> "total_sent" .= binfoRawSent + <> "final_balance" .= binfoRawBalance + <> "txs" `AE.pair` AE.list (binfoTxToEncoding net) binfoRawTxs + where + address = case binfoRawAddr of + BinfoAddr a -> addrToEncoding net a + BinfoXpub x -> xPubToEncoding net x + h160 = + encodeHex . runPutS . serialize + <$> case binfoRawAddr of + BinfoAddr a -> case a of + PubKeyAddress h -> Just h + ScriptAddress h -> Just h + WitnessPubKeyAddress h -> Just h + _ -> Nothing + _ -> Nothing + +binfoRawAddrParseJSON :: Network -> Value -> Parser BinfoRawAddr +binfoRawAddrParseJSON net = A.withObject "balancetxs" $ \o -> do + addr <- o .: "address" + binfoRawAddr <- + BinfoAddr <$> addrFromJSON net addr + <|> BinfoXpub <$> xPubFromJSON net addr + binfoRawBalance <- o .: "final_balance" + binfoRawUnredeemed <- o .: "n_unredeemed" + binfoRawTxCount <- o .: "n_tx" + binfoRawReceived <- o .: "total_received" + binfoRawSent <- o .: "total_sent" + binfoRawTxs <- mapM (binfoTxParseJSON net) =<< o .: "txs" + return BinfoRawAddr {..} + +data BinfoShortBal = BinfoShortBal + { binfoShortBalFinal :: !Word64, + binfoShortBalTxCount :: !Word64, + binfoShortBalReceived :: !Word64 + } + deriving (Eq, Show, Read, Generic, NFData) + +instance ToJSON BinfoShortBal where + toJSON BinfoShortBal {..} = + A.object + [ "final_balance" .= binfoShortBalFinal, + "n_tx" .= binfoShortBalTxCount, + "total_received" .= binfoShortBalReceived + ] + toEncoding BinfoShortBal {..} = + AE.pairs $ + "final_balance" .= binfoShortBalFinal + <> "n_tx" .= binfoShortBalTxCount + <> "total_received" .= binfoShortBalReceived + +instance FromJSON BinfoShortBal where + parseJSON = A.withObject "short_balance" $ \o -> do + binfoShortBalFinal <- o .: "final_balance" + binfoShortBalTxCount <- o .: "n_tx" + binfoShortBalReceived <- o .: "total_received" + return BinfoShortBal {..} + +data BinfoBalance + = BinfoAddrBalance + { getBinfoAddress :: !Address, + getBinfoAddrTxCount :: !Word64, + getBinfoAddrReceived :: !Word64, + getBinfoAddrSent :: !Word64, + getBinfoAddrBalance :: !Word64 + } + | BinfoXPubBalance + { getBinfoXPubKey :: !XPubKey, + getBinfoAddrTxCount :: !Word64, + getBinfoAddrReceived :: !Word64, + getBinfoAddrSent :: !Word64, + getBinfoAddrBalance :: !Word64, + getBinfoXPubAccountIndex :: !Word32, + getBinfoXPubChangeIndex :: !Word32 + } + deriving (Eq, Show, Generic, NFData) + +binfoBalanceToJSON :: Network -> BinfoBalance -> Value +binfoBalanceToJSON net BinfoAddrBalance {..} = + A.object + [ "address" .= addrToJSON net getBinfoAddress, + "final_balance" .= getBinfoAddrBalance, + "n_tx" .= getBinfoAddrTxCount, + "total_received" .= getBinfoAddrReceived, + "total_sent" .= getBinfoAddrSent + ] +binfoBalanceToJSON net BinfoXPubBalance {..} = + A.object + [ "address" .= xPubToJSON net getBinfoXPubKey, + "change_index" .= getBinfoXPubChangeIndex, + "account_index" .= getBinfoXPubAccountIndex, + "final_balance" .= getBinfoAddrBalance, + "n_tx" .= getBinfoAddrTxCount, + "total_received" .= getBinfoAddrReceived, + "total_sent" .= getBinfoAddrSent + ] + +binfoBalanceParseJSON :: Network -> Value -> Parser BinfoBalance +binfoBalanceParseJSON net = A.withObject "address" $ \o -> x o <|> a o + where + x o = do + getBinfoXPubKey <- xPubFromJSON net =<< o .: "address" + getBinfoXPubChangeIndex <- o .: "change_index" + getBinfoXPubAccountIndex <- o .: "account_index" + getBinfoAddrBalance <- o .: "final_balance" + getBinfoAddrTxCount <- o .: "n_tx" + getBinfoAddrReceived <- o .: "total_received" + getBinfoAddrSent <- o .: "total_sent" + return BinfoXPubBalance {..} + a o = do + getBinfoAddress <- addrFromJSON net =<< o .: "address" + getBinfoAddrBalance <- o .: "final_balance" + getBinfoAddrTxCount <- o .: "n_tx" + getBinfoAddrReceived <- o .: "total_received" + getBinfoAddrSent <- o .: "total_sent" + return BinfoAddrBalance {..} + +binfoBalanceToEncoding :: Network -> BinfoBalance -> Encoding +binfoBalanceToEncoding net BinfoAddrBalance {..} = + AE.pairs + ( "address" `AE.pair` addrToEncoding net getBinfoAddress + <> "final_balance" .= getBinfoAddrBalance + <> "n_tx" .= getBinfoAddrTxCount + <> "total_received" .= getBinfoAddrReceived + <> "total_sent" .= getBinfoAddrSent + ) +binfoBalanceToEncoding net BinfoXPubBalance {..} = + AE.pairs + ( "address" `AE.pair` xPubToEncoding net getBinfoXPubKey + <> "change_index" .= getBinfoXPubChangeIndex + <> "account_index" .= getBinfoXPubAccountIndex + <> "final_balance" .= getBinfoAddrBalance + <> "n_tx" .= getBinfoAddrTxCount + <> "total_received" .= getBinfoAddrReceived + <> "total_sent" .= getBinfoAddrSent + ) + +data BinfoWallet = BinfoWallet + { getBinfoWalletBalance :: !Word64, + getBinfoWalletTxCount :: !Word64, + getBinfoWalletFilteredCount :: !Word64, + getBinfoWalletTotalReceived :: !Word64, + getBinfoWalletTotalSent :: !Word64 + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoWallet where + toJSON BinfoWallet {..} = + A.object + [ "final_balance" .= getBinfoWalletBalance, + "n_tx" .= getBinfoWalletTxCount, + "n_tx_filtered" .= getBinfoWalletFilteredCount, + "total_received" .= getBinfoWalletTotalReceived, + "total_sent" .= getBinfoWalletTotalSent + ] + toEncoding BinfoWallet {..} = + AE.pairs + ( "final_balance" .= getBinfoWalletBalance + <> "n_tx" .= getBinfoWalletTxCount + <> "n_tx_filtered" .= getBinfoWalletFilteredCount + <> "total_received" .= getBinfoWalletTotalReceived + <> "total_sent" .= getBinfoWalletTotalSent + ) + +instance FromJSON BinfoWallet where + parseJSON = A.withObject "wallet" $ \o -> do + getBinfoWalletBalance <- o .: "final_balance" + getBinfoWalletTxCount <- o .: "n_tx" + getBinfoWalletFilteredCount <- o .: "n_tx_filtered" + getBinfoWalletTotalReceived <- o .: "total_received" + getBinfoWalletTotalSent <- o .: "total_sent" + return BinfoWallet {..} + +binfoHexValue :: Word64 -> Text +binfoHexValue w64 = + let bs = BS.dropWhile (== 0x00) (runPutS (serialize w64)) + in encodeHex $ + if BS.null bs || BS.head bs `testBit` 7 + then BS.cons 0x00 bs + else bs + +data BinfoUnspent = BinfoUnspent + { getBinfoUnspentHash :: !TxHash, + getBinfoUnspentOutputIndex :: !Word32, + getBinfoUnspentScript :: !ByteString, + getBinfoUnspentValue :: !Word64, + getBinfoUnspentConfirmations :: !Int32, + getBinfoUnspentTxIndex :: !BinfoTxId, + getBinfoUnspentXPub :: !(Maybe BinfoXPubPath) + } + deriving (Eq, Show, Generic, NFData) + +binfoUnspentToJSON :: Network -> BinfoUnspent -> Value +binfoUnspentToJSON net BinfoUnspent {..} = + A.object $ + [ "tx_hash_big_endian" .= getBinfoUnspentHash, + "tx_hash" + .= encodeHex (runPutS (serialize (getTxHash getBinfoUnspentHash))), + "tx_output_n" .= getBinfoUnspentOutputIndex, + "script" .= encodeHex getBinfoUnspentScript, + "value" .= getBinfoUnspentValue, + "value_hex" .= binfoHexValue getBinfoUnspentValue, + "confirmations" .= getBinfoUnspentConfirmations, + "tx_index" .= getBinfoUnspentTxIndex + ] + <> [ "xpub" .= binfoXPubPathToJSON net x + | x <- maybeToList getBinfoUnspentXPub + ] + +binfoUnspentToEncoding :: Network -> BinfoUnspent -> Encoding +binfoUnspentToEncoding net BinfoUnspent {..} = + AE.pairs $ + "tx_hash_big_endian" .= getBinfoUnspentHash + <> "tx_hash" + .= encodeHex (runPutS (serialize (getTxHash getBinfoUnspentHash))) + <> "tx_output_n" + .= getBinfoUnspentOutputIndex + <> "script" + .= encodeHex getBinfoUnspentScript + <> "value" + .= getBinfoUnspentValue + <> "value_hex" + .= binfoHexValue getBinfoUnspentValue + <> "confirmations" + .= getBinfoUnspentConfirmations + <> "tx_index" + .= getBinfoUnspentTxIndex + <> maybe + mempty + (("xpub" `AE.pair`) . binfoXPubPathToEncoding net) + getBinfoUnspentXPub + +binfoUnspentParseJSON :: Network -> Value -> Parser BinfoUnspent +binfoUnspentParseJSON net = A.withObject "unspent" $ \o -> do + getBinfoUnspentHash <- o .: "tx_hash_big_endian" + getBinfoUnspentOutputIndex <- o .: "tx_output_n" + getBinfoUnspentScript <- maybe mzero return . decodeHex =<< o .: "script" + getBinfoUnspentValue <- o .: "value" + getBinfoUnspentConfirmations <- o .: "confirmations" + getBinfoUnspentTxIndex <- o .: "tx_index" + getBinfoUnspentXPub <- mapM (binfoXPubPathParseJSON net) =<< o .:? "xpub" + return BinfoUnspent {..} + +newtype BinfoUnspents = BinfoUnspents [BinfoUnspent] + deriving (Eq, Show, Generic, NFData) + +binfoUnspentsToJSON :: Network -> BinfoUnspents -> Value +binfoUnspentsToJSON net (BinfoUnspents us) = + A.object + [ "notice" .= T.empty, + "unspent_outputs" .= map (binfoUnspentToJSON net) us + ] + +binfoUnspentsToEncoding :: Network -> BinfoUnspents -> Encoding +binfoUnspentsToEncoding net (BinfoUnspents us) = + AE.pairs $ + "notice" .= T.empty + <> "unspent_outputs" `AE.pair` AE.list (binfoUnspentToEncoding net) us + +binfoUnspentsParseJSON :: Network -> Value -> Parser BinfoUnspents +binfoUnspentsParseJSON net = A.withObject "unspents" $ \o -> do + us <- mapM (binfoUnspentParseJSON net) =<< o .: "unspent_outputs" + return (BinfoUnspents us) + +binfoBlocksToJSON :: Network -> [BinfoBlock] -> Value +binfoBlocksToJSON net blocks = + A.object ["blocks" .= map (binfoBlockToJSON net) blocks] + +binfoBlocksToEncoding :: Network -> [BinfoBlock] -> Encoding +binfoBlocksToEncoding net blocks = + AE.pairs $ "blocks" `AE.pair` AE.list (binfoBlockToEncoding net) blocks + +binfoBlocksParseJSON :: Network -> Value -> Parser [BinfoBlock] +binfoBlocksParseJSON net = + A.withObject "blocks" $ \o -> + mapM (binfoBlockParseJSON net) =<< o .: "blocks" + +toBinfoBlock :: BlockData -> [BinfoTx] -> [BlockHash] -> BinfoBlock +toBinfoBlock BlockData {..} txs next_blocks = + BinfoBlock + { getBinfoBlockHash = headerHash blockDataHeader, + getBinfoBlockVer = blockVersion blockDataHeader, + getBinfoPrevBlock = prevBlock blockDataHeader, + getBinfoMerkleRoot = merkleRoot blockDataHeader, + getBinfoBlockTime = blockTimestamp blockDataHeader, + getBinfoBlockBits = blockBits blockDataHeader, + getBinfoNextBlock = next_blocks, + getBinfoBlockFee = blockDataFees, + getBinfoBlockNonce = bhNonce blockDataHeader, + getBinfoBlockTxCount = fromIntegral (length txs), + getBinfoBlockSize = blockDataSize, + getBinfoBlockIndex = blockDataHeight, + getBinfoBlockMain = blockDataMainChain, + getBinfoBlockHeight = blockDataHeight, + getBinfoBlockWeight = blockDataWeight, + getBinfoBlockTx = txs + } + +data BinfoBlock = BinfoBlock + { getBinfoBlockHash :: !BlockHash, + getBinfoBlockVer :: !Word32, + getBinfoPrevBlock :: !BlockHash, + getBinfoMerkleRoot :: !Hash256, + getBinfoBlockTime :: !Word32, + getBinfoBlockBits :: !Word32, + getBinfoNextBlock :: ![BlockHash], + getBinfoBlockFee :: !Word64, + getBinfoBlockNonce :: !Word32, + getBinfoBlockTxCount :: !Word32, + getBinfoBlockSize :: !Word32, + getBinfoBlockIndex :: !Word32, + getBinfoBlockMain :: !Bool, + getBinfoBlockHeight :: !Word32, + getBinfoBlockWeight :: !Word32, + getBinfoBlockTx :: ![BinfoTx] + } + deriving (Eq, Show, Generic, NFData) + +binfoBlockToJSON :: Network -> BinfoBlock -> Value +binfoBlockToJSON net BinfoBlock {..} = + A.object + [ "hash" .= getBinfoBlockHash, + "ver" .= getBinfoBlockVer, + "prev_block" .= getBinfoPrevBlock, + "mrkl_root" .= TxHash getBinfoMerkleRoot, + "time" .= getBinfoBlockTime, + "bits" .= getBinfoBlockBits, + "next_block" .= getBinfoNextBlock, + "fee" .= getBinfoBlockFee, + "nonce" .= getBinfoBlockNonce, + "n_tx" .= getBinfoBlockTxCount, + "size" .= getBinfoBlockSize, + "block_index" .= getBinfoBlockIndex, + "main_chain" .= getBinfoBlockMain, + "height" .= getBinfoBlockHeight, + "weight" .= getBinfoBlockWeight, + "tx" .= map (binfoTxToJSON net) getBinfoBlockTx + ] + +binfoBlockToEncoding :: Network -> BinfoBlock -> Encoding +binfoBlockToEncoding net BinfoBlock {..} = + AE.pairs $ + "hash" .= getBinfoBlockHash + <> "ver" .= getBinfoBlockVer + <> "prev_block" .= getBinfoPrevBlock + <> "mrkl_root" .= TxHash getBinfoMerkleRoot + <> "time" .= getBinfoBlockTime + <> "bits" .= getBinfoBlockBits + <> "next_block" .= getBinfoNextBlock + <> "fee" .= getBinfoBlockFee + <> "nonce" .= getBinfoBlockNonce + <> "n_tx" .= getBinfoBlockTxCount + <> "size" .= getBinfoBlockSize + <> "block_index" .= getBinfoBlockIndex + <> "main_chain" .= getBinfoBlockMain + <> "height" .= getBinfoBlockHeight + <> "weight" .= getBinfoBlockWeight + <> "tx" `AE.pair` AE.list (binfoTxToEncoding net) getBinfoBlockTx + +binfoBlockParseJSON :: Network -> Value -> Parser BinfoBlock +binfoBlockParseJSON net = A.withObject "block" $ \o -> do + getBinfoBlockHash <- o .: "hash" + getBinfoBlockVer <- o .: "ver" + getBinfoPrevBlock <- o .: "prev_block" + getBinfoMerkleRoot <- getTxHash <$> o .: "mrkl_root" + getBinfoBlockTime <- o .: "time" + getBinfoBlockBits <- o .: "bits" + getBinfoNextBlock <- o .: "next_block" + getBinfoBlockFee <- o .: "fee" + getBinfoBlockNonce <- o .: "nonce" + getBinfoBlockTxCount <- o .: "n_tx" + getBinfoBlockSize <- o .: "size" + getBinfoBlockIndex <- o .: "block_index" + getBinfoBlockMain <- o .: "main_chain" + getBinfoBlockHeight <- o .: "height" + getBinfoBlockWeight <- o .: "weight" + getBinfoBlockTx <- o .: "tx" >>= mapM (binfoTxParseJSON net) + return BinfoBlock {..} + +data BinfoTx = BinfoTx + { getBinfoTxHash :: !TxHash, + getBinfoTxVer :: !Word32, + getBinfoTxVinSz :: !Word32, + getBinfoTxVoutSz :: !Word32, + getBinfoTxSize :: !Word32, + getBinfoTxWeight :: !Word32, + getBinfoTxFee :: !Word64, + getBinfoTxRelayedBy :: !ByteString, + getBinfoTxLockTime :: !Word32, + getBinfoTxIndex :: !BinfoTxId, + getBinfoTxDoubleSpend :: !Bool, + getBinfoTxRBF :: !Bool, + getBinfoTxResultBal :: !(Maybe (Int64, Int64)), + getBinfoTxTime :: !Word64, + getBinfoTxBlockIndex :: !(Maybe Word32), + getBinfoTxBlockHeight :: !(Maybe Word32), + getBinfoTxInputs :: [BinfoTxInput], + getBinfoTxOutputs :: [BinfoTxOutput] + } + deriving (Eq, Show, Generic, NFData) + +binfoTxToJSON :: Network -> BinfoTx -> Value +binfoTxToJSON net BinfoTx {..} = + A.object $ + [ "hash" .= getBinfoTxHash, + "ver" .= getBinfoTxVer, + "vin_sz" .= getBinfoTxVinSz, + "vout_sz" .= getBinfoTxVoutSz, + "size" .= getBinfoTxSize, + "weight" .= getBinfoTxWeight, + "fee" .= getBinfoTxFee, + "relayed_by" .= TE.decodeUtf8 getBinfoTxRelayedBy, + "lock_time" .= getBinfoTxLockTime, + "tx_index" .= getBinfoTxIndex, + "double_spend" .= getBinfoTxDoubleSpend, + "time" .= getBinfoTxTime, + "block_index" .= getBinfoTxBlockIndex, + "block_height" .= getBinfoTxBlockHeight, + "inputs" .= map (binfoTxInputToJSON net) getBinfoTxInputs, + "out" .= map (binfoTxOutputToJSON net) getBinfoTxOutputs + ] + ++ bal + ++ rbf + where + bal = + case getBinfoTxResultBal of + Nothing -> [] + Just (res, bal') -> ["result" .= res, "balance" .= bal'] + rbf = ["rbf" .= True | getBinfoTxRBF] + +binfoTxToEncoding :: Network -> BinfoTx -> Encoding +binfoTxToEncoding net BinfoTx {..} = + AE.pairs $ + "hash" .= getBinfoTxHash + <> "ver" .= getBinfoTxVer + <> "vin_sz" .= getBinfoTxVinSz + <> "vout_sz" .= getBinfoTxVoutSz + <> "size" .= getBinfoTxSize + <> "weight" .= getBinfoTxWeight + <> "fee" .= getBinfoTxFee + <> "relayed_by" .= TE.decodeUtf8 getBinfoTxRelayedBy + <> "lock_time" .= getBinfoTxLockTime + <> "tx_index" .= getBinfoTxIndex + <> "double_spend" .= getBinfoTxDoubleSpend + <> "time" .= getBinfoTxTime + <> "block_index" .= getBinfoTxBlockIndex + <> "block_height" .= getBinfoTxBlockHeight + <> "inputs" `AE.pair` AE.list (binfoTxInputToEncoding net) getBinfoTxInputs + <> "out" `AE.pair` AE.list (binfoTxOutputToEncoding net) getBinfoTxOutputs + <> bal + <> rbf + where + bal = + case getBinfoTxResultBal of + Nothing -> mempty + Just (res, bal') -> "result" .= res <> "balance" .= bal' + rbf = if getBinfoTxRBF then "rbf" .= True else mempty + +binfoTxParseJSON :: Network -> Value -> Parser BinfoTx +binfoTxParseJSON net = A.withObject "tx" $ \o -> do + getBinfoTxHash <- o .: "hash" + getBinfoTxVer <- o .: "ver" + getBinfoTxVinSz <- o .: "vin_sz" + getBinfoTxVoutSz <- o .: "vout_sz" + getBinfoTxSize <- o .: "size" + getBinfoTxWeight <- o .: "weight" + getBinfoTxFee <- o .: "fee" + getBinfoTxRelayedBy <- TE.encodeUtf8 <$> o .: "relayed_by" + getBinfoTxLockTime <- o .: "lock_time" + getBinfoTxIndex <- o .: "tx_index" + getBinfoTxDoubleSpend <- o .: "double_spend" + getBinfoTxTime <- o .: "time" + getBinfoTxBlockIndex <- o .: "block_index" + getBinfoTxBlockHeight <- o .: "block_height" + getBinfoTxInputs <- o .: "inputs" >>= mapM (binfoTxInputParseJSON net) + getBinfoTxOutputs <- o .: "out" >>= mapM (binfoTxOutputParseJSON net) + getBinfoTxRBF <- o .:? "rbf" .!= False + res <- o .:? "result" + bal <- o .:? "balance" + let getBinfoTxResultBal = (,) <$> res <*> bal + return BinfoTx {..} + +data BinfoTxInput = BinfoTxInput + { getBinfoTxInputSeq :: !Word32, + getBinfoTxInputWitness :: !ByteString, + getBinfoTxInputScript :: !ByteString, + getBinfoTxInputIndex :: !Word32, + getBinfoTxInputPrevOut :: !BinfoTxOutput + } + deriving (Eq, Show, Generic, NFData) + +binfoTxInputToJSON :: Network -> BinfoTxInput -> Value +binfoTxInputToJSON net BinfoTxInput {..} = + A.object + [ "sequence" .= getBinfoTxInputSeq, + "witness" .= encodeHex getBinfoTxInputWitness, + "script" .= encodeHex getBinfoTxInputScript, + "index" .= getBinfoTxInputIndex, + "prev_out" .= binfoTxOutputToJSON net getBinfoTxInputPrevOut + ] + +binfoTxInputToEncoding :: Network -> BinfoTxInput -> Encoding +binfoTxInputToEncoding net BinfoTxInput {..} = + AE.pairs + ( "sequence" .= getBinfoTxInputSeq + <> "witness" .= encodeHex getBinfoTxInputWitness + <> "script" .= encodeHex getBinfoTxInputScript + <> "index" .= getBinfoTxInputIndex + <> "prev_out" .= binfoTxOutputToJSON net getBinfoTxInputPrevOut + ) + +binfoTxInputParseJSON :: Network -> Value -> Parser BinfoTxInput +binfoTxInputParseJSON net = A.withObject "txin" $ \o -> do + getBinfoTxInputSeq <- o .: "sequence" + getBinfoTxInputWitness <- + maybe mzero return . decodeHex + =<< o .: "witness" + getBinfoTxInputScript <- + maybe mzero return . decodeHex + =<< o .: "script" + getBinfoTxInputIndex <- o .: "index" + getBinfoTxInputPrevOut <- + o .: "prev_out" + >>= binfoTxOutputParseJSON net + return BinfoTxInput {..} + +data BinfoTxOutput = BinfoTxOutput + { getBinfoTxOutputType :: !Int, + getBinfoTxOutputSpent :: !Bool, + getBinfoTxOutputValue :: !Word64, + getBinfoTxOutputIndex :: !Word32, + getBinfoTxOutputTxIndex :: !BinfoTxId, + getBinfoTxOutputScript :: !ByteString, + getBinfoTxOutputSpenders :: ![BinfoSpender], + getBinfoTxOutputAddress :: !(Maybe Address), + getBinfoTxOutputXPub :: !(Maybe BinfoXPubPath) + } + deriving (Eq, Show, Generic, NFData) + +binfoTxOutputToJSON :: Network -> BinfoTxOutput -> Value +binfoTxOutputToJSON net BinfoTxOutput {..} = + A.object $ + [ "type" .= getBinfoTxOutputType, + "spent" .= getBinfoTxOutputSpent, + "value" .= getBinfoTxOutputValue, + "spending_outpoints" .= getBinfoTxOutputSpenders, + "n" .= getBinfoTxOutputIndex, + "tx_index" .= getBinfoTxOutputTxIndex, + "script" .= encodeHex getBinfoTxOutputScript + ] + <> [ "addr" .= addrToJSON net a + | a <- maybeToList getBinfoTxOutputAddress + ] + <> [ "xpub" .= binfoXPubPathToJSON net x + | x <- maybeToList getBinfoTxOutputXPub + ] + +binfoTxOutputToEncoding :: Network -> BinfoTxOutput -> Encoding +binfoTxOutputToEncoding net BinfoTxOutput {..} = + AE.pairs $ + mconcat $ + [ "type" .= getBinfoTxOutputType, + "spent" .= getBinfoTxOutputSpent, + "value" .= getBinfoTxOutputValue, + "spending_outpoints" .= getBinfoTxOutputSpenders, + "n" .= getBinfoTxOutputIndex, + "tx_index" .= getBinfoTxOutputTxIndex, + "script" .= encodeHex getBinfoTxOutputScript + ] + <> [ "addr" .= addrToJSON net a + | a <- maybeToList getBinfoTxOutputAddress + ] + <> [ "xpub" .= binfoXPubPathToJSON net x + | x <- maybeToList getBinfoTxOutputXPub + ] + +binfoTxOutputParseJSON :: Network -> Value -> Parser BinfoTxOutput +binfoTxOutputParseJSON net = A.withObject "txout" $ \o -> do + getBinfoTxOutputType <- o .: "type" + getBinfoTxOutputSpent <- o .: "spent" + getBinfoTxOutputValue <- o .: "value" + getBinfoTxOutputSpenders <- o .: "spending_outpoints" + getBinfoTxOutputIndex <- o .: "n" + getBinfoTxOutputTxIndex <- o .: "tx_index" + getBinfoTxOutputScript <- maybe mzero return . decodeHex =<< o .: "script" + getBinfoTxOutputAddress <- o .:? "addr" >>= mapM (addrFromJSON net) + getBinfoTxOutputXPub <- o .:? "xpub" >>= mapM (binfoXPubPathParseJSON net) + return BinfoTxOutput {..} + +data BinfoSpender = BinfoSpender + { getBinfoSpenderTxIndex :: !BinfoTxId, + getBinfoSpenderIndex :: !Word32 + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoSpender where + toJSON BinfoSpender {..} = + A.object + [ "tx_index" .= getBinfoSpenderTxIndex, + "n" .= getBinfoSpenderIndex + ] + toEncoding BinfoSpender {..} = + AE.pairs + ( "tx_index" .= getBinfoSpenderTxIndex + <> "n" .= getBinfoSpenderIndex + ) + +instance FromJSON BinfoSpender where + parseJSON = A.withObject "spender" $ \o -> do + getBinfoSpenderTxIndex <- o .: "tx_index" + getBinfoSpenderIndex <- o .: "n" + return BinfoSpender {..} + +data BinfoXPubPath = BinfoXPubPath + { getBinfoXPubPathKey :: !XPubKey, + getBinfoXPubPathDeriv :: !SoftPath + } + deriving (Eq, Show, Generic, NFData) + +instance Ord BinfoXPubPath where + compare = compare `on` f + where + f b = + ( xPubParent (getBinfoXPubPathKey b), + getBinfoXPubPathDeriv b + ) + +binfoXPubPathToJSON :: Network -> BinfoXPubPath -> Value +binfoXPubPathToJSON net BinfoXPubPath {..} = + A.object + [ "m" .= xPubToJSON net getBinfoXPubPathKey, + "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) + ] + +binfoXPubPathToEncoding :: Network -> BinfoXPubPath -> Encoding +binfoXPubPathToEncoding net BinfoXPubPath {..} = + AE.pairs $ + "m" `AE.pair` xPubToEncoding net getBinfoXPubPathKey + <> "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) + +binfoXPubPathParseJSON :: Network -> Value -> Parser BinfoXPubPath +binfoXPubPathParseJSON net = A.withObject "xpub" $ \o -> do + getBinfoXPubPathKey <- o .: "m" >>= xPubFromJSON net + getBinfoXPubPathDeriv <- + fromMaybe "bad xpub path" . parseSoft <$> o .: "path" + return BinfoXPubPath {..} + +data BinfoInfo = BinfoInfo + { getBinfoConnected :: !Word32, + getBinfoConversion :: !Double, + getBinfoLocal :: !BinfoSymbol, + getBinfoBTC :: !BinfoSymbol, + getBinfoLatestBlock :: !BinfoBlockInfo + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoInfo where + toJSON BinfoInfo {..} = + A.object + [ "nconnected" .= getBinfoConnected, + "conversion" .= getBinfoConversion, + "symbol_local" .= getBinfoLocal, + "symbol_btc" .= getBinfoBTC, + "latest_block" .= getBinfoLatestBlock + ] + toEncoding BinfoInfo {..} = + AE.pairs + ( "nconnected" .= getBinfoConnected + <> "conversion" .= getBinfoConversion + <> "symbol_local" .= getBinfoLocal + <> "symbol_btc" .= getBinfoBTC + <> "latest_block" .= getBinfoLatestBlock + ) + +instance FromJSON BinfoInfo where + parseJSON = A.withObject "info" $ \o -> do + getBinfoConnected <- o .: "nconnected" + getBinfoConversion <- o .: "conversion" + getBinfoLocal <- o .: "symbol_local" + getBinfoBTC <- o .: "symbol_btc" + getBinfoLatestBlock <- o .: "latest_block" + return BinfoInfo {..} + +data BinfoBlockInfo = BinfoBlockInfo + { getBinfoBlockInfoHash :: !BlockHash, + getBinfoBlockInfoHeight :: !BlockHeight, + getBinfoBlockInfoTime :: !Word32, + getBinfoBlockInfoIndex :: !BlockHeight + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoBlockInfo where + toJSON BinfoBlockInfo {..} = + A.object + [ "hash" .= getBinfoBlockInfoHash, + "height" .= getBinfoBlockInfoHeight, + "time" .= getBinfoBlockInfoTime, + "block_index" .= getBinfoBlockInfoIndex + ] + toEncoding BinfoBlockInfo {..} = + AE.pairs + ( "hash" .= getBinfoBlockInfoHash + <> "height" .= getBinfoBlockInfoHeight + <> "time" .= getBinfoBlockInfoTime + <> "block_index" .= getBinfoBlockInfoIndex + ) + +instance FromJSON BinfoBlockInfo where + parseJSON = A.withObject "block_info" $ \o -> do + getBinfoBlockInfoHash <- o .: "hash" + getBinfoBlockInfoHeight <- o .: "height" + getBinfoBlockInfoTime <- o .: "time" + getBinfoBlockInfoIndex <- o .: "block_index" + return BinfoBlockInfo {..} + +toBinfoBlockInfo :: BlockData -> BinfoBlockInfo +toBinfoBlockInfo BlockData {..} = + BinfoBlockInfo + { getBinfoBlockInfoHash = headerHash blockDataHeader, + getBinfoBlockInfoHeight = blockDataHeight, + getBinfoBlockInfoTime = blockTimestamp blockDataHeader, + getBinfoBlockInfoIndex = blockDataHeight + } + +data BinfoRate = BinfoRate + { binfoRateTime :: !Word64, + binfoRatePrice :: !Double, + binfoRateVol24 :: !Double + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoRate where + toJSON BinfoRate {..} = + A.object + [ "timestamp" .= binfoRateTime, + "price" .= binfoRatePrice, + "volume24h" .= binfoRateVol24 + ] + +instance FromJSON BinfoRate where + parseJSON = A.withObject "price" $ \o -> do + binfoRateTime <- o .: "timestamp" + binfoRatePrice <- o .: "price" + binfoRateVol24 <- o .: "volume24h" + return BinfoRate {..} + +data BinfoHistory = BinfoHistory + { binfoHistoryDate :: !Text, + binfoHistoryTime :: !Text, + binfoHistoryType :: !Text, + binfoHistoryAmount :: !Double, + binfoHistoryValueThen :: !Double, + binfoHistoryValueNow :: !Double, + binfoHistoryExchangeRateThen :: !Double, + binfoHistoryTx :: !TxHash + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoHistory where + toJSON BinfoHistory {..} = + A.object + [ "date" .= binfoHistoryDate, + "time" .= binfoHistoryTime, + "type" .= binfoHistoryType, + "amount" .= binfoHistoryAmount, + "value_then" .= binfoHistoryValueThen, + "value_now" .= binfoHistoryValueNow, + "exchange_rate_then" .= binfoHistoryExchangeRateThen, + "tx" .= binfoHistoryTx + ] + +instance FromJSON BinfoHistory where + parseJSON = A.withObject "history" $ \o -> do + binfoHistoryDate <- o .: "date" + binfoHistoryTime <- o .: "time" + binfoHistoryType <- o .: "type" + binfoHistoryAmount <- o .: "amount" + binfoHistoryValueThen <- o .: "value_then" + binfoHistoryValueNow <- o .: "value_now" + binfoHistoryExchangeRateThen <- o .: "exchange_rate_then" + binfoHistoryTx <- o .: "tx" + return BinfoHistory {..} + +toBinfoHistory :: + Int64 -> + Word64 -> + Double -> + Double -> + TxHash -> + BinfoHistory +toBinfoHistory satoshi timestamp rate_then rate_now txhash = + BinfoHistory + { binfoHistoryDate = + T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" t, + binfoHistoryTime = + T.pack $ formatTime defaultTimeLocale "%H:%M:%S GMT %Ez" t, + binfoHistoryType = + if satoshi <= 0 then "sent" else "received", + binfoHistoryAmount = + fromRational v, + binfoHistoryValueThen = + fromRational v1, + binfoHistoryValueNow = + fromRational v2, + binfoHistoryExchangeRateThen = + rate_then, + binfoHistoryTx = + txhash + } + where + t = posixSecondsToUTCTime (realToFrac timestamp) + v = toRational satoshi / (100 * 1000 * 1000) + r1 = toRational rate_then + r2 = toRational rate_now + v1 = v * r1 + v2 = v * r2 + +newtype BinfoDate = BinfoDate Word64 + deriving (Eq, Show, Read, Generic, NFData) + +instance Parsable BinfoDate where + parseParam t = + maybeToEither "Cannot parse date" + . fmap (BinfoDate . round . utcTimeToPOSIXSeconds) + $ p "%d-%m-%Y" <|> p "%d/%m/%Y" + where + s = TL.unpack t + p fmt = parseTimeM False defaultTimeLocale fmt s + +data BinfoTicker = BinfoTicker + { binfoTicker15m :: !Double, + binfoTickerLast :: !Double, + binfoTickerBuy :: !Double, + binfoTickerSell :: !Double, + binfoTickerSymbol :: !Text + } + deriving (Eq, Show, Generic, NFData) + +instance Default BinfoTicker where + def = + BinfoTicker + { binfoTickerSymbol = "XXX", + binfoTicker15m = 0.0, + binfoTickerLast = 0.0, + binfoTickerBuy = 0.0, + binfoTickerSell = 0.0 + } + +instance ToJSON BinfoTicker where + toJSON BinfoTicker {..} = + A.object + [ "symbol" .= binfoTickerSymbol, + "sell" .= binfoTickerSell, + "buy" .= binfoTickerBuy, + "last" .= binfoTickerLast, + "15m" .= binfoTicker15m + ] + toEncoding BinfoTicker {..} = + AE.pairs $ + "symbol" .= binfoTickerSymbol + <> "sell" .= binfoTickerSell + <> "buy" .= binfoTickerBuy + <> "last" .= binfoTickerLast + <> "15m" .= binfoTicker15m + +instance FromJSON BinfoTicker where + parseJSON = A.withObject "ticker" $ \o -> do + binfoTickerSymbol <- o .: "symbol" + binfoTicker15m <- o .: "15m" + binfoTickerSell <- o .: "sell" + binfoTickerBuy <- o .: "buy" + binfoTickerLast <- o .: "last" + return BinfoTicker {..} + +data BinfoSymbol = BinfoSymbol + { getBinfoSymbolCode :: !Text, + getBinfoSymbolString :: !Text, + getBinfoSymbolName :: !Text, + getBinfoSymbolConversion :: !Double, + getBinfoSymbolAfter :: !Bool, + getBinfoSymbolLocal :: !Bool + } + deriving (Eq, Show, Generic, NFData) + +instance Default BinfoSymbol where + def = + BinfoSymbol + { getBinfoSymbolCode = "XXX", + getBinfoSymbolString = "¤", + getBinfoSymbolName = "No currency", + getBinfoSymbolConversion = 0.0, + getBinfoSymbolAfter = False, + getBinfoSymbolLocal = True + } + +instance ToJSON BinfoSymbol where + toJSON BinfoSymbol {..} = + A.object + [ "code" .= getBinfoSymbolCode, + "symbol" .= getBinfoSymbolString, + "name" .= getBinfoSymbolName, + "conversion" .= getBinfoSymbolConversion, + "symbolAppearsAfter" .= getBinfoSymbolAfter, + "local" .= getBinfoSymbolLocal + ] + toEncoding BinfoSymbol {..} = + AE.pairs + ( "code" .= getBinfoSymbolCode + <> "symbol" .= getBinfoSymbolString + <> "name" .= getBinfoSymbolName + <> "conversion" .= getBinfoSymbolConversion + <> "symbolAppearsAfter" .= getBinfoSymbolAfter + <> "local" .= getBinfoSymbolLocal + ) + +instance FromJSON BinfoSymbol where + parseJSON = A.withObject "symbol" $ \o -> do + getBinfoSymbolCode <- o .: "code" + getBinfoSymbolString <- o .: "symbol" + getBinfoSymbolName <- o .: "name" + getBinfoSymbolConversion <- o .: "conversion" + getBinfoSymbolAfter <- o .: "symbolAppearsAfter" + getBinfoSymbolLocal <- o .: "local" + return BinfoSymbol {..} + +relevantTxs :: + HashSet Address -> + Bool -> + Transaction -> + HashSet TxHash +relevantTxs addrs prune t@Transaction {..} = + let p a = prune && getTxResult addrs t > 0 && not (HashSet.member a addrs) + f StoreOutput {..} = + case outputSpender of + Nothing -> Nothing + Just Spender {..} -> + case outputAddr of + Nothing -> Nothing + Just a + | p a -> Nothing + | otherwise -> Just spenderHash + outs = mapMaybe f transactionOutputs + g StoreCoinbase {} = Nothing + g StoreInput {inputPoint = OutPoint {..}} = Just outPointHash + ins = mapMaybe g transactionInputs + in HashSet.fromList $ ins <> outs + +toBinfoAddrs :: + HashMap Address Balance -> + HashMap XPubSpec [XPubBal] -> + HashMap XPubSpec Word64 -> + [BinfoBalance] +toBinfoAddrs only_addrs only_xpubs xpub_txs = + xpub_bals <> addr_bals + where + xpub_bal k xs = + let f x = case xPubBalPath x of + [0, _] -> balanceTotalReceived (xPubBal x) + _ -> 0 + g x = balanceAmount (xPubBal x) + balanceZero (xPubBal x) + i m x = case xPubBalPath x of + [m', n] | m == m' -> n + 1 + _ -> 0 + received = sum (map f xs) + bal = fromIntegral (sum (map g xs)) + sent = if bal <= received then received - bal else 0 + count = HashMap.lookupDefault 0 k xpub_txs + ax = foldl max 0 (map (i 0) xs) + cx = foldl max 0 (map (i 1) xs) + in BinfoXPubBalance + { getBinfoXPubKey = xPubSpecKey k, + getBinfoAddrTxCount = count, + getBinfoAddrReceived = received, + getBinfoAddrSent = sent, + getBinfoAddrBalance = bal, + getBinfoXPubAccountIndex = ax, + getBinfoXPubChangeIndex = cx + } + xpub_bals = map (uncurry xpub_bal) (HashMap.toList only_xpubs) + addr_bals = + let f Balance {..} = + let addr = balanceAddress + sent = recv - bal + recv = balanceTotalReceived + tx_count = balanceTxCount + bal = balanceAmount + balanceZero + in BinfoAddrBalance + { getBinfoAddress = addr, + getBinfoAddrTxCount = tx_count, + getBinfoAddrReceived = recv, + getBinfoAddrSent = sent, + getBinfoAddrBalance = bal + } + in map f $ HashMap.elems only_addrs + +toBinfoTxSimple :: + Bool -> + Transaction -> + BinfoTx +toBinfoTxSimple numtxid = + toBinfoTx numtxid HashMap.empty False 0 + +toBinfoTxInputs :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Transaction -> + [BinfoTxInput] +toBinfoTxInputs numtxid abook t = + zipWith f [0 ..] (transactionInputs t) + where + f n i = + BinfoTxInput + { getBinfoTxInputIndex = n, + getBinfoTxInputSeq = inputSequence i, + getBinfoTxInputScript = inputSigScript i, + getBinfoTxInputWitness = wit i, + getBinfoTxInputPrevOut = prev n i + } + wit i = + case inputWitness i of + [] -> BS.empty + ws -> runPutS (put_witness ws) + prev = inputToBinfoTxOutput numtxid abook t + put_witness ws = do + putVarInt (length ws) + mapM_ put_item ws + put_item bs = do + putVarInt (BS.length bs) + putByteString bs + +toBinfoBlockIndex :: Transaction -> Maybe BlockHeight +toBinfoBlockIndex Transaction {transactionDeleted = True} = Nothing +toBinfoBlockIndex Transaction {transactionBlock = MemRef _} = Nothing +toBinfoBlockIndex Transaction {transactionBlock = BlockRef h _} = Just h + +toBinfoTx :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Bool -> + Int64 -> + Transaction -> + BinfoTx +toBinfoTx numtxid abook prune bal t@Transaction {..} = + BinfoTx + { getBinfoTxHash = txHash (transactionData t), + getBinfoTxVer = transactionVersion, + getBinfoTxVinSz = fromIntegral (length transactionInputs), + getBinfoTxVoutSz = fromIntegral (length transactionOutputs), + getBinfoTxSize = transactionSize, + getBinfoTxWeight = transactionWeight, + getBinfoTxFee = transactionFees, + getBinfoTxRelayedBy = "0.0.0.0", + getBinfoTxLockTime = transactionLockTime, + getBinfoTxIndex = + encodeBinfoTxId numtxid (txHash (transactionData t)), + getBinfoTxDoubleSpend = transactionDeleted, + getBinfoTxRBF = transactionRBF, + getBinfoTxTime = transactionTime, + getBinfoTxBlockIndex = toBinfoBlockIndex t, + getBinfoTxBlockHeight = toBinfoBlockIndex t, + getBinfoTxInputs = toBinfoTxInputs numtxid abook t, + getBinfoTxOutputs = outs, + getBinfoTxResultBal = resbal + } + where + simple = HashMap.null abook && bal == 0 + resbal = if simple then Nothing else Just (getTxResult aset t, bal) + aset = HashMap.keysSet abook + outs = + let p = prune && getTxResult aset t > 0 + f = toBinfoTxOutput numtxid abook p t + in catMaybes $ zipWith f [0 ..] transactionOutputs + +getTxResult :: HashSet Address -> Transaction -> Int64 +getTxResult aset Transaction {..} = + let input_sum = sum $ map input_value transactionInputs + input_value StoreCoinbase {} = 0 + input_value StoreInput {..} = + case inputAddress of + Nothing -> 0 + Just a -> + if test_addr a + then negate $ fromIntegral inputAmount + else 0 + test_addr a = HashSet.member a aset + output_sum = sum $ map out_value transactionOutputs + out_value StoreOutput {..} = + case outputAddr of + Nothing -> 0 + Just a -> + if test_addr a + then fromIntegral outputAmount + else 0 + in input_sum + output_sum + +toBinfoTxOutput :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Bool -> + Transaction -> + Word32 -> + StoreOutput -> + Maybe BinfoTxOutput +toBinfoTxOutput numtxid abook prune t n StoreOutput {..} = + let getBinfoTxOutputType = 0 + getBinfoTxOutputSpent = isJust outputSpender + getBinfoTxOutputValue = outputAmount + getBinfoTxOutputIndex = n + getBinfoTxOutputTxIndex = + encodeBinfoTxId numtxid (txHash (transactionData t)) + getBinfoTxOutputScript = outputScript + getBinfoTxOutputSpenders = + maybeToList $ toBinfoSpender numtxid <$> outputSpender + getBinfoTxOutputAddress = outputAddr + getBinfoTxOutputXPub = + outputAddr >>= join . (`HashMap.lookup` abook) + in if prune && isNothing (outputAddr >>= (`HashMap.lookup` abook)) + then Nothing + else Just BinfoTxOutput {..} + +toBinfoSpender :: Bool -> Spender -> BinfoSpender +toBinfoSpender numtxid Spender {..} = + let getBinfoSpenderTxIndex = encodeBinfoTxId numtxid spenderHash + getBinfoSpenderIndex = spenderIndex + in BinfoSpender {..} + +inputToBinfoTxOutput :: + Bool -> + HashMap Address (Maybe BinfoXPubPath) -> + Transaction -> + Word32 -> + StoreInput -> + BinfoTxOutput +inputToBinfoTxOutput numtxid abook t n i = + BinfoTxOutput + { getBinfoTxOutputIndex = out_index, + getBinfoTxOutputType = 0, + getBinfoTxOutputSpent = True, + getBinfoTxOutputValue = inputAmount, + getBinfoTxOutputTxIndex = encodeBinfoTxId numtxid out_hash, + getBinfoTxOutputScript = inputPkScript, + getBinfoTxOutputSpenders = [spender], + getBinfoTxOutputAddress = inputAddress, + getBinfoTxOutputXPub = xpub + } + where + inputAmount = + case i of + StoreCoinbase {} -> 0 + StoreInput {..} -> inputAmount + inputPkScript = + case i of + StoreCoinbase {} -> BS.empty + StoreInput {..} -> inputPkScript + inputAddress = + case i of + StoreCoinbase {} -> Nothing + StoreInput {..} -> inputAddress + OutPoint out_hash out_index = inputPoint i + spender = + BinfoSpender + (encodeBinfoTxId numtxid (txHash (transactionData t))) + n + xpub = inputAddress >>= join . (`HashMap.lookup` abook) + +data BinfoAddr + = BinfoAddr !Address + | BinfoXpub !XPubKey + deriving (Eq, Show, Generic, Hashable, NFData) + +parseBinfoAddr :: Network -> Text -> Maybe [BinfoAddr] +parseBinfoAddr _ "" = Just [] +parseBinfoAddr net s = + mapM f $ + filter (not . T.null) $ + concatMap (T.splitOn ",") (T.splitOn "|" s) + where + f x = BinfoAddr <$> textToAddr net x <|> BinfoXpub <$> xPubImport net x + +data BinfoHeader = BinfoHeader + { binfoHeaderHash :: !BlockHash, + binfoHeaderTime :: !Timestamp, + binfoHeaderIndex :: !Word32, + binfoHeaderHeight :: !BlockHeight, + binfoTxIndices :: ![BinfoTxId] + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoHeader where + toJSON BinfoHeader {..} = + A.object + [ "hash" .= binfoHeaderHash, + "time" .= binfoHeaderTime, + "block_index" .= binfoHeaderIndex, + "height" .= binfoHeaderHeight, + "txIndexes" .= binfoTxIndices + ] + +instance FromJSON BinfoHeader where + parseJSON = A.withObject "header" $ \o -> do + binfoHeaderHash <- o .: "hash" + binfoHeaderTime <- o .: "time" + binfoHeaderIndex <- o .: "block_index" + binfoHeaderHeight <- o .: "height" + binfoTxIndices <- o .: "txIndexes" + return BinfoHeader {..} + +newtype BinfoMempool = BinfoMempool {getBinfoMempool :: [BinfoTx]} + deriving (Eq, Show, Generic, NFData) + +binfoMempoolToJSON :: Network -> BinfoMempool -> Value +binfoMempoolToJSON net (BinfoMempool txs) = + A.object ["txs" .= map (binfoTxToJSON net) txs] + +binfoMempoolToEncoding :: Network -> BinfoMempool -> Encoding +binfoMempoolToEncoding net (BinfoMempool txs) = + AE.pairs $ AE.pair "txs" (AE.list (binfoTxToEncoding net) txs) + +binfoMempoolParseJSON :: Network -> Value -> Parser BinfoMempool +binfoMempoolParseJSON net = + A.withObject "mempool" $ \o -> + BinfoMempool <$> (mapM (binfoTxParseJSON net) =<< o .: "txs") + +newtype BinfoBlocks = BinfoBlocks {binfoBlocks :: [BinfoBlockInfo]} + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoBlocks where + toJSON BinfoBlocks {..} = A.object ["blocks" .= binfoBlocks] + +instance FromJSON BinfoBlocks where + parseJSON = A.withObject "blocks" $ \o -> BinfoBlocks <$> o .: "blocks" diff --git a/src/Haskoin/Store/WebClient.hs b/src/Haskoin/Store/WebClient.hs --- a/src/Haskoin/Store/WebClient.hs +++ b/src/Haskoin/Store/WebClient.hs @@ -4,8 +4,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -module Haskoin.Store.WebClient ( - ApiConfig (..), +module Haskoin.Store.WebClient + ( ApiConfig (..), apiCall, apiBatch, -- Blocks @@ -60,7 +60,8 @@ Store.DeriveType (..), NoCache (..), NoTx (..), -) where + ) +where import Control.Arrow (second) import Control.Exception @@ -89,163 +90,160 @@ import Network.Wreq.Types (ResponseChecker) import Numeric.Natural (Natural) -{- | Configuration specifying the Network and the Host for API calls. - Default instance: - - @ - ApiConfig - { configNetwork = bch - , configHost = "https://api.haskoin.com/" - } - @ --} +-- | Configuration specifying the Network and the Host for API calls. +-- Default instance: +-- +-- @ +-- ApiConfig +-- { configNetwork = bch +-- , configHost = "https://api.haskoin.com/" +-- } +-- @ data ApiConfig = ApiConfig - { configNetwork :: !Network - , configHost :: !String - } - deriving (Eq, Show) + { configNetwork :: !Network, + configHost :: !String + } + deriving (Eq, Show) instance Default ApiConfig where - def = - ApiConfig - { configNetwork = bch - , configHost = "https://api.haskoin.com/" - } - -{- | Make a call to the haskoin-store API. - - Usage (default options): - - > apiCall def $ GetAddrsTxs addrs def - - With options: + def = + ApiConfig + { configNetwork = bch, + configHost = "https://api.haskoin.com/" + } - > apiCall def $ GetAddrsUnspent addrs def{ paramLimit = Just 10 } --} +-- | Make a call to the haskoin-store API. +-- +-- Usage (default options): +-- +-- > apiCall def $ GetAddrsTxs addrs def +-- +-- With options: +-- +-- > apiCall def $ GetAddrsUnspent addrs def{ paramLimit = Just 10 } apiCall :: - (ApiResource a b, MonadIO m, MonadError Store.Except m) => - ApiConfig -> - a -> - m b + (ApiResource a b, MonadIO m, MonadError Store.Except m) => + ApiConfig -> + a -> + m b apiCall (ApiConfig net apiHost) res = do - args <- liftEither $ toOptions net res - let url = apiHost <> getNetworkName net <> cs (queryPath net res) - case resourceMethod $ asProxy res of - GET -> liftEither =<< liftIO (getBinary args url) - POST -> - case resourceBody res of - Just (PostBox val) -> - liftEither =<< liftIO (postBinary args url val) - _ -> throwError $ Store.StringError "Could not post resource" - _ -> throwError $ Store.StringError "Unsupported HTTP method" - -{- | Batch commands that have a large list of arguments: + args <- liftEither $ toOptions net res + let url = apiHost <> getNetworkName net <> cs (queryPath net res) + case resourceMethod $ asProxy res of + GET -> liftEither =<< liftIO (getBinary args url) + POST -> + case resourceBody res of + Just (PostBox val) -> + liftEither =<< liftIO (postBinary args url val) + _ -> throwError $ Store.StringError "Could not post resource" + _ -> throwError $ Store.StringError "Unsupported HTTP method" - > apiBatch 20 def (GetAddrsTxs addrs def) --} +-- | Batch commands that have a large list of arguments: +-- +-- > apiBatch 20 def (GetAddrsTxs addrs def) apiBatch :: - (Batchable a b, MonadIO m, MonadError Store.Except m) => - Natural -> - ApiConfig -> - a -> - m b + (Batchable a b, MonadIO m, MonadError Store.Except m) => + Natural -> + ApiConfig -> + a -> + m b apiBatch i conf res = mconcat <$> mapM (apiCall conf) (resourceBatch i res) class (ApiResource a b, Monoid b) => Batchable a b where - resourceBatch :: Natural -> a -> [a] + resourceBatch :: Natural -> a -> [a] instance Batchable GetBlocks (Store.SerialList Store.BlockData) where - resourceBatch i (GetBlocks hs t) = - (`GetBlocks` t) <$> chunksOf i hs + resourceBatch i (GetBlocks hs t) = + (`GetBlocks` t) <$> chunksOf i hs instance Batchable GetBlockHeights (Store.SerialList Store.BlockData) where - resourceBatch i (GetBlockHeights (HeightsParam hs) n) = - (`GetBlockHeights` n) - <$> (HeightsParam <$> chunksOf i hs) + resourceBatch i (GetBlockHeights (HeightsParam hs) n) = + (`GetBlockHeights` n) + <$> (HeightsParam <$> chunksOf i hs) instance Batchable GetTxs (Store.SerialList Store.Transaction) where - resourceBatch i (GetTxs ts) = - GetTxs <$> chunksOf i ts + resourceBatch i (GetTxs ts) = + GetTxs <$> chunksOf i ts instance Batchable GetTxsRaw (Store.RawResultList Tx) where - resourceBatch i (GetTxsRaw ts) = - GetTxsRaw <$> chunksOf i ts + resourceBatch i (GetTxsRaw ts) = + GetTxsRaw <$> chunksOf i ts instance Batchable GetAddrsTxs (Store.SerialList Store.TxRef) where - resourceBatch i (GetAddrsTxs as l) = - (`GetAddrsTxs` l) <$> chunksOf i as + resourceBatch i (GetAddrsTxs as l) = + (`GetAddrsTxs` l) <$> chunksOf i as instance Batchable GetAddrsTxsFull (Store.SerialList Store.Transaction) where - resourceBatch i (GetAddrsTxsFull as l) = - (`GetAddrsTxsFull` l) <$> chunksOf i as + resourceBatch i (GetAddrsTxsFull as l) = + (`GetAddrsTxsFull` l) <$> chunksOf i as instance Batchable GetAddrsBalance (Store.SerialList Store.Balance) where - resourceBatch i (GetAddrsBalance as) = - GetAddrsBalance <$> chunksOf i as + resourceBatch i (GetAddrsBalance as) = + GetAddrsBalance <$> chunksOf i as instance Batchable GetAddrsUnspent (Store.SerialList Store.Unspent) where - resourceBatch i (GetAddrsUnspent as l) = - (`GetAddrsUnspent` l) <$> chunksOf i as + resourceBatch i (GetAddrsUnspent as l) = + (`GetAddrsUnspent` l) <$> chunksOf i as ------------------ -- API Internal -- ------------------ toOptions :: - ApiResource a b => Network -> a -> Either Store.Except (Endo HTTP.Options) + ApiResource a b => Network -> a -> Either Store.Except (Endo HTTP.Options) toOptions net res = - mconcat <$> mapM f (snd $ queryParams res) + mconcat <$> mapM f (snd $ queryParams res) where f (ParamBox p) = toOption net p toOption :: Param a => Network -> a -> Either Store.Except (Endo HTTP.Options) toOption net a = do - res <- maybeToEither (Store.UserError "Invalid Param") $ encodeParam net a - return $ applyOpt (paramLabel a) res + res <- maybeToEither (Store.UserError "Invalid Param") $ encodeParam net a + return $ applyOpt (paramLabel a) res applyOpt :: Text -> [Text] -> Endo HTTP.Options applyOpt p t = Endo $ HTTP.param p .~ [Text.intercalate "," t] getBinary :: - Serial a => - Endo HTTP.Options -> - String -> - IO (Either Store.Except a) + Serial a => + Endo HTTP.Options -> + String -> + IO (Either Store.Except a) getBinary opts url = do - resE <- try $ HTTP.getWith (binaryOpts opts) url - return $ do - res <- resE - toExcept $ runGetS deserialize $ BL.toStrict $ res ^. HTTP.responseBody + resE <- try $ HTTP.getWith (binaryOpts opts) url + return $ do + res <- resE + toExcept $ runGetS deserialize $ BL.toStrict $ res ^. HTTP.responseBody postBinary :: - (Serial a, Serial r) => - Endo HTTP.Options -> - String -> - a -> - IO (Either Store.Except r) + (Serial a, Serial r) => + Endo HTTP.Options -> + String -> + a -> + IO (Either Store.Except r) postBinary opts url body = do - resE <- try $ HTTP.postWith (binaryOpts opts) url (runPutL (serialize body)) - return $ do - res <- resE - toExcept $ runGetL deserialize $ res ^. HTTP.responseBody + resE <- try $ HTTP.postWith (binaryOpts opts) url (runPutL (serialize body)) + return $ do + res <- resE + toExcept $ runGetL deserialize $ res ^. HTTP.responseBody binaryOpts :: Endo HTTP.Options -> HTTP.Options binaryOpts opts = - appEndo (opts <> accept <> stat) HTTP.defaults + appEndo (opts <> accept <> stat) HTTP.defaults where accept = Endo $ HTTP.header "Accept" .~ ["application/octet-stream"] stat = Endo $ HTTP.checkResponse ?~ checkStatus checkStatus :: ResponseChecker checkStatus req res - | statusIsSuccessful status = return () - | isHealthPath && code == 503 = return () -- Ignore health checks - | otherwise = do - e <- A.decodeStrict <$> res ^. HTTP.responseBody - throwIO $ - case e of - Just except -> except :: Store.Except - Nothing -> Store.StringError "could not decode error" + | statusIsSuccessful status = return () + | isHealthPath && code == 503 = return () -- Ignore health checks + | otherwise = do + e <- A.decodeStrict <$> res ^. HTTP.responseBody + throwIO $ + case e of + Just except -> except :: Store.Except + Nothing -> Store.StringError "could not decode error" where code = res ^. HTTP.responseStatus . HTTP.statusCode message = res ^. HTTP.responseStatus . HTTP.statusMessage @@ -262,6 +260,6 @@ chunksOf :: Natural -> [a] -> [[a]] chunksOf n xs - | null xs = [] - | otherwise = - uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral n) xs + | null xs = [] + | otherwise = + uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral n) xs diff --git a/src/Haskoin/Store/WebCommon.hs b/src/Haskoin/Store/WebCommon.hs --- a/src/Haskoin/Store/WebCommon.hs +++ b/src/Haskoin/Store/WebCommon.hs @@ -18,12 +18,12 @@ import Data.Text (Text) import qualified Data.Text as T import Haskoin.Address -import Haskoin.Block ( - Block, +import Haskoin.Block + ( Block, BlockHash, blockHashToHex, hexToBlockHash, - ) + ) import Haskoin.Constants import Haskoin.Crypto (Hash256) import Haskoin.Data @@ -40,18 +40,20 @@ ------------------- class Serial b => ApiResource a b | a -> b where - resourceMethod :: Proxy a -> StdMethod - resourceMethod _ = GET - resourcePath :: Proxy a -> ([Text] -> Text) - queryParams :: a -> ([ParamBox], [ParamBox]) -- (resource, querystring) - queryParams _ = ([], []) - captureParams :: Proxy a -> [ProxyBox] - captureParams _ = [] - resourceBody :: a -> Maybe PostBox - resourceBody = const Nothing + resourceMethod :: Proxy a -> StdMethod + resourceMethod _ = GET + resourcePath :: Proxy a -> ([Text] -> Text) + queryParams :: a -> ([ParamBox], [ParamBox]) -- (resource, querystring) + queryParams _ = ([], []) + captureParams :: Proxy a -> [ProxyBox] + captureParams _ = [] + resourceBody :: a -> Maybe PostBox + resourceBody = const Nothing data PostBox = forall s. Serial s => PostBox !s + data ParamBox = forall p. (Eq p, Param p) => ParamBox !p + data ProxyBox = forall p. Param p => ProxyBox !(Proxy p) -------------------- @@ -60,51 +62,85 @@ -- Blocks data GetBlock = GetBlock !BlockHash !NoTx + data GetBlocks = GetBlocks ![BlockHash] !NoTx + newtype GetBlockRaw = GetBlockRaw BlockHash + newtype GetBlockBest = GetBlockBest NoTx + data GetBlockBestRaw = GetBlockBestRaw + newtype GetBlockLatest = GetBlockLatest NoTx + data GetBlockHeight = GetBlockHeight !HeightParam !NoTx + data GetBlockHeights = GetBlockHeights !HeightsParam !NoTx + newtype GetBlockHeightRaw = GetBlockHeightRaw HeightParam + data GetBlockTime = GetBlockTime !TimeParam !NoTx + newtype GetBlockTimeRaw = GetBlockTimeRaw TimeParam + data GetBlockMTP = GetBlockMTP !TimeParam !NoTx + newtype GetBlockMTPRaw = GetBlockMTPRaw TimeParam -- Transactions newtype GetTx = GetTx TxHash + newtype GetTxs = GetTxs [TxHash] + newtype GetTxRaw = GetTxRaw TxHash + newtype GetTxsRaw = GetTxsRaw [TxHash] + newtype GetTxsBlock = GetTxsBlock BlockHash + newtype GetTxsBlockRaw = GetTxsBlockRaw BlockHash + data GetTxAfter = GetTxAfter !TxHash !HeightParam + newtype PostTx = PostTx Tx + data GetMempool = GetMempool !(Maybe LimitParam) !OffsetParam + data GetEvents = GetEvents -- Address data GetAddrTxs = GetAddrTxs !Address !LimitsParam + data GetAddrsTxs = GetAddrsTxs ![Address] !LimitsParam + data GetAddrTxsFull = GetAddrTxsFull !Address !LimitsParam + data GetAddrsTxsFull = GetAddrsTxsFull ![Address] !LimitsParam + newtype GetAddrBalance = GetAddrBalance Address + newtype GetAddrsBalance = GetAddrsBalance [Address] + data GetAddrUnspent = GetAddrUnspent !Address !LimitsParam + data GetAddrsUnspent = GetAddrsUnspent ![Address] !LimitsParam -- XPubs data GetXPub = GetXPub !XPubKey !Store.DeriveType !NoCache + data GetXPubTxs = GetXPubTxs !XPubKey !Store.DeriveType !LimitsParam !NoCache + data GetXPubTxsFull = GetXPubTxsFull !XPubKey !Store.DeriveType !LimitsParam !NoCache + data GetXPubBalances = GetXPubBalances !XPubKey !Store.DeriveType !NoCache + data GetXPubUnspent = GetXPubUnspent !XPubKey !Store.DeriveType !LimitsParam !NoCache + data DelCachedXPub = DelCachedXPub !XPubKey !Store.DeriveType -- Network data GetPeers = GetPeers + data GetHealth = GetHealth ------------ @@ -112,215 +148,215 @@ ------------ instance ApiResource GetBlock Store.BlockData where - resourcePath _ = ("/block/" <:>) - queryParams (GetBlock h t) = ([ParamBox h], noDefBox t) - captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] + resourcePath _ = ("/block/" <:>) + queryParams (GetBlock h t) = ([ParamBox h], noDefBox t) + captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] instance ApiResource GetBlocks (Store.SerialList Store.BlockData) where - resourcePath _ _ = "/blocks" - queryParams (GetBlocks hs t) = ([], [ParamBox hs] <> noDefBox t) + resourcePath _ _ = "/blocks" + queryParams (GetBlocks hs t) = ([], [ParamBox hs] <> noDefBox t) instance ApiResource GetBlockRaw (Store.RawResult Block) where - resourcePath _ = "/block/" <+> "/raw" - queryParams (GetBlockRaw h) = ([ParamBox h], []) - captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] + resourcePath _ = "/block/" <+> "/raw" + queryParams (GetBlockRaw h) = ([ParamBox h], []) + captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] instance ApiResource GetBlockBest Store.BlockData where - resourcePath _ _ = "/block/best" - queryParams (GetBlockBest t) = ([], noDefBox t) + resourcePath _ _ = "/block/best" + queryParams (GetBlockBest t) = ([], noDefBox t) instance ApiResource GetBlockBestRaw (Store.RawResult Block) where - resourcePath _ _ = "/block/best/raw" + resourcePath _ _ = "/block/best/raw" instance ApiResource GetBlockLatest (Store.SerialList Store.BlockData) where - resourcePath _ _ = "/block/latest" - queryParams (GetBlockLatest t) = ([], noDefBox t) + resourcePath _ _ = "/block/latest" + queryParams (GetBlockLatest t) = ([], noDefBox t) instance ApiResource GetBlockHeight (Store.SerialList Store.BlockData) where - resourcePath _ = ("/block/height/" <:>) - queryParams (GetBlockHeight h t) = ([ParamBox h], noDefBox t) - captureParams _ = [ProxyBox (Proxy :: Proxy HeightParam)] + resourcePath _ = ("/block/height/" <:>) + queryParams (GetBlockHeight h t) = ([ParamBox h], noDefBox t) + captureParams _ = [ProxyBox (Proxy :: Proxy HeightParam)] instance ApiResource GetBlockHeights (Store.SerialList Store.BlockData) where - resourcePath _ _ = "/block/heights" - queryParams (GetBlockHeights hs t) = ([], [ParamBox hs] <> noDefBox t) + resourcePath _ _ = "/block/heights" + queryParams (GetBlockHeights hs t) = ([], [ParamBox hs] <> noDefBox t) instance ApiResource GetBlockHeightRaw (Store.RawResultList Block) where - resourcePath _ = "/block/height/" <+> "/raw" - queryParams (GetBlockHeightRaw h) = ([ParamBox h], []) - captureParams _ = [ProxyBox (Proxy :: Proxy HeightParam)] + resourcePath _ = "/block/height/" <+> "/raw" + queryParams (GetBlockHeightRaw h) = ([ParamBox h], []) + captureParams _ = [ProxyBox (Proxy :: Proxy HeightParam)] instance ApiResource GetBlockTime Store.BlockData where - resourcePath _ = ("/block/time/" <:>) - queryParams (GetBlockTime u t) = ([ParamBox u], noDefBox t) - captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] + resourcePath _ = ("/block/time/" <:>) + queryParams (GetBlockTime u t) = ([ParamBox u], noDefBox t) + captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] instance ApiResource GetBlockTimeRaw (Store.RawResult Block) where - resourcePath _ = "/block/time/" <+> "/raw" - queryParams (GetBlockTimeRaw u) = ([ParamBox u], []) - captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] + resourcePath _ = "/block/time/" <+> "/raw" + queryParams (GetBlockTimeRaw u) = ([ParamBox u], []) + captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] instance ApiResource GetBlockMTP Store.BlockData where - resourcePath _ = ("/block/mtp/" <:>) - queryParams (GetBlockMTP u t) = ([ParamBox u], noDefBox t) - captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] + resourcePath _ = ("/block/mtp/" <:>) + queryParams (GetBlockMTP u t) = ([ParamBox u], noDefBox t) + captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] instance ApiResource GetBlockMTPRaw (Store.RawResult Block) where - resourcePath _ = "/block/mtp/" <+> "/raw" - queryParams (GetBlockMTPRaw u) = ([ParamBox u], []) - captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] + resourcePath _ = "/block/mtp/" <+> "/raw" + queryParams (GetBlockMTPRaw u) = ([ParamBox u], []) + captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)] ------------------ -- Transactions -- ------------------ instance ApiResource GetTx Store.Transaction where - resourcePath _ = ("/transaction/" <:>) - queryParams (GetTx h) = ([ParamBox h], []) - captureParams _ = [ProxyBox (Proxy :: Proxy TxHash)] + resourcePath _ = ("/transaction/" <:>) + queryParams (GetTx h) = ([ParamBox h], []) + captureParams _ = [ProxyBox (Proxy :: Proxy TxHash)] instance ApiResource GetTxs (Store.SerialList Store.Transaction) where - resourcePath _ _ = "/transactions" - queryParams (GetTxs hs) = ([], [ParamBox hs]) + resourcePath _ _ = "/transactions" + queryParams (GetTxs hs) = ([], [ParamBox hs]) instance ApiResource GetTxRaw (Store.RawResult Tx) where - resourcePath _ = "/transaction/" <+> "/raw" - queryParams (GetTxRaw h) = ([ParamBox h], []) - captureParams _ = [ProxyBox (Proxy :: Proxy TxHash)] + resourcePath _ = "/transaction/" <+> "/raw" + queryParams (GetTxRaw h) = ([ParamBox h], []) + captureParams _ = [ProxyBox (Proxy :: Proxy TxHash)] instance ApiResource GetTxsRaw (Store.RawResultList Tx) where - resourcePath _ _ = "/transactions/raw" - queryParams (GetTxsRaw hs) = ([], [ParamBox hs]) + resourcePath _ _ = "/transactions/raw" + queryParams (GetTxsRaw hs) = ([], [ParamBox hs]) instance ApiResource GetTxsBlock (Store.SerialList Store.Transaction) where - resourcePath _ = ("/transactions/block/" <:>) - queryParams (GetTxsBlock h) = ([ParamBox h], []) - captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] + resourcePath _ = ("/transactions/block/" <:>) + queryParams (GetTxsBlock h) = ([ParamBox h], []) + captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] instance ApiResource GetTxsBlockRaw (Store.RawResultList Tx) where - resourcePath _ = "/transactions/block/" <+> "/raw" - queryParams (GetTxsBlockRaw h) = ([ParamBox h], []) - captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] + resourcePath _ = "/transactions/block/" <+> "/raw" + queryParams (GetTxsBlockRaw h) = ([ParamBox h], []) + captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)] instance ApiResource GetTxAfter (Store.GenericResult (Maybe Bool)) where - resourcePath _ = "/transaction/" <++> "/after/" - queryParams (GetTxAfter h i) = ([ParamBox h, ParamBox i], []) - captureParams _ = - [ ProxyBox (Proxy :: Proxy TxHash) - , ProxyBox (Proxy :: Proxy HeightParam) - ] + resourcePath _ = "/transaction/" <++> "/after/" + queryParams (GetTxAfter h i) = ([ParamBox h, ParamBox i], []) + captureParams _ = + [ ProxyBox (Proxy :: Proxy TxHash), + ProxyBox (Proxy :: Proxy HeightParam) + ] instance ApiResource PostTx Store.TxId where - resourceMethod _ = POST - resourcePath _ _ = "/transactions" - resourceBody (PostTx tx) = Just $ PostBox tx + resourceMethod _ = POST + resourcePath _ _ = "/transactions" + resourceBody (PostTx tx) = Just $ PostBox tx instance ApiResource GetMempool (Store.SerialList TxHash) where - resourcePath _ _ = "/mempool" - queryParams (GetMempool l o) = ([], noMaybeBox l <> noDefBox o) + resourcePath _ _ = "/mempool" + queryParams (GetMempool l o) = ([], noMaybeBox l <> noDefBox o) instance ApiResource GetEvents (Store.SerialList Store.Event) where - resourcePath _ _ = "/events" + resourcePath _ _ = "/events" ------------- -- Address -- ------------- instance ApiResource GetAddrTxs (Store.SerialList Store.TxRef) where - resourcePath _ = "/address/" <+> "/transactions" - queryParams (GetAddrTxs a (LimitsParam l o sM)) = - ([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM) - captureParams _ = [ProxyBox (Proxy :: Proxy Address)] + resourcePath _ = "/address/" <+> "/transactions" + queryParams (GetAddrTxs a (LimitsParam l o sM)) = + ([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM) + captureParams _ = [ProxyBox (Proxy :: Proxy Address)] instance ApiResource GetAddrsTxs (Store.SerialList Store.TxRef) where - resourcePath _ _ = "/address/transactions" - queryParams (GetAddrsTxs as (LimitsParam l o sM)) = - ([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM) + resourcePath _ _ = "/address/transactions" + queryParams (GetAddrsTxs as (LimitsParam l o sM)) = + ([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM) instance ApiResource GetAddrTxsFull (Store.SerialList Store.Transaction) where - resourcePath _ = "/address/" <+> "/transactions/full" - queryParams (GetAddrTxsFull a (LimitsParam l o sM)) = - ([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM) - captureParams _ = [ProxyBox (Proxy :: Proxy Address)] + resourcePath _ = "/address/" <+> "/transactions/full" + queryParams (GetAddrTxsFull a (LimitsParam l o sM)) = + ([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM) + captureParams _ = [ProxyBox (Proxy :: Proxy Address)] instance ApiResource GetAddrsTxsFull (Store.SerialList Store.Transaction) where - resourcePath _ _ = "/address/transactions/full" - queryParams (GetAddrsTxsFull as (LimitsParam l o sM)) = - ([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM) + resourcePath _ _ = "/address/transactions/full" + queryParams (GetAddrsTxsFull as (LimitsParam l o sM)) = + ([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM) instance ApiResource GetAddrBalance Store.Balance where - resourcePath _ = "/address/" <+> "/balance" - queryParams (GetAddrBalance a) = ([ParamBox a], []) - captureParams _ = [ProxyBox (Proxy :: Proxy Address)] + resourcePath _ = "/address/" <+> "/balance" + queryParams (GetAddrBalance a) = ([ParamBox a], []) + captureParams _ = [ProxyBox (Proxy :: Proxy Address)] instance ApiResource GetAddrsBalance (Store.SerialList Store.Balance) where - resourcePath _ _ = "/address/balances" - queryParams (GetAddrsBalance as) = ([], [ParamBox as]) + resourcePath _ _ = "/address/balances" + queryParams (GetAddrsBalance as) = ([], [ParamBox as]) instance ApiResource GetAddrUnspent (Store.SerialList Store.Unspent) where - resourcePath _ = "/address/" <+> "/unspent" - queryParams (GetAddrUnspent a (LimitsParam l o sM)) = - ([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM) - captureParams _ = [ProxyBox (Proxy :: Proxy Address)] + resourcePath _ = "/address/" <+> "/unspent" + queryParams (GetAddrUnspent a (LimitsParam l o sM)) = + ([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM) + captureParams _ = [ProxyBox (Proxy :: Proxy Address)] instance ApiResource GetAddrsUnspent (Store.SerialList Store.Unspent) where - resourcePath _ _ = "/address/unspent" - queryParams (GetAddrsUnspent as (LimitsParam l o sM)) = - ([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM) + resourcePath _ _ = "/address/unspent" + queryParams (GetAddrsUnspent as (LimitsParam l o sM)) = + ([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM) ----------- -- XPubs -- ----------- instance ApiResource GetXPub Store.XPubSummary where - resourcePath _ = ("/xpub/" <:>) - queryParams (GetXPub p d n) = ([ParamBox p], noDefBox d <> noDefBox n) - captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] + resourcePath _ = ("/xpub/" <:>) + queryParams (GetXPub p d n) = ([ParamBox p], noDefBox d <> noDefBox n) + captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] instance ApiResource GetXPubTxs (Store.SerialList Store.TxRef) where - resourcePath _ = "/xpub/" <+> "/transactions" - queryParams (GetXPubTxs p d (LimitsParam l o sM) n) = - ( [ParamBox p] - , noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n - ) - captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] + resourcePath _ = "/xpub/" <+> "/transactions" + queryParams (GetXPubTxs p d (LimitsParam l o sM) n) = + ( [ParamBox p], + noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n + ) + captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] instance ApiResource GetXPubTxsFull (Store.SerialList Store.Transaction) where - resourcePath _ = "/xpub/" <+> "/transactions/full" - queryParams (GetXPubTxsFull p d (LimitsParam l o sM) n) = - ( [ParamBox p] - , noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n - ) - captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] + resourcePath _ = "/xpub/" <+> "/transactions/full" + queryParams (GetXPubTxsFull p d (LimitsParam l o sM) n) = + ( [ParamBox p], + noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n + ) + captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] instance ApiResource GetXPubBalances (Store.SerialList Store.XPubBal) where - resourcePath _ = "/xpub/" <+> "/balances" - queryParams (GetXPubBalances p d n) = ([ParamBox p], noDefBox d <> noDefBox n) - captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] + resourcePath _ = "/xpub/" <+> "/balances" + queryParams (GetXPubBalances p d n) = ([ParamBox p], noDefBox d <> noDefBox n) + captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] instance ApiResource GetXPubUnspent (Store.SerialList Store.XPubUnspent) where - resourcePath _ = "/xpub/" <+> "/unspent" - queryParams (GetXPubUnspent p d (LimitsParam l o sM) n) = - ( [ParamBox p] - , noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n - ) - captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] + resourcePath _ = "/xpub/" <+> "/unspent" + queryParams (GetXPubUnspent p d (LimitsParam l o sM) n) = + ( [ParamBox p], + noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n + ) + captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] instance ApiResource DelCachedXPub (Store.GenericResult Bool) where - resourceMethod _ = DELETE - resourcePath _ = ("/xpub/" <:>) - queryParams (DelCachedXPub p d) = ([ParamBox p], noDefBox d) - captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] + resourceMethod _ = DELETE + resourcePath _ = ("/xpub/" <:>) + queryParams (DelCachedXPub p d) = ([ParamBox p], noDefBox d) + captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] ------------- -- Network -- ------------- instance ApiResource GetPeers (Store.SerialList Store.PeerInformation) where - resourcePath _ _ = "/peers" + resourcePath _ _ = "/peers" instance ApiResource GetHealth Store.HealthCheck where - resourcePath _ _ = "/health" + resourcePath _ _ = "/health" ------------- -- Helpers -- @@ -337,8 +373,8 @@ fill :: Int -> [Text] -> [Text] -> Text fill i a b - | length b /= i = error "Invalid query parameters" - | otherwise = mconcat $ uncurry (<>) <$> zip a (b <> repeat "") + | length b /= i = error "Invalid query parameters" + | otherwise = mconcat $ uncurry (<>) <$> zip a (b <> repeat "") noDefBox :: (Default p, Param p, Eq p) => p -> [ParamBox] noDefBox p = [ParamBox p | p /= def] @@ -355,13 +391,13 @@ where f = resourcePath $ asProxy a encParam (ParamBox p) = - case encodeParam net p of - Just [res] -> res - _ -> error "Invalid query param" + case encodeParam net p of + Just [res] -> res + _ -> error "Invalid query param" capturePath :: ApiResource a b => Proxy a -> Scotty.RoutePattern capturePath proxy = - fromString $ cs $ f $ toLabel <$> captureParams proxy + fromString $ cs $ f $ toLabel <$> captureParams proxy where f = resourcePath proxy toLabel (ProxyBox p) = ":" <> proxyLabel p @@ -374,197 +410,197 @@ ------------- class Param a where - proxyLabel :: Proxy a -> Text - encodeParam :: Network -> a -> Maybe [Text] - parseParam :: Network -> [Text] -> Maybe a + proxyLabel :: Proxy a -> Text + encodeParam :: Network -> a -> Maybe [Text] + parseParam :: Network -> [Text] -> Maybe a instance Param Address where - proxyLabel = const "address" - encodeParam net a = (: []) <$> addrToText net a - parseParam net [a] = textToAddr net a - parseParam _ _ = Nothing + proxyLabel = const "address" + encodeParam net a = (: []) <$> addrToText net a + parseParam net [a] = textToAddr net a + parseParam _ _ = Nothing instance Param [Address] where - proxyLabel = const "addresses" - encodeParam = mapM . addrToText - parseParam = mapM . textToAddr + proxyLabel = const "addresses" + encodeParam = mapM . addrToText + parseParam = mapM . textToAddr data StartParam - = StartParamHash - { startParamHash :: Hash256 - } - | StartParamHeight - { startParamHeight :: Natural - } - | StartParamTime - { startParamTime :: Store.UnixTime - } - deriving (Eq, Show) + = StartParamHash + { startParamHash :: Hash256 + } + | StartParamHeight + { startParamHeight :: Natural + } + | StartParamTime + { startParamTime :: Store.UnixTime + } + deriving (Eq, Show) instance Param StartParam where - proxyLabel = const "height" - encodeParam _ p = - case p of - StartParamHash h -> return [txHashToHex (TxHash h)] - StartParamHeight h -> do - guard $ h <= 1230768000 - return [cs $ show h] - StartParamTime t -> do - guard $ t > 1230768000 - return [cs $ show t] - parseParam _ [s] = parseHash <|> parseHeight <|> parseUnix - where - parseHash = do - guard (T.length s == 32 * 2) - TxHash x <- hexToTxHash s - return $ StartParamHash x - parseHeight = do - x <- readMaybe $ cs s - guard $ x <= 1230768000 - return $ StartParamHeight x - parseUnix = do - x <- readMaybe $ cs s - guard $ x > 1230768000 - return $ StartParamTime x - parseParam _ _ = Nothing + proxyLabel = const "height" + encodeParam _ p = + case p of + StartParamHash h -> return [txHashToHex (TxHash h)] + StartParamHeight h -> do + guard $ h <= 1230768000 + return [cs $ show h] + StartParamTime t -> do + guard $ t > 1230768000 + return [cs $ show t] + parseParam _ [s] = parseHash <|> parseHeight <|> parseUnix + where + parseHash = do + guard (T.length s == 32 * 2) + TxHash x <- hexToTxHash s + return $ StartParamHash x + parseHeight = do + x <- readMaybe $ cs s + guard $ x <= 1230768000 + return $ StartParamHeight x + parseUnix = do + x <- readMaybe $ cs s + guard $ x > 1230768000 + return $ StartParamTime x + parseParam _ _ = Nothing newtype OffsetParam = OffsetParam - { getOffsetParam :: Natural - } - deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) + { getOffsetParam :: Natural + } + deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Default OffsetParam where - def = OffsetParam 0 + def = OffsetParam 0 instance Param OffsetParam where - proxyLabel = const "offset" - encodeParam _ (OffsetParam o) = Just [cs $ show o] - parseParam _ [s] = OffsetParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + proxyLabel = const "offset" + encodeParam _ (OffsetParam o) = Just [cs $ show o] + parseParam _ [s] = OffsetParam <$> readMaybe (cs s) + parseParam _ _ = Nothing newtype LimitParam = LimitParam - { getLimitParam :: Natural - } - deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) + { getLimitParam :: Natural + } + deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Param LimitParam where - proxyLabel = const "limit" - encodeParam _ (LimitParam l) = Just [cs $ show l] - parseParam _ [s] = LimitParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + proxyLabel = const "limit" + encodeParam _ (LimitParam l) = Just [cs $ show l] + parseParam _ [s] = LimitParam <$> readMaybe (cs s) + parseParam _ _ = Nothing data LimitsParam = LimitsParam - { paramLimit :: Maybe LimitParam -- 0 means maximum - , paramOffset :: OffsetParam - , paramStart :: Maybe StartParam - } - deriving (Eq, Show) + { paramLimit :: Maybe LimitParam, -- 0 means maximum + paramOffset :: OffsetParam, + paramStart :: Maybe StartParam + } + deriving (Eq, Show) instance Default LimitsParam where - def = LimitsParam Nothing def Nothing + def = LimitsParam Nothing def Nothing newtype HeightParam = HeightParam - { getHeightParam :: Natural - } - deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) + { getHeightParam :: Natural + } + deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Param HeightParam where - proxyLabel = const "height" - encodeParam _ (HeightParam h) = Just [cs $ show h] - parseParam _ [s] = HeightParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + proxyLabel = const "height" + encodeParam _ (HeightParam h) = Just [cs $ show h] + parseParam _ [s] = HeightParam <$> readMaybe (cs s) + parseParam _ _ = Nothing newtype HeightsParam = HeightsParam - { getHeightsParam :: [Natural] - } - deriving (Eq, Show, Read) + { getHeightsParam :: [Natural] + } + deriving (Eq, Show, Read) instance Param HeightsParam where - proxyLabel = const "heights" - encodeParam _ (HeightsParam hs) = Just $ cs . show <$> hs - parseParam _ xs = HeightsParam <$> mapM (readMaybe . cs) xs + proxyLabel = const "heights" + encodeParam _ (HeightsParam hs) = Just $ cs . show <$> hs + parseParam _ xs = HeightsParam <$> mapM (readMaybe . cs) xs newtype TimeParam = TimeParam - { getTimeParam :: Store.UnixTime - } - deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) + { getTimeParam :: Store.UnixTime + } + deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral) instance Param TimeParam where - proxyLabel = const "time" - encodeParam _ (TimeParam t) = Just [cs $ show t] - parseParam _ [s] = TimeParam <$> readMaybe (cs s) - parseParam _ _ = Nothing + proxyLabel = const "time" + encodeParam _ (TimeParam t) = Just [cs $ show t] + parseParam _ [s] = TimeParam <$> readMaybe (cs s) + parseParam _ _ = Nothing instance Param XPubKey where - proxyLabel = const "xpub" - encodeParam net p = Just [xPubExport net p] - parseParam net [s] = xPubImport net s - parseParam _ _ = Nothing + proxyLabel = const "xpub" + encodeParam net p = Just [xPubExport net p] + parseParam net [s] = xPubImport net s + parseParam _ _ = Nothing instance Param Store.DeriveType where - proxyLabel = const "derive" - encodeParam net p = do - guard (getSegWit net || p == Store.DeriveNormal) - Just [Store.deriveTypeToText p] - parseParam net d = do - res <- case d of - [x] -> Store.textToDeriveType x - _ -> Nothing - guard (getSegWit net || res == Store.DeriveNormal) - return res + proxyLabel = const "derive" + encodeParam net p = do + guard (getSegWit net || p == Store.DeriveNormal) + Just [Store.deriveTypeToText p] + parseParam net d = do + res <- case d of + [x] -> Store.textToDeriveType x + _ -> Nothing + guard (getSegWit net || res == Store.DeriveNormal) + return res newtype NoCache = NoCache - { getNoCache :: Bool - } - deriving (Eq, Show, Read) + { getNoCache :: Bool + } + deriving (Eq, Show, Read) instance Default NoCache where - def = NoCache False + def = NoCache False instance Param NoCache where - proxyLabel = const "nocache" - encodeParam _ (NoCache True) = Just ["true"] - encodeParam _ (NoCache False) = Just ["false"] - parseParam _ = \case - ["true"] -> Just $ NoCache True - ["false"] -> Just $ NoCache False - _ -> Nothing + proxyLabel = const "nocache" + encodeParam _ (NoCache True) = Just ["true"] + encodeParam _ (NoCache False) = Just ["false"] + parseParam _ = \case + ["true"] -> Just $ NoCache True + ["false"] -> Just $ NoCache False + _ -> Nothing newtype NoTx = NoTx - { getNoTx :: Bool - } - deriving (Eq, Show, Read) + { getNoTx :: Bool + } + deriving (Eq, Show, Read) instance Default NoTx where - def = NoTx False + def = NoTx False instance Param NoTx where - proxyLabel = const "notx" - encodeParam _ (NoTx True) = Just ["true"] - encodeParam _ (NoTx False) = Just ["false"] - parseParam _ = \case - ["true"] -> Just $ NoTx True - ["false"] -> Just $ NoTx False - _ -> Nothing + proxyLabel = const "notx" + encodeParam _ (NoTx True) = Just ["true"] + encodeParam _ (NoTx False) = Just ["false"] + parseParam _ = \case + ["true"] -> Just $ NoTx True + ["false"] -> Just $ NoTx False + _ -> Nothing instance Param BlockHash where - proxyLabel = const "block" - encodeParam _ b = Just [blockHashToHex b] - parseParam _ [s] = hexToBlockHash s - parseParam _ _ = Nothing + proxyLabel = const "block" + encodeParam _ b = Just [blockHashToHex b] + parseParam _ [s] = hexToBlockHash s + parseParam _ _ = Nothing instance Param [BlockHash] where - proxyLabel = const "blocks" - encodeParam _ bs = Just $ blockHashToHex <$> bs - parseParam _ = mapM hexToBlockHash + proxyLabel = const "blocks" + encodeParam _ bs = Just $ blockHashToHex <$> bs + parseParam _ = mapM hexToBlockHash instance Param TxHash where - proxyLabel = const "txid" - encodeParam _ t = Just [txHashToHex t] - parseParam _ [s] = hexToTxHash s - parseParam _ _ = Nothing + proxyLabel = const "txid" + encodeParam _ t = Just [txHashToHex t] + parseParam _ [s] = hexToTxHash s + parseParam _ _ = Nothing instance Param [TxHash] where - proxyLabel = const "txids" - encodeParam _ ts = Just $ txHashToHex <$> ts - parseParam _ = mapM hexToTxHash + proxyLabel = const "txids" + encodeParam _ ts = Just $ txHashToHex <$> ts + parseParam _ = mapM hexToTxHash diff --git a/test/Haskoin/Store/DataSpec.hs b/test/Haskoin/Store/DataSpec.hs --- a/test/Haskoin/Store/DataSpec.hs +++ b/test/Haskoin/Store/DataSpec.hs @@ -5,642 +5,643 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Haskoin.Store.DataSpec ( - spec, -) where - -import Control.Monad (forM_) -import Data.Aeson (FromJSON (..)) -import qualified Data.ByteString as B -import Data.String.Conversions (cs) -import Haskoin -import Haskoin.Store.Data -import Haskoin.Util.Arbitrary -import Test.Hspec (Spec, describe) -import Test.QuickCheck - -serialVals :: [SerialBox] -serialVals = - [ SerialBox (arbitrary :: Gen DeriveType) - , SerialBox (arbitrary :: Gen XPubSpec) - , SerialBox (arbitrary :: Gen BlockRef) - , SerialBox (arbitrary :: Gen TxRef) - , SerialBox (arbitrary :: Gen Balance) - , SerialBox (arbitrary :: Gen Unspent) - , SerialBox (arbitrary :: Gen BlockData) - , SerialBox (arbitrary :: Gen StoreInput) - , SerialBox (arbitrary :: Gen Spender) - , SerialBox (arbitrary :: Gen StoreOutput) - , SerialBox (arbitrary :: Gen Prev) - , SerialBox (arbitrary :: Gen TxData) - , SerialBox (arbitrary :: Gen Transaction) - , SerialBox (arbitrary :: Gen XPubBal) - , SerialBox (arbitrary :: Gen XPubUnspent) - , SerialBox (arbitrary :: Gen XPubSummary) - , SerialBox (arbitrary :: Gen HealthCheck) - , SerialBox (arbitrary :: Gen Event) - , SerialBox (arbitrary :: Gen TxId) - , SerialBox (arbitrary :: Gen PeerInformation) - , SerialBox (arbitrary :: Gen (GenericResult BlockData)) - , SerialBox (arbitrary :: Gen (RawResult BlockData)) - , SerialBox (arbitrary :: Gen (RawResultList BlockData)) - ] - -jsonVals :: [JsonBox] -jsonVals = - [ JsonBox (arbitrary :: Gen TxRef) - , JsonBox (arbitrary :: Gen BlockRef) - , JsonBox (arbitrary :: Gen Spender) - , JsonBox (arbitrary :: Gen XPubSummary) - , JsonBox (arbitrary :: Gen HealthCheck) - , JsonBox (arbitrary :: Gen Event) - , JsonBox (arbitrary :: Gen TxId) - , JsonBox (arbitrary :: Gen PeerInformation) - , JsonBox (arbitrary :: Gen (GenericResult XPubSummary)) - , JsonBox (arbitrary :: Gen (RawResult BlockData)) - , JsonBox (arbitrary :: Gen (RawResultList BlockData)) - , JsonBox (arbitrary :: Gen Except) - , JsonBox (arbitrary :: Gen BinfoWallet) - , JsonBox (arbitrary :: Gen BinfoSymbol) - , JsonBox (arbitrary :: Gen BinfoBlockInfo) - , JsonBox (arbitrary :: Gen BinfoInfo) - , JsonBox (arbitrary :: Gen BinfoSpender) - , JsonBox (arbitrary :: Gen BinfoRate) - , JsonBox (arbitrary :: Gen BinfoTicker) - , JsonBox (arbitrary :: Gen BinfoTxId) - , JsonBox (arbitrary :: Gen BinfoShortBal) - , JsonBox (arbitrary :: Gen BinfoHistory) - , JsonBox (arbitrary :: Gen BinfoHeader) - , JsonBox (arbitrary :: Gen BinfoBlocks) - ] - -netVals :: [NetBox] -netVals = - [ NetBox - ( balanceToJSON - , balanceToEncoding - , balanceParseJSON - , arbitraryNetData - ) - , NetBox - ( storeOutputToJSON - , storeOutputToEncoding - , storeOutputParseJSON - , arbitraryNetData - ) - , NetBox - ( unspentToJSON - , unspentToEncoding - , unspentParseJSON - , arbitraryNetData - ) - , NetBox - ( xPubBalToJSON - , xPubBalToEncoding - , xPubBalParseJSON - , arbitraryNetData - ) - , NetBox - ( xPubUnspentToJSON - , xPubUnspentToEncoding - , xPubUnspentParseJSON - , arbitraryNetData - ) - , NetBox - ( storeInputToJSON - , storeInputToEncoding - , storeInputParseJSON - , arbitraryStoreInputNet - ) - , NetBox - ( blockDataToJSON - , blockDataToEncoding - , const parseJSON - , arbitraryBlockDataNet - ) - , NetBox - ( transactionToJSON - , transactionToEncoding - , transactionParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoMultiAddrToJSON - , binfoMultiAddrToEncoding - , binfoMultiAddrParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoBalanceToJSON - , binfoBalanceToEncoding - , binfoBalanceParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoBlockToJSON - , binfoBlockToEncoding - , binfoBlockParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoTxToJSON - , binfoTxToEncoding - , binfoTxParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoTxInputToJSON - , binfoTxInputToEncoding - , binfoTxInputParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoTxOutputToJSON - , binfoTxOutputToEncoding - , binfoTxOutputParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoXPubPathToJSON - , binfoXPubPathToEncoding - , binfoXPubPathParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoUnspentToJSON - , binfoUnspentToEncoding - , binfoUnspentParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoBlocksToJSON - , binfoBlocksToEncoding - , binfoBlocksParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoRawAddrToJSON - , binfoRawAddrToEncoding - , binfoRawAddrParseJSON - , arbitraryNetData - ) - , NetBox - ( binfoMempoolToJSON - , binfoMempoolToEncoding - , binfoMempoolParseJSON - , arbitraryNetData - ) - ] - -spec :: Spec -spec = do - describe "Binary Encoding" $ - forM_ serialVals $ \(SerialBox g) -> testSerial g - describe "JSON Encoding" $ - forM_ jsonVals $ \(JsonBox g) -> testJson g - describe "JSON Encoding with Network" $ - forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g - -instance Arbitrary BlockRef where - arbitrary = - oneof [BlockRef <$> arbitrary <*> arbitrary, MemRef <$> arbitrary] - -instance Arbitrary Prev where - arbitrary = Prev <$> arbitraryBS1 <*> arbitrary - -instance Arbitrary TxData where - arbitrary = - TxData - <$> arbitrary - <*> arbitraryTx btc - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary StoreInput where - arbitrary = - oneof - [ StoreCoinbase - <$> arbitraryOutPoint - <*> arbitrary - <*> arbitraryBS1 - <*> listOf arbitraryBS1 - , StoreInput - <$> arbitraryOutPoint - <*> arbitrary - <*> arbitraryBS1 - <*> arbitraryBS1 - <*> arbitrary - <*> listOf arbitraryBS1 - <*> arbitraryMaybe arbitraryAddress - ] - -arbitraryStoreInputNet :: Gen (Network, StoreInput) -arbitraryStoreInputNet = do - net <- arbitraryNetwork - store <- arbitrary - let res - | getSegWit net = store - | otherwise = store{inputWitness = []} - return (net, res) - -instance Arbitrary Spender where - arbitrary = Spender <$> arbitraryTxHash <*> arbitrary - -instance Arbitrary StoreOutput where - arbitrary = - StoreOutput - <$> arbitrary - <*> arbitraryBS1 - <*> arbitrary - <*> arbitraryMaybe arbitraryAddress - -instance Arbitrary Transaction where - arbitrary = - Transaction - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryTxHash - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary PeerInformation where - arbitrary = - PeerInformation - <$> (cs <$> listOf arbitraryUnicodeChar) - <*> listOf arbitraryPrintableChar - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary BlockHealth where - arbitrary = - BlockHealth - <$> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary TimeHealth where - arbitrary = - TimeHealth - <$> arbitrary - <*> arbitrary - -instance Arbitrary CountHealth where - arbitrary = - CountHealth - <$> arbitrary - <*> arbitrary - -instance Arbitrary MaxHealth where - arbitrary = - MaxHealth - <$> arbitrary - <*> arbitrary - -instance Arbitrary HealthCheck where - arbitrary = - HealthCheck - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary RejectCode where - arbitrary = - elements - [ RejectMalformed - , RejectInvalid - , RejectObsolete - , RejectDuplicate - , RejectNonStandard - , RejectDust - , RejectInsufficientFee - , RejectCheckpoint - ] - -instance Arbitrary XPubSpec where - arbitrary = XPubSpec <$> (snd <$> arbitraryXPubKey) <*> arbitrary - -instance Arbitrary DeriveType where - arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH] - -instance Arbitrary TxId where - arbitrary = TxId <$> arbitraryTxHash - -instance Arbitrary TxRef where - arbitrary = TxRef <$> arbitrary <*> arbitraryTxHash - -instance Arbitrary Balance where - arbitrary = - Balance - <$> arbitraryAddress - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary Unspent where - arbitrary = - Unspent - <$> arbitrary - <*> arbitraryOutPoint - <*> arbitrary - <*> arbitraryBS1 - <*> arbitraryMaybe arbitraryAddress - -instance Arbitrary BlockData where - arbitrary = - BlockData - <$> arbitrary - <*> arbitrary - <*> (fromInteger <$> suchThat arbitrary (0 <=)) - <*> arbitraryBlockHeader - <*> arbitrary - <*> arbitrary - <*> listOf1 arbitraryTxHash - <*> arbitrary - <*> arbitrary - <*> arbitrary - -arbitraryBlockDataNet :: Gen (Network, BlockData) -arbitraryBlockDataNet = do - net <- arbitraryNetwork - dat <- arbitrary - let res - | getSegWit net = dat - | otherwise = dat{blockDataWeight = 0} - return (net, res) - -instance Arbitrary a => Arbitrary (GenericResult a) where - arbitrary = GenericResult <$> arbitrary - -instance Arbitrary a => Arbitrary (RawResult a) where - arbitrary = RawResult <$> arbitrary - -instance Arbitrary a => Arbitrary (RawResultList a) where - arbitrary = RawResultList <$> 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 <$> arbitraryBlockHash - , EventTx <$> arbitraryTxHash - ] - -instance Arbitrary Except where - arbitrary = - oneof - [ return ThingNotFound - , return ServerError - , return BadRequest - , UserError <$> arbitrary - , StringError <$> arbitrary - , TxIndexConflict <$> listOf1 arbitraryTxHash - , return ServerTimeout - ] - ---------------------------------------- --- Blockchain.info API Compatibility -- ---------------------------------------- - -instance Arbitrary BinfoTxId where - arbitrary = - oneof - [ BinfoTxIdHash <$> arbitraryTxHash - , BinfoTxIdIndex <$> arbitrary - ] - -instance Arbitrary BinfoMultiAddr where - arbitrary = do - getBinfoMultiAddrAddresses <- arbitrary - getBinfoMultiAddrWallet <- arbitrary - getBinfoMultiAddrTxs <- resize 10 arbitrary - getBinfoMultiAddrInfo <- arbitrary - getBinfoMultiAddrRecommendFee <- arbitrary - getBinfoMultiAddrCashAddr <- arbitrary - return BinfoMultiAddr{..} - -instance Arbitrary BinfoRawAddr where - arbitrary = do - binfoRawAddr <- - oneof - [ BinfoAddr <$> arbitraryAddress - , BinfoXpub . snd <$> arbitraryXPubKey - ] - binfoRawBalance <- arbitrary - binfoRawTxCount <- arbitrary - binfoRawUnredeemed <- arbitrary - binfoRawReceived <- arbitrary - binfoRawSent <- arbitrary - binfoRawTxs <- arbitrary - return $ BinfoRawAddr{..} - -instance Arbitrary BinfoShortBal where - arbitrary = BinfoShortBal <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary BinfoBalance where - arbitrary = do - getBinfoAddress <- arbitraryAddress - getBinfoAddrTxCount <- arbitrary - getBinfoAddrReceived <- arbitrary - getBinfoAddrSent <- arbitrary - getBinfoAddrBalance <- arbitrary - getBinfoXPubKey <- snd <$> arbitraryXPubKey - getBinfoXPubAccountIndex <- arbitrary - getBinfoXPubChangeIndex <- arbitrary - elements [BinfoAddrBalance{..}, BinfoXPubBalance{..}] - -instance Arbitrary BinfoWallet where - arbitrary = do - getBinfoWalletBalance <- arbitrary - getBinfoWalletTxCount <- arbitrary - getBinfoWalletFilteredCount <- arbitrary - getBinfoWalletTotalReceived <- arbitrary - getBinfoWalletTotalSent <- arbitrary - return BinfoWallet{..} - -instance Arbitrary BinfoBlock where - arbitrary = do - getBinfoBlockHash <- arbitraryBlockHash - getBinfoBlockVer <- arbitrary - getBinfoPrevBlock <- arbitraryBlockHash - getBinfoMerkleRoot <- getTxHash <$> arbitraryTxHash - getBinfoBlockTime <- arbitrary - getBinfoBlockBits <- arbitrary - getBinfoNextBlock <- listOf arbitraryBlockHash - getBinfoBlockTxCount <- arbitrary - getBinfoBlockFee <- arbitrary - getBinfoBlockNonce <- arbitrary - getBinfoBlockSize <- arbitrary - getBinfoBlockIndex <- arbitrary - getBinfoBlockMain <- arbitrary - getBinfoBlockHeight <- arbitrary - getBinfoBlockWeight <- arbitrary - getBinfoBlockTx <- resize 5 arbitrary - return BinfoBlock{..} - -instance Arbitrary BinfoTx where - arbitrary = do - getBinfoTxHash <- arbitraryTxHash - getBinfoTxVer <- arbitrary - getBinfoTxInputs <- resize 5 $ listOf1 arbitrary - getBinfoTxOutputs <- resize 5 $ listOf1 arbitrary - let getBinfoTxVinSz = fromIntegral (length getBinfoTxInputs) - getBinfoTxVoutSz = fromIntegral (length getBinfoTxOutputs) - getBinfoTxSize <- arbitrary - getBinfoTxWeight <- arbitrary - getBinfoTxFee <- arbitrary - getBinfoTxRelayedBy <- cs <$> listOf arbitraryUnicodeChar - getBinfoTxLockTime <- arbitrary - getBinfoTxIndex <- arbitrary - getBinfoTxDoubleSpend <- arbitrary - getBinfoTxRBF <- arbitrary - getBinfoTxTime <- arbitrary - getBinfoTxBlockIndex <- arbitrary - getBinfoTxBlockHeight <- arbitrary - getBinfoTxResultBal <- arbitrary - return BinfoTx{..} - -instance Arbitrary BinfoTxInput where - arbitrary = do - getBinfoTxInputSeq <- arbitrary - getBinfoTxInputWitness <- B.pack <$> listOf arbitrary - getBinfoTxInputScript <- B.pack <$> listOf arbitrary - getBinfoTxInputIndex <- arbitrary - getBinfoTxInputPrevOut <- arbitrary - return BinfoTxInput{..} - -instance Arbitrary BinfoTxOutput where - arbitrary = do - getBinfoTxOutputType <- arbitrary - getBinfoTxOutputSpent <- arbitrary - getBinfoTxOutputValue <- arbitrary - getBinfoTxOutputIndex <- arbitrary - getBinfoTxOutputTxIndex <- arbitrary - getBinfoTxOutputScript <- B.pack <$> listOf arbitrary - getBinfoTxOutputSpenders <- arbitrary - getBinfoTxOutputAddress <- - oneof [return Nothing, Just <$> arbitraryAddress] - getBinfoTxOutputXPub <- arbitrary - return BinfoTxOutput{..} - -instance Arbitrary BinfoSpender where - arbitrary = do - getBinfoSpenderTxIndex <- arbitrary - getBinfoSpenderIndex <- arbitrary - return BinfoSpender{..} - -instance Arbitrary BinfoXPubPath where - arbitrary = do - getBinfoXPubPathKey <- snd <$> arbitraryXPubKey - getBinfoXPubPathDeriv <- arbitrarySoftPath - return BinfoXPubPath{..} - -instance Arbitrary BinfoInfo where - arbitrary = do - getBinfoConnected <- arbitrary - getBinfoConversion <- arbitrary - getBinfoLocal <- arbitrary - getBinfoBTC <- arbitrary - getBinfoLatestBlock <- arbitrary - return BinfoInfo{..} - -instance Arbitrary BinfoBlockInfo where - arbitrary = do - getBinfoBlockInfoHash <- arbitraryBlockHash - getBinfoBlockInfoHeight <- arbitrary - getBinfoBlockInfoTime <- arbitrary - getBinfoBlockInfoIndex <- arbitrary - return BinfoBlockInfo{..} - -instance Arbitrary BinfoSymbol where - arbitrary = do - getBinfoSymbolCode <- cs <$> listOf1 arbitraryUnicodeChar - getBinfoSymbolString <- cs <$> listOf1 arbitraryUnicodeChar - getBinfoSymbolName <- cs <$> listOf1 arbitraryUnicodeChar - getBinfoSymbolConversion <- arbitrary - getBinfoSymbolAfter <- arbitrary - getBinfoSymbolLocal <- arbitrary - return BinfoSymbol{..} - -instance Arbitrary BinfoRate where - arbitrary = BinfoRate <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary BinfoTicker where - arbitrary = do - binfoTicker15m <- arbitrary - binfoTickerSell <- arbitrary - binfoTickerBuy <- arbitrary - binfoTickerLast <- arbitrary - binfoTickerSymbol <- cs <$> listOf1 arbitraryUnicodeChar - return BinfoTicker{..} - -instance Arbitrary BinfoHistory where - arbitrary = do - binfoHistoryDate <- cs <$> listOf1 arbitraryUnicodeChar - binfoHistoryTime <- cs <$> listOf1 arbitraryUnicodeChar - binfoHistoryType <- cs <$> listOf1 arbitraryUnicodeChar - binfoHistoryAmount <- arbitrary - binfoHistoryValueThen <- arbitrary - binfoHistoryValueNow <- arbitrary - binfoHistoryExchangeRateThen <- arbitrary - binfoHistoryTx <- arbitraryTxHash - return BinfoHistory{..} - -instance Arbitrary BinfoUnspent where - arbitrary = do - getBinfoUnspentHash <- arbitraryTxHash - getBinfoUnspentOutputIndex <- arbitrary - getBinfoUnspentScript <- B.pack <$> listOf arbitrary - getBinfoUnspentValue <- arbitrary - getBinfoUnspentConfirmations <- arbitrary - getBinfoUnspentTxIndex <- arbitrary - getBinfoUnspentXPub <- arbitrary - return BinfoUnspent{..} - -instance Arbitrary BinfoUnspents where - arbitrary = BinfoUnspents <$> arbitrary - -instance Arbitrary BinfoHeader where - arbitrary = - BinfoHeader - <$> arbitraryBlockHash - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary BinfoMempool where - arbitrary = BinfoMempool <$> arbitrary - -instance Arbitrary BinfoBlocks where - arbitrary = BinfoBlocks <$> arbitrary +module Haskoin.Store.DataSpec + ( spec, + ) +where + +import Control.Monad (forM_) +import Data.Aeson (FromJSON (..)) +import qualified Data.ByteString as B +import Data.String.Conversions (cs) +import Haskoin +import Haskoin.Store.Data +import Haskoin.Util.Arbitrary +import Test.Hspec (Spec, describe) +import Test.QuickCheck + +serialVals :: [SerialBox] +serialVals = + [ SerialBox (arbitrary :: Gen DeriveType), + SerialBox (arbitrary :: Gen XPubSpec), + SerialBox (arbitrary :: Gen BlockRef), + SerialBox (arbitrary :: Gen TxRef), + SerialBox (arbitrary :: Gen Balance), + SerialBox (arbitrary :: Gen Unspent), + SerialBox (arbitrary :: Gen BlockData), + SerialBox (arbitrary :: Gen StoreInput), + SerialBox (arbitrary :: Gen Spender), + SerialBox (arbitrary :: Gen StoreOutput), + SerialBox (arbitrary :: Gen Prev), + SerialBox (arbitrary :: Gen TxData), + SerialBox (arbitrary :: Gen Transaction), + SerialBox (arbitrary :: Gen XPubBal), + SerialBox (arbitrary :: Gen XPubUnspent), + SerialBox (arbitrary :: Gen XPubSummary), + SerialBox (arbitrary :: Gen HealthCheck), + SerialBox (arbitrary :: Gen Event), + SerialBox (arbitrary :: Gen TxId), + SerialBox (arbitrary :: Gen PeerInformation), + SerialBox (arbitrary :: Gen (GenericResult BlockData)), + SerialBox (arbitrary :: Gen (RawResult BlockData)), + SerialBox (arbitrary :: Gen (RawResultList BlockData)) + ] + +jsonVals :: [JsonBox] +jsonVals = + [ JsonBox (arbitrary :: Gen TxRef), + JsonBox (arbitrary :: Gen BlockRef), + JsonBox (arbitrary :: Gen Spender), + JsonBox (arbitrary :: Gen XPubSummary), + JsonBox (arbitrary :: Gen HealthCheck), + JsonBox (arbitrary :: Gen Event), + JsonBox (arbitrary :: Gen TxId), + JsonBox (arbitrary :: Gen PeerInformation), + JsonBox (arbitrary :: Gen (GenericResult XPubSummary)), + JsonBox (arbitrary :: Gen (RawResult BlockData)), + JsonBox (arbitrary :: Gen (RawResultList BlockData)), + JsonBox (arbitrary :: Gen Except), + JsonBox (arbitrary :: Gen BinfoWallet), + JsonBox (arbitrary :: Gen BinfoSymbol), + JsonBox (arbitrary :: Gen BinfoBlockInfo), + JsonBox (arbitrary :: Gen BinfoInfo), + JsonBox (arbitrary :: Gen BinfoSpender), + JsonBox (arbitrary :: Gen BinfoRate), + JsonBox (arbitrary :: Gen BinfoTicker), + JsonBox (arbitrary :: Gen BinfoTxId), + JsonBox (arbitrary :: Gen BinfoShortBal), + JsonBox (arbitrary :: Gen BinfoHistory), + JsonBox (arbitrary :: Gen BinfoHeader), + JsonBox (arbitrary :: Gen BinfoBlocks) + ] + +netVals :: [NetBox] +netVals = + [ NetBox + ( balanceToJSON, + balanceToEncoding, + balanceParseJSON, + arbitraryNetData + ), + NetBox + ( storeOutputToJSON, + storeOutputToEncoding, + storeOutputParseJSON, + arbitraryNetData + ), + NetBox + ( unspentToJSON, + unspentToEncoding, + unspentParseJSON, + arbitraryNetData + ), + NetBox + ( xPubBalToJSON, + xPubBalToEncoding, + xPubBalParseJSON, + arbitraryNetData + ), + NetBox + ( xPubUnspentToJSON, + xPubUnspentToEncoding, + xPubUnspentParseJSON, + arbitraryNetData + ), + NetBox + ( storeInputToJSON, + storeInputToEncoding, + storeInputParseJSON, + arbitraryStoreInputNet + ), + NetBox + ( blockDataToJSON, + blockDataToEncoding, + const parseJSON, + arbitraryBlockDataNet + ), + NetBox + ( transactionToJSON, + transactionToEncoding, + transactionParseJSON, + arbitraryNetData + ), + NetBox + ( binfoMultiAddrToJSON, + binfoMultiAddrToEncoding, + binfoMultiAddrParseJSON, + arbitraryNetData + ), + NetBox + ( binfoBalanceToJSON, + binfoBalanceToEncoding, + binfoBalanceParseJSON, + arbitraryNetData + ), + NetBox + ( binfoBlockToJSON, + binfoBlockToEncoding, + binfoBlockParseJSON, + arbitraryNetData + ), + NetBox + ( binfoTxToJSON, + binfoTxToEncoding, + binfoTxParseJSON, + arbitraryNetData + ), + NetBox + ( binfoTxInputToJSON, + binfoTxInputToEncoding, + binfoTxInputParseJSON, + arbitraryNetData + ), + NetBox + ( binfoTxOutputToJSON, + binfoTxOutputToEncoding, + binfoTxOutputParseJSON, + arbitraryNetData + ), + NetBox + ( binfoXPubPathToJSON, + binfoXPubPathToEncoding, + binfoXPubPathParseJSON, + arbitraryNetData + ), + NetBox + ( binfoUnspentToJSON, + binfoUnspentToEncoding, + binfoUnspentParseJSON, + arbitraryNetData + ), + NetBox + ( binfoBlocksToJSON, + binfoBlocksToEncoding, + binfoBlocksParseJSON, + arbitraryNetData + ), + NetBox + ( binfoRawAddrToJSON, + binfoRawAddrToEncoding, + binfoRawAddrParseJSON, + arbitraryNetData + ), + NetBox + ( binfoMempoolToJSON, + binfoMempoolToEncoding, + binfoMempoolParseJSON, + arbitraryNetData + ) + ] + +spec :: Spec +spec = do + describe "Binary Encoding" $ + forM_ serialVals $ \(SerialBox g) -> testSerial g + describe "JSON Encoding" $ + forM_ jsonVals $ \(JsonBox g) -> testJson g + describe "JSON Encoding with Network" $ + forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g + +instance Arbitrary BlockRef where + arbitrary = + oneof [BlockRef <$> arbitrary <*> arbitrary, MemRef <$> arbitrary] + +instance Arbitrary Prev where + arbitrary = Prev <$> arbitraryBS1 <*> arbitrary + +instance Arbitrary TxData where + arbitrary = + TxData + <$> arbitrary + <*> arbitraryTx btc + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary StoreInput where + arbitrary = + oneof + [ StoreCoinbase + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> listOf arbitraryBS1, + StoreInput + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> arbitraryBS1 + <*> arbitrary + <*> listOf arbitraryBS1 + <*> arbitraryMaybe arbitraryAddress + ] + +arbitraryStoreInputNet :: Gen (Network, StoreInput) +arbitraryStoreInputNet = do + net <- arbitraryNetwork + store <- arbitrary + let res + | getSegWit net = store + | otherwise = store {inputWitness = []} + return (net, res) + +instance Arbitrary Spender where + arbitrary = Spender <$> arbitraryTxHash <*> arbitrary + +instance Arbitrary StoreOutput where + arbitrary = + StoreOutput + <$> arbitrary + <*> arbitraryBS1 + <*> arbitrary + <*> arbitraryMaybe arbitraryAddress + +instance Arbitrary Transaction where + arbitrary = + Transaction + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryTxHash + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary PeerInformation where + arbitrary = + PeerInformation + <$> (cs <$> listOf arbitraryUnicodeChar) + <*> listOf arbitraryPrintableChar + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary BlockHealth where + arbitrary = + BlockHealth + <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary TimeHealth where + arbitrary = + TimeHealth + <$> arbitrary + <*> arbitrary + +instance Arbitrary CountHealth where + arbitrary = + CountHealth + <$> arbitrary + <*> arbitrary + +instance Arbitrary MaxHealth where + arbitrary = + MaxHealth + <$> arbitrary + <*> arbitrary + +instance Arbitrary HealthCheck where + arbitrary = + HealthCheck + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary RejectCode where + arbitrary = + elements + [ RejectMalformed, + RejectInvalid, + RejectObsolete, + RejectDuplicate, + RejectNonStandard, + RejectDust, + RejectInsufficientFee, + RejectCheckpoint + ] + +instance Arbitrary XPubSpec where + arbitrary = XPubSpec <$> (snd <$> arbitraryXPubKey) <*> arbitrary + +instance Arbitrary DeriveType where + arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH] + +instance Arbitrary TxId where + arbitrary = TxId <$> arbitraryTxHash + +instance Arbitrary TxRef where + arbitrary = TxRef <$> arbitrary <*> arbitraryTxHash + +instance Arbitrary Balance where + arbitrary = + Balance + <$> arbitraryAddress + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Unspent where + arbitrary = + Unspent + <$> arbitrary + <*> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> arbitraryMaybe arbitraryAddress + +instance Arbitrary BlockData where + arbitrary = + BlockData + <$> arbitrary + <*> arbitrary + <*> (fromInteger <$> suchThat arbitrary (0 <=)) + <*> arbitraryBlockHeader + <*> arbitrary + <*> arbitrary + <*> listOf1 arbitraryTxHash + <*> arbitrary + <*> arbitrary + <*> arbitrary + +arbitraryBlockDataNet :: Gen (Network, BlockData) +arbitraryBlockDataNet = do + net <- arbitraryNetwork + dat <- arbitrary + let res + | getSegWit net = dat + | otherwise = dat {blockDataWeight = 0} + return (net, res) + +instance Arbitrary a => Arbitrary (GenericResult a) where + arbitrary = GenericResult <$> arbitrary + +instance Arbitrary a => Arbitrary (RawResult a) where + arbitrary = RawResult <$> arbitrary + +instance Arbitrary a => Arbitrary (RawResultList a) where + arbitrary = RawResultList <$> 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 <$> arbitraryBlockHash, + EventTx <$> arbitraryTxHash + ] + +instance Arbitrary Except where + arbitrary = + oneof + [ return ThingNotFound, + return ServerError, + return BadRequest, + UserError <$> arbitrary, + StringError <$> arbitrary, + TxIndexConflict <$> listOf1 arbitraryTxHash, + return ServerTimeout + ] + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- + +instance Arbitrary BinfoTxId where + arbitrary = + oneof + [ BinfoTxIdHash <$> arbitraryTxHash, + BinfoTxIdIndex <$> arbitrary + ] + +instance Arbitrary BinfoMultiAddr where + arbitrary = do + getBinfoMultiAddrAddresses <- arbitrary + getBinfoMultiAddrWallet <- arbitrary + getBinfoMultiAddrTxs <- resize 10 arbitrary + getBinfoMultiAddrInfo <- arbitrary + getBinfoMultiAddrRecommendFee <- arbitrary + getBinfoMultiAddrCashAddr <- arbitrary + return BinfoMultiAddr {..} + +instance Arbitrary BinfoRawAddr where + arbitrary = do + binfoRawAddr <- + oneof + [ BinfoAddr <$> arbitraryAddress, + BinfoXpub . snd <$> arbitraryXPubKey + ] + binfoRawBalance <- arbitrary + binfoRawTxCount <- arbitrary + binfoRawUnredeemed <- arbitrary + binfoRawReceived <- arbitrary + binfoRawSent <- arbitrary + binfoRawTxs <- arbitrary + return $ BinfoRawAddr {..} + +instance Arbitrary BinfoShortBal where + arbitrary = BinfoShortBal <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary BinfoBalance where + arbitrary = do + getBinfoAddress <- arbitraryAddress + getBinfoAddrTxCount <- arbitrary + getBinfoAddrReceived <- arbitrary + getBinfoAddrSent <- arbitrary + getBinfoAddrBalance <- arbitrary + getBinfoXPubKey <- snd <$> arbitraryXPubKey + getBinfoXPubAccountIndex <- arbitrary + getBinfoXPubChangeIndex <- arbitrary + elements [BinfoAddrBalance {..}, BinfoXPubBalance {..}] + +instance Arbitrary BinfoWallet where + arbitrary = do + getBinfoWalletBalance <- arbitrary + getBinfoWalletTxCount <- arbitrary + getBinfoWalletFilteredCount <- arbitrary + getBinfoWalletTotalReceived <- arbitrary + getBinfoWalletTotalSent <- arbitrary + return BinfoWallet {..} + +instance Arbitrary BinfoBlock where + arbitrary = do + getBinfoBlockHash <- arbitraryBlockHash + getBinfoBlockVer <- arbitrary + getBinfoPrevBlock <- arbitraryBlockHash + getBinfoMerkleRoot <- getTxHash <$> arbitraryTxHash + getBinfoBlockTime <- arbitrary + getBinfoBlockBits <- arbitrary + getBinfoNextBlock <- listOf arbitraryBlockHash + getBinfoBlockTxCount <- arbitrary + getBinfoBlockFee <- arbitrary + getBinfoBlockNonce <- arbitrary + getBinfoBlockSize <- arbitrary + getBinfoBlockIndex <- arbitrary + getBinfoBlockMain <- arbitrary + getBinfoBlockHeight <- arbitrary + getBinfoBlockWeight <- arbitrary + getBinfoBlockTx <- resize 5 arbitrary + return BinfoBlock {..} + +instance Arbitrary BinfoTx where + arbitrary = do + getBinfoTxHash <- arbitraryTxHash + getBinfoTxVer <- arbitrary + getBinfoTxInputs <- resize 5 $ listOf1 arbitrary + getBinfoTxOutputs <- resize 5 $ listOf1 arbitrary + let getBinfoTxVinSz = fromIntegral (length getBinfoTxInputs) + getBinfoTxVoutSz = fromIntegral (length getBinfoTxOutputs) + getBinfoTxSize <- arbitrary + getBinfoTxWeight <- arbitrary + getBinfoTxFee <- arbitrary + getBinfoTxRelayedBy <- cs <$> listOf arbitraryUnicodeChar + getBinfoTxLockTime <- arbitrary + getBinfoTxIndex <- arbitrary + getBinfoTxDoubleSpend <- arbitrary + getBinfoTxRBF <- arbitrary + getBinfoTxTime <- arbitrary + getBinfoTxBlockIndex <- arbitrary + getBinfoTxBlockHeight <- arbitrary + getBinfoTxResultBal <- arbitrary + return BinfoTx {..} + +instance Arbitrary BinfoTxInput where + arbitrary = do + getBinfoTxInputSeq <- arbitrary + getBinfoTxInputWitness <- B.pack <$> listOf arbitrary + getBinfoTxInputScript <- B.pack <$> listOf arbitrary + getBinfoTxInputIndex <- arbitrary + getBinfoTxInputPrevOut <- arbitrary + return BinfoTxInput {..} + +instance Arbitrary BinfoTxOutput where + arbitrary = do + getBinfoTxOutputType <- arbitrary + getBinfoTxOutputSpent <- arbitrary + getBinfoTxOutputValue <- arbitrary + getBinfoTxOutputIndex <- arbitrary + getBinfoTxOutputTxIndex <- arbitrary + getBinfoTxOutputScript <- B.pack <$> listOf arbitrary + getBinfoTxOutputSpenders <- arbitrary + getBinfoTxOutputAddress <- + oneof [return Nothing, Just <$> arbitraryAddress] + getBinfoTxOutputXPub <- arbitrary + return BinfoTxOutput {..} + +instance Arbitrary BinfoSpender where + arbitrary = do + getBinfoSpenderTxIndex <- arbitrary + getBinfoSpenderIndex <- arbitrary + return BinfoSpender {..} + +instance Arbitrary BinfoXPubPath where + arbitrary = do + getBinfoXPubPathKey <- snd <$> arbitraryXPubKey + getBinfoXPubPathDeriv <- arbitrarySoftPath + return BinfoXPubPath {..} + +instance Arbitrary BinfoInfo where + arbitrary = do + getBinfoConnected <- arbitrary + getBinfoConversion <- arbitrary + getBinfoLocal <- arbitrary + getBinfoBTC <- arbitrary + getBinfoLatestBlock <- arbitrary + return BinfoInfo {..} + +instance Arbitrary BinfoBlockInfo where + arbitrary = do + getBinfoBlockInfoHash <- arbitraryBlockHash + getBinfoBlockInfoHeight <- arbitrary + getBinfoBlockInfoTime <- arbitrary + getBinfoBlockInfoIndex <- arbitrary + return BinfoBlockInfo {..} + +instance Arbitrary BinfoSymbol where + arbitrary = do + getBinfoSymbolCode <- cs <$> listOf1 arbitraryUnicodeChar + getBinfoSymbolString <- cs <$> listOf1 arbitraryUnicodeChar + getBinfoSymbolName <- cs <$> listOf1 arbitraryUnicodeChar + getBinfoSymbolConversion <- arbitrary + getBinfoSymbolAfter <- arbitrary + getBinfoSymbolLocal <- arbitrary + return BinfoSymbol {..} + +instance Arbitrary BinfoRate where + arbitrary = BinfoRate <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary BinfoTicker where + arbitrary = do + binfoTicker15m <- arbitrary + binfoTickerSell <- arbitrary + binfoTickerBuy <- arbitrary + binfoTickerLast <- arbitrary + binfoTickerSymbol <- cs <$> listOf1 arbitraryUnicodeChar + return BinfoTicker {..} + +instance Arbitrary BinfoHistory where + arbitrary = do + binfoHistoryDate <- cs <$> listOf1 arbitraryUnicodeChar + binfoHistoryTime <- cs <$> listOf1 arbitraryUnicodeChar + binfoHistoryType <- cs <$> listOf1 arbitraryUnicodeChar + binfoHistoryAmount <- arbitrary + binfoHistoryValueThen <- arbitrary + binfoHistoryValueNow <- arbitrary + binfoHistoryExchangeRateThen <- arbitrary + binfoHistoryTx <- arbitraryTxHash + return BinfoHistory {..} + +instance Arbitrary BinfoUnspent where + arbitrary = do + getBinfoUnspentHash <- arbitraryTxHash + getBinfoUnspentOutputIndex <- arbitrary + getBinfoUnspentScript <- B.pack <$> listOf arbitrary + getBinfoUnspentValue <- arbitrary + getBinfoUnspentConfirmations <- arbitrary + getBinfoUnspentTxIndex <- arbitrary + getBinfoUnspentXPub <- arbitrary + return BinfoUnspent {..} + +instance Arbitrary BinfoUnspents where + arbitrary = BinfoUnspents <$> arbitrary + +instance Arbitrary BinfoHeader where + arbitrary = + BinfoHeader + <$> arbitraryBlockHash + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary BinfoMempool where + arbitrary = BinfoMempool <$> arbitrary + +instance Arbitrary BinfoBlocks where + arbitrary = BinfoBlocks <$> arbitrary diff --git a/test/Haskoin/Store/WebCommonSpec.hs b/test/Haskoin/Store/WebCommonSpec.hs --- a/test/Haskoin/Store/WebCommonSpec.hs +++ b/test/Haskoin/Store/WebCommonSpec.hs @@ -5,9 +5,10 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Haskoin.Store.WebCommonSpec ( - spec, -) where +module Haskoin.Store.WebCommonSpec + ( spec, + ) +where import Control.Monad (forM_) import Data.Proxy @@ -26,50 +27,50 @@ params :: [GenBox] params = - [ GenBox arbitraryAddress - , GenBox (listOf arbitraryAddress) - , GenBox (arbitrary :: Gen StartParam) - , GenBox (arbitrarySizedNatural :: Gen OffsetParam) - , GenBox (arbitrarySizedNatural :: Gen LimitParam) - , GenBox (arbitrarySizedNatural :: Gen HeightParam) - , GenBox (arbitrary :: Gen HeightsParam) - , GenBox (arbitrarySizedNatural :: Gen TimeParam) - , GenBox (snd <$> arbitraryXPubKey :: Gen XPubKey) - , GenBox (arbitrary :: Gen DeriveType) - , GenBox (NoCache <$> arbitrary :: Gen NoCache) - , GenBox (NoTx <$> arbitrary :: Gen NoTx) - , GenBox arbitraryBlockHash - , GenBox (listOf arbitraryBlockHash) - , GenBox arbitraryTxHash - , GenBox (listOf arbitraryTxHash) - ] + [ GenBox arbitraryAddress, + GenBox (listOf arbitraryAddress), + GenBox (arbitrary :: Gen StartParam), + GenBox (arbitrarySizedNatural :: Gen OffsetParam), + GenBox (arbitrarySizedNatural :: Gen LimitParam), + GenBox (arbitrarySizedNatural :: Gen HeightParam), + GenBox (arbitrary :: Gen HeightsParam), + GenBox (arbitrarySizedNatural :: Gen TimeParam), + GenBox (snd <$> arbitraryXPubKey :: Gen XPubKey), + GenBox (arbitrary :: Gen DeriveType), + GenBox (NoCache <$> arbitrary :: Gen NoCache), + GenBox (NoTx <$> arbitrary :: Gen NoTx), + GenBox arbitraryBlockHash, + GenBox (listOf arbitraryBlockHash), + GenBox arbitraryTxHash, + GenBox (listOf arbitraryTxHash) + ] spec :: Spec spec = - describe "Parameter encoding" $ - forM_ params $ \(GenBox g) -> testParam g + describe "Parameter encoding" $ + forM_ params $ \(GenBox g) -> testParam g testParam :: (Eq a, Show a, Param a) => Gen a -> Spec testParam pGen = - prop ("encodeParam/parseParam identity for parameter " <> name) $ - forAll pGen $ \p -> - case encodeParam btc p of - Just txts -> parseParam btc txts `shouldBe` Just p - _ -> expectationFailure "Param encoding failed" + prop ("encodeParam/parseParam identity for parameter " <> name) $ + forAll pGen $ \p -> + case encodeParam btc p of + Just txts -> parseParam btc txts `shouldBe` Just p + _ -> expectationFailure "Param encoding failed" where name = cs $ proxyLabel $ proxy pGen proxy :: Gen a -> Proxy a proxy = const Proxy instance Arbitrary StartParam where - arbitrary = - oneof - [ StartParamHash <$> arbitraryHash256 - , StartParamHeight . fromIntegral - <$> (choose (0, 1230768000) :: Gen Word64) - , StartParamTime . fromIntegral - <$> (choose (1230768000, maxBound) :: Gen Word64) - ] + arbitrary = + oneof + [ StartParamHash <$> arbitraryHash256, + StartParamHeight . fromIntegral + <$> (choose (0, 1230768000) :: Gen Word64), + StartParamTime . fromIntegral + <$> (choose (1230768000, maxBound) :: Gen Word64) + ] instance Arbitrary HeightsParam where - arbitrary = HeightsParam <$> listOf arbitrarySizedNatural + arbitrary = HeightsParam <$> listOf arbitrarySizedNatural