diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for bitcoind-rpc +## 0.2.0.0 -- 2020-11-01 + +* Define our own `BlockHeader` type instead of using the one from `haskoin-core` +* Refactor code to deal with new `aeson` instance definitions in `haskoin-core 0.13.5` +* Adds `getBlockFilter` for fetching BIP 157 filters + ## 0.1.0.0 -- 2020-03-07 Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright 2020 Bitnomial, Inc. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/bitcoind-rpc.cabal b/bitcoind-rpc.cabal --- a/bitcoind-rpc.cabal +++ b/bitcoind-rpc.cabal @@ -1,9 +1,11 @@ cabal-version: 2.2 name: bitcoind-rpc -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A streamlined interface to bitcoin core using Haskoin types and Servant -homepage: https://github.com/GambolingPangolin/bitcoind-rpc -license: ISC +homepage: https://github.com/bitnomial/bitcoind-rpc +license: BSD-3-Clause +license-file: LICENSE +copyright: Bitnomial, Inc. (c) 2020 author: Ian Shipman maintainer: ics@gambolingpangolin.com build-type: Simple @@ -27,16 +29,19 @@ Servant.Bitcoind build-depends: - aeson ^>=1.4 - , base ^>=4.12 - , bytestring ^>=0.10 + aeson >=1.4 && <1.6 + , base >=4.12 && <4.15 + , bytestring >=0.10 && <0.12 + , base16-bytestring <1.0 + -- ^^ needed due to missing upper bound in haskoin-core + , bitcoin-compact-filters ^>=0.1 , cereal ^>=0.5 - , haskoin-core >=0.9 && <0.12 - , http-client ^>=0.6 + , haskoin-core >=0.13.5 && <0.18 + , http-client >=0.6 && <0.8 , scientific ^>=0.3 - , servant >=0.15 && <0.18 - , servant-client >=0.15 && <0.18 - , servant-jsonrpc-client ^>=1.0 + , servant >=0.15 && <0.19 + , servant-client >=0.15 && <0.19 + , servant-jsonrpc-client >=1.0 && <1.2 , text ^>=1.2 - , time >=1.8 && <1.10 + , time >=1.8 && <1.12 , transformers ^>=0.5 diff --git a/src/Bitcoin/Core/RPC.hs b/src/Bitcoin/Core/RPC.hs --- a/src/Bitcoin/Core/RPC.hs +++ b/src/Bitcoin/Core/RPC.hs @@ -1,140 +1,143 @@ --- | --- Module: Bitcoin.Core.RPC --- Stability: experimental --- --- We provide limited access to the bitcoin-core daemon RPC interface. RPC --- method descriptions come from the bitcoind RPC help pages. -module Bitcoin.Core.RPC - ( +{- | + Module: Bitcoin.Core.RPC + Stability: experimental + + We provide limited access to the bitcoin-core daemon RPC interface. RPC + method descriptions come from the bitcoind RPC help pages. +-} +module Bitcoin.Core.RPC ( -- * Interacting with bitcoind - BitcoindClient - , runBitcoind - , cookieClient - , basicAuthFromCookie - , mkBitcoindEnv - , BitcoindException (..) + BitcoindClient, + runBitcoind, + cookieClient, + basicAuthFromCookie, + mkBitcoindEnv, + BitcoindException (..), -- * Transactions - , getTransaction - , sendRawTransaction - , sendTransaction - , testMempoolAccept + getTransaction, + sendRawTransaction, + sendTransaction, + testMempoolAccept, -- * Blocks - , getBlock - , getBlockHeader - , getBlockHash - , getBlockCount - , getDifficulty - - , getBestBlockHash - , getBlockStats - , getChainTips - , getChainTxStats + getBlock, + getBlockFilter, + getBlockHeader, + getBlockHash, + getBlockCount, + getDifficulty, + getBestBlockHash, + getBlockStats, + getChainTips, + getChainTxStats, -- * Mempool - , getMempoolInfo - , getMempoolAncestors - , getMempoolDescendants - , getRawMempool + getMempoolInfo, + getMempoolAncestors, + getMempoolDescendants, + getRawMempool, -- * Network - , getPeerInfo - , getConnectionCount - , getNodeAddresses - , getAddedNodeInfo - , listBanned - , getNetTotals + getPeerInfo, + getConnectionCount, + getNodeAddresses, + getAddedNodeInfo, + listBanned, + getNetTotals, -- * Control - , stop - , uptime - , Command (..) - , addNode - , disconnectNode - , clearBanned - , generateToAddress + stop, + uptime, + Command (..), + addNode, + disconnectNode, + clearBanned, + generateToAddress, -- * Response models - , module Bitcoin.Core.RPC.Responses - ) where - -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Reader (runReaderT) -import Data.Bifunctor (first, second) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Network.HTTP.Client (Manager) -import Servant.API (BasicAuthData (..)) -import Servant.Client (BaseUrl (..), ClientEnv, - ClientError, Scheme (..), - mkClientEnv, runClientM) + module Bitcoin.Core.RPC.Responses, +) where -import Bitcoin.Core.RPC.Blockchain -import Bitcoin.Core.RPC.Control -import Bitcoin.Core.RPC.Generating -import Bitcoin.Core.RPC.Network -import Bitcoin.Core.RPC.Responses -import Bitcoin.Core.RPC.Transactions -import Servant.Bitcoind (BitcoindClient, - BitcoindException (..)) +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Reader (runReaderT) +import Data.Bifunctor (first, second) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Network.HTTP.Client (Manager) +import Servant.API (BasicAuthData (..)) +import Servant.Client ( + BaseUrl (..), + ClientEnv, + ClientError, + Scheme (..), + mkClientEnv, + runClientM, + ) +import Bitcoin.Core.RPC.Blockchain +import Bitcoin.Core.RPC.Control +import Bitcoin.Core.RPC.Generating +import Bitcoin.Core.RPC.Network +import Bitcoin.Core.RPC.Responses +import Bitcoin.Core.RPC.Transactions +import Servant.Bitcoind ( + BitcoindClient, + BitcoindException (..), + ) -- | Convenience function for sending a RPC call to bitcoind -runBitcoind - :: Manager - -> String - -- ^ host - -> Int - -- ^ port - -> BasicAuthData - -> BitcoindClient a - -> IO (Either BitcoindException a) -runBitcoind mgr host port auth - = fmap consolidateErrors . (`runClientM` env) . runExceptT . (`runReaderT` auth) - where +runBitcoind :: + Manager -> + -- | host + String -> + -- | port + Int -> + BasicAuthData -> + BitcoindClient a -> + IO (Either BitcoindException a) +runBitcoind mgr host port auth = + fmap consolidateErrors . (`runClientM` env) . runExceptT . (`runReaderT` auth) + where env = mkBitcoindEnv mgr host port - -- | Send a RPC call to bitcoind using credentials from a cookie file -cookieClient - :: Manager - -> FilePath - -- ^ path to the cookie file - -> String - -- ^ host - -> Int - -- ^ port - -> BitcoindClient r - -> IO (Either BitcoindException r) -cookieClient mgr cookiePath host port go - = liftIO (basicAuthFromCookie cookiePath) - >>= flip (runBitcoind mgr host port) go - +cookieClient :: + Manager -> + -- | path to the cookie file + FilePath -> + -- | host + String -> + -- | port + Int -> + BitcoindClient r -> + IO (Either BitcoindException r) +cookieClient mgr cookiePath host port go = + liftIO (basicAuthFromCookie cookiePath) + >>= flip (runBitcoind mgr host port) go --- | Parse a username and password from a file. The contents of the file --- should be exactly "username:password" (not base64 encoded). -basicAuthFromCookie - :: FilePath - -- ^ path to the cookie file - -> IO BasicAuthData +{- | Parse a username and password from a file. The contents of the file + should be exactly "username:password" (not base64 encoded). +-} +basicAuthFromCookie :: + -- | path to the cookie file + FilePath -> + IO BasicAuthData basicAuthFromCookie f = repack <$> BS.readFile f - where + where repack = uncurry BasicAuthData . second (BS.drop 1) . BS8.break (== ':') - -- | Convenience function for connecting to bitcoind -mkBitcoindEnv - :: Manager - -> String - -- ^ bitcoind host - -> Int - -- ^ bitcoind RPC port - -> ClientEnv +mkBitcoindEnv :: + Manager -> + -- | bitcoind host + String -> + -- | bitcoind RPC port + Int -> + ClientEnv mkBitcoindEnv mgr host port = mkClientEnv mgr $ BaseUrl Http host port "" - consolidateErrors :: Either ClientError (Either BitcoindException a) -> Either BitcoindException a consolidateErrors = join . first ClientException diff --git a/src/Bitcoin/Core/RPC/Blockchain.hs b/src/Bitcoin/Core/RPC/Blockchain.hs --- a/src/Bitcoin/Core/RPC/Blockchain.hs +++ b/src/Bitcoin/Core/RPC/Blockchain.hs @@ -1,74 +1,97 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -module Bitcoin.Core.RPC.Blockchain - ( getBestBlockHash - , getBlock - , getBlockCount - , getBlockHash - , getBlockHeader - , BlockStats (..) - , getBlockStats - , ChainTip (..) - , ChainTipStatus (..) - , getChainTips - , ChainTxStats (..) - , getChainTxStats - , getDifficulty - , getMempoolAncestors - , getMempoolDescendants - , MempoolInfo (..) - , getMempoolInfo - , getRawMempool - ) where +module Bitcoin.Core.RPC.Blockchain ( + getBestBlockHash, + getBlock, + getBlockCount, + getBlockHash, + CompactFilter (..), + getBlockFilter, + BlockHeader (..), + getBlockHeader, + BlockStats (..), + getBlockStats, + ChainTip (..), + ChainTipStatus (..), + getChainTips, + ChainTxStats (..), + getChainTxStats, + getDifficulty, + getMempoolAncestors, + getMempoolDescendants, + MempoolInfo (..), + getMempoolInfo, + getRawMempool, +) where -import Data.Aeson (FromJSON (..), withObject, - withText, (.:), (.:?)) -import Data.Proxy (Proxy (..)) -import Data.Scientific (Scientific) -import Data.Text (Text) -import Data.Time (NominalDiffTime, UTCTime) -import Data.Word (Word16, Word32) -import Network.Haskoin.Block (Block, BlockHash, BlockHeader, - BlockHeight) -import Network.Haskoin.Transaction (TxHash) -import Servant.API ((:<|>) (..)) +import Bitcoin.CompactFilter (BlockFilter, BlockFilterHeader) +import Data.Aeson ( + FromJSON (..), + withObject, + withText, + (.:), + (.:?), + ) +import Data.Aeson.Types (Parser) +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Serialize (Serialize) +import Data.Text (Text) +import Data.Time (NominalDiffTime, UTCTime) +import Data.Word (Word16, Word32, Word64) +import Haskoin.Block (Block, BlockHash, BlockHeight) +import Haskoin.Crypto (Hash256) +import Haskoin.Transaction (TxHash) +import Servant.API ((:<|>) (..)) -import Servant.Bitcoind (BitcoindClient, BitcoindEndpoint, - C, DefFalse, DefZero, F, I, O, - toBitcoindClient, toSatoshis, - utcTime) +import Servant.Bitcoind ( + BitcoindClient, + BitcoindEndpoint, + C, + DefFalse, + DefTrue, + DefZero, + F, + HexEncoded (..), + I, + O, + decodeFromHex, + toBitcoindClient, + toSatoshis, + utcTime, + ) data BlockStats = BlockStats - { blockStatsAvgFee :: Double - , blockStatsAvgFeeRate :: Word32 - , blockStatsAvgTxSize :: Word32 - , blockStatsBlockHash :: BlockHash + { blockStatsAvgFee :: Double + , blockStatsAvgFeeRate :: Word32 + , blockStatsAvgTxSize :: Word32 + , blockStatsBlockHash :: BlockHash , blockStatsFeeRatePercentiles :: [Word32] - , blockStatsHeight :: BlockHeight - , blockStatsIns :: Word32 - , blockStatsMaxFee :: Word32 - , blockStatsMaxFeeRate :: Word32 - , blockStatsMinTxSize :: Word32 - , blockStatsOuts :: Word32 - , blockStatsSubsidy :: Word32 - , blockStatsSegwitSize :: Word32 - , blockStastSegwitWeight :: Word32 - , blockStatsSegwitCount :: Word32 - , blockStatsTime :: UTCTime - , blockStatsTotalOut :: Word32 - , blockStatsTotalSize :: Word32 - , blockStatsTotalWeight :: Word32 - , blockStatsTotalFee :: Word32 - , blockStatsCount :: Word32 - , blockStatsUtxoIncrease :: Int - , blockStatsUtxoSizeIncrease :: Int - } deriving (Eq, Show) - + , blockStatsHeight :: BlockHeight + , blockStatsIns :: Word32 + , blockStatsMaxFee :: Word32 + , blockStatsMaxFeeRate :: Word32 + , blockStatsMinTxSize :: Word32 + , blockStatsOuts :: Word32 + , blockStatsSubsidy :: Word32 + , blockStatsSegwitSize :: Word32 + , blockStastSegwitWeight :: Word32 + , blockStatsSegwitCount :: Word32 + , blockStatsTime :: UTCTime + , blockStatsTotalOut :: Word32 + , blockStatsTotalSize :: Word32 + , blockStatsTotalWeight :: Word32 + , blockStatsTotalFee :: Word32 + , blockStatsCount :: Word32 + , blockStatsUtxoIncrease :: Int + , blockStatsUtxoSizeIncrease :: Int + } + deriving (Eq, Show) instance FromJSON BlockStats where parseJSON = withObject "BlockStats" $ \o -> @@ -97,72 +120,105 @@ <*> o .: "utxo_increase" <*> o .: "utxo_size_inc" +data CompactFilter = CompactFilter + { filterHeader :: BlockFilterHeader + , filterBody :: BlockFilter + } +instance FromJSON CompactFilter where + parseJSON = withObject "CompactFilter" $ \o -> + CompactFilter + <$> (o .: "header" >>= parseFromHex) + <*> (o .: "filter" >>= parseFromHex) + +data BlockHeader = BlockHeader + { blockHeaderHash :: BlockHash + , blockHeaderConfs :: Word32 + , blockHeaderHeight :: BlockHeight + , blockHeaderMerkleRoot :: Hash256 + , blockHeaderTime :: UTCTime + , blockHeaderMedianTime :: UTCTime + , blockHeaderNonce :: Word64 + , blockHeaderTxCount :: Int + , blockHeaderPrevHash :: Hash256 + } + +instance FromJSON BlockHeader where + parseJSON = withObject "BlockHeader" $ \o -> + BlockHeader + <$> o .: "hash" + <*> o .: "confirmations" + <*> o .: "height" + <*> (o .: "merkleroot" >>= parseFromHex) + <*> (utcTime <$> o .: "time") + <*> (utcTime <$> o .: "mediantime") + <*> o .: "nonce" + <*> o .: "nTx" + <*> (o .: "previousblockhash" >>= parseFromHex) + +parseFromHex :: Serialize a => Text -> Parser a +parseFromHex = either fail return . decodeFromHex + data ChainTipStatus = Invalid | HeadersOnly | ValidHeaders | ValidFork | Active deriving (Eq, Show) - instance FromJSON ChainTipStatus where parseJSON = withText "ChainTipStatus" chainTipStatus - where + where chainTipStatus t - | t == "invalid" = return Invalid - | t == "headers-only" = return HeadersOnly + | t == "invalid" = return Invalid + | t == "headers-only" = return HeadersOnly | t == "valid-headers" = return ValidHeaders - | t == "valid-fork" = return ValidFork - | t == "active" = return Active - | otherwise = fail "Unknown chain tip status" - + | t == "valid-fork" = return ValidFork + | t == "active" = return Active + | otherwise = fail "Unknown chain tip status" data ChainTip = ChainTip - { tipHeight :: Word32 - , tipHash :: BlockHash + { tipHeight :: Word32 + , tipHash :: BlockHash , branchLength :: Word16 - , tipStatus :: ChainTipStatus - } deriving (Eq, Show) - + , tipStatus :: ChainTipStatus + } + deriving (Eq, Show) instance FromJSON ChainTip where parseJSON = withObject "ChainTip" $ \o -> ChainTip <$> o .: "height" <*> o .: "hash" <*> o .: "branchlen" <*> o .: "status" - data ChainTxStats = ChainTxStats - { txStatsTime :: UTCTime - , txCount :: Word32 - , finalBlockHash :: BlockHash + { txStatsTime :: UTCTime + , txCount :: Word32 + , finalBlockHash :: BlockHash , finalBlockHeight :: BlockHeight - , finalBlockCount :: Word32 - , windowTxCount :: Maybe Word32 - , windowInterval :: Maybe NominalDiffTime - , txRate :: Maybe Double - } deriving (Eq, Show) - + , finalBlockCount :: Word32 + , windowTxCount :: Maybe Word32 + , windowInterval :: Maybe NominalDiffTime + , txRate :: Maybe Double + } + deriving (Eq, Show) instance FromJSON ChainTxStats where parseJSON = withObject "ChainTxStats" $ \o -> ChainTxStats <$> (utcTime <$> o .: "time") - <*> o .: "txcount" - <*> o .: "window_final_block_hash" - <*> o .: "window_final_block_height" - <*> o .: "window_block_count" + <*> o .: "txcount" + <*> o .: "window_final_block_hash" + <*> o .: "window_final_block_height" + <*> o .: "window_block_count" <*> o .:? "window_tx_count" <*> o .:? "window_interval" <*> o .:? "txrate" - - data MempoolInfo = MempoolInfo - { mempoolLoaded :: Bool - , mempoolSize :: Word32 - , mempoolBytes :: Word32 - , mempoolUsage :: Word32 - , mempoolMax :: Word32 - , mempoolMinFee :: Word32 + { mempoolLoaded :: Bool + , mempoolSize :: Word32 + , mempoolBytes :: Word32 + , mempoolUsage :: Word32 + , mempoolMax :: Word32 + , mempoolMinFee :: Word32 , mempoolMinRelayFee :: Word32 - } deriving (Eq, Show) - + } + deriving (Eq, Show) instance FromJSON MempoolInfo where parseJSON = withObject "MempoolInfo" $ \o -> @@ -175,78 +231,65 @@ <*> (toSatoshis <$> o .: "mempoolminfee") <*> (toSatoshis <$> o .: "minrelaytxfee") - -type BlockchainRpc - = BitcoindEndpoint "getbestblockhash" (C BlockHash) - :<|> BitcoindEndpoint "getblock" (I BlockHash -> F DefZero Int -> C Block) - :<|> BitcoindEndpoint "getblockcount" (C Word32) - :<|> BitcoindEndpoint "getblockhash" (I BlockHeight -> C BlockHash) - :<|> BitcoindEndpoint "getblockheader" (I BlockHash -> F DefFalse Bool -> C BlockHeader) - :<|> BitcoindEndpoint "getblockstats" (I BlockHash -> O [Text] -> C BlockStats) - :<|> BitcoindEndpoint "getchaintips" (C [ChainTip]) - :<|> BitcoindEndpoint "getchaintxstats" (O Word32 -> O BlockHash -> C ChainTxStats) - :<|> BitcoindEndpoint "getdifficulty" (C Scientific) - :<|> BitcoindEndpoint "getmempoolancestors" (I TxHash -> F DefFalse Bool -> C [TxHash]) - :<|> BitcoindEndpoint "getmempooldescendants" (I TxHash -> F DefFalse Bool -> C [TxHash]) - :<|> BitcoindEndpoint "getmempoolinfo" (C MempoolInfo) - :<|> BitcoindEndpoint "getrawmempool" (F DefFalse Bool -> C [TxHash]) - +type BlockchainRpc = + BitcoindEndpoint "getbestblockhash" (C BlockHash) + :<|> BitcoindEndpoint "getblock" (I BlockHash -> F DefZero Int -> C (HexEncoded Block)) + :<|> BitcoindEndpoint "getblockcount" (C Word32) + :<|> BitcoindEndpoint "getblockfilter" (I BlockHash -> C CompactFilter) + :<|> BitcoindEndpoint "getblockhash" (I BlockHeight -> C BlockHash) + :<|> BitcoindEndpoint "getblockheader" (I BlockHash -> F DefTrue Bool -> C BlockHeader) + :<|> BitcoindEndpoint "getblockstats" (I BlockHash -> O [Text] -> C BlockStats) + :<|> BitcoindEndpoint "getchaintips" (C [ChainTip]) + :<|> BitcoindEndpoint "getchaintxstats" (O Word32 -> O BlockHash -> C ChainTxStats) + :<|> BitcoindEndpoint "getdifficulty" (C Scientific) + :<|> BitcoindEndpoint "getmempoolancestors" (I TxHash -> F DefFalse Bool -> C [TxHash]) + :<|> BitcoindEndpoint "getmempooldescendants" (I TxHash -> F DefFalse Bool -> C [TxHash]) + :<|> BitcoindEndpoint "getmempoolinfo" (C MempoolInfo) + :<|> BitcoindEndpoint "getrawmempool" (F DefFalse Bool -> C [TxHash]) -- | Returns the hash of the best (tip) block in the most-work fully-validated chain. getBestBlockHash :: BitcoindClient BlockHash - - --- | Produce the block corresponding to the given 'BlockHash' if it exists. -getBlock :: BlockHash -> BitcoindClient Block - +getBlock' :: BlockHash -> BitcoindClient (HexEncoded Block) -- | Returns the height of the most-work fully-validated chain. The genesis block has height 0. getBlockCount :: BitcoindClient Word32 - -- | Returns hash of block in best-block-chain at height provided. getBlockHash :: BlockHeight -> BitcoindClient BlockHash +-- | Retrieve a BIP 157 content filter for a particular block. +getBlockFilter :: BlockHash -> BitcoindClient CompactFilter -- | Returns the header of the block corresponding to the given 'BlockHash' getBlockHeader :: BlockHash -> BitcoindClient BlockHeader - - getBlockStats' :: BlockHash -> Maybe [Text] -> BitcoindClient BlockStats - --- | Return information about all known tips in the block tree, including the --- main chain as well as orphaned branches. +{- | Return information about all known tips in the block tree, including the + main chain as well as orphaned branches. +-} getChainTips :: BitcoindClient [ChainTip] - -- | Compute statistics about the total number and rate of transactions in the chain. getChainTxStats :: Maybe Word32 -> Maybe BlockHash -> BitcoindClient ChainTxStats - -- | Returns the proof-of-work difficulty as a multiple of the minimum difficulty. getDifficulty :: BitcoindClient Scientific - -- | If txid is in the mempool, returns all in-mempool ancestors. getMempoolAncestors :: TxHash -> BitcoindClient [TxHash] - -- | If txid is in the mempool, returns all in-mempool descendants. getMempoolDescendants :: TxHash -> BitcoindClient [TxHash] - -- | Returns details on the active state of the TX memory pool. getMempoolInfo :: BitcoindClient MempoolInfo - -- | Returns all transaction ids in memory pool. getRawMempool :: BitcoindClient [TxHash] - - getBestBlockHash - :<|> getBlock + :<|> getBlock' :<|> getBlockCount + :<|> getBlockFilter :<|> getBlockHash :<|> getBlockHeader :<|> getBlockStats' @@ -256,11 +299,15 @@ :<|> getMempoolAncestors :<|> getMempoolDescendants :<|> getMempoolInfo - :<|> getRawMempool - = toBitcoindClient $ Proxy @BlockchainRpc - + :<|> getRawMempool = + toBitcoindClient $ Proxy @BlockchainRpc --- | Compute per block statistics for a given window. All amounts are in --- satoshis. It won't work for some heights with pruning. +{- | Compute per block statistics for a given window. All amounts are in + satoshis. It won't work for some heights with pruning. +-} getBlockStats :: BlockHash -> BitcoindClient BlockStats getBlockStats h = getBlockStats' h Nothing + +-- | Produce the block corresponding to the given 'BlockHash' if it exists. +getBlock :: BlockHash -> BitcoindClient Block +getBlock = fmap unHexEncoded . getBlock' diff --git a/src/Bitcoin/Core/RPC/Control.hs b/src/Bitcoin/Core/RPC/Control.hs --- a/src/Bitcoin/Core/RPC/Control.hs +++ b/src/Bitcoin/Core/RPC/Control.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Bitcoin.Core.RPC.Control - ( stop - , uptime - ) where - -import Data.Proxy (Proxy (..)) -import Data.Word (Word32) -import Servant.API ((:<|>) (..)) +{-# LANGUAGE TypeOperators #-} -import Servant.Bitcoind (BitcoindClient, BitcoindEndpoint, C, CX, - toBitcoindClient) +module Bitcoin.Core.RPC.Control ( + stop, + uptime, +) where +import Data.Proxy (Proxy (..)) +import Data.Word (Word32) +import Servant.API ((:<|>) (..)) -type ControlRpc - = BitcoindEndpoint "stop" CX - :<|> BitcoindEndpoint "uptime" (C Word32) +import Servant.Bitcoind ( + BitcoindClient, + BitcoindEndpoint, + C, + CX, + toBitcoindClient, + ) +type ControlRpc = + BitcoindEndpoint "stop" CX + :<|> BitcoindEndpoint "uptime" (C Word32) -- | Request a graceful shutdown of Bitcoin Core. stop :: BitcoindClient () - -- | Returns the total uptime of the server (in seconds) uptime :: BitcoindClient Word32 - - stop :<|> uptime = toBitcoindClient $ Proxy @ControlRpc diff --git a/src/Bitcoin/Core/RPC/Generating.hs b/src/Bitcoin/Core/RPC/Generating.hs --- a/src/Bitcoin/Core/RPC/Generating.hs +++ b/src/Bitcoin/Core/RPC/Generating.hs @@ -1,32 +1,36 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Bitcoin.Core.RPC.Generating - ( generateToAddress - ) where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import Data.Word (Word32) -import Network.Haskoin.Block (BlockHash) +module Bitcoin.Core.RPC.Generating ( + generateToAddress, +) where -import Servant.Bitcoind (BitcoindClient, BitcoindEndpoint, C, I, - O, toBitcoindClient) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Word (Word32) +import Haskoin.Block (BlockHash) +import Servant.Bitcoind ( + BitcoindClient, + BitcoindEndpoint, + C, + I, + O, + toBitcoindClient, + ) type GeneratingRpc = BitcoindEndpoint "generatetoaddress" (I Word32 -> I Text -> O Word32 -> C [BlockHash]) - -- | Generate blocks in @regtest@ mode -generateToAddress - :: Word32 - -- ^ number of blocks to generate - -> Text - -- ^ address for the coinbase reward - -> Maybe Word32 - -- ^ how many iterations to try - -> BitcoindClient [BlockHash] +generateToAddress :: + -- | number of blocks to generate + Word32 -> + -- | address for the coinbase reward + Text -> + -- | how many iterations to try + Maybe Word32 -> + BitcoindClient [BlockHash] generateToAddress = toBitcoindClient $ Proxy @GeneratingRpc diff --git a/src/Bitcoin/Core/RPC/Network.hs b/src/Bitcoin/Core/RPC/Network.hs --- a/src/Bitcoin/Core/RPC/Network.hs +++ b/src/Bitcoin/Core/RPC/Network.hs @@ -1,64 +1,73 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Bitcoin.Core.RPC.Network - ( Command (..) - , addNode - , clearBanned - , disconnectNode - , NodeInfo (..) - , NodeInfoAddress (..) - , ConnDir (..) - , getAddedNodeInfo - , getConnectionCount - , NetTotals (..) - , getNetTotals - , NodeAddress (..) - , getNodeAddresses - , PeerInfo (..) - , getPeerInfo - , listBanned - ) where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -import Data.Aeson (FromJSON (..), ToJSON (..), withObject, - withText, (.:)) -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import Data.Time (NominalDiffTime, UTCTime) -import Data.Word (Word16, Word32, Word64) -import Network.Haskoin.Block (BlockHeight) -import Servant.API ((:<|>) (..)) +module Bitcoin.Core.RPC.Network ( + Command (..), + addNode, + clearBanned, + disconnectNode, + NodeInfo (..), + NodeInfoAddress (..), + ConnDir (..), + getAddedNodeInfo, + getConnectionCount, + NetTotals (..), + getNetTotals, + NodeAddress (..), + getNodeAddresses, + PeerInfo (..), + getPeerInfo, + listBanned, +) where -import Servant.Bitcoind (BitcoindClient, BitcoindEndpoint, C, CX, - I, O, toBitcoindClient, toSatoshis, - utcTime) +import Data.Aeson ( + FromJSON (..), + ToJSON (..), + withObject, + withText, + (.:), + ) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Time (NominalDiffTime, UTCTime) +import Data.Word (Word16, Word32, Word64) +import Haskoin.Block (BlockHeight) +import Servant.API ((:<|>) (..)) +import Servant.Bitcoind ( + BitcoindClient, + BitcoindEndpoint, + C, + CX, + I, + O, + toBitcoindClient, + toSatoshis, + utcTime, + ) -- | Commands as understood by 'addNode' data Command = Add | Remove | OneTry deriving (Eq, Show, Enum) - commandText :: Command -> Text commandText = \case - Add -> "add" + Add -> "add" Remove -> "remove" OneTry -> "onetry" - instance ToJSON Command where toJSON = toJSON . commandText - data NodeAddress = NodeAddress - { addrTime :: UTCTime + { addrTime :: UTCTime , addrServices :: Word64 - , addrHost :: Text - , addrPort :: Word32 - } deriving (Eq, Show) - + , addrHost :: Text + , addrPort :: Word32 + } + deriving (Eq, Show) instance FromJSON NodeAddress where parseJSON = withObject "NodeAddress" $ \o -> @@ -68,79 +77,73 @@ <*> o .: "address" <*> o .: "port" - data ConnDir = Inbound | Outbound deriving (Eq, Show, Enum) - instance FromJSON ConnDir where parseJSON = withText "ConnDir" fromText - where + where fromText t - | t == "inbound" = return Inbound + | t == "inbound" = return Inbound | t == "outbound" = return Outbound - | otherwise = fail "Unable to decode connection direction" - + | otherwise = fail "Unable to decode connection direction" data NodeInfoAddress = NodeInfoAddress { nodeInfoAddress :: Text - , connDirection :: ConnDir - } deriving (Eq, Show) - + , connDirection :: ConnDir + } + deriving (Eq, Show) instance FromJSON NodeInfoAddress where parseJSON = withObject "NodeInfoAddress" $ \o -> NodeInfoAddress <$> o .: "address" <*> o .: "connected" - data NodeInfo = NodeInfo { addedNode :: Text , connected :: Bool , addresses :: [NodeInfoAddress] - } deriving (Eq, Show) - + } + deriving (Eq, Show) instance FromJSON NodeInfo where parseJSON = withObject "NodeInfo" $ \o -> NodeInfo <$> o .: "addednode" <*> o .: "connected" <*> o .: "addresses" - data NetTotals = NetTotals { bytesReceived :: Word64 - , bytesSent :: Word64 - } deriving (Eq, Show) - + , bytesSent :: Word64 + } + deriving (Eq, Show) instance FromJSON NetTotals where parseJSON = withObject "NetTotals" $ \o -> NetTotals <$> o .: "totalbytesrecv" <*> o .: "totalbytessent" - data PeerInfo = PeerInfo - { peerIndex :: Word16 - , peerAddr :: Text - , peerBind :: Text - , services :: Text - , relay :: Bool - , lastSend :: UTCTime - , lastRecv :: UTCTime - , peerBytesSent :: Word64 - , peerBytesRecv :: Word64 - , connTime :: UTCTime - , timeOffset :: NominalDiffTime - , pingTime :: Maybe Double - , version :: Word64 - , inbound :: Bool - , addnode :: Bool + { peerIndex :: Word16 + , peerAddr :: Text + , peerBind :: Text + , services :: Text + , relay :: Bool + , lastSend :: UTCTime + , lastRecv :: UTCTime + , peerBytesSent :: Word64 + , peerBytesRecv :: Word64 + , connTime :: UTCTime + , timeOffset :: NominalDiffTime + , pingTime :: Maybe Double + , version :: Word64 + , inbound :: Bool + , addnode :: Bool , startingHeight :: BlockHeight - , banScore :: Word16 - , syncedHeaders :: Word32 - , syncedBlocks :: Word32 - , inflight :: [BlockHeight] - , whitelisted :: Bool - , minFeeFilter :: Word32 - -- ^ in satoshis - } deriving (Eq, Show) - + , banScore :: Word16 + , syncedHeaders :: Word32 + , syncedBlocks :: Word32 + , inflight :: [BlockHeight] + , whitelisted :: Bool + , -- | in satoshis + minFeeFilter :: Word32 + } + deriving (Eq, Show) instance FromJSON PeerInfo where parseJSON = withObject "PeerInfo" $ \o -> @@ -168,70 +171,63 @@ <*> o .: "whitelisted" <*> (toSatoshis <$> o .: "minfeefilter") - -type NetworkRpc - = BitcoindEndpoint "addnode" (I Text -> I Command -> CX) - :<|> BitcoindEndpoint "clearbanned" CX - :<|> BitcoindEndpoint "disconnectnode" (I Text -> CX) - :<|> BitcoindEndpoint "getaddednodeinfo" (O Text -> C [NodeInfo]) - :<|> BitcoindEndpoint "getconnectioncount" (C Word16) - :<|> BitcoindEndpoint "getnettotals" (C NetTotals) - :<|> BitcoindEndpoint "getnodeaddresses" (O Word32 -> C [NodeAddress]) - :<|> BitcoindEndpoint "getpeerinfo" (C [PeerInfo]) - :<|> BitcoindEndpoint "listbanned" (C [Text]) - - --- | Attempts to add or remove a node from the addnode list; or try a --- connection to a node once. Nodes added using addnode are protected from DoS --- disconnection and are not required to be full nodes/support SegWit as other --- outbound peers are (though such peers will not be synced from). -addNode - :: Text - -- ^ node address @host:port@ - -> Command - -> BitcoindClient () +type NetworkRpc = + BitcoindEndpoint "addnode" (I Text -> I Command -> CX) + :<|> BitcoindEndpoint "clearbanned" CX + :<|> BitcoindEndpoint "disconnectnode" (I Text -> CX) + :<|> BitcoindEndpoint "getaddednodeinfo" (O Text -> C [NodeInfo]) + :<|> BitcoindEndpoint "getconnectioncount" (C Word16) + :<|> BitcoindEndpoint "getnettotals" (C NetTotals) + :<|> BitcoindEndpoint "getnodeaddresses" (O Word32 -> C [NodeAddress]) + :<|> BitcoindEndpoint "getpeerinfo" (C [PeerInfo]) + :<|> BitcoindEndpoint "listbanned" (C [Text]) +{- | Attempts to add or remove a node from the addnode list; or try a + connection to a node once. Nodes added using addnode are protected from DoS + disconnection and are not required to be full nodes/support SegWit as other + outbound peers are (though such peers will not be synced from). +-} +addNode :: + -- | node address @host:port@ + Text -> + Command -> + BitcoindClient () -- | Clear all banned IPs. clearBanned :: BitcoindClient () - -- | Immediately disconnects from the specified peer node. -disconnectNode - :: Text - -- ^ node address @host:port@ - -> BitcoindClient () - --- | Returns information about the given added node, or all added nodes (note --- that onetry addnodes are not listed here) -getAddedNodeInfo - :: Maybe Text - -- ^ optionally specify a node by address - -> BitcoindClient [NodeInfo] +disconnectNode :: + -- | node address @host:port@ + Text -> + BitcoindClient () +{- | Returns information about the given added node, or all added nodes (note + that onetry addnodes are not listed here) +-} +getAddedNodeInfo :: + -- | optionally specify a node by address + Maybe Text -> + BitcoindClient [NodeInfo] -- | Returns the number of connections to other nodes. getConnectionCount :: BitcoindClient Word16 - --- | Returns information about network traffic, including bytes in, bytes out, --- and current time. +{- | Returns information about network traffic, including bytes in, bytes out, + and current time. +-} getNetTotals :: BitcoindClient NetTotals - --- | Return known addresses which can potentially be used to find new nodes in --- the network +{- | Return known addresses which can potentially be used to find new nodes in + the network +-} getNodeAddresses :: Maybe Word32 -> BitcoindClient [NodeAddress] - -- | Returns data about each connected network node. getPeerInfo :: BitcoindClient [PeerInfo] - -- | List all banned IPs/Subnets. listBanned :: BitcoindClient [Text] - - addNode :<|> clearBanned :<|> disconnectNode @@ -240,5 +236,5 @@ :<|> getNetTotals :<|> getNodeAddresses :<|> getPeerInfo - :<|> listBanned - = toBitcoindClient $ Proxy @NetworkRpc + :<|> listBanned = + toBitcoindClient $ Proxy @NetworkRpc diff --git a/src/Bitcoin/Core/RPC/Responses.hs b/src/Bitcoin/Core/RPC/Responses.hs --- a/src/Bitcoin/Core/RPC/Responses.hs +++ b/src/Bitcoin/Core/RPC/Responses.hs @@ -1,26 +1,27 @@ -module Bitcoin.Core.RPC.Responses - ( +module Bitcoin.Core.RPC.Responses ( -- * Transactions - MempoolTestResult (..) + MempoolTestResult (..), -- * Blocks - , BlockStats (..) - , ChainTip (..) - , ChainTipStatus (..) - , ChainTxStats (..) + CompactFilter (..), + BlockHeader (..), + BlockStats (..), + ChainTip (..), + ChainTipStatus (..), + ChainTxStats (..), -- * Mempool - , MempoolInfo (..) + MempoolInfo (..), -- * Network - , PeerInfo (..) - , NodeAddress (..) - , NodeInfo (..) - , NodeInfoAddress (..) - , ConnDir (..) - , NetTotals (..) - ) where + PeerInfo (..), + NodeAddress (..), + NodeInfo (..), + NodeInfoAddress (..), + ConnDir (..), + NetTotals (..), +) where -import Bitcoin.Core.RPC.Blockchain -import Bitcoin.Core.RPC.Network -import Bitcoin.Core.RPC.Transactions +import Bitcoin.Core.RPC.Blockchain +import Bitcoin.Core.RPC.Network +import Bitcoin.Core.RPC.Transactions diff --git a/src/Bitcoin/Core/RPC/Transactions.hs b/src/Bitcoin/Core/RPC/Transactions.hs --- a/src/Bitcoin/Core/RPC/Transactions.hs +++ b/src/Bitcoin/Core/RPC/Transactions.hs @@ -1,71 +1,75 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Bitcoin.Core.RPC.Transactions - ( getTransaction - , sendRawTransaction - , sendTransaction - , MempoolTestResult (..) - , testMempoolAccept - ) where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -import Data.Aeson (FromJSON (..), withObject, (.:), - (.:?)) -import Data.Proxy (Proxy (..)) -import qualified Data.Serialize as S -import Data.Text (Text) -import Network.Haskoin.Block (BlockHash) -import Network.Haskoin.Transaction (Tx, TxHash) -import Network.Haskoin.Util (encodeHex) -import Servant.API ((:<|>) (..)) +module Bitcoin.Core.RPC.Transactions ( + getTransaction, + sendRawTransaction, + sendTransaction, + MempoolTestResult (..), + testMempoolAccept, +) where -import Servant.Bitcoind (BitcoindClient, BitcoindEndpoint, - C, DefFalse, F, I, O, - toBitcoindClient) +import Data.Aeson (FromJSON (..), withObject, (.:), (.:?)) +import Data.Proxy (Proxy (..)) +import qualified Data.Serialize as S +import Data.Text (Text) +import Haskoin.Block (BlockHash) +import Haskoin.Transaction (Tx, TxHash) +import Haskoin.Util (encodeHex) +import Servant.API ((:<|>) (..)) +import Servant.Bitcoind ( + BitcoindClient, + BitcoindEndpoint, + C, + DefFalse, + F, + HexEncoded (..), + I, + O, + toBitcoindClient, + ) data MempoolTestResult = MempoolTestResult - { testTxid :: TxHash - , txAccepted :: Bool + { testTxid :: TxHash + , txAccepted :: Bool , rejectReason :: Maybe Text - } deriving (Eq, Show) - + } + deriving (Eq, Show) instance FromJSON MempoolTestResult where parseJSON = withObject "MempoolTestResult" $ \o -> MempoolTestResult <$> o .: "txid" <*> o .: "allowed" <*> o .:? "reject-reason" - -type RawTxRpc - = BitcoindEndpoint "sendrawtransaction" (I Text -> O Double -> C TxHash) - :<|> BitcoindEndpoint "getrawtransaction" (I TxHash -> F DefFalse Bool -> O BlockHash -> C Tx) - :<|> BitcoindEndpoint "testmempoolaccept" (I [Tx] -> O Double -> C [MempoolTestResult]) - +type RawTxRpc = + BitcoindEndpoint "sendrawtransaction" (I Text -> O Double -> C TxHash) + :<|> BitcoindEndpoint "getrawtransaction" (I TxHash -> F DefFalse Bool -> O BlockHash -> C (HexEncoded Tx)) + :<|> BitcoindEndpoint "testmempoolaccept" (I [Tx] -> O Double -> C [MempoolTestResult]) -- | Submit a raw transaction (serialized, hex-encoded) to local node and network. sendRawTransaction :: Text -> Maybe Double -> BitcoindClient TxHash - -- | A version of 'sendRawTransaction' that handles serialization sendTransaction :: Tx -> Maybe Double -> BitcoindClient TxHash sendTransaction = sendRawTransaction . encodeHex . S.encode - --- | By default this function only works for mempool transactions. When called --- with a blockhash argument, getrawtransaction will return the transaction if --- the specified block is available and the transaction is found in that block. --- When called without a blockhash argument, getrawtransaction will return the --- transaction if it is in the mempool, or if -txindex is enabled and the --- transaction is in a block in the blockchain. -getTransaction :: TxHash -> Maybe BlockHash -> BitcoindClient Tx - +getTransaction' :: TxHash -> Maybe BlockHash -> BitcoindClient (HexEncoded Tx) --- | Returns result of mempool acceptance tests indicating if the transactions --- would be accepted by mempool. This checks if the transaction violates the --- consensus or policy rules. +{- | Returns result of mempool acceptance tests indicating if the transactions + would be accepted by mempool. This checks if the transaction violates the + consensus or policy rules. +-} testMempoolAccept :: [Tx] -> Maybe Double -> BitcoindClient [MempoolTestResult] - +sendRawTransaction :<|> getTransaction' :<|> testMempoolAccept = toBitcoindClient $ Proxy @RawTxRpc -sendRawTransaction :<|> getTransaction :<|> testMempoolAccept = toBitcoindClient $ Proxy @RawTxRpc +{- | By default this function only works for mempool transactions. When called + with a blockhash argument, getrawtransaction will return the transaction if + the specified block is available and the transaction is found in that block. + When called without a blockhash argument, getrawtransaction will return the + transaction if it is in the mempool, or if -txindex is enabled and the + transaction is in a block in the blockchain. +-} +getTransaction :: TxHash -> Maybe BlockHash -> BitcoindClient Tx +getTransaction h = fmap unHexEncoded . getTransaction' h diff --git a/src/Servant/Bitcoind.hs b/src/Servant/Bitcoind.hs --- a/src/Servant/Bitcoind.hs +++ b/src/Servant/Bitcoind.hs @@ -1,82 +1,87 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -module Servant.Bitcoind - ( +module Servant.Bitcoind ( -- * Bitcoind api endpoint DSL - - C - , CX - , F - , I - , O + C, + CX, + F, + I, + O, -- * Types related to defaulting - - , EmptyString - , EmptyList - , DefFalse - , DefZero + EmptyString, + EmptyList, + DefFalse, + DefTrue, + DefZero, -- * Types related to the client - - , BitcoindClient - , BitcoindEndpoint - , BitcoindException (..) + BitcoindClient, + BitcoindEndpoint, + BitcoindException (..), -- * Client generation mechanism - - , HasBitcoindClient (..) - , Rewrite (..) + HasBitcoindClient (..), + Rewrite (..), -- * Utility functions - , utcTime - , toSatoshis - ) where - -import Control.Exception (Exception) -import Control.Monad.Trans.Except (ExceptT (..)) -import Control.Monad.Trans.Reader (ReaderT (..)) -import Data.Aeson (FromJSON (..), ToJSON (..), Value) -import qualified Data.Aeson.Types as Ae -import Data.Bifunctor (first) -import Data.Proxy (Proxy (..)) -import Data.Scientific (Scientific) -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Word (Word32, Word64) -import GHC.TypeLits (KnownSymbol, Symbol) -import Servant.API ((:<|>) (..), (:>)) -import Servant.API.BasicAuth (BasicAuth, BasicAuthData) -import Servant.Client (ClientError, ClientM, client) -import Servant.Client.JsonRpc (JsonRpc, JsonRpcErr (..), - JsonRpcResponse (..)) + utcTime, + toSatoshis, + decodeFromHex, + HexEncoded (..), +) where +import Control.Exception (Exception) +import Control.Monad ((>=>)) +import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Aeson ( + FromJSON (..), + ToJSON (..), + Value, + withText, + ) +import qualified Data.Aeson.Types as Ae +import Data.Bifunctor (first) +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Serialize (Serialize, decode) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word32, Word64) +import GHC.TypeLits (KnownSymbol, Symbol) +import Haskoin.Util (decodeHex) +import Servant.API ((:<|>) (..), (:>)) +import Servant.API.BasicAuth (BasicAuth, BasicAuthData) +import Servant.Client (ClientError, ClientM, client) +import Servant.Client.JsonRpc ( + JsonRpc, + JsonRpcErr (..), + JsonRpcResponse (..), + ) -- | Exceptions resulting from interacting with bitcoind data BitcoindException - = RpcException String - -- ^ The error message returned by bitcoind on failure + = -- | The error message returned by bitcoind on failure + RpcException String | ClientException ClientError | DecodingError String - deriving Show - + deriving (Show) instance Exception BitcoindException - data BitcoindEndpoint (m :: Symbol) a - -- | A client returning @Either BitcoindException r@ data C r @@ -92,164 +97,147 @@ -- | An ordinary argument data I r - class HasDefault x a where getDefault :: p x -> a - data EmptyString - instance HasDefault EmptyString Text where getDefault _ = "" - data DefFalse - instance HasDefault DefFalse Bool where getDefault _ = False +data DefTrue -data EmptyList +instance HasDefault DefTrue Bool where getDefault _ = True +data EmptyList instance HasDefault EmptyList [a] where getDefault _ = [] - data DefZero - instance Num a => HasDefault DefZero a where getDefault _ = 0 - class HasBitcoindClient x where type TheBitcoindClient x :: * toBitcoindClient :: p x -> TheBitcoindClient x - instance - (Rewrite a, RewriteFrom a ~ NakedClient, KnownSymbol m) - => HasBitcoindClient (BitcoindEndpoint m a) + (Rewrite a, RewriteFrom a ~ NakedClient, KnownSymbol m) => + HasBitcoindClient (BitcoindEndpoint m a) where - type TheBitcoindClient (BitcoindEndpoint m a) = RewriteTo a - toBitcoindClient _ - = rewriteRpc (Proxy @a) - . client - $ Proxy @(BitcoindRpc m) - + toBitcoindClient _ = + rewriteRpc (Proxy @a) + . client + $ Proxy @(BitcoindRpc m) instance - (HasBitcoindClient x, HasBitcoindClient y) - => HasBitcoindClient (x :<|> y) + (HasBitcoindClient x, HasBitcoindClient y) => + HasBitcoindClient (x :<|> y) where - type TheBitcoindClient (x :<|> y) = TheBitcoindClient x :<|> TheBitcoindClient y toBitcoindClient _ = toBitcoindClient (Proxy @x) :<|> toBitcoindClient (Proxy @y) - -type BitcoindRpc m = BasicAuth "bitcoind" () :> JsonRpc m [Value] String Value - +type BitcoindRpc m = BasicAuth "bitcoind" () :> JsonRpc m [Value] String Value type BitcoindClient r = ReaderT BasicAuthData (ExceptT BitcoindException ClientM) r - -type NakedClient - = BasicAuthData - -> [Value] - -> ClientM (JsonRpcResponse String Value) - +type NakedClient = + BasicAuthData -> + [Value] -> + ClientM (JsonRpcResponse String Value) --- | Bitcoind uses JSON arrays to serialize parameters. This typeclass --- describes a generic rewriting system, but we apply it here to transform --- clients of the form @BasicAuthData -> [Value] -> ClientM Value@ into curried --- functions with endpoint specific arguments. +{- | Bitcoind uses JSON arrays to serialize parameters. This typeclass + describes a generic rewriting system, but we apply it here to transform + clients of the form @BasicAuthData -> [Value] -> ClientM Value@ into curried + functions with endpoint specific arguments. +-} class Rewrite a where type RewriteFrom a :: * - type RewriteTo a :: * + type RewriteTo a :: * rewriteRpc :: p a -> RewriteFrom a -> RewriteTo a - -- | Handle endpoints which do not have an expected return value instance Rewrite CX where type RewriteFrom CX = NakedClient - type RewriteTo CX = BitcoindClient () + type RewriteTo CX = BitcoindClient () rewriteRpc _ f = ReaderT $ ExceptT . fmap repack . (`f` []) - where + where repack = \case - Ack _ -> return () + Ack _ -> return () Errors _ (JsonRpcErr _ e _) -> Left $ RpcException e - Result{} -> Left $ RpcException "Expecting ack; got result" - + Result{} -> Left $ RpcException "Expecting ack; got result" -- | Endpoints which simply return a value instance FromJSON r => Rewrite (C r) where type RewriteFrom (C r) = NakedClient - type RewriteTo (C r) = BitcoindClient r + type RewriteTo (C r) = BitcoindClient r rewriteRpc _ f = ReaderT $ ExceptT . fmap repack . (`f` []) - where + where repack = \case - Result _ x -> first DecodingError $ Ae.parseEither parseJSON x + Result _ x -> first DecodingError $ Ae.parseEither parseJSON x Errors _ (JsonRpcErr _ e _) -> Left $ RpcException e - Ack{} -> Left $ RpcException "Expecting result; got ack" - + Ack{} -> Left $ RpcException "Expecting result; got ack" -- | Add a normal argument instance - (RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a) - => Rewrite (I a -> b) + (RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a) => + Rewrite (I a -> b) where - type RewriteFrom (I a -> b) = NakedClient - type RewriteTo (I a -> b) = a -> RewriteTo b + type RewriteTo (I a -> b) = a -> RewriteTo b rewriteRpc _ f x = rewriteRpc (Proxy @b) $ \auth args -> f auth (toJSON x : args) - -- | Add an optional argument instance - (RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a) - => Rewrite (O a -> b) + (RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a) => + Rewrite (O a -> b) where - type RewriteFrom (O a -> b) = NakedClient - type RewriteTo (O a -> b) = Maybe a -> RewriteTo b + type RewriteTo (O a -> b) = Maybe a -> RewriteTo b rewriteRpc _ f x = rewriteRpc (Proxy @b) $ \auth args -> f auth ((toJSON <$> x) `maybeCons` args) - -- | Add a fixed argument instance - (RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a, HasDefault x a) - => Rewrite (F x a -> b) + (RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a, HasDefault x a) => + Rewrite (F x a -> b) where - type RewriteFrom (F x a -> b) = NakedClient - type RewriteTo (F x a -> b) = RewriteTo b + type RewriteTo (F x a -> b) = RewriteTo b rewriteRpc _ f = rewriteRpc (Proxy @b) f' - where + where f' auth args = f auth $ fixedVal : args fixedVal = toJSON @a . getDefault $ Proxy @x - - instance (Rewrite a, Rewrite b) => Rewrite (a :<|> b) where type RewriteFrom (a :<|> b) = RewriteFrom a :<|> RewriteFrom b - type RewriteTo (a :<|> b) = RewriteTo a :<|> RewriteTo b + type RewriteTo (a :<|> b) = RewriteTo a :<|> RewriteTo b rewriteRpc _ (x :<|> y) = rewriteRpc (Proxy @a) x :<|> rewriteRpc (Proxy @b) y - maybeCons :: Maybe a -> [a] -> [a] -maybeCons mx xs = maybe xs (:xs) mx - +maybeCons mx xs = maybe xs (: xs) mx -- | Helper function for decoding POSIX timestamps utcTime :: Word64 -> UTCTime utcTime = posixSecondsToUTCTime . fromIntegral - -- | Convert BTC to Satoshis toSatoshis :: Scientific -> Word32 toSatoshis = floor . (* 100_000_000) + +-- | Read a serializable from a hex string +decodeFromHex :: Serialize a => Text -> Either String a +decodeFromHex = maybe (Left "Invalid hex") Right . decodeHex >=> decode + +newtype HexEncoded a = HexEncoded {unHexEncoded :: a} deriving (Eq, Show) + +instance Serialize a => FromJSON (HexEncoded a) where + parseJSON = withText "HexEncoded" $ either fail (return . HexEncoded) . decodeFromHex