module Network.Bitcoin
(
Auth(..)
, Address
, mkAddress
, Amount
, Account
, MinConf
, AddressValidation
, isValid
, isMine
, account
, BitcoinException(..)
, Satoshi(..)
, getBalance
, getBlockCount
, getConnectionCount
, getDifficulty
, getGenerate
, getHashesPerSec
, getReceivedByAccount
, getReceivedByAddress
, validateAddress
, isValidAddress
, 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
satoshis :: Integer
satoshis = 10^(8::Integer)
data Satoshi = Satoshi
instance HasResolution Satoshi where
resolution _ = satoshis
type Amount = Fixed Satoshi
type Account = String
type MinConf = Integer
data Auth = Auth
{ rpcUrl :: String
, rpcUser :: String
, rpcPassword :: String
}
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
data BitcoinException
= BitcoinApiError Int String
deriving (Show,Typeable)
instance Exception BitcoinException
jsonRpcReqBody :: String -> [Value] -> BL.ByteString
jsonRpcReqBody cmd params = encode $ object [
"jsonrpc" .= ("2.0"::String),
"method" .= cmd,
"params" .= params,
"id" .= (1::Int)
]
callApi :: Auth
-> String
-> [Value]
-> 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
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"
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 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
getBalance :: Auth
-> Account
-> MinConf
-> IO Amount
getBalance auth acct minconf = callNumber "getbalance" args auth
where
args = [ String $ fromString acct, Number $ fromInteger minconf ]
getBlockCount :: Auth -> IO Integer
getBlockCount = callNumber "getblockcount" []
getConnectionCount :: Auth -> IO Integer
getConnectionCount = callNumber "getconnectioncount" []
getDifficulty :: Auth -> IO Double
getDifficulty = callNumber "getdifficulty" []
getGenerate :: Auth -> IO Bool
getGenerate = callBool "getgenerate" []
getHashesPerSec :: Auth -> IO Integer
getHashesPerSec = callNumber "gethashespersec" []
getReceivedByAccount :: Auth
-> Account
-> MinConf
-> IO Amount
getReceivedByAccount auth acct conf =
callNumber "getreceivedbyaccount" [toValue acct,toValue conf] auth
getReceivedByAddress :: Auth
-> Address
-> MinConf
-> IO Amount
getReceivedByAddress auth addr conf =
callNumber "getreceivedbyaddress" [toValue addr,toValue conf] auth
data AddressValidation = AddressValidation
{ isValid :: Bool
, isMine :: Bool
, account :: Account
} deriving (Show)
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
isValidAddress :: Auth -> Address -> IO Bool
isValidAddress auth addr = validateAddress auth addr >>= return . isValid