module Network.Bitcoin
(
Auth(..)
, Address
, mkAddress
, Amount
, Account
, MinConf
, AddressValidation
, isValid
, isMine
, account
, BitcoinException(..)
, getBalance
, getBlockCount
, getConnectionCount
, getDifficulty
, getGenerate
, getHashesPerSec
, getReceivedByAccount
, getReceivedByAddress
, validateAddress
, isValidAddress
, callApi
) 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.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
data Satoshi = Satoshi
instance HasResolution Satoshi where
resolution _ = 10^(8::Integer)
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 $ toRational d
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