{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
module Network.Bitcoin.Internal ( module Network.Bitcoin.Types
, Text, Vector
, FromJSON(..)
, callApi
, getClient
, Nil(..)
, NilOrArray(..)
, tj
, tjm
, tja
, AddrAddress(..)
, BitcoinRpcResponse(..)
) where
import Control.Exception
import Control.Monad
import Data.Aeson
import qualified Data.ByteString as BS
import Data.Maybe
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Network.Bitcoin.Types
import Network.HTTP.Client
import Network.HTTP.Types.Header
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
getClient :: String
-> BS.ByteString
-> BS.ByteString
-> IO Client
getClient url user pass = do
url' <- parseUrlThrow url
mgr <- newManager defaultManagerSettings
let baseReq = applyBasicAuth user pass url'
{ method = "POST"
, requestHeaders = [(hContentType, "application/json")] }
return $ \r -> do
resp <- httpLbs (baseReq { requestBody = RequestBodyLBS r }) mgr
return $ responseBody resp
callApi :: FromJSON v
=> Client
-> Text
-> [Value]
-> IO v
callApi client cmd params = readVal =<< client 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)
]
{-# INLINE callApi #-}
newtype Nil = Nil { unNil :: () }
instance FromJSON Nil where
parseJSON Null = return $ Nil ()
parseJSON x = fail $ "\"null\" was expected, but " ++ show x ++ " was recieved."
newtype NilOrArray = NilOrArray {unArr :: Maybe [HexString]}
instance FromJSON NilOrArray where
parseJSON Null = return $ NilOrArray Nothing
parseJSON a@(Array _) = NilOrArray <$> parseJSON a
parseJSON x = fail $ "Expected \"null\" or array, but " ++ show x ++ " was recieved."
tj :: ToJSON a => a -> Value
tj = toJSON
{-# INLINE tj #-}
tjm :: ToJSON a => a -> Maybe a -> Value
tjm d m = tj $ fromMaybe d m
{-# INLINE tjm #-}
tja :: ToJSON a => Maybe a -> [Value]
tja = maybe [] (pure . tj)
{-# INLINE tja #-}
newtype AddrAddress = AA (Vector (Address, BTC))
instance ToJSON AddrAddress where
toJSON (AA vec) = object . V.toList $ uncurry (.=) <$> vec