{-# 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)
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
} 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])
addNode
:: Text
-> Command
-> BitcoindClient ()
clearBanned :: BitcoindClient ()
disconnectNode
:: Text
-> BitcoindClient ()
getAddedNodeInfo
:: Maybe Text
-> BitcoindClient [NodeInfo]
getConnectionCount :: BitcoindClient Word16
getNetTotals :: BitcoindClient NetTotals
getNodeAddresses :: Maybe Word32 -> BitcoindClient [NodeAddress]
getPeerInfo :: BitcoindClient [PeerInfo]
listBanned :: BitcoindClient [Text]
addNode
:<|> clearBanned
:<|> disconnectNode
:<|> getAddedNodeInfo
:<|> getConnectionCount
:<|> getNetTotals
:<|> getNodeAddresses
:<|> getPeerInfo
:<|> listBanned
= toBitcoindClient $ Proxy @NetworkRpc