packages feed

bitcoind-rpc (empty) → 0.1.0.0

raw patch · 11 files changed

+1114/−0 lines, 11 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, cereal, haskoin-core, http-client, scientific, servant, servant-client, servant-jsonrpc-client, text, time, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for bitcoind-rpc++## 0.1.0.0 -- 2020-03-07++Initial release
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bitcoind-rpc.cabal view
@@ -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
+ src/Bitcoin/Core/RPC.hs view
@@ -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
+ src/Bitcoin/Core/RPC/Blockchain.hs view
@@ -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
+ src/Bitcoin/Core/RPC/Control.hs view
@@ -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
+ src/Bitcoin/Core/RPC/Generating.hs view
@@ -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
+ src/Bitcoin/Core/RPC/Network.hs view
@@ -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
+ src/Bitcoin/Core/RPC/Responses.hs view
@@ -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
+ src/Bitcoin/Core/RPC/Transactions.hs view
@@ -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
+ src/Servant/Bitcoind.hs view
@@ -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)