diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for bitcoind-rpc + +## 0.1.0.0 -- 2020-03-07 + +Initial release diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bitcoind-rpc.cabal b/bitcoind-rpc.cabal new file mode 100644 --- /dev/null +++ b/bitcoind-rpc.cabal @@ -0,0 +1,42 @@ +cabal-version: 2.2 +name: bitcoind-rpc +version: 0.1.0.0 +synopsis: A streamlined interface to bitcoin core using Haskoin types and Servant +homepage: https://github.com/GambolingPangolin/bitcoind-rpc +license: ISC +author: Ian Shipman +maintainer: ics@gambolingpangolin.com +build-type: Simple +extra-source-files: CHANGELOG.md + +library + default-language: Haskell2010 + hs-source-dirs: src/ + ghc-options: -Wall + + exposed-modules: + Bitcoin.Core.RPC + Bitcoin.Core.RPC.Responses + + other-modules: + Bitcoin.Core.RPC.Blockchain + Bitcoin.Core.RPC.Generating + Bitcoin.Core.RPC.Control + Bitcoin.Core.RPC.Network + Bitcoin.Core.RPC.Transactions + Servant.Bitcoind + + build-depends: + aeson ^>=1.4 + , base ^>=4.12 + , bytestring ^>=0.10 + , cereal ^>=0.5 + , haskoin-core >=0.9 && <0.12 + , http-client ^>=0.6 + , scientific ^>=0.3 + , servant >=0.15 && <0.18 + , servant-client >=0.15 && <0.18 + , servant-jsonrpc-client ^>=1.0 + , text ^>=1.2 + , time >=1.8 && <1.10 + , transformers ^>=0.5 diff --git a/src/Bitcoin/Core/RPC.hs b/src/Bitcoin/Core/RPC.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Core/RPC.hs @@ -0,0 +1,140 @@ +-- | +-- 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 (..) + + -- * Transactions + , getTransaction + , sendRawTransaction + , sendTransaction + , testMempoolAccept + + -- * Blocks + , getBlock + , getBlockHeader + , getBlockHash + , getBlockCount + , getDifficulty + + , getBestBlockHash + , getBlockStats + , getChainTips + , getChainTxStats + + -- * Mempool + , getMempoolInfo + , getMempoolAncestors + , getMempoolDescendants + , getRawMempool + + -- * Network + , getPeerInfo + , getConnectionCount + , getNodeAddresses + , getAddedNodeInfo + , listBanned + , getNetTotals + + -- * Control + , 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) + +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 + 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 + + +-- | 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 +basicAuthFromCookie f = repack <$> BS.readFile f + 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 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 new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Core/RPC/Blockchain.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 + +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 Servant.Bitcoind (BitcoindClient, BitcoindEndpoint, + C, DefFalse, DefZero, F, I, O, + toBitcoindClient, toSatoshis, + utcTime) + +data BlockStats = BlockStats + { 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) + + +instance FromJSON BlockStats where + parseJSON = withObject "BlockStats" $ \o -> + BlockStats + <$> o .: "avgfee" + <*> o .: "avgfeerate" + <*> o .: "avgtxsize" + <*> o .: "blockhash" + <*> o .: "feerate_percentiles" + <*> o .: "height" + <*> o .: "ins" + <*> o .: "maxfee" + <*> o .: "maxfeerate" + <*> o .: "mintxsize" + <*> o .: "outs" + <*> o .: "subsidy" + <*> o .: "swtotal_size" + <*> o .: "swtotal_weight" + <*> o .: "swtxs" + <*> (utcTime <$> o .: "time") + <*> o .: "total_out" + <*> o .: "total_size" + <*> o .: "total_weight" + <*> o .: "totalfee" + <*> o .: "txs" + <*> o .: "utxo_increase" + <*> o .: "utxo_size_inc" + + +data ChainTipStatus = Invalid | HeadersOnly | ValidHeaders | ValidFork | Active + deriving (Eq, Show) + + +instance FromJSON ChainTipStatus where + parseJSON = withText "ChainTipStatus" chainTipStatus + where + chainTipStatus t + | 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" + + +data ChainTip = ChainTip + { tipHeight :: Word32 + , tipHash :: BlockHash + , branchLength :: Word16 + , 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 + , finalBlockHeight :: BlockHeight + , 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 .:? "window_tx_count" + <*> o .:? "window_interval" + <*> o .:? "txrate" + + + +data MempoolInfo = MempoolInfo + { mempoolLoaded :: Bool + , mempoolSize :: Word32 + , mempoolBytes :: Word32 + , mempoolUsage :: Word32 + , mempoolMax :: Word32 + , mempoolMinFee :: Word32 + , mempoolMinRelayFee :: Word32 + } deriving (Eq, Show) + + +instance FromJSON MempoolInfo where + parseJSON = withObject "MempoolInfo" $ \o -> + MempoolInfo + <$> o .: "loaded" + <*> o .: "size" + <*> o .: "bytes" + <*> o .: "usage" + <*> o .: "maxmempool" + <*> (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]) + + +-- | 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 + + +-- | 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 + + +-- | 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. +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 + :<|> getBlockCount + :<|> getBlockHash + :<|> getBlockHeader + :<|> getBlockStats' + :<|> getChainTips + :<|> getChainTxStats + :<|> getDifficulty + :<|> getMempoolAncestors + :<|> getMempoolDescendants + :<|> getMempoolInfo + :<|> 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. +getBlockStats :: BlockHash -> BitcoindClient BlockStats +getBlockStats h = getBlockStats' h Nothing diff --git a/src/Bitcoin/Core/RPC/Control.hs b/src/Bitcoin/Core/RPC/Control.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Core/RPC/Control.hs @@ -0,0 +1,31 @@ +{-# 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 ((:<|>) (..)) + +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 new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Core/RPC/Generating.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Bitcoin.Core.RPC.Generating + ( generateToAddress + ) where + +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Word (Word32) +import Network.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 = toBitcoindClient $ Proxy @GeneratingRpc diff --git a/src/Bitcoin/Core/RPC/Network.hs b/src/Bitcoin/Core/RPC/Network.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Core/RPC/Network.hs @@ -0,0 +1,244 @@ +{-# 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 + +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 ((:<|>) (..)) + +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" + Remove -> "remove" + OneTry -> "onetry" + + +instance ToJSON Command where + toJSON = toJSON . commandText + + +data NodeAddress = NodeAddress + { addrTime :: UTCTime + , addrServices :: Word64 + , addrHost :: Text + , addrPort :: Word32 + } deriving (Eq, Show) + + +instance FromJSON NodeAddress where + parseJSON = withObject "NodeAddress" $ \o -> + NodeAddress + <$> (utcTime <$> o .: "time") + <*> o .: "services" + <*> o .: "address" + <*> o .: "port" + + +data ConnDir = Inbound | Outbound deriving (Eq, Show, Enum) + + +instance FromJSON ConnDir where + parseJSON = withText "ConnDir" fromText + where + fromText t + | t == "inbound" = return Inbound + | t == "outbound" = return Outbound + | otherwise = fail "Unable to decode connection direction" + + +data NodeInfoAddress = NodeInfoAddress + { nodeInfoAddress :: Text + , 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) + + +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) + + +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 + , startingHeight :: BlockHeight + , banScore :: Word16 + , syncedHeaders :: Word32 + , syncedBlocks :: Word32 + , inflight :: [BlockHeight] + , whitelisted :: Bool + , minFeeFilter :: Word32 + -- ^ in satoshis + } deriving (Eq, Show) + + +instance FromJSON PeerInfo where + parseJSON = withObject "PeerInfo" $ \o -> + PeerInfo + <$> o .: "id" + <*> o .: "addr" + <*> o .: "addrbind" + <*> o .: "services" + <*> o .: "relaytxes" + <*> (utcTime <$> o .: "lastsend") + <*> (utcTime <$> o .: "lastrecv") + <*> o .: "bytessent" + <*> o .: "bytesrecv" + <*> (utcTime <$> o .: "conntime") + <*> (fromIntegral @Int <$> o .: "timeoffset") + <*> o .: "pingtime" + <*> o .: "version" + <*> o .: "inbound" + <*> o .: "addnode" + <*> o .: "startingheight" + <*> o .: "banscore" + <*> o .: "synced_headers" + <*> o .: "synced_blocks" + <*> o .: "inflight" + <*> 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 () + + +-- | 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] + + +-- | Returns the number of connections to other nodes. +getConnectionCount :: BitcoindClient Word16 + + +-- | 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 +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 + :<|> getAddedNodeInfo + :<|> getConnectionCount + :<|> getNetTotals + :<|> getNodeAddresses + :<|> getPeerInfo + :<|> listBanned + = toBitcoindClient $ Proxy @NetworkRpc diff --git a/src/Bitcoin/Core/RPC/Responses.hs b/src/Bitcoin/Core/RPC/Responses.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Core/RPC/Responses.hs @@ -0,0 +1,26 @@ +module Bitcoin.Core.RPC.Responses + ( + -- * Transactions + MempoolTestResult (..) + + -- * Blocks + , BlockStats (..) + , ChainTip (..) + , ChainTipStatus (..) + , ChainTxStats (..) + + -- * Mempool + , MempoolInfo (..) + + -- * Network + , PeerInfo (..) + , NodeAddress (..) + , NodeInfo (..) + , NodeInfoAddress (..) + , ConnDir (..) + , NetTotals (..) + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Core/RPC/Transactions.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Bitcoin.Core.RPC.Transactions + ( getTransaction + , sendRawTransaction + , sendTransaction + , MempoolTestResult (..) + , testMempoolAccept + ) where + +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 ((:<|>) (..)) + +import Servant.Bitcoind (BitcoindClient, BitcoindEndpoint, + C, DefFalse, F, I, O, + toBitcoindClient) + + +data MempoolTestResult = MempoolTestResult + { testTxid :: TxHash + , txAccepted :: Bool + , rejectReason :: Maybe Text + } 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]) + + +-- | 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 + + +-- | 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 diff --git a/src/Servant/Bitcoind.hs b/src/Servant/Bitcoind.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Bitcoind.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Bitcoind + ( + -- * Bitcoind api endpoint DSL + + C + , CX + , F + , I + , O + + -- * Types related to defaulting + + , EmptyString + , EmptyList + , DefFalse + , DefZero + + -- * Types related to the client + + , BitcoindClient + , BitcoindEndpoint + , BitcoindException (..) + + -- * Client generation mechanism + + , 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 (..)) + + +-- | Exceptions resulting from interacting with bitcoind +data BitcoindException + = RpcException String + -- ^ The error message returned by bitcoind on failure + | ClientException ClientError + | DecodingError String + deriving Show + + +instance Exception BitcoindException + + +data BitcoindEndpoint (m :: Symbol) a + + +-- | A client returning @Either BitcoindException r@ +data C r + +-- | A client returning @Either BitcoindException ()@ +data CX + +-- | An argument with a fixed value +data F x r + +-- | An optional argument +data O r + +-- | 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 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) + where + + type TheBitcoindClient (BitcoindEndpoint m a) = RewriteTo a + toBitcoindClient _ + = rewriteRpc (Proxy @a) + . client + $ Proxy @(BitcoindRpc m) + + +instance + (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 BitcoindClient r = ReaderT BasicAuthData (ExceptT BitcoindException ClientM) r + + +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. +class Rewrite a where + type RewriteFrom 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 () + + rewriteRpc _ f = ReaderT $ ExceptT . fmap repack . (`f` []) + where + repack = \case + Ack _ -> return () + Errors _ (JsonRpcErr _ e _) -> Left $ RpcException e + 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 + + rewriteRpc _ f = ReaderT $ ExceptT . fmap repack . (`f` []) + where + repack = \case + Result _ x -> first DecodingError $ Ae.parseEither parseJSON x + Errors _ (JsonRpcErr _ e _) -> Left $ RpcException e + Ack{} -> Left $ RpcException "Expecting result; got ack" + + +-- | Add a normal argument +instance + (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 + + 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) + where + + type RewriteFrom (O a -> b) = NakedClient + 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) + where + + type RewriteFrom (F x a -> b) = NakedClient + type RewriteTo (F x a -> b) = RewriteTo b + + rewriteRpc _ f = rewriteRpc (Proxy @b) f' + 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 + rewriteRpc _ (x :<|> y) = rewriteRpc (Proxy @a) x :<|> rewriteRpc (Proxy @b) y + + +maybeCons :: Maybe a -> [a] -> [a] +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)