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: d47cb9ae7ff346dd501859f21e3e9a0d8294ce49157710e2cd91e085c13665cd +-- hash: 84464e988a1908c7ad47ff0186701bdffc077925760e73de350b8aab941faee3 name: haskoin-store-data -version: 0.38.1 +version: 0.40.0 synopsis: Data for Haskoin Store description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -41,7 +41,7 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0 - , haskoin-core >=0.17.0 + , haskoin-core >=0.19.0 , http-client >=0.6.4.1 , http-types >=0.12.3 , lens >=4.18.1 @@ -49,7 +49,8 @@ , network >=3.1.1.1 , scotty >=0.11.5 , string-conversions >=0.4.0.1 - , text >=1.2.4.0 + , text >=1.2.3.0 + , unordered-containers >=0.2.10 , wreq >=0.5.3.2 default-language: Haskell2010 @@ -73,8 +74,8 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0 - , haskoin-core >=0.17.0 - , haskoin-store-data ==0.38.1 + , haskoin-core >=0.19.0 + , haskoin-store-data , hspec >=2.7.1 , http-client >=0.6.4.1 , http-types >=0.12.3 @@ -83,7 +84,8 @@ , network >=3.1.1.1 , scotty >=0.11.5 , string-conversions >=0.4.0.1 - , text >=1.2.4.0 + , text >=1.2.3.0 + , unordered-containers >=0.2.10 , wreq >=0.5.3.2 default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover 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 @@ -80,1420 +80,2349 @@ , HealthCheck(..) , Event(..) , Except(..) - ) - -where - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) -import Control.Exception (Exception) -import Control.Monad (guard, join, mzero, (<=<)) -import Data.Aeson (Encoding, FromJSON (..), ToJSON (..), - Value (..), object, pairs, (.!=), - (.:), (.:?), (.=)) -import qualified Data.Aeson as A -import Data.Aeson.Encoding (list, null_, pair, text, - unsafeToEncoding) -import Data.Aeson.Types (Parser) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Builder (char7, lazyByteStringHex) -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS -import Data.Default (Default (..)) -import Data.Foldable (toList) -import Data.Hashable (Hashable (..)) -import qualified Data.IntMap as I -import Data.IntMap.Strict (IntMap) -import Data.Maybe (catMaybes, fromMaybe, isJust, - mapMaybe) -import Data.Serialize (Get, Put, Serialize (..), getWord32be, - getWord64be, getWord8, putWord32be, - putWord64be, putWord8) -import qualified Data.Serialize as S -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text.Lazy as TL -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) -import Haskoin (Address, BlockHash, BlockHeader (..), - BlockHeight, BlockWork, Coin (..), - KeyIndex, Network (..), OutPoint (..), - PubKeyI (..), Tx (..), TxHash (..), - TxIn (..), TxOut (..), WitnessStack, - XPubKey (..), addrFromJSON, - addrToEncoding, addrToJSON, - blockHashToHex, decodeHex, - eitherToMaybe, encodeHex, headerHash, - scriptToAddressBS, txHash, - txHashToHex, wrapPubKey) -import Web.Scotty.Trans (ScottyError (..)) - -data DeriveType = DeriveNormal - | DeriveP2SH - | DeriveP2WPKH - deriving (Show, Eq, Generic, NFData, Serialize) - -instance Default DeriveType where - def = DeriveNormal - -data XPubSpec = - XPubSpec - { xPubSpecKey :: !XPubKey - , xPubDeriveType :: !DeriveType - } - deriving (Show, Eq, Generic, NFData) - -instance Hashable XPubSpec where - hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} = - hashWithSalt i pubkey - -instance Serialize XPubSpec where - put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do - put (xPubDepth k) - put (xPubParent k) - put (xPubIndex k) - put (xPubChain k) - put (wrapPubKey True (xPubKey k)) - put t - get = do - d <- get - p <- get - i <- get - c <- get - k <- get - t <- get - let x = - XPubKey - { xPubDepth = d - , xPubParent = p - , xPubIndex = i - , xPubChain = c - , xPubKey = pubKeyPoint k - } - return XPubSpec {xPubSpecKey = x, xPubDeriveType = t} - -type UnixTime = Word64 -type BlockPos = Word32 - --- | Serialize such that ordering is inverted. -putUnixTime :: Word64 -> Put -putUnixTime w = putWord64be $ maxBound - w - -getUnixTime :: Get Word64 -getUnixTime = (maxBound -) <$> getWord64be - --- | Reference to a block where a transaction is stored. -data BlockRef - = BlockRef - { blockRefHeight :: !BlockHeight - -- ^ block height in the chain - , blockRefPos :: !Word32 - -- ^ position of transaction within the block - } - | MemRef - { memRefTime :: !UnixTime - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - --- | Serialized entities will sort in reverse order. -instance Serialize BlockRef where - put MemRef {memRefTime = t} = do - putWord8 0x00 - putUnixTime t - put BlockRef {blockRefHeight = h, blockRefPos = p} = do - putWord8 0x01 - putWord32be (maxBound - h) - putWord32be (maxBound - p) - get = getmemref <|> getblockref - where - getmemref = do - guard . (== 0x00) =<< getWord8 - MemRef <$> getUnixTime - getblockref = do - guard . (== 0x01) =<< getWord8 - h <- (maxBound -) <$> getWord32be - p <- (maxBound -) <$> getWord32be - return BlockRef {blockRefHeight = h, blockRefPos = p} - -confirmed :: BlockRef -> Bool -confirmed BlockRef {} = True -confirmed MemRef {} = False - -instance ToJSON BlockRef where - toJSON BlockRef {blockRefHeight = h, blockRefPos = p} = - object ["height" .= h, "position" .= p] - toJSON MemRef {memRefTime = t} = object ["mempool" .= t] - toEncoding BlockRef {blockRefHeight = h, blockRefPos = p} = - pairs ("height" .= h <> "position" .= p) - toEncoding MemRef {memRefTime = t} = pairs ("mempool" .= t) - -instance FromJSON BlockRef where - parseJSON = A.withObject "blockref" $ \o -> b o <|> m o - where - b o = do - height <- o .: "height" - position <- o .: "position" - return BlockRef {blockRefHeight = height, blockRefPos = position} - m o = do - mempool <- o .: "mempool" - return MemRef {memRefTime = mempool} - --- | Transaction in relation to an address. -data TxRef = - TxRef - { txRefBlock :: !BlockRef - -- ^ block information - , txRefHash :: !TxHash - -- ^ transaction hash - } - deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData) - -instance ToJSON TxRef where - toJSON btx = object ["txid" .= txRefHash btx, "block" .= txRefBlock btx] - toEncoding btx = - 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 - { balanceAddress :: !Address - -- ^ address balance - , balanceAmount :: !Word64 - -- ^ confirmed balance - , balanceZero :: !Word64 - -- ^ unconfirmed balance - , balanceUnspentCount :: !Word64 - -- ^ number of unspent outputs - , balanceTxCount :: !Word64 - -- ^ number of transactions - , balanceTotalReceived :: !Word64 - -- ^ total amount from all outputs in this address - } - deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) - -zeroBalance :: Address -> Balance -zeroBalance a = - Balance - { balanceAddress = a - , balanceAmount = 0 - , balanceUnspentCount = 0 - , balanceZero = 0 - , balanceTxCount = 0 - , balanceTotalReceived = 0 - } - -nullBalance :: Balance -> Bool -nullBalance Balance { balanceAmount = 0 - , balanceUnspentCount = 0 - , balanceZero = 0 - , balanceTxCount = 0 - , balanceTotalReceived = 0 - } = True -nullBalance _ = False - -balanceToJSON :: Network -> Balance -> Value -balanceToJSON net b = - object - [ "address" .= addrToJSON net (balanceAddress b) - , "confirmed" .= balanceAmount b - , "unconfirmed" .= balanceZero b - , "utxo" .= balanceUnspentCount b - , "txs" .= balanceTxCount b - , "received" .= balanceTotalReceived b - ] - -balanceToEncoding :: Network -> Balance -> Encoding -balanceToEncoding net b = - pairs - ( "address" `pair` addrToEncoding net (balanceAddress b) - <> "confirmed" .= balanceAmount b - <> "unconfirmed" .= balanceZero b - <> "utxo" .= balanceUnspentCount b - <> "txs" .= balanceTxCount b - <> "received" .= balanceTotalReceived b - ) - -balanceParseJSON :: Network -> Value -> Parser Balance -balanceParseJSON net = - A.withObject "balance" $ \o -> do - amount <- o .: "confirmed" - unconfirmed <- o .: "unconfirmed" - utxo <- o .: "utxo" - txs <- o .: "txs" - received <- o .: "received" - address <- addrFromJSON net =<< o .: "address" - return - Balance - { balanceAddress = address - , balanceAmount = amount - , balanceUnspentCount = utxo - , balanceZero = unconfirmed - , balanceTxCount = txs - , balanceTotalReceived = received - } - --- | Unspent output. -data Unspent = - Unspent - { unspentBlock :: !BlockRef - , unspentPoint :: !OutPoint - , unspentAmount :: !Word64 - , unspentScript :: !ShortByteString - , unspentAddress :: !(Maybe Address) - } - deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) - -instance Coin Unspent where - coinValue = unspentAmount - -unspentToJSON :: Network -> Unspent -> Value -unspentToJSON net u = - object - [ "address" .= (addrToJSON net <$> unspentAddress u) - , "block" .= unspentBlock u - , "txid" .= outPointHash (unspentPoint u) - , "index" .= outPointIndex (unspentPoint u) - , "pkscript" .= script - , "value" .= unspentAmount u - ] - where - bsscript = BSS.fromShort (unspentScript u) - script = encodeHex bsscript - -unspentToEncoding :: Network -> Unspent -> Encoding -unspentToEncoding net u = - pairs - ( "address" `pair` maybe null_ (addrToEncoding net) (unspentAddress u) - <> "block" .= unspentBlock u - <> "txid" .= outPointHash (unspentPoint u) - <> "index" .= outPointIndex (unspentPoint u) - <> "pkscript" `pair` text script - <> "value" .= unspentAmount u - ) - where - bsscript = BSS.fromShort (unspentScript u) - script = encodeHex bsscript - -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 <- BSS.toShort <$> (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 - { blockDataHeight :: !BlockHeight - -- ^ height of the block in the chain - , blockDataMainChain :: !Bool - -- ^ is this block in the main chain? - , blockDataWork :: !BlockWork - -- ^ accumulated work in that block - , blockDataHeader :: !BlockHeader - -- ^ block header - , blockDataSize :: !Word32 - -- ^ size of the block including witnesses - , blockDataWeight :: !Word32 - -- ^ weight of this block (for segwit networks) - , blockDataTxs :: ![TxHash] - -- ^ block transactions - , blockDataOutputs :: !Word64 - -- ^ sum of all transaction outputs - , blockDataFees :: !Word64 - -- ^ sum of all transaction fees - , blockDataSubsidy :: !Word64 - -- ^ block subsidy - } - deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) - -blockDataToJSON :: Network -> BlockData -> Value -blockDataToJSON net bv = - object $ - [ "hash" .= headerHash (blockDataHeader bv) - , "height" .= blockDataHeight bv - , "mainchain" .= blockDataMainChain bv - , "previous" .= prevBlock (blockDataHeader bv) - , "time" .= blockTimestamp (blockDataHeader bv) - , "version" .= blockVersion (blockDataHeader bv) - , "bits" .= blockBits (blockDataHeader bv) - , "nonce" .= bhNonce (blockDataHeader bv) - , "size" .= blockDataSize bv - , "tx" .= blockDataTxs bv - , "merkle" .= TxHash (merkleRoot (blockDataHeader bv)) - , "subsidy" .= blockDataSubsidy bv - , "fees" .= blockDataFees bv - , "outputs" .= blockDataOutputs bv - , "work" .= blockDataWork bv - ] <> - ["weight" .= blockDataWeight bv | getSegWit net] - -blockDataToEncoding :: Network -> BlockData -> Encoding -blockDataToEncoding net bv = - pairs - ( "hash" `pair` text (blockHashToHex (headerHash (blockDataHeader bv))) - <> "height" .= blockDataHeight bv - <> "mainchain" .= blockDataMainChain bv - <> "previous" .= prevBlock (blockDataHeader bv) - <> "time" .= blockTimestamp (blockDataHeader bv) - <> "version" .= blockVersion (blockDataHeader bv) - <> "bits" .= blockBits (blockDataHeader bv) - <> "nonce" .= bhNonce (blockDataHeader bv) - <> "size" .= blockDataSize bv - <> "tx" .= blockDataTxs bv - <> "merkle" `pair` text (txHashToHex (TxHash (merkleRoot (blockDataHeader bv)))) - <> "subsidy" .= blockDataSubsidy bv - <> "fees" .= blockDataFees bv - <> "outputs" .= blockDataOutputs bv - <> "work" .= blockDataWork bv - <> (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 :: !(Maybe WitnessStack) - } - | StoreInput - { inputPoint :: !OutPoint - , inputSequence :: !Word32 - , inputSigScript :: !ByteString - , inputPkScript :: !ByteString - , inputAmount :: !Word64 - , inputWitness :: !(Maybe WitnessStack) - , inputAddress :: !(Maybe Address) - } - deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) - -isCoinbase :: StoreInput -> Bool -isCoinbase StoreCoinbase {} = True -isCoinbase StoreInput {} = False - -storeInputToJSON :: Network -> StoreInput -> Value -storeInputToJSON net StoreInput { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputPkScript = ps - , inputAmount = val - , inputWitness = wit - , inputAddress = 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" .= fmap (map encodeHex) wit | getSegWit net] -storeInputToJSON net StoreCoinbase { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputWitness = wit - } = - object $ - [ "coinbase" .= True - , "txid" .= oph - , "output" .= opi - , "sigscript" .= String (encodeHex ss) - , "sequence" .= sq - , "pkscript" .= Null - , "value" .= Null - , "address" .= Null - ] <> - ["witness" .= fmap (map encodeHex) wit | getSegWit net] - -storeInputToEncoding :: Network -> StoreInput -> Encoding -storeInputToEncoding net StoreInput { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputPkScript = ps - , inputAmount = val - , inputWitness = wit - , inputAddress = a - } = - pairs - ( "coinbase" .= False - <> "txid" .= oph - <> "output" .= opi - <> "sigscript" `pair` text (encodeHex ss) - <> "sequence" .= sq - <> "pkscript" `pair` text (encodeHex ps) - <> "value" .= val - <> "address" `pair` maybe null_ (addrToEncoding net) a - <> (if getSegWit net - then "witness" .= fmap (map encodeHex) wit - else mempty) - ) -storeInputToEncoding net StoreCoinbase { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputWitness = wit - } = - pairs - ( "coinbase" .= True - <> "txid" `pair` text (txHashToHex oph) - <> "output" .= opi - <> "sigscript" `pair` text (encodeHex ss) - <> "sequence" .= sq - <> "pkscript" `pair` null_ - <> "value" `pair` null_ - <> "address" `pair` null_ - <> (if getSegWit net - then "witness" .= fmap (map encodeHex) wit - else mempty) - ) - -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 <- - o .:? "witness" >>= \mmxs -> - case join mmxs of - Nothing -> return Nothing - Just xs -> Just <$> mapM jsonHex xs - sigscript <- o .: "sigscript" >>= jsonHex - if coinbase - then return - StoreCoinbase - { inputPoint = outpoint - , inputSequence = sequ - , inputSigScript = sigscript - , inputWitness = witness - } - else do - pkscript <- o .: "pkscript" >>= jsonHex - value <- o .: "value" - 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 - { spenderHash :: !TxHash - -- ^ input transaction hash - , spenderIndex :: !Word32 - -- ^ input position in transaction - } - deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) - -instance ToJSON Spender where - toJSON n = object ["txid" .= txHashToHex (spenderHash n), "input" .= spenderIndex n] - toEncoding n = pairs ("txid" .= txHashToHex (spenderHash n) <> "input" .= spenderIndex n) - -instance FromJSON Spender where - parseJSON = - A.withObject "spender" $ \o -> Spender <$> o .: "txid" <*> o .: "input" - --- | Output information. -data StoreOutput = - StoreOutput - { outputAmount :: !Word64 - , outputScript :: !ByteString - , outputSpender :: !(Maybe Spender) - , outputAddress :: !(Maybe Address) - } - deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) - -storeOutputToJSON :: Network -> StoreOutput -> Value -storeOutputToJSON net d = - object - [ "address" .= (addrToJSON net <$> outputAddress d) - , "pkscript" .= encodeHex (outputScript d) - , "value" .= outputAmount d - , "spent" .= isJust (outputSpender d) - , "spender" .= outputSpender d - ] - -storeOutputToEncoding :: Network -> StoreOutput -> Encoding -storeOutputToEncoding net d = - pairs - ( "address" `pair` maybe null_ (addrToEncoding net) (outputAddress d) - <> "pkscript" `pair` 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 - , outputAddress = addr - } - -data Prev = - Prev - { prevScript :: !ByteString - , prevAmount :: !Word64 - } - deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) - -toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput -toInput i Nothing w = - StoreCoinbase - { inputPoint = prevOutput i - , inputSequence = txInSequence i - , inputSigScript = scriptInput i - , inputWitness = w - } -toInput i (Just p) w = - StoreInput - { inputPoint = prevOutput i - , inputSequence = txInSequence i - , inputSigScript = scriptInput i - , inputPkScript = prevScript p - , inputAmount = prevAmount p - , inputWitness = w - , inputAddress = eitherToMaybe (scriptToAddressBS (prevScript p)) - } - -toOutput :: TxOut -> Maybe Spender -> StoreOutput -toOutput o s = - StoreOutput - { outputAmount = outValue o - , outputScript = scriptOutput o - , outputSpender = s - , outputAddress = 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, Serialize, NFData) - -toTransaction :: TxData -> IntMap Spender -> Transaction -toTransaction t sm = - Transaction - { transactionBlock = txDataBlock t - , transactionVersion = txVersion (txData t) - , transactionLockTime = txLockTime (txData t) - , transactionInputs = ins - , transactionOutputs = outs - , transactionDeleted = txDataDeleted t - , transactionRBF = txDataRBF t - , transactionTime = txDataTime t - , transactionId = txid - , transactionSize = txsize - , transactionWeight = txweight - , transactionFees = fees - } - where - txid = txHash (txData t) - txsize = fromIntegral $ B.length (S.encode (txData t)) - txweight = - let b = B.length $ S.encode (txData t) {txWitness = []} - x = B.length $ S.encode (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))) $ - map Just (txWitness (txData t)) <> repeat Nothing - f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n) - ins = zipWith f [0 ..] (txIn (txData t)) - g n o = toOutput o (I.lookup n sm) - outs = zipWith g [0 ..] (txOut (txData t)) - -fromTransaction :: Transaction -> (TxData, IntMap Spender) -fromTransaction t = (d, sm) - where - d = - TxData - { txDataBlock = transactionBlock t - , txData = transactionData t - , txDataPrevs = ps - , txDataDeleted = transactionDeleted t - , txDataRBF = transactionRBF t - , txDataTime = transactionTime t - } - f _ StoreCoinbase {} = Nothing - f n StoreInput {inputPkScript = s, inputAmount = v} = - Just (n, Prev {prevScript = s, prevAmount = v}) - ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t) - g _ StoreOutput {outputSpender = Nothing} = Nothing - g n StoreOutput {outputSpender = Just s} = Just (n, s) - sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) - --- | Detailed transaction information. -data Transaction = - Transaction - { transactionBlock :: !BlockRef - -- ^ block information for this transaction - , transactionVersion :: !Word32 - -- ^ transaction version - , transactionLockTime :: !Word32 - -- ^ lock time - , transactionInputs :: ![StoreInput] - -- ^ transaction inputs - , transactionOutputs :: ![StoreOutput] - -- ^ transaction outputs - , transactionDeleted :: !Bool - -- ^ this transaction has been deleted and is no longer valid - , transactionRBF :: !Bool - -- ^ this transaction can be replaced in the mempool - , transactionTime :: !Word64 - -- ^ time the transaction was first seen or time of block - , transactionId :: !TxHash - -- ^ transaction id - , transactionSize :: !Word32 - -- ^ serialized transaction size (includes witness data) - , transactionWeight :: !Word32 - -- ^ transaction weight - , transactionFees :: !Word64 - -- ^ fees that this transaction pays (0 for coinbase) - } - deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) - -transactionData :: Transaction -> Tx -transactionData t = - Tx - { txVersion = transactionVersion t - , txIn = map i (transactionInputs t) - , txOut = map o (transactionOutputs t) - , txWitness = mapMaybe inputWitness (transactionInputs t) - , txLockTime = transactionLockTime t - } - where - i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} = - TxIn {prevOutput = p, scriptInput = s, txInSequence = q} - i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} = - TxIn {prevOutput = p, scriptInput = s, txInSequence = q} - o StoreOutput {outputAmount = v, outputScript = s} = - TxOut {outValue = v, scriptOutput = s} - -transactionToJSON :: Network -> Transaction -> Value -transactionToJSON net dtx = - object $ - [ "txid" .= 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 | getReplaceByFee net] <> - [ "weight" .= transactionWeight dtx | getSegWit net] - -transactionToEncoding :: Network -> Transaction -> Encoding -transactionToEncoding net dtx = - pairs - ( "txid" .= transactionId dtx - <> "size" .= transactionSize dtx - <> "version" .= transactionVersion dtx - <> "locktime" .= transactionLockTime dtx - <> "fee" .= transactionFees dtx - <> "inputs" `pair` list (storeInputToEncoding net) (transactionInputs dtx) - <> "outputs" `pair` list (storeOutputToEncoding net) (transactionOutputs dtx) - <> "block" .= transactionBlock dtx - <> "deleted" .= transactionDeleted dtx - <> "time" .= transactionTime dtx - <> (if getReplaceByFee net - then "rbf" .= transactionRBF dtx - else mempty) - <> (if getSegWit net - then "weight" .= transactionWeight dtx - else mempty) - ) - -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 - { peerUserAgent :: !ByteString - -- ^ user agent string - , peerAddress :: !String - -- ^ network address - , peerVersion :: !Word32 - -- ^ version number - , peerServices :: !Word64 - -- ^ services field - , peerRelay :: !Bool - -- ^ will relay transactions - } - deriving (Show, Eq, Ord, Generic, NFData, Serialize) - -instance ToJSON PeerInformation where - toJSON p = object - [ "useragent" .= String (cs (peerUserAgent p)) - , "address" .= peerAddress p - , "version" .= peerVersion p - , "services" .= String (encodeHex (S.encode (peerServices p))) - , "relay" .= peerRelay p - ] - toEncoding p = pairs - ( "useragent" `pair` text (cs (peerUserAgent p)) - <> "address" .= peerAddress p - <> "version" .= peerVersion p - <> "services" `pair` text (encodeHex (S.encode (peerServices p))) - <> "relay" .= peerRelay p - ) - -instance FromJSON PeerInformation where - parseJSON = - A.withObject "peerinformation" $ \o -> do - String useragent <- o .: "useragent" - address <- o .: "address" - version <- o .: "version" - services <- - o .: "services" >>= jsonHex >>= \b -> - case S.decode b of - Left e -> fail $ "Could not decode services: " <> e - Right s -> return s - relay <- o .: "relay" - return - PeerInformation - { peerUserAgent = cs useragent - , peerAddress = address - , peerVersion = version - , peerServices = services - , peerRelay = relay - } - --- | Address balances for an extended public key. -data XPubBal = - XPubBal - { xPubBalPath :: ![KeyIndex] - , xPubBal :: !Balance - } - deriving (Show, Ord, Eq, Generic, Serialize, NFData) - -xPubBalToJSON :: Network -> XPubBal -> Value -xPubBalToJSON net XPubBal {xPubBalPath = p, xPubBal = b} = - object ["path" .= p, "balance" .= balanceToJSON net b] - -xPubBalToEncoding :: Network -> XPubBal -> Encoding -xPubBalToEncoding net XPubBal {xPubBalPath = p, xPubBal = b} = - pairs ("path" .= p <> "balance" `pair` balanceToEncoding net b) - -xPubBalParseJSON :: Network -> Value -> Parser XPubBal -xPubBalParseJSON net = - A.withObject "xpubbal" $ \o -> do - path <- o .: "path" - balance <- balanceParseJSON net =<< o .: "balance" - return XPubBal {xPubBalPath = path, xPubBal = balance} - --- | Unspent transaction for extended public key. -data XPubUnspent = - XPubUnspent - { xPubUnspentPath :: ![KeyIndex] - , xPubUnspent :: !Unspent - } - deriving (Show, Eq, Generic, Serialize, NFData) - -xPubUnspentToJSON :: Network -> XPubUnspent -> Value -xPubUnspentToJSON net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = - object ["path" .= p, "unspent" .= unspentToJSON net u] - -xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding -xPubUnspentToEncoding net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = - pairs ("path" .= p <> "unspent" `pair` unspentToEncoding net u) - -xPubUnspentParseJSON :: Network -> Value -> Parser XPubUnspent -xPubUnspentParseJSON net = - A.withObject "xpubunspent" $ \o -> do - p <- o .: "path" - u <- o .: "unspent" >>= unspentParseJSON net - return XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} - -data XPubSummary = - XPubSummary - { xPubSummaryConfirmed :: !Word64 - , xPubSummaryZero :: !Word64 - , xPubSummaryReceived :: !Word64 - , xPubUnspentCount :: !Word64 - , xPubExternalIndex :: !Word32 - , xPubChangeIndex :: !Word32 - } - deriving (Eq, Show, Generic, Serialize, NFData) - -instance ToJSON XPubSummary where - toJSON XPubSummary { xPubSummaryConfirmed = c - , xPubSummaryZero = z - , xPubSummaryReceived = r - , xPubUnspentCount = u - , xPubExternalIndex = ext - , xPubChangeIndex = ch - } = - object - [ "balance" .= - object - [ "confirmed" .= c - , "unconfirmed" .= z - , "received" .= r - , "utxo" .= u - ] - , "indices" .= object ["change" .= ch, "external" .= ext] - ] - toEncoding XPubSummary { xPubSummaryConfirmed = c - , xPubSummaryZero = z - , xPubSummaryReceived = r - , xPubUnspentCount = u - , xPubExternalIndex = ext - , xPubChangeIndex = ch - } = - pairs - ( "balance" `pair` pairs - ( "confirmed" .= c - <> "unconfirmed" .= z - <> "received" .= r - <> "utxo" .= u - ) - <> "indices" `pair` pairs - ( "change" .= ch - <> "external" .= ext - ) - ) - -instance FromJSON XPubSummary where - parseJSON = - A.withObject "xpubsummary" $ \o -> do - b <- o .: "balance" - i <- o .: "indices" - conf <- b .: "confirmed" - unconfirmed <- b .: "unconfirmed" - received <- b .: "received" - utxo <- b .: "utxo" - change <- i .: "change" - external <- i .: "external" - return - XPubSummary - { xPubSummaryConfirmed = conf - , xPubSummaryZero = unconfirmed - , xPubSummaryReceived = received - , xPubUnspentCount = utxo - , xPubExternalIndex = external - , xPubChangeIndex = change - } - -class Healthy a where - isOK :: a -> Bool - -data BlockHealth = - BlockHealth - { blockHealthHeaders :: !BlockHeight - , blockHealthBlocks :: !BlockHeight - , blockHealthMaxDiff :: !Int - } - deriving (Show, Eq, Generic, NFData) - -instance Serialize BlockHealth where - put h@BlockHealth {..} = do - put (isOK h) - put blockHealthHeaders - put blockHealthBlocks - put blockHealthMaxDiff - get = do - k <- get - blockHealthHeaders <- get - blockHealthBlocks <- get - blockHealthMaxDiff <- get - let h = BlockHealth {..} - guard (k == isOK h) - return h - -instance Healthy BlockHealth where - isOK BlockHealth {..} = - h - b <= blockHealthMaxDiff - where - h = fromIntegral blockHealthHeaders - b = fromIntegral blockHealthBlocks - -instance ToJSON BlockHealth where - toJSON h@BlockHealth {..} = - object - [ "headers" .= blockHealthHeaders - , "blocks" .= blockHealthBlocks - , "diff" .= diff - , "max" .= blockHealthMaxDiff - , "ok" .= isOK h - ] - where - diff = blockHealthHeaders - 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 :: !Int - , timeHealthMax :: !Int - } - deriving (Show, Eq, Generic, NFData) - -instance Serialize TimeHealth where - put h@TimeHealth {..} = do - put (isOK h) - put timeHealthAge - put timeHealthMax - get = do - k <- get - timeHealthAge <- get - timeHealthMax <- get - let t = TimeHealth {..} - guard (k == isOK t) - return t - -instance Healthy TimeHealth where - isOK TimeHealth {..} = - timeHealthAge <= timeHealthMax - -instance ToJSON TimeHealth where - toJSON h@TimeHealth {..} = - 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 :: !Int - , countHealthMin :: !Int - } - deriving (Show, Eq, Generic, NFData) - -instance Serialize CountHealth where - put h@CountHealth {..} = do - put (isOK h) - put countHealthNum - put countHealthMin - get = do - k <- get - countHealthNum <- get - countHealthMin <- get - let c = CountHealth {..} - guard (k == isOK c) - return c - -instance Healthy CountHealth where - isOK CountHealth {..} = - countHealthMin <= countHealthNum - -instance ToJSON CountHealth where - toJSON h@CountHealth {..} = - 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 :: !Int - , maxHealthMax :: !Int - } - deriving (Show, Eq, Generic, NFData) - -instance Serialize MaxHealth where - put h@MaxHealth {..} = do - put $ isOK h - put maxHealthNum - put maxHealthMax - get = do - k <- get - maxHealthNum <- get - maxHealthMax <- get - let h = MaxHealth {..} - guard (k == isOK h) - return h - -instance Healthy MaxHealth where - isOK MaxHealth {..} = maxHealthNum <= maxHealthMax - -instance ToJSON MaxHealth where - toJSON h@MaxHealth {..} = - 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 Serialize HealthCheck where - put h@HealthCheck {..} = do - put (isOK h) - put healthBlocks - put healthLastBlock - put healthLastTx - put healthPendingTxs - put healthPeers - put healthNetwork - put healthVersion - get = do - k <- get - healthBlocks <- get - healthLastBlock <- get - healthLastTx <- get - healthPendingTxs <- get - healthPeers <- get - healthNetwork <- get - healthVersion <- get - let h = HealthCheck {..} - guard (k == isOK h) - return h - -instance Healthy HealthCheck where - isOK HealthCheck {..} = - isOK healthBlocks && - isOK healthLastBlock && - isOK healthLastTx && - isOK healthPendingTxs && - isOK healthPeers - -instance ToJSON HealthCheck where - toJSON h@HealthCheck {..} = - 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, Serialize, NFData) - -instance ToJSON Event where - toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h] - toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h] - toEncoding (EventTx h) = - pairs ("type" `pair` text "tx" <> "id" `pair` text (txHashToHex h)) - toEncoding (EventBlock h) = - pairs - ("type" `pair` text "block" <> "id" `pair` text (blockHashToHex h)) - -instance FromJSON Event where - parseJSON = - A.withObject "event" $ \o -> do - t <- o .: "type" - case t of - "tx" -> do - i <- o .: "id" - return $ EventTx i - "block" -> do - i <- o .: "id" - return $ EventBlock i - _ -> fail $ "Could not recognize event type: " <> t - -newtype GenericResult a = - GenericResult - { getResult :: a - } - deriving (Show, Eq, Generic, Serialize, NFData) - -instance ToJSON a => ToJSON (GenericResult a) where - toJSON (GenericResult b) = object ["result" .= b] - toEncoding (GenericResult b) = pairs ("result" .= b) - -instance FromJSON a => FromJSON (GenericResult a) where - parseJSON = - A.withObject "GenericResult" $ \o -> GenericResult <$> o .: "result" - -newtype RawResult a = - RawResult - { getRawResult :: a - } - deriving (Show, Eq, Generic, Serialize, NFData) - -instance S.Serialize a => ToJSON (RawResult a) where - toJSON (RawResult b) = - object [ "result" .= A.String (encodeHex $ S.encode b)] - toEncoding (RawResult b) = - pairs $ "result" `pair` unsafeToEncoding str - where - str = char7 '"' <> lazyByteStringHex (S.runPutLazy $ put b) <> char7 '"' - -instance S.Serialize a => FromJSON (RawResult a) where - parseJSON = - A.withObject "RawResult" $ \o -> do - res <- o .: "result" - let valM = eitherToMaybe . S.decode =<< decodeHex res - maybe mzero (return . RawResult) valM - -newtype RawResultList a = - RawResultList - { getRawResultList :: [a] - } - deriving (Show, Eq, Generic, Serialize, NFData) - -instance Semigroup (RawResultList a) where - (RawResultList a) <> (RawResultList b) = RawResultList $ a <> b - -instance Monoid (RawResultList a) where - mempty = RawResultList mempty - -instance S.Serialize a => ToJSON (RawResultList a) where - toJSON (RawResultList xs) = - toJSON $ encodeHex . S.encode <$> xs - toEncoding (RawResultList xs) = - list (unsafeToEncoding . str) xs - where - str x = - char7 '"' <> lazyByteStringHex (S.runPutLazy (put x)) <> char7 '"' - -instance S.Serialize 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 . S.decode <=< decodeHex - -newtype TxId = - TxId TxHash - deriving (Show, Eq, Generic, Serialize, NFData) - -instance ToJSON TxId where - toJSON (TxId h) = object ["txid" .= h] - toEncoding (TxId h) = pairs ("txid" `pair` text (txHashToHex h)) - -instance FromJSON TxId where - parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid" - -data Except - = ThingNotFound - | ServerError - | BadRequest - | UserError !String - | StringError !String - | BlockTooLarge - deriving (Show, Eq, Ord, Serialize, Generic, NFData) - -instance Exception Except - -instance ScottyError Except where - stringError = StringError - showError = TL.pack . show - -instance ToJSON Except where - toJSON e = - object $ - case e of - ThingNotFound -> - ["error" .= String "not-found"] - ServerError -> - ["error" .= String "server-error"] - BadRequest -> - ["error" .= String "bad-request"] - UserError msg -> - [ "error" .= String "user-error" - , "message" .= String (cs msg) - ] - StringError msg -> - [ "error" .= String "string-error" - , "message" .= String (cs msg) - ] - BlockTooLarge -> - ["error" .= String "block-too-large"] - -instance FromJSON Except where - parseJSON = - A.withObject "Except" $ \o -> do - ctr <- o .: "error" - msg <- fromMaybe "" <$> o .:? "message" - case ctr of - String "not-found" -> 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 "block-too-large" -> return BlockTooLarge - _ -> mzero + + -- * Blockchain.info API + , BinfoTxIndex + , isBinfoTxIndexNull + , isBinfoTxIndexBlock + , isBinfoTxIndexHash + , encodeBinfoTxIndexHash + , hashToBinfoTxIndex + , blockToBinfoTxIndex + , matchBinfoTxHash + , binfoTxIndexBlock + , binfoTransactionIndex + , BinfoTxId(..) + , BinfoMultiAddr(..) + , binfoMultiAddrToJSON + , binfoMultiAddrToEncoding + , binfoMultiAddrParseJSON + , BinfoAddress(..) + , toBinfoAddrs + , binfoAddressToJSON + , binfoAddressToEncoding + , binfoAddressParseJSON + , BinfoAddr(..) + , parseBinfoAddr + , BinfoWallet(..) + , BinfoTx(..) + , relevantTxs + , toBinfoTx + , toBinfoTxSimple + , binfoTxToJSON + , binfoTxToEncoding + , binfoTxParseJSON + , BinfoTxInput(..) + , binfoTxInputToJSON + , binfoTxInputToEncoding + , binfoTxInputParseJSON + , BinfoTxOutput(..) + , binfoTxOutputToJSON + , binfoTxOutputToEncoding + , binfoTxOutputParseJSON + , BinfoSpender(..) + , BinfoXPubPath(..) + , binfoXPubPathToJSON + , binfoXPubPathToEncoding + , binfoXPubPathParseJSON + , BinfoInfo(..) + , BinfoBlockInfo(..) + , BinfoSymbol(..) + , BinfoTicker(..) + ) + +where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData) +import Control.Exception (Exception) +import Control.Monad (guard, join, mzero, (<=<)) +import Data.Aeson (Encoding, FromJSON (..), + FromJSONKey (..), ToJSON (..), + ToJSONKey (..), Value (..), object, + pairs, withObject, (.!=), (.:), (.:?), + (.=)) +import qualified Data.Aeson as A +import Data.Aeson.Encoding (list, null_, pair, text, + unsafeToEncoding) +import Data.Aeson.Types (Parser) +import Data.Bits (setBit, shift, testBit, (.&.), (.|.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Builder (char7, lazyByteStringHex) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as BSS +import Data.Default (Default (..)) +import Data.Either (fromRight, lefts, rights) +import Data.Foldable (toList) +import Data.Function (on) +import Data.Hashable (Hashable (..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Int (Int64) +import qualified Data.IntMap as IntMap +import Data.IntMap.Strict (IntMap) +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes, fromMaybe, isJust, + isNothing, mapMaybe, maybeToList) +import Data.Serialize (Get, Put, Serialize (..), getWord32be, + getWord64be, getWord8, putWord32be, + putWord64be, putWord8) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy as TL +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import Haskoin (Address, BlockHash, BlockHeader (..), + BlockHeight, BlockWork, Coin (..), + KeyIndex, Network (..), OutPoint (..), + PubKeyI (..), SoftPath, Tx (..), + TxHash (..), TxIn (..), TxOut (..), + WitnessStack, XPubKey (..), + addrFromJSON, addrToEncoding, + addrToJSON, bch, blockHashToHex, btc, + decodeHex, eitherToMaybe, encodeHex, + headerHash, hexToTxHash, + maybeToEither, parseSoft, pathToList, + pathToStr, putVarInt, + scriptToAddressBS, textToAddr, txHash, + txHashToHex, wrapPubKey, xPubFromJSON, + xPubImport, xPubToEncoding, + xPubToJSON) +import Text.Read (readMaybe) +import Web.Scotty.Trans (Parsable (..), ScottyError (..)) + +data DeriveType = DeriveNormal + | DeriveP2SH + | DeriveP2WPKH + deriving (Show, Eq, Generic, NFData, Serialize) + +instance Default DeriveType where + def = DeriveNormal + +data XPubSpec = + XPubSpec + { xPubSpecKey :: !XPubKey + , xPubDeriveType :: !DeriveType + } + deriving (Show, Eq, Generic, NFData) + +instance Hashable XPubSpec where + hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} = + hashWithSalt i pubkey + +instance Serialize XPubSpec where + put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do + put (xPubDepth k) + put (xPubParent k) + put (xPubIndex k) + put (xPubChain k) + put (wrapPubKey True (xPubKey k)) + put t + get = do + d <- get + p <- get + i <- get + c <- get + k <- get + t <- get + let x = + XPubKey + { xPubDepth = d + , xPubParent = p + , xPubIndex = i + , xPubChain = c + , xPubKey = pubKeyPoint k + } + return XPubSpec {xPubSpecKey = x, xPubDeriveType = t} + +type UnixTime = Word64 +type BlockPos = Word32 + +-- | Serialize such that ordering is inverted. +putUnixTime :: Word64 -> Put +putUnixTime w = putWord64be $ maxBound - w + +getUnixTime :: Get Word64 +getUnixTime = (maxBound -) <$> getWord64be + +-- | Reference to a block where a transaction is stored. +data BlockRef + = BlockRef + { blockRefHeight :: !BlockHeight + -- ^ block height in the chain + , blockRefPos :: !Word32 + -- ^ position of transaction within the block + } + | MemRef + { memRefTime :: !UnixTime + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +-- | Serialized entities will sort in reverse order. +instance Serialize BlockRef where + put MemRef {memRefTime = t} = do + putWord8 0x00 + putUnixTime t + put BlockRef {blockRefHeight = h, blockRefPos = p} = do + putWord8 0x01 + putWord32be (maxBound - h) + putWord32be (maxBound - p) + get = getmemref <|> getblockref + where + getmemref = do + guard . (== 0x00) =<< getWord8 + MemRef <$> getUnixTime + getblockref = do + guard . (== 0x01) =<< getWord8 + h <- (maxBound -) <$> getWord32be + p <- (maxBound -) <$> getWord32be + return BlockRef {blockRefHeight = h, blockRefPos = p} + +confirmed :: BlockRef -> Bool +confirmed BlockRef {} = True +confirmed MemRef {} = False + +instance ToJSON BlockRef where + toJSON BlockRef {blockRefHeight = h, blockRefPos = p} = + object ["height" .= h, "position" .= p] + toJSON MemRef {memRefTime = t} = object ["mempool" .= t] + toEncoding BlockRef {blockRefHeight = h, blockRefPos = p} = + pairs ("height" .= h <> "position" .= p) + toEncoding MemRef {memRefTime = t} = pairs ("mempool" .= t) + +instance FromJSON BlockRef where + parseJSON = A.withObject "blockref" $ \o -> b o <|> m o + where + b o = do + height <- o .: "height" + position <- o .: "position" + return BlockRef{blockRefHeight = height, blockRefPos = position} + m o = do + mempool <- o .: "mempool" + return MemRef{memRefTime = mempool} + +-- | Transaction in relation to an address. +data TxRef = + TxRef + { txRefBlock :: !BlockRef + -- ^ block information + , txRefHash :: !TxHash + -- ^ transaction hash + } + deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData) + +instance ToJSON TxRef where + toJSON btx = object ["txid" .= txRefHash btx, "block" .= txRefBlock btx] + toEncoding btx = + 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 + { balanceAddress :: !Address + -- ^ address balance + , balanceAmount :: !Word64 + -- ^ confirmed balance + , balanceZero :: !Word64 + -- ^ unconfirmed balance + , balanceUnspentCount :: !Word64 + -- ^ number of unspent outputs + , balanceTxCount :: !Word64 + -- ^ number of transactions + , balanceTotalReceived :: !Word64 + -- ^ total amount from all outputs in this address + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +zeroBalance :: Address -> Balance +zeroBalance a = + Balance + { balanceAddress = a + , balanceAmount = 0 + , balanceUnspentCount = 0 + , balanceZero = 0 + , balanceTxCount = 0 + , balanceTotalReceived = 0 + } + +nullBalance :: Balance -> Bool +nullBalance Balance { balanceAmount = 0 + , balanceUnspentCount = 0 + , balanceZero = 0 + , balanceTxCount = 0 + , balanceTotalReceived = 0 + } = True +nullBalance _ = False + +balanceToJSON :: Network -> Balance -> Value +balanceToJSON net b = + object + [ "address" .= addrToJSON net (balanceAddress b) + , "confirmed" .= balanceAmount b + , "unconfirmed" .= balanceZero b + , "utxo" .= balanceUnspentCount b + , "txs" .= balanceTxCount b + , "received" .= balanceTotalReceived b + ] + +balanceToEncoding :: Network -> Balance -> Encoding +balanceToEncoding net b = + pairs + ( "address" `pair` addrToEncoding net (balanceAddress b) + <> "confirmed" .= balanceAmount b + <> "unconfirmed" .= balanceZero b + <> "utxo" .= balanceUnspentCount b + <> "txs" .= balanceTxCount b + <> "received" .= balanceTotalReceived b + ) + +balanceParseJSON :: Network -> Value -> Parser Balance +balanceParseJSON net = + A.withObject "balance" $ \o -> do + amount <- o .: "confirmed" + unconfirmed <- o .: "unconfirmed" + utxo <- o .: "utxo" + txs <- o .: "txs" + received <- o .: "received" + address <- addrFromJSON net =<< o .: "address" + return + Balance + { balanceAddress = address + , balanceAmount = amount + , balanceUnspentCount = utxo + , balanceZero = unconfirmed + , balanceTxCount = txs + , balanceTotalReceived = received + } + +-- | Unspent output. +data Unspent = + Unspent + { unspentBlock :: !BlockRef + , unspentPoint :: !OutPoint + , unspentAmount :: !Word64 + , unspentScript :: !ShortByteString + , unspentAddress :: !(Maybe Address) + } + deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +instance Coin Unspent where + coinValue = unspentAmount + +unspentToJSON :: Network -> Unspent -> Value +unspentToJSON net u = + object + [ "address" .= (addrToJSON net <$> unspentAddress u) + , "block" .= unspentBlock u + , "txid" .= outPointHash (unspentPoint u) + , "index" .= outPointIndex (unspentPoint u) + , "pkscript" .= script + , "value" .= unspentAmount u + ] + where + bsscript = BSS.fromShort (unspentScript u) + script = encodeHex bsscript + +unspentToEncoding :: Network -> Unspent -> Encoding +unspentToEncoding net u = + pairs + ( "address" `pair` maybe null_ (addrToEncoding net) (unspentAddress u) + <> "block" .= unspentBlock u + <> "txid" .= outPointHash (unspentPoint u) + <> "index" .= outPointIndex (unspentPoint u) + <> "pkscript" `pair` text script + <> "value" .= unspentAmount u + ) + where + bsscript = BSS.fromShort (unspentScript u) + script = encodeHex bsscript + +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 <- BSS.toShort <$> (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 + { blockDataHeight :: !BlockHeight + -- ^ height of the block in the chain + , blockDataMainChain :: !Bool + -- ^ is this block in the main chain? + , blockDataWork :: !BlockWork + -- ^ accumulated work in that block + , blockDataHeader :: !BlockHeader + -- ^ block header + , blockDataSize :: !Word32 + -- ^ size of the block including witnesses + , blockDataWeight :: !Word32 + -- ^ weight of this block (for segwit networks) + , blockDataTxs :: ![TxHash] + -- ^ block transactions + , blockDataOutputs :: !Word64 + -- ^ sum of all transaction outputs + , blockDataFees :: !Word64 + -- ^ sum of all transaction fees + , blockDataSubsidy :: !Word64 + -- ^ block subsidy + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +blockDataToJSON :: Network -> BlockData -> Value +blockDataToJSON net bv = + object $ + [ "hash" .= headerHash (blockDataHeader bv) + , "height" .= blockDataHeight bv + , "mainchain" .= blockDataMainChain bv + , "previous" .= prevBlock (blockDataHeader bv) + , "time" .= blockTimestamp (blockDataHeader bv) + , "version" .= blockVersion (blockDataHeader bv) + , "bits" .= blockBits (blockDataHeader bv) + , "nonce" .= bhNonce (blockDataHeader bv) + , "size" .= blockDataSize bv + , "tx" .= blockDataTxs bv + , "merkle" .= TxHash (merkleRoot (blockDataHeader bv)) + , "subsidy" .= blockDataSubsidy bv + , "fees" .= blockDataFees bv + , "outputs" .= blockDataOutputs bv + , "work" .= blockDataWork bv + ] <> + ["weight" .= blockDataWeight bv | getSegWit net] + +blockDataToEncoding :: Network -> BlockData -> Encoding +blockDataToEncoding net bv = + pairs + ( "hash" `pair` text (blockHashToHex (headerHash (blockDataHeader bv))) + <> "height" .= blockDataHeight bv + <> "mainchain" .= blockDataMainChain bv + <> "previous" .= prevBlock (blockDataHeader bv) + <> "time" .= blockTimestamp (blockDataHeader bv) + <> "version" .= blockVersion (blockDataHeader bv) + <> "bits" .= blockBits (blockDataHeader bv) + <> "nonce" .= bhNonce (blockDataHeader bv) + <> "size" .= blockDataSize bv + <> "tx" .= blockDataTxs bv + <> "merkle" `pair` text (txHashToHex (TxHash (merkleRoot (blockDataHeader bv)))) + <> "subsidy" .= blockDataSubsidy bv + <> "fees" .= blockDataFees bv + <> "outputs" .= blockDataOutputs bv + <> "work" .= blockDataWork bv + <> (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, Serialize, Hashable, NFData) + +isCoinbase :: StoreInput -> Bool +isCoinbase StoreCoinbase {} = True +isCoinbase StoreInput {} = False + +storeInputToJSON :: Network -> StoreInput -> Value +storeInputToJSON net StoreInput { inputPoint = OutPoint oph opi + , inputSequence = sq + , inputSigScript = ss + , inputPkScript = ps + , inputAmount = val + , inputWitness = wit + , inputAddress = 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 net StoreCoinbase { inputPoint = OutPoint oph opi + , inputSequence = sq + , inputSigScript = ss + , inputWitness = wit + } = + object $ + [ "coinbase" .= True + , "txid" .= oph + , "output" .= opi + , "sigscript" .= String (encodeHex ss) + , "sequence" .= sq + , "pkscript" .= Null + , "value" .= Null + , "address" .= Null + , "witness" .= 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 + } = + pairs + ( "coinbase" .= False + <> "txid" .= oph + <> "output" .= opi + <> "sigscript" `pair` text (encodeHex ss) + <> "sequence" .= sq + <> "pkscript" `pair` text (encodeHex ps) + <> "value" .= val + <> "address" `pair` maybe null_ (addrToEncoding net) a + <> "witness" .= map encodeHex wit + ) +storeInputToEncoding net StoreCoinbase { inputPoint = OutPoint oph opi + , inputSequence = sq + , inputSigScript = ss + , inputWitness = wit + } = + pairs + ( "coinbase" .= True + <> "txid" `pair` text (txHashToHex oph) + <> "output" .= opi + <> "sigscript" `pair` text (encodeHex ss) + <> "sequence" .= sq + <> "pkscript" `pair` null_ + <> "value" `pair` null_ + <> "address" `pair` null_ + <> "witness" .= 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 + { spenderHash :: !TxHash + -- ^ input transaction hash + , spenderIndex :: !Word32 + -- ^ input position in transaction + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +instance ToJSON Spender where + toJSON n = + object + [ "txid" .= txHashToHex (spenderHash n) + , "input" .= spenderIndex n + ] + toEncoding n = + pairs $ + "txid" .= txHashToHex (spenderHash n) <> + "input" .= spenderIndex n + +instance FromJSON Spender where + parseJSON = + A.withObject "spender" $ \o -> Spender <$> o .: "txid" <*> o .: "input" + +-- | Output information. +data StoreOutput = + StoreOutput + { outputAmount :: !Word64 + , outputScript :: !ByteString + , outputSpender :: !(Maybe Spender) + , outputAddress :: !(Maybe Address) + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +storeOutputToJSON :: Network -> StoreOutput -> Value +storeOutputToJSON net d = + object + [ "address" .= (addrToJSON net <$> outputAddress d) + , "pkscript" .= encodeHex (outputScript d) + , "value" .= outputAmount d + , "spent" .= isJust (outputSpender d) + , "spender" .= outputSpender d + ] + +storeOutputToEncoding :: Network -> StoreOutput -> Encoding +storeOutputToEncoding net d = + pairs + ( "address" `pair` maybe null_ (addrToEncoding net) (outputAddress d) + <> "pkscript" `pair` 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 + , outputAddress = addr + } + +data Prev = + Prev + { prevScript :: !ByteString + , prevAmount :: !Word64 + } + deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +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 + , outputAddress = 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, Serialize, NFData) + +toTransaction :: TxData -> IntMap Spender -> Transaction +toTransaction t sm = + Transaction + { transactionBlock = txDataBlock t + , transactionVersion = txVersion (txData t) + , transactionLockTime = txLockTime (txData t) + , transactionInputs = ins + , transactionOutputs = outs + , transactionDeleted = txDataDeleted t + , transactionRBF = txDataRBF t + , transactionTime = txDataTime t + , transactionId = txid + , transactionSize = txsize + , transactionWeight = txweight + , transactionFees = fees + } + where + txid = txHash (txData t) + txsize = fromIntegral $ B.length (S.encode (txData t)) + txweight = + let b = B.length $ S.encode (txData t) {txWitness = []} + x = B.length $ S.encode (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 + { transactionBlock :: !BlockRef + -- ^ block information for this transaction + , transactionVersion :: !Word32 + -- ^ transaction version + , transactionLockTime :: !Word32 + -- ^ lock time + , transactionInputs :: ![StoreInput] + -- ^ transaction inputs + , transactionOutputs :: ![StoreOutput] + -- ^ transaction outputs + , transactionDeleted :: !Bool + -- ^ this transaction has been deleted and is no longer valid + , transactionRBF :: !Bool + -- ^ this transaction can be replaced in the mempool + , transactionTime :: !Word64 + -- ^ time the transaction was first seen or time of block + , transactionId :: !TxHash + -- ^ transaction id + , transactionSize :: !Word32 + -- ^ serialized transaction size (includes witness data) + , transactionWeight :: !Word32 + -- ^ transaction weight + , transactionFees :: !Word64 + -- ^ fees that this transaction pays (0 for coinbase) + } + deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +transactionData :: Transaction -> Tx +transactionData t = + Tx + { txVersion = transactionVersion t + , txIn = map i (transactionInputs t) + , txOut = map o (transactionOutputs t) + , txWitness = 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 = + 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 = + pairs + ( "txid" .= transactionId dtx + <> "size" .= transactionSize dtx + <> "version" .= transactionVersion dtx + <> "locktime" .= transactionLockTime dtx + <> "fee" .= transactionFees dtx + <> "inputs" `pair` list (storeInputToEncoding net) (transactionInputs dtx) + <> "outputs" `pair` list (storeOutputToEncoding net) (transactionOutputs dtx) + <> "block" .= transactionBlock dtx + <> "deleted" .= transactionDeleted dtx + <> "time" .= transactionTime dtx + <> "rbf" .= transactionRBF dtx + <> "weight" .= 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 + { peerUserAgent :: !ByteString + -- ^ user agent string + , peerAddress :: !String + -- ^ network address + , peerVersion :: !Word32 + -- ^ version number + , peerServices :: !Word64 + -- ^ services field + , peerRelay :: !Bool + -- ^ will relay transactions + } + deriving (Show, Eq, Ord, Generic, NFData, Serialize) + +instance ToJSON PeerInformation where + toJSON p = object + [ "useragent" .= String (cs (peerUserAgent p)) + , "address" .= peerAddress p + , "version" .= peerVersion p + , "services" .= String (encodeHex (S.encode (peerServices p))) + , "relay" .= peerRelay p + ] + toEncoding p = pairs + ( "useragent" `pair` text (cs (peerUserAgent p)) + <> "address" .= peerAddress p + <> "version" .= peerVersion p + <> "services" `pair` text (encodeHex (S.encode (peerServices p))) + <> "relay" .= peerRelay p + ) + +instance FromJSON PeerInformation where + parseJSON = + A.withObject "peerinformation" $ \o -> do + String useragent <- o .: "useragent" + address <- o .: "address" + version <- o .: "version" + services <- + o .: "services" >>= jsonHex >>= \b -> + case S.decode b of + Left e -> fail $ "Could not decode services: " <> e + Right s -> return s + relay <- o .: "relay" + return + PeerInformation + { peerUserAgent = cs useragent + , peerAddress = address + , peerVersion = version + , peerServices = services + , peerRelay = relay + } + +-- | Address balances for an extended public key. +data XPubBal = + XPubBal + { xPubBalPath :: ![KeyIndex] + , xPubBal :: !Balance + } + deriving (Show, Ord, Eq, Generic, Serialize, NFData) + +xPubBalToJSON :: Network -> XPubBal -> Value +xPubBalToJSON net XPubBal {xPubBalPath = p, xPubBal = b} = + object ["path" .= p, "balance" .= balanceToJSON net b] + +xPubBalToEncoding :: Network -> XPubBal -> Encoding +xPubBalToEncoding net XPubBal {xPubBalPath = p, xPubBal = b} = + pairs ("path" .= p <> "balance" `pair` balanceToEncoding net b) + +xPubBalParseJSON :: Network -> Value -> Parser XPubBal +xPubBalParseJSON net = + A.withObject "xpubbal" $ \o -> do + path <- o .: "path" + balance <- balanceParseJSON net =<< o .: "balance" + return XPubBal {xPubBalPath = path, xPubBal = balance} + +-- | Unspent transaction for extended public key. +data XPubUnspent = + XPubUnspent + { xPubUnspentPath :: ![KeyIndex] + , xPubUnspent :: !Unspent + } + deriving (Show, Eq, Generic, Serialize, NFData) + +xPubUnspentToJSON :: Network -> XPubUnspent -> Value +xPubUnspentToJSON net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = + object ["path" .= p, "unspent" .= unspentToJSON net u] + +xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding +xPubUnspentToEncoding net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = + pairs ("path" .= p <> "unspent" `pair` unspentToEncoding net u) + +xPubUnspentParseJSON :: Network -> Value -> Parser XPubUnspent +xPubUnspentParseJSON net = + A.withObject "xpubunspent" $ \o -> do + p <- o .: "path" + u <- o .: "unspent" >>= unspentParseJSON net + return XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} + +data XPubSummary = + XPubSummary + { xPubSummaryConfirmed :: !Word64 + , xPubSummaryZero :: !Word64 + , xPubSummaryReceived :: !Word64 + , xPubUnspentCount :: !Word64 + , xPubExternalIndex :: !Word32 + , xPubChangeIndex :: !Word32 + } + deriving (Eq, Show, Generic, Serialize, NFData) + +instance ToJSON XPubSummary where + toJSON XPubSummary { xPubSummaryConfirmed = c + , xPubSummaryZero = z + , xPubSummaryReceived = r + , xPubUnspentCount = u + , xPubExternalIndex = ext + , xPubChangeIndex = ch + } = + object + [ "balance" .= + object + [ "confirmed" .= c + , "unconfirmed" .= z + , "received" .= r + , "utxo" .= u + ] + , "indices" .= object ["change" .= ch, "external" .= ext] + ] + toEncoding XPubSummary { xPubSummaryConfirmed = c + , xPubSummaryZero = z + , xPubSummaryReceived = r + , xPubUnspentCount = u + , xPubExternalIndex = ext + , xPubChangeIndex = ch + } = + pairs + ( "balance" `pair` pairs + ( "confirmed" .= c + <> "unconfirmed" .= z + <> "received" .= r + <> "utxo" .= u + ) + <> "indices" `pair` pairs + ( "change" .= ch + <> "external" .= ext + ) + ) + +instance FromJSON XPubSummary where + parseJSON = + A.withObject "xpubsummary" $ \o -> do + b <- o .: "balance" + i <- o .: "indices" + conf <- b .: "confirmed" + unconfirmed <- b .: "unconfirmed" + received <- b .: "received" + utxo <- b .: "utxo" + change <- i .: "change" + external <- i .: "external" + return + XPubSummary + { xPubSummaryConfirmed = conf + , xPubSummaryZero = unconfirmed + , xPubSummaryReceived = received + , xPubUnspentCount = utxo + , xPubExternalIndex = external + , xPubChangeIndex = change + } + +class Healthy a where + isOK :: a -> Bool + +data BlockHealth = + BlockHealth + { blockHealthHeaders :: !BlockHeight + , blockHealthBlocks :: !BlockHeight + , blockHealthMaxDiff :: !Int + } + deriving (Show, Eq, Generic, NFData) + +instance Serialize BlockHealth where + put h@BlockHealth {..} = do + put (isOK h) + put blockHealthHeaders + put blockHealthBlocks + put blockHealthMaxDiff + get = do + k <- get + blockHealthHeaders <- get + blockHealthBlocks <- get + blockHealthMaxDiff <- get + let h = BlockHealth {..} + guard (k == isOK h) + return h + +instance Healthy BlockHealth where + isOK BlockHealth {..} = + h - b <= blockHealthMaxDiff + where + h = fromIntegral blockHealthHeaders + b = fromIntegral blockHealthBlocks + +instance ToJSON BlockHealth where + toJSON h@BlockHealth {..} = + object + [ "headers" .= blockHealthHeaders + , "blocks" .= blockHealthBlocks + , "diff" .= diff + , "max" .= blockHealthMaxDiff + , "ok" .= isOK h + ] + where + diff = blockHealthHeaders - 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 :: !Int + , timeHealthMax :: !Int + } + deriving (Show, Eq, Generic, NFData) + +instance Serialize TimeHealth where + put h@TimeHealth {..} = do + put (isOK h) + put timeHealthAge + put timeHealthMax + get = do + k <- get + timeHealthAge <- get + timeHealthMax <- get + let t = TimeHealth {..} + guard (k == isOK t) + return t + +instance Healthy TimeHealth where + isOK TimeHealth {..} = + timeHealthAge <= timeHealthMax + +instance ToJSON TimeHealth where + toJSON h@TimeHealth {..} = + 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 :: !Int + , countHealthMin :: !Int + } + deriving (Show, Eq, Generic, NFData) + +instance Serialize CountHealth where + put h@CountHealth {..} = do + put (isOK h) + put countHealthNum + put countHealthMin + get = do + k <- get + countHealthNum <- get + countHealthMin <- get + let c = CountHealth {..} + guard (k == isOK c) + return c + +instance Healthy CountHealth where + isOK CountHealth {..} = + countHealthMin <= countHealthNum + +instance ToJSON CountHealth where + toJSON h@CountHealth {..} = + 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 :: !Int + , maxHealthMax :: !Int + } + deriving (Show, Eq, Generic, NFData) + +instance Serialize MaxHealth where + put h@MaxHealth {..} = do + put $ isOK h + put maxHealthNum + put maxHealthMax + get = do + k <- get + maxHealthNum <- get + maxHealthMax <- get + let h = MaxHealth {..} + guard (k == isOK h) + return h + +instance Healthy MaxHealth where + isOK MaxHealth {..} = maxHealthNum <= maxHealthMax + +instance ToJSON MaxHealth where + toJSON h@MaxHealth {..} = + 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 Serialize HealthCheck where + put h@HealthCheck {..} = do + put (isOK h) + put healthBlocks + put healthLastBlock + put healthLastTx + put healthPendingTxs + put healthPeers + put healthNetwork + put healthVersion + get = do + k <- get + healthBlocks <- get + healthLastBlock <- get + healthLastTx <- get + healthPendingTxs <- get + healthPeers <- get + healthNetwork <- get + healthVersion <- get + let h = HealthCheck {..} + guard (k == isOK h) + return h + +instance Healthy HealthCheck where + isOK HealthCheck {..} = + isOK healthBlocks && + isOK healthLastBlock && + isOK healthLastTx && + isOK healthPendingTxs && + isOK healthPeers + +instance ToJSON HealthCheck where + toJSON h@HealthCheck {..} = + 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, Serialize, NFData) + +instance ToJSON Event where + toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h] + toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h] + toEncoding (EventTx h) = + pairs ("type" `pair` text "tx" <> "id" `pair` text (txHashToHex h)) + toEncoding (EventBlock h) = + pairs + ("type" `pair` text "block" <> "id" `pair` text (blockHashToHex h)) + +instance FromJSON Event where + parseJSON = + A.withObject "event" $ \o -> do + t <- o .: "type" + case t of + "tx" -> do + i <- o .: "id" + return $ EventTx i + "block" -> do + i <- o .: "id" + return $ EventBlock i + _ -> fail $ "Could not recognize event type: " <> t + +newtype GenericResult a = + GenericResult + { getResult :: a + } + deriving (Show, Eq, Generic, Serialize, NFData) + +instance ToJSON a => ToJSON (GenericResult a) where + toJSON (GenericResult b) = object ["result" .= b] + toEncoding (GenericResult b) = pairs ("result" .= b) + +instance FromJSON a => FromJSON (GenericResult a) where + parseJSON = + A.withObject "GenericResult" $ \o -> GenericResult <$> o .: "result" + +newtype RawResult a = + RawResult + { getRawResult :: a + } + deriving (Show, Eq, Generic, Serialize, NFData) + +instance S.Serialize a => ToJSON (RawResult a) where + toJSON (RawResult b) = + object [ "result" .= A.String (encodeHex $ S.encode b)] + toEncoding (RawResult b) = + pairs $ "result" `pair` unsafeToEncoding str + where + str = char7 '"' <> lazyByteStringHex (S.runPutLazy $ put b) <> char7 '"' + +instance S.Serialize a => FromJSON (RawResult a) where + parseJSON = + A.withObject "RawResult" $ \o -> do + res <- o .: "result" + let valM = eitherToMaybe . S.decode =<< decodeHex res + maybe mzero (return . RawResult) valM + +newtype RawResultList a = + RawResultList + { getRawResultList :: [a] + } + deriving (Show, Eq, Generic, Serialize, NFData) + +instance Semigroup (RawResultList a) where + (RawResultList a) <> (RawResultList b) = RawResultList $ a <> b + +instance Monoid (RawResultList a) where + mempty = RawResultList mempty + +instance S.Serialize a => ToJSON (RawResultList a) where + toJSON (RawResultList xs) = + toJSON $ encodeHex . S.encode <$> xs + toEncoding (RawResultList xs) = + list (unsafeToEncoding . str) xs + where + str x = + char7 '"' <> lazyByteStringHex (S.runPutLazy (put x)) <> char7 '"' + +instance S.Serialize 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 . S.decode <=< decodeHex + +newtype TxId = + TxId TxHash + deriving (Show, Eq, Generic, Serialize, NFData) + +instance ToJSON TxId where + toJSON (TxId h) = object ["txid" .= h] + toEncoding (TxId h) = pairs ("txid" `pair` text (txHashToHex h)) + +instance FromJSON TxId where + parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid" + +data Except + = ThingNotFound + | ServerError + | BadRequest + | UserError !String + | StringError !String + | BlockTooLarge + deriving (Show, Eq, Ord, Serialize, Generic, NFData) + +instance Exception Except + +instance ScottyError Except where + stringError = StringError + showError = TL.pack . show + +instance ToJSON Except where + toJSON e = + object $ + case e of + ThingNotFound -> + ["error" .= String "not-found"] + ServerError -> + ["error" .= String "server-error"] + BadRequest -> + ["error" .= String "bad-request"] + UserError msg -> + [ "error" .= String "user-error" + , "message" .= String (cs msg) + ] + StringError msg -> + [ "error" .= String "string-error" + , "message" .= String (cs msg) + ] + BlockTooLarge -> + ["error" .= String "block-too-large"] + +instance FromJSON Except where + parseJSON = + A.withObject "Except" $ \o -> do + ctr <- o .: "error" + msg <- fromMaybe "" <$> o .:? "message" + case ctr of + String "not-found" -> 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 "block-too-large" -> return BlockTooLarge + _ -> mzero + + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- + +type BinfoTxIndex = Int64 + +isBinfoTxIndexNull :: BinfoTxIndex -> Bool +isBinfoTxIndexNull = (0 >) + +isBinfoTxIndexBlock :: BinfoTxIndex -> Bool +isBinfoTxIndexBlock n = 0 <= n && not (testBit n 48) + +isBinfoTxIndexHash :: BinfoTxIndex -> Bool +isBinfoTxIndexHash n = 0 <= n && testBit n 48 + +encodeBinfoTxIndexHash :: BinfoTxIndex -> Maybe ByteString +encodeBinfoTxIndexHash n = + if isBinfoTxIndexHash n + then Just . B.drop 2 $ S.encode n + else Nothing + +hashToBinfoTxIndex :: TxHash -> BinfoTxIndex +hashToBinfoTxIndex h = + fromRight (error "weird monkeys dancing") . S.decode $ + 0x00 `B.cons` 0x01 `B.cons` B.take 6 (S.encode h) + +blockToBinfoTxIndex :: BlockHeight -> Word32 -> BinfoTxIndex +blockToBinfoTxIndex h p = + let norm = (.&.) (2 ^ 24 - 1) . fromIntegral + in norm h `shift` 24 .|. norm p + +matchBinfoTxHash :: Int64 -> TxHash -> Bool +matchBinfoTxHash n h = + let bn = B.drop 2 $ S.encode n + bh = B.take 6 $ S.encode h + in isBinfoTxIndexHash n && bn == bh + +binfoTxIndexBlock :: BinfoTxIndex -> Maybe (BlockHeight, Word32) +binfoTxIndexBlock n = + let norm = (.&.) (2 ^ 24 - 1) . fromIntegral + height = norm $ n `shift` (-24) + pos = norm n + in if isBinfoTxIndexBlock n + then Just (height, pos) + else Nothing + +binfoTransactionIndex :: Bool -> Transaction -> BinfoTxId +binfoTransactionIndex True t = BinfoTxIdHash (txHash (transactionData t)) +binfoTransactionIndex False Transaction{transactionDeleted = True} = + BinfoTxIdIndex (-1) +binfoTransactionIndex False t@Transaction{transactionBlock = MemRef _} = + BinfoTxIdIndex (hashToBinfoTxIndex (txHash (transactionData t))) +binfoTransactionIndex False Transaction{transactionBlock = BlockRef h p} = + BinfoTxIdIndex (blockToBinfoTxIndex h p) + +data BinfoTxId + = BinfoTxIdHash !TxHash + | BinfoTxIdIndex !BinfoTxIndex + deriving (Eq, Show, Read, Generic, Serialize, NFData) + +instance Parsable BinfoTxId where + parseParam t = + case hexToTxHash (TL.toStrict t) of + Nothing -> BinfoTxIdIndex <$> parseParam t + Just h -> Right (BinfoTxIdHash h) + +getBinfoTxId :: Maybe (HashMap TxHash Transaction) -> TxHash -> BinfoTxId +getBinfoTxId Nothing h = BinfoTxIdHash h +getBinfoTxId (Just m) h = + case HashMap.lookup h m of + Nothing -> BinfoTxIdIndex (-1) + Just t -> binfoTransactionIndex False 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 BinfoMultiAddr + = BinfoMultiAddr + { getBinfoMultiAddrAddresses :: ![BinfoAddress] + , getBinfoMultiAddrWallet :: !BinfoWallet + , getBinfoMultiAddrTxs :: ![BinfoTx] + , getBinfoMultiAddrInfo :: !BinfoInfo + , getBinfoMultiAddrRecommendFee :: !Bool + , getBinfoMultiAddrCashAddr :: !Bool + } + deriving (Eq, Show, Generic, NFData) + +binfoMultiAddrToJSON :: Network -> BinfoMultiAddr -> Value +binfoMultiAddrToJSON net' BinfoMultiAddr {..} = + object $ + [ "addresses" .= map (binfoAddressToJSON 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 = withObject "multiaddr" $ \o -> do + getBinfoMultiAddrAddresses <- + mapM (binfoAddressParseJSON 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 {..} = + pairs + ( "addresses" `pair` as + <> "wallet" .= getBinfoMultiAddrWallet + <> "txs" `pair` ts + <> "info" .= getBinfoMultiAddrInfo + <> "recommend_include_fee" .= getBinfoMultiAddrRecommendFee + <> if getBinfoMultiAddrCashAddr then "cash_addr" .= True else mempty + ) + where + as = list (binfoAddressToEncoding net) getBinfoMultiAddrAddresses + ts = list (binfoTxToEncoding net) getBinfoMultiAddrTxs + net = if not getBinfoMultiAddrCashAddr && net' == bch then btc else net' + +data BinfoAddress + = BinfoAddress + { getBinfoAddress :: !Address + , getBinfoAddrTxCount :: !Word64 + , getBinfoAddrReceived :: !Word64 + , getBinfoAddrSent :: !Word64 + , getBinfoAddrBalance :: !Word64 + } + | BinfoXPubKey + { getBinfoXPubKey :: !XPubKey + , getBinfoAddrTxCount :: !Word64 + , getBinfoAddrReceived :: !Word64 + , getBinfoAddrSent :: !Word64 + , getBinfoAddrBalance :: !Word64 + , getBinfoXPubAccountIndex :: !Word32 + , getBinfoXPubChangeIndex :: !Word32 + } + deriving (Eq, Show, Generic, Serialize, NFData) + +binfoAddressToJSON :: Network -> BinfoAddress -> Value +binfoAddressToJSON net BinfoAddress {..} = + object + [ "address" .= addrToJSON net getBinfoAddress + , "final_balance" .= getBinfoAddrBalance + , "n_tx" .= getBinfoAddrTxCount + , "total_received" .= getBinfoAddrReceived + , "total_sent" .= getBinfoAddrSent + ] +binfoAddressToJSON net BinfoXPubKey {..} = + object + [ "address" .= xPubToJSON net getBinfoXPubKey + , "change_index" .= getBinfoXPubChangeIndex + , "account_index" .= getBinfoXPubAccountIndex + , "final_balance" .= getBinfoAddrBalance + , "n_tx" .= getBinfoAddrTxCount + , "total_received" .= getBinfoAddrReceived + , "total_sent" .= getBinfoAddrSent + ] + +binfoAddressParseJSON :: Network -> Value -> Parser BinfoAddress +binfoAddressParseJSON net = 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 BinfoXPubKey{..} + 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 BinfoAddress{..} + +binfoAddressToEncoding :: Network -> BinfoAddress -> Encoding +binfoAddressToEncoding net BinfoAddress {..} = + pairs + ( "address" `pair` addrToEncoding net getBinfoAddress + <> "final_balance" .= getBinfoAddrBalance + <> "n_tx" .= getBinfoAddrTxCount + <> "total_received" .= getBinfoAddrReceived + <> "total_sent" .= getBinfoAddrSent + ) +binfoAddressToEncoding net BinfoXPubKey {..} = + pairs + ( "address" `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, Serialize, NFData) + +instance ToJSON BinfoWallet where + toJSON BinfoWallet {..} = + object + [ "final_balance" .= getBinfoWalletBalance + , "n_tx" .= getBinfoWalletTxCount + , "n_tx_filtered" .= getBinfoWalletFilteredCount + , "total_received" .= getBinfoWalletTotalReceived + , "total_sent" .= getBinfoWalletTotalSent + ] + toEncoding BinfoWallet {..} = + pairs + ( "final_balance" .= getBinfoWalletBalance + <> "n_tx" .= getBinfoWalletTxCount + <> "n_tx_filtered" .= getBinfoWalletFilteredCount + <> "total_received" .= getBinfoWalletTotalReceived + <> "total_sent" .= getBinfoWalletTotalSent + ) + +instance FromJSON BinfoWallet where + parseJSON = 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 {..} + +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 + , getBinfoTxResultBal :: !(Maybe (Int64, Int64)) + , getBinfoTxTime :: !Word64 + , getBinfoTxBlockIndex :: !(Maybe Word32) + , getBinfoTxBlockHeight :: !(Maybe Word32) + , getBinfoTxInputs :: [BinfoTxInput] + , getBinfoTxOutputs :: [BinfoTxOutput] + } + deriving (Eq, Show, Generic, Serialize, NFData) + +binfoTxToJSON :: Network -> BinfoTx -> Value +binfoTxToJSON net BinfoTx {..} = + object $ + [ "hash" .= getBinfoTxHash + , "ver" .= getBinfoTxVer + , "vin_sz" .= getBinfoTxVinSz + , "vout_sz" .= getBinfoTxVoutSz + , "size" .= getBinfoTxSize + , "weight" .= getBinfoTxWeight + , "fee" .= getBinfoTxFee + , "relayed_by" .= 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 + ] ++ + case getBinfoTxResultBal of + Nothing -> [] + Just (res, bal) -> ["result" .= res, "balance" .= bal] + +binfoTxToEncoding :: Network -> BinfoTx -> Encoding +binfoTxToEncoding net BinfoTx {..} = + pairs $ + "hash" .= getBinfoTxHash <> + "ver" .= getBinfoTxVer <> + "vin_sz" .= getBinfoTxVinSz <> + "vout_sz" .= getBinfoTxVoutSz <> + "size" .= getBinfoTxSize <> + "weight" .= getBinfoTxWeight <> + "fee" .= getBinfoTxFee <> + "relayed_by" .= decodeUtf8 getBinfoTxRelayedBy <> + "lock_time" .= getBinfoTxLockTime <> + "tx_index" .= getBinfoTxIndex <> + "double_spend" .= getBinfoTxDoubleSpend <> + "time" .= getBinfoTxTime <> + "block_index" .= getBinfoTxBlockIndex <> + "block_height" .= getBinfoTxBlockHeight <> + "inputs" `pair` list (binfoTxInputToEncoding net) getBinfoTxInputs <> + "out" `pair` list (binfoTxOutputToEncoding net) getBinfoTxOutputs <> + case getBinfoTxResultBal of + Nothing -> mempty + Just (res, bal) -> "result" .= res <> "balance" .= bal + +binfoTxParseJSON :: Network -> Value -> Parser BinfoTx +binfoTxParseJSON net = 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 <- 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) + res <- o .:? "result" + bal <- o .:? "balance" + let getBinfoTxResultBal = (,) <$> res <*> bal + return BinfoTx {..} + +data BinfoTxInput + = BinfoTxInput + { getBinfoTxInputSeq :: !Word32 + , getBinfoTxInputWitness :: !ByteString + , getBinfoTxInputScript :: !ByteString + , getBinfoTxInputIndex :: !Word32 + , getBinfoTxInputPrevOut :: !(Maybe BinfoTxOutput) + } + deriving (Eq, Show, Generic, Serialize, NFData) + +binfoTxInputToJSON :: Network -> BinfoTxInput -> Value +binfoTxInputToJSON net BinfoTxInput {..} = + object + [ "sequence" .= getBinfoTxInputSeq + , "witness" .= encodeHex getBinfoTxInputWitness + , "script" .= encodeHex getBinfoTxInputScript + , "index" .= getBinfoTxInputIndex + , "prev_out" .= (binfoTxOutputToJSON net <$> getBinfoTxInputPrevOut) + ] + +binfoTxInputToEncoding :: Network -> BinfoTxInput -> Encoding +binfoTxInputToEncoding net BinfoTxInput {..} = + pairs + ( "sequence" .= getBinfoTxInputSeq + <> "witness" .= encodeHex getBinfoTxInputWitness + <> "script" .= encodeHex getBinfoTxInputScript + <> "index" .= getBinfoTxInputIndex + <> "prev_out" .= (binfoTxOutputToJSON net <$> getBinfoTxInputPrevOut) + ) + +binfoTxInputParseJSON :: Network -> Value -> Parser BinfoTxInput +binfoTxInputParseJSON net = 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" >>= + mapM (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, Serialize, NFData) + +binfoTxOutputToJSON :: Network -> BinfoTxOutput -> Value +binfoTxOutputToJSON net BinfoTxOutput {..} = + 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 {..} = + 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 = 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, Serialize, NFData) + +instance ToJSON BinfoSpender where + toJSON BinfoSpender {..} = + object + [ "tx_index" .= getBinfoSpenderTxIndex + , "n" .= getBinfoSpenderIndex + ] + toEncoding BinfoSpender {..} = + pairs + ( "tx_index" .= getBinfoSpenderTxIndex + <> "n" .= getBinfoSpenderIndex + ) + +instance FromJSON BinfoSpender where + parseJSON = withObject "spender" $ \o -> do + getBinfoSpenderTxIndex <- o .: "tx_index" + getBinfoSpenderIndex <- o .: "n" + return BinfoSpender {..} + +data BinfoXPubPath + = BinfoXPubPath + { getBinfoXPubPathKey :: !XPubKey + , getBinfoXPubPathDeriv :: !SoftPath + } + deriving (Eq, Show, Generic, Serialize, NFData) + +binfoXPubPathToJSON :: Network -> BinfoXPubPath -> Value +binfoXPubPathToJSON net BinfoXPubPath {..} = + object + [ "m" .= xPubToJSON net getBinfoXPubPathKey + , "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) + ] + +binfoXPubPathToEncoding :: Network -> BinfoXPubPath -> Encoding +binfoXPubPathToEncoding net BinfoXPubPath {..} = + pairs $ + "m" `pair` xPubToEncoding net getBinfoXPubPathKey <> + "path" .= ("M" ++ pathToStr getBinfoXPubPathDeriv) + +binfoXPubPathParseJSON :: Network -> Value -> Parser BinfoXPubPath +binfoXPubPathParseJSON net = 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 {..} = + object + [ "nconnected" .= getBinfoConnected + , "conversion" .= getBinfoConversion + , "symbol_local" .= getBinfoLocal + , "symbol_btc" .= getBinfoBTC + , "latest_block" .= getBinfoLatestBlock + ] + toEncoding BinfoInfo {..} = + pairs + ( "nconnected" .= getBinfoConnected + <> "conversion" .= getBinfoConversion + <> "symbol_local" .= getBinfoLocal + <> "symbol_btc" .= getBinfoBTC + <> "latest_block" .= getBinfoLatestBlock + ) + +instance FromJSON BinfoInfo where + parseJSON = 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, Serialize, NFData) + +instance ToJSON BinfoBlockInfo where + toJSON BinfoBlockInfo {..} = + object + [ "hash" .= getBinfoBlockInfoHash + , "height" .= getBinfoBlockInfoHeight + , "time" .= getBinfoBlockInfoTime + , "block_index" .= getBinfoBlockInfoIndex + ] + toEncoding BinfoBlockInfo {..} = + pairs + ( "hash" .= getBinfoBlockInfoHash + <> "height" .= getBinfoBlockInfoHeight + <> "time" .= getBinfoBlockInfoTime + <> "block_index" .= getBinfoBlockInfoIndex + ) + +instance FromJSON BinfoBlockInfo where + parseJSON = withObject "block_info" $ \o -> do + getBinfoBlockInfoHash <- o .: "hash" + getBinfoBlockInfoHeight <- o .: "height" + getBinfoBlockInfoTime <- o .: "time" + getBinfoBlockInfoIndex <- o .: "block_index" + return BinfoBlockInfo {..} + +data BinfoTicker + = BinfoTicker + { binfoTickerSymbol :: !Text + , binfoTickerPrice24h :: !Double + , binfoTickerVol24h :: !Double + , binfoTickerLastPrice :: !Double + } + deriving (Eq, Show, Generic, NFData) + +instance Default BinfoTicker where + def = BinfoTicker{ binfoTickerSymbol = "XXX" + , binfoTickerPrice24h = 0.0 + , binfoTickerVol24h = 0.0 + , binfoTickerLastPrice = 0.0 + } + +instance ToJSON BinfoTicker where + toJSON BinfoTicker{..} = + object + [ "symbol" .= binfoTickerSymbol + , "price_24h" .= binfoTickerPrice24h + , "volume_24h" .= binfoTickerVol24h + , "last_trade_price" .= binfoTickerLastPrice + ] + +instance FromJSON BinfoTicker where + parseJSON = withObject "ticker" $ \o -> do + binfoTickerSymbol <- o .: "symbol" + binfoTickerPrice24h <- o .: "price_24h" + binfoTickerVol24h <- o .: "volume_24h" + binfoTickerLastPrice <- o .: "last_trade_price" + return BinfoTicker{..} + +data BinfoSymbol + = BinfoSymbol + { getBinfoSymbolCode :: !Text + , getBinfoSymbolString :: !Text + , getBinfoSymbolName :: !Text + , getBinfoSymbolConversion :: !Double + , getBinfoSymbolAfter :: !Bool + , getBinfoSymbolLocal :: !Bool + } + deriving (Eq, Show, Generic, NFData) + +instance ToJSON BinfoSymbol where + toJSON BinfoSymbol {..} = + object + [ "code" .= getBinfoSymbolCode + , "symbol" .= getBinfoSymbolString + , "name" .= getBinfoSymbolName + , "conversion" .= getBinfoSymbolConversion + , "symbolAppearsAfter" .= getBinfoSymbolAfter + , "local" .= getBinfoSymbolLocal + ] + toEncoding BinfoSymbol {..} = + pairs + ( "code" .= getBinfoSymbolCode + <> "symbol" .= getBinfoSymbolString + <> "name" .= getBinfoSymbolName + <> "conversion" .= getBinfoSymbolConversion + <> "symbolAppearsAfter" .= getBinfoSymbolAfter + <> "local" .= getBinfoSymbolLocal + ) + +instance FromJSON BinfoSymbol where + parseJSON = 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 outputAddress 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 XPubKey [XPubBal] + -> HashMap XPubKey Int + -> [BinfoAddress] +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 = case HashMap.lookup k xpub_txs of + Nothing -> 0 + Just i -> fromIntegral i + ax = foldl max 0 (map (i 0) xs) + cx = foldl max 0 (map (i 1) xs) + in BinfoXPubKey{ getBinfoXPubKey = 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 BinfoAddress{ getBinfoAddress = addr + , getBinfoAddrTxCount = tx_count + , getBinfoAddrReceived = recv + , getBinfoAddrSent = sent + , getBinfoAddrBalance = bal + } + in map f $ HashMap.elems only_addrs + +toBinfoTxSimple :: Maybe (HashMap TxHash Transaction) + -> Transaction + -> BinfoTx +toBinfoTxSimple etxs = + toBinfoTx etxs HashMap.empty HashSet.empty False 0 + +toBinfoTxInputs :: Maybe (HashMap TxHash Transaction) + -> HashMap Address (Maybe BinfoXPubPath) + -> Transaction + -> [BinfoTxInput] +toBinfoTxInputs etxs 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 + [] -> B.empty + ws -> S.runPut (put_witness ws) + prev = inputToBinfoTxOutput etxs abook t + put_witness ws = do + putVarInt (length ws) + mapM_ put_item ws + put_item bs = do + putVarInt (B.length bs) + S.putByteString bs + +toBinfoBlockIndex :: Transaction -> Maybe BlockHeight +toBinfoBlockIndex Transaction{transactionDeleted = True} = Nothing +toBinfoBlockIndex Transaction{transactionBlock = MemRef _} = Nothing +toBinfoBlockIndex Transaction{transactionBlock = BlockRef h _} = Just h + +toBinfoTx :: Maybe (HashMap TxHash Transaction) + -> HashMap Address (Maybe BinfoXPubPath) + -> HashSet Address + -> Bool + -> Int64 + -> Transaction + -> BinfoTx +toBinfoTx etxs abook saddrs 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 = binfoTransactionIndex (isNothing etxs) t + , getBinfoTxDoubleSpend = transactionRBF + , getBinfoTxTime = transactionTime + , getBinfoTxBlockIndex = toBinfoBlockIndex t + , getBinfoTxBlockHeight = toBinfoBlockIndex t + , getBinfoTxInputs = toBinfoTxInputs etxs abook t + , getBinfoTxOutputs = outs + , getBinfoTxResultBal = resbal + } + where + simple = HashSet.null saddrs && HashMap.null abook && bal == 0 + resbal = if simple then Nothing else Just (getTxResult saddrs t, bal) + outs = + let p = prune && getTxResult saddrs t > 0 + f = toBinfoTxOutput etxs abook p t + in catMaybes $ zipWith f [0..] transactionOutputs + +getTxResult :: HashSet Address -> Transaction -> Int64 +getTxResult saddrs 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 saddrs + output_sum = sum $ map out_value transactionOutputs + out_value StoreOutput{..} = + case outputAddress of + Nothing -> 0 + Just a -> + if test_addr a + then fromIntegral outputAmount + else 0 + in input_sum + output_sum + +toBinfoTxOutput :: Maybe (HashMap TxHash Transaction) + -> HashMap Address (Maybe BinfoXPubPath) + -> Bool + -> Transaction + -> Word32 + -> StoreOutput + -> Maybe BinfoTxOutput +toBinfoTxOutput etxs abook prune t n StoreOutput{..} = + let getBinfoTxOutputType = 0 + getBinfoTxOutputSpent = isJust outputSpender + getBinfoTxOutputValue = outputAmount + getBinfoTxOutputIndex = n + getBinfoTxOutputTxIndex = binfoTransactionIndex (isNothing etxs) t + getBinfoTxOutputScript = outputScript + getBinfoTxOutputSpenders = + maybeToList $ toBinfoSpender etxs <$> outputSpender + getBinfoTxOutputAddress = outputAddress + getBinfoTxOutputXPub = + outputAddress >>= join . (`HashMap.lookup` abook) + in if prune && isNothing (outputAddress >>= (`HashMap.lookup` abook)) + then Nothing + else Just BinfoTxOutput{..} + +toBinfoSpender :: Maybe (HashMap TxHash Transaction) + -> Spender + -> BinfoSpender +toBinfoSpender etxs Spender{..} = + let getBinfoSpenderTxIndex = getBinfoTxId etxs spenderHash + getBinfoSpenderIndex = spenderIndex + in BinfoSpender{..} + +inputToBinfoTxOutput :: Maybe (HashMap TxHash Transaction) + -> HashMap Address (Maybe BinfoXPubPath) + -> Transaction + -> Word32 + -> StoreInput + -> Maybe BinfoTxOutput +inputToBinfoTxOutput _ _ _ _ StoreCoinbase{} = Nothing +inputToBinfoTxOutput etxs abook t n StoreInput{..} = + Just BinfoTxOutput{ getBinfoTxOutputIndex = out_index + , getBinfoTxOutputType = 0 + , getBinfoTxOutputSpent = True + , getBinfoTxOutputValue = inputAmount + , getBinfoTxOutputTxIndex = getBinfoTxId etxs out_hash + , getBinfoTxOutputScript = inputPkScript + , getBinfoTxOutputSpenders = [spender] + , getBinfoTxOutputAddress = inputAddress + , getBinfoTxOutputXPub = xpub + } + where + OutPoint out_hash out_index = inputPoint + spender = BinfoSpender (binfoTransactionIndex (isNothing etxs) t) n + xpub = inputAddress >>= join . (`HashMap.lookup` abook) + +data BinfoAddr + = BinfoAddr !Address + | BinfoXpub !XPubKey + deriving (Eq, Show, Generic, Serialize, Hashable, NFData) + +parseBinfoAddr :: Network -> Text -> Maybe [BinfoAddr] +parseBinfoAddr _ "" = Just [] +parseBinfoAddr net s = + mapM f $ T.splitOn "|" s + where + f x = BinfoAddr <$> textToAddr net x <|> BinfoXpub <$> xPubImport net x 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 @@ -4,32 +4,35 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Haskoin.Store.WebCommon where -import Control.Applicative ((<|>)) -import Control.Monad (guard) -import Data.Default (Default, def) -import Data.Proxy (Proxy(..)) -import qualified Data.Serialize as S -import Data.String (IsString (..)) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as Text +import Control.Applicative ((<|>)) +import Control.Monad (guard) +import Data.Default (Default, def) +import Data.Proxy (Proxy (..)) +import qualified Data.Serialize as S +import Data.String (IsString (..)) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T import Haskoin.Address -import Haskoin.Block (Block, BlockHash, blockHashToHex, - hexToBlockHash) +import Haskoin.Block (Block, BlockHash, blockHashToHex, + hexToBlockHash) import Haskoin.Constants -import Haskoin.Crypto (Hash256) +import Haskoin.Crypto (Hash256) import Haskoin.Keys -import qualified Haskoin.Store.Data as Store +import qualified Haskoin.Store.Data as Store import Haskoin.Transaction -import Network.HTTP.Types (StdMethod (..)) -import Numeric.Natural (Natural) -import Text.Read (readMaybe) -import qualified Web.Scotty.Trans as Scotty +import Network.HTTP.Types (StdMethod (..)) +import Numeric.Natural (Natural) +import Text.Read (readMaybe) +import qualified Web.Scotty.Trans as Scotty ------------------- -- API Resources -- @@ -336,7 +339,7 @@ noMaybeBox :: (Param p, Eq p) => Maybe p -> [ParamBox] noMaybeBox (Just p) = [ParamBox p] -noMaybeBox _ = [] +noMaybeBox _ = [] asProxy :: a -> Proxy a asProxy = const Proxy @@ -405,7 +408,7 @@ parseParam _ [s] = parseHash <|> parseHeight <|> parseUnix where parseHash = do - guard (Text.length s == 32 * 2) + guard (T.length s == 32 * 2) TxHash x <- hexToTxHash s return $ StartParamHash x parseHeight = do @@ -558,3 +561,7 @@ encodeParam _ ts = Just $ txHashToHex <$> ts parseParam _ = mapM hexToTxHash + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- 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 @@ -2,19 +2,24 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Haskoin.Store.DataSpec ( spec ) where -import Control.Monad (forM_) +import Control.Monad (forM_, replicateM) import Data.Aeson (FromJSON (..)) +import qualified Data.ByteString as B import qualified Data.ByteString.Short as BSS +import qualified Data.Map.Strict as Map +import qualified Data.Serialize as S import Data.String.Conversions (cs) import Haskoin import Haskoin.Store.Data import Haskoin.Util.Arbitrary -import Test.Hspec (Spec, describe) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) import Test.QuickCheck serialVals :: [SerialBox] @@ -43,6 +48,15 @@ , SerialBox (arbitrary :: Gen (RawResult BlockData)) , SerialBox (arbitrary :: Gen (RawResultList BlockData)) , SerialBox (arbitrary :: Gen Except) + , SerialBox (arbitrary :: Gen BinfoWallet) + , SerialBox (arbitrary :: Gen BinfoAddress) + , SerialBox (arbitrary :: Gen BinfoBlockInfo) + , SerialBox (arbitrary :: Gen BinfoXPubPath) + , SerialBox (arbitrary :: Gen BinfoSpender) + , SerialBox (arbitrary :: Gen BinfoTxOutput) + , SerialBox (arbitrary :: Gen BinfoTxInput) + , SerialBox (arbitrary :: Gen BinfoTx) + , SerialBox (arbitrary :: Gen BinfoTxId) ] jsonVals :: [JsonBox] @@ -59,6 +73,13 @@ , 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 BinfoTicker) + , JsonBox (arbitrary :: Gen BinfoTxId) ] netVals :: [NetBox] @@ -94,7 +115,31 @@ , NetBox ( transactionToJSON , transactionToEncoding , transactionParseJSON - , arbitraryTransactionNet) + , arbitraryNetData) + , NetBox ( binfoMultiAddrToJSON + , binfoMultiAddrToEncoding + , binfoMultiAddrParseJSON + , arbitraryNetData) + , NetBox ( binfoAddressToJSON + , binfoAddressToEncoding + , binfoAddressParseJSON + , arbitraryNetData) + , NetBox ( binfoTxToJSON + , binfoTxToEncoding + , binfoTxParseJSON + , arbitraryNetData) + , NetBox ( binfoTxInputToJSON + , binfoTxInputToEncoding + , binfoTxInputParseJSON + , arbitraryNetData) + , NetBox ( binfoTxOutputToJSON + , binfoTxOutputToEncoding + , binfoTxOutputParseJSON + , arbitraryNetData) + , NetBox ( binfoXPubPathToJSON + , binfoXPubPathToEncoding + , binfoXPubPathParseJSON + , arbitraryNetData) ] spec :: Spec @@ -105,7 +150,18 @@ forM_ jsonVals $ \(JsonBox g) -> testJson g describe "Data.Aeson Encoding with Network" $ forM_ netVals $ \(NetBox (j,e,p,g)) -> testNetJson j e p g + describe "Blockchain.info API" $ do + it "compresses txids correctly" $ + forAll arbitraryTxHash $ \h -> + matchBinfoTxHash (hashToBinfoTxIndex h) h + prop "compresses blockchain locations correctly" $ + let x = choose (0, 2 ^ 24 - 1) + in forAll ((,) <$> x <*> x) $ \(b, p) -> + let i = blockToBinfoTxIndex b p + Just (b', p') = binfoTxIndexBlock i + in b == b' && p == p' + instance Arbitrary BlockRef where arbitrary = oneof [BlockRef <$> arbitrary <*> arbitrary, MemRef <$> arbitrary] @@ -130,14 +186,14 @@ <$> arbitraryOutPoint <*> arbitrary <*> arbitraryBS1 - <*> arbitraryMaybe (listOf arbitraryBS1) + <*> listOf arbitraryBS1 , StoreInput <$> arbitraryOutPoint <*> arbitrary <*> arbitraryBS1 <*> arbitraryBS1 <*> arbitrary - <*> arbitraryMaybe (listOf arbitraryBS1) + <*> listOf arbitraryBS1 <*> arbitraryMaybe arbitraryAddress ] @@ -146,7 +202,7 @@ net <- arbitraryNetwork store <- arbitrary let res | getSegWit net = store - | otherwise = store{ inputWitness = Nothing } + | otherwise = store{ inputWitness = [] } return (net, res) instance Arbitrary Spender where @@ -188,7 +244,7 @@ | otherwise = val1{ transactionRBF = False } return (net, res) where - f i = i {inputWitness = Nothing} + f i = i {inputWitness = []} instance Arbitrary PeerInformation where arbitrary = @@ -343,3 +399,135 @@ , StringError <$> arbitrary , return BlockTooLarge ] + +--------------------------------------- +-- 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 <- arbitrary + getBinfoMultiAddrInfo <- arbitrary + getBinfoMultiAddrRecommendFee <- arbitrary + getBinfoMultiAddrCashAddr <- arbitrary + return BinfoMultiAddr {..} + +instance Arbitrary BinfoAddress where + arbitrary = do + getBinfoAddress <- arbitraryAddress + getBinfoAddrTxCount <- arbitrary + getBinfoAddrReceived <- arbitrary + getBinfoAddrSent <- arbitrary + getBinfoAddrBalance <- arbitrary + getBinfoXPubKey <- snd <$> arbitraryXPubKey + getBinfoXPubAccountIndex <- arbitrary + getBinfoXPubChangeIndex <- arbitrary + elements [BinfoAddress {..}, BinfoXPubKey {..}] + +instance Arbitrary BinfoWallet where + arbitrary = do + getBinfoWalletBalance <- arbitrary + getBinfoWalletTxCount <- arbitrary + getBinfoWalletFilteredCount <- arbitrary + getBinfoWalletTotalReceived <- arbitrary + getBinfoWalletTotalSent <- arbitrary + return BinfoWallet {..} + +instance Arbitrary BinfoTx where + arbitrary = do + getBinfoTxHash <- arbitraryTxHash + getBinfoTxVer <- arbitrary + getBinfoTxInputs <- resize 10 $ listOf1 arbitrary + getBinfoTxOutputs <- resize 10 $ 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 + 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 BinfoTicker where + arbitrary = do + binfoTickerSymbol <- cs <$> listOf1 arbitraryUnicodeChar + binfoTickerPrice24h <- arbitrary + binfoTickerVol24h <- arbitrary + binfoTickerLastPrice <- arbitrary + return BinfoTicker{..} 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 @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Haskoin.Store.WebCommonSpec ( spec @@ -10,7 +11,7 @@ import Control.Monad (forM_) import Data.Proxy import Data.String.Conversions (cs) -import Data.Word (Word64) +import Data.Word import Haskoin import Haskoin.Store.Data import Haskoin.Store.DataSpec () @@ -53,7 +54,7 @@ forAll pGen $ \p -> case encodeParam btc p of Just txts -> parseParam btc txts `shouldBe` Just p - _ -> expectationFailure "Param encoding failed" + _ -> expectationFailure "Param encoding failed" where name = cs $ proxyLabel $ proxy pGen proxy :: Gen a -> Proxy a