{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Communicate with a Bitcoin daemon over JSON RPC
module Network.Bitcoin
(
-- * Types
Auth(..)
, Address
, mkAddress
, Amount
, Account
, MinConf
, AddressValidation
, isValid
, isMine
, account
, BitcoinException(..)
, Satoshi(..)
-- * Individual API methods
, getBalance
, getBlockCount
, getConnectionCount
, getDifficulty
, getGenerate
, getHashesPerSec
, getReceivedByAccount
, getReceivedByAddress
, validateAddress
, isValidAddress
-- * Low-level API
, callApi
, FromNumber
, fromNumber
) where
import Network.Bitcoin.Address
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.Aeson
import Data.Attoparsec
import Data.Attoparsec.Number
import Data.Fixed
import Data.Maybe (fromJust)
import Data.Ratio ((%))
import Data.String (fromString)
import Data.Typeable
import Network.Browser
import Network.HTTP hiding (password)
import Network.URI (parseURI)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.Text as T
-- | Defines Bitcoin's internal precision
satoshis :: Integer
satoshis = 10^(8::Integer)
data Satoshi = Satoshi
instance HasResolution Satoshi where
resolution _ = satoshis
-- | Fixed precision Bitcoin amount (to avoid floating point errors)
type Amount = Fixed Satoshi
-- | Name of a Bitcoin wallet account
type Account = String
-- | Minimum number of confirmations for a payment
type MinConf = Integer
-- | 'Auth' describes authentication credentials for
-- making API requests to the Bitcoin daemon
data Auth = Auth
{ rpcUrl :: String -- ^ URL, with port, where bitcoind listens
, rpcUser :: String -- ^ same as bitcoind's 'rpcuser' config
, rpcPassword :: String -- ^ same as bitcoind's 'rpcpassword' config
}
deriving (Show)
data BitcoinRpcResponse = BitcoinRpcResponse {
btcResult :: Value,
btcError :: Value
}
deriving (Show)
instance FromJSON BitcoinRpcResponse where
parseJSON (Object v) = BitcoinRpcResponse <$> v .: "result"
<*> v .: "error"
parseJSON _ = mzero
-- |A 'BitcoinException' is thrown when 'callApi' encounters an
-- error. The API error code is represented as an @Int@, the message as
-- a @String@.
data BitcoinException
= BitcoinApiError Int String
deriving (Show,Typeable)
instance Exception BitcoinException
-- encodes an RPC request into a ByteString containing JSON
jsonRpcReqBody :: String -> [Value] -> BL.ByteString
jsonRpcReqBody cmd params = encode $ object [
"jsonrpc" .= ("2.0"::String),
"method" .= cmd,
"params" .= params,
"id" .= (1::Int)
]
-- |'callApi' is a low-level interface for making authenticated API
-- calls to a Bitcoin daemon. The first argument specifies
-- authentication details (URL, username, password) and is often
-- curried for convenience:
--
-- > callBtc = callApi $ Auth "http://127.0.0.1:8332" "user" "password"
--
-- The second argument is the command name. The third argument provides
-- parameters for the API call.
--
-- > let result = callBtc "getbalance" ["account-name", Number 6]
--
-- On error, throws a 'BitcoinException'
callApi :: Auth -- ^ authentication credentials for bitcoind
-> String -- ^ command name
-> [Value] -- ^ command arguments
-> IO Value
callApi auth command params = do
(_,httpRes) <- browse $ do
setOutHandler $ const $ return ()
addAuthority authority
setAllowBasicAuth True
request $ httpRequest urlString $ jsonRpcReqBody command params
let res = fromSuccess $ fromJSON $ toVal $ rspBody httpRes
case res of
BitcoinRpcResponse {btcError=Null} -> return $ btcResult res
BitcoinRpcResponse {btcError=e} -> throw $ buildBtcError e
where authority = httpAuthority auth
urlString = rpcUrl auth
toStrict = B.concat . BL.toChunks
justParseJSON = fromJust . maybeResult . parse json
toVal = justParseJSON . toStrict
-- Internal helper functions to make callApi more readable
httpAuthority :: Auth -> Authority
httpAuthority (Auth urlString username password) =
AuthBasic {
auRealm = "jsonrpc",
auUsername = username,
auPassword = password,
auSite = uri
}
where uri = fromJust $ parseURI urlString
httpRequest :: String -> BL.ByteString -> Request BL.ByteString
httpRequest urlString jsonBody =
(postRequest urlString){
rqBody = jsonBody,
rqHeaders = [
mkHeader HdrContentType "application/json",
mkHeader HdrContentLength (show $ BL.length jsonBody)
]
}
fromSuccess :: Data.Aeson.Result t -> t
fromSuccess (Success a) = a
fromSuccess (Error s) = error s
buildBtcError :: Value -> BitcoinException
buildBtcError (Object o) = BitcoinApiError code msg
where find k = fromSuccess . fromJSON . fromJust . M.lookup k
code = find "code" o
msg = find "message" o
buildBtcError _ = error "Need an object to buildBtcError"
-- | Convert JSON numeric values to more specific numeric types
class FromNumber a where
fromNumber :: Number -> a
instance FromNumber Amount where
fromNumber (I i) = fromInteger i
fromNumber (D d) = fromRational $ numerator % satoshis
where
numerator = round $ d * (fromInteger satoshis)
instance FromNumber Integer where
fromNumber (I i) = i
fromNumber (D d) = round d
instance FromNumber Double where
fromNumber (I i) = fromInteger i
fromNumber (D d) = d
-- Class of types that can be converted to a JSON representation
class ToValue a where
toValue :: a -> Value
instance ToValue Address where
toValue addr = String $ fromString $ show addr
instance ToValue MinConf where
toValue conf = Number $ fromInteger conf
instance ToValue Account where
toValue acct = String $ fromString acct
callNumber :: FromNumber a => String -> [Value] -> Auth -> IO a
callNumber cmd args auth = do
(Number n) <- callApi auth cmd args
return $ fromNumber n
callBool :: String -> [Value] -> Auth -> IO Bool
callBool cmd args auth = do
(Bool b) <- callApi auth cmd args
return b
-- | Returns the balance of a specific Bitcoin account
getBalance :: Auth
-> Account
-> MinConf
-> IO Amount
getBalance auth acct minconf = callNumber "getbalance" args auth
where
args = [ String $ fromString acct, Number $ fromInteger minconf ]
-- | Returns the number of blocks in the longest block chain
getBlockCount :: Auth -> IO Integer
getBlockCount = callNumber "getblockcount" []
-- | Returns the number of connections to other nodes
getConnectionCount :: Auth -> IO Integer
getConnectionCount = callNumber "getconnectioncount" []
-- | Returns the proof-of-work difficulty as a multiple of the minimum
-- difficulty
getDifficulty :: Auth -> IO Double
getDifficulty = callNumber "getdifficulty" []
-- | Indicates whether the node is generating or not
getGenerate :: Auth -> IO Bool
getGenerate = callBool "getgenerate" []
-- | Returns a recent hashes per second performance measurement while
-- generating
getHashesPerSec :: Auth -> IO Integer
getHashesPerSec = callNumber "gethashespersec" []
-- | Returns the total amount received by addresses with
-- @account@ in transactions with at least @minconf@ confirmations
getReceivedByAccount :: Auth
-> Account
-> MinConf
-> IO Amount
getReceivedByAccount auth acct conf =
callNumber "getreceivedbyaccount" [toValue acct,toValue conf] auth
-- | Returns the total amount received by an address in transactions
-- with at least 'minconf' confirmations.
getReceivedByAddress :: Auth
-> Address
-> MinConf
-> IO Amount
getReceivedByAddress auth addr conf =
callNumber "getreceivedbyaddress" [toValue addr,toValue conf] auth
-- | Encapsulates address validation results from 'validateAddress'
data AddressValidation = AddressValidation
{ isValid :: Bool -- ^ Is the address valid?
, isMine :: Bool -- ^ Does the address belong to my wallet?
, account :: Account -- ^ To which account does this address belong?
} deriving (Show)
-- | Return information about an address.
-- If the address is invalid or doesn't belong to us, the account name
-- is the empty string.
validateAddress :: Auth
-> Address
-> IO AddressValidation
validateAddress auth addr = do
(Object result) <- callApi auth "validateaddress" [toValue addr]
return AddressValidation
{ isValid = bool False "isvalid" result
, isMine = bool False "ismine" result
, account = str "" "account" result
}
where
bool d k r = maybe d (\(Bool b)->b) $ M.lookup k r
str d k r = maybe d (\(String t)->T.unpack t) $ M.lookup k r
-- | Returns true if the RPC says the address is valid.
-- Use this function until 'mkAddress' verifies address checksums
isValidAddress :: Auth -> Address -> IO Bool
isValidAddress auth addr = validateAddress auth addr >>= return . isValid