module Network.Ethereum.Web3.JsonRpc (remote, MethodName) where
import Network.Ethereum.Web3.Types
import Network.HTTP.Client (httpLbs, newManager, defaultManagerSettings,
requestBody, responseBody, method,
requestHeaders, parseRequest,
RequestBody(RequestBodyLBS))
import Control.Monad.Error.Class (throwError)
import Data.ByteString.Lazy (ByteString)
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (liftIO)
import Control.Applicative ((<|>))
import Control.Monad.Trans (lift)
import Data.Vector (fromList)
import Control.Monad ((>=>))
import Data.Text (Text)
import Data.Aeson
type MethodName = Text
remote :: Remote a => MethodName -> a
remote n = remote_ (call . Array . fromList)
where connection body = do
conf <- ask
liftIO $ do
manager <- newManager defaultManagerSettings
request <- parseRequest (rpcUri conf)
let request' = request
{ requestBody = RequestBodyLBS body
, requestHeaders = [("Content-Type", "application/json")]
, method = "POST" }
responseBody <$> httpLbs request' manager
call = connection . encode . Request n 1
class Remote a where
remote_ :: ([Value] -> Web3 ByteString) -> a
instance (ToJSON a, Remote b) => Remote (a -> b) where
remote_ f x = remote_ (\xs -> f (toJSON x : xs))
decodeResponse :: FromJSON a => ByteString -> Web3 a
decodeResponse = tryParse . eitherDecode
>=> tryJsonRpc . rsResult
>=> tryParse . eitherDecode . encode
where tryJsonRpc :: Either RpcError a -> Web3 a
tryJsonRpc (Right a) = return a
tryJsonRpc (Left e) = lift $ throwError (JsonRpcFail e)
tryParse :: Either String a -> Web3 a
tryParse (Right a) = return a
tryParse (Left e) = lift $ throwError (ParserFail e)
instance FromJSON a => Remote (Web3 a) where
remote_ f = decodeResponse =<< f []
data Request = Request { rqMethod :: Text
, rqId :: Int
, rqParams :: Value }
instance ToJSON Request where
toJSON rq = object $ [ "jsonrpc" .= String "2.0"
, "method" .= rqMethod rq
, "params" .= rqParams rq
, "id" .= rqId rq ]
data Response = Response
{ rsResult :: Either RpcError Value
} deriving (Show)
instance FromJSON Response where
parseJSON = withObject "JSON-RPC response object" $
\v -> Response <$>
(Right <$> v .: "result" <|> Left <$> v .: "error")