module Network.Bitcoin.Internal ( module Network.Bitcoin.Types
, Text, Vector
, FromJSON(..)
, callApi
, callApi'
, Nil(..)
, tj
, AddrAddress(..)
, BitcoinRpcResponse(..)
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.Aeson
import Data.Maybe
import Data.Vector ( Vector )
import qualified Data.Vector as V
import Network.Bitcoin.Types
import Network.Browser
import Network.HTTP hiding ( password )
import Network.URI ( parseURI )
import qualified Data.ByteString.Lazy as BL
import Data.Text ( Text )
import qualified Data.Text as T
data BitcoinRpcError = NoError
| BitcoinRpcError Int Text
deriving ( Show, Read, Ord, Eq )
instance FromJSON BitcoinRpcError where
parseJSON (Object v) = BitcoinRpcError <$> v .: "code"
<*> v .: "message"
parseJSON Null = return NoError
parseJSON _ = mzero
data BitcoinRpcResponse a = BitcoinRpcResponse { btcResult :: a
, btcError :: BitcoinRpcError
}
deriving ( Show, Read, Ord, Eq )
instance FromJSON a => FromJSON (BitcoinRpcResponse a) where
parseJSON (Object v) = BitcoinRpcResponse <$> v .: "result"
<*> v .: "error"
parseJSON _ = mzero
callApi' :: Auth -> BL.ByteString -> IO BL.ByteString
callApi' auth rpcReqBody = do
(_, httpRes) <- browse $ do
setOutHandler . const $ return ()
addAuthority authority
setAllowBasicAuth True
request $ httpRequest (T.unpack urlString) rpcReqBody
return $ rspBody httpRes
where
authority = httpAuthority auth
urlString = rpcUrl auth
callApi :: FromJSON v
=> Auth
-> Text
-> [Value]
-> IO v
callApi auth cmd params = readVal =<< callApi' auth jsonRpcReqBody
where
readVal bs = case decode' bs of
Just r@(BitcoinRpcResponse {btcError=NoError})
-> return $ btcResult r
Just (BitcoinRpcResponse {btcError=BitcoinRpcError code msg})
-> throw $ BitcoinApiError code msg
Nothing
-> throw $ BitcoinResultTypeError bs
jsonRpcReqBody =
encode $ object [ "jsonrpc" .= ("2.0" :: Text)
, "method" .= cmd
, "params" .= params
, "id" .= (1 :: Int)
]
data Nil = Nil { unNil :: () }
instance FromJSON Nil where
parseJSON Null = return $ Nil ()
parseJSON x = fail $ "\"null\" was expected, but " ++ show x ++ " was recieved."
httpAuthority :: Auth -> Authority
httpAuthority (Auth urlString username password) =
AuthBasic { auRealm = "jsonrpc"
, auUsername = T.unpack username
, auPassword = T.unpack password
, auSite = uri
}
where
uri = fromJust . parseURI $ T.unpack 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)
]
}
tj :: ToJSON a => a -> Value
tj = toJSON
newtype AddrAddress = AA (Vector (Address, BTC))
instance ToJSON AddrAddress where
toJSON (AA vec) = object . V.toList $ uncurry (.=) <$> vec