296 lines
10 KiB
Haskell
296 lines
10 KiB
Haskell
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Zenith.RPC where
|
|
|
|
import Control.Exception (try)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Logger (runNoLoggingT)
|
|
import Data.Aeson
|
|
import qualified Data.Text as T
|
|
import qualified Data.Vector as V
|
|
import Database.Esqueleto.Experimental (toSqlKey)
|
|
import Servant
|
|
import ZcashHaskell.Types
|
|
( RpcError(..)
|
|
, ZcashNet(..)
|
|
, ZebraGetBlockChainInfo(..)
|
|
, ZebraGetInfo(..)
|
|
)
|
|
import Zenith.Core (checkBlockChain, checkZebra)
|
|
import Zenith.DB
|
|
( getAccounts
|
|
, getWallets
|
|
, initDb
|
|
, initPool
|
|
, toZcashAccountAPI
|
|
, toZcashWalletAPI
|
|
)
|
|
import Zenith.Types (Config(..), ZcashAccountAPI(..), ZcashWalletAPI(..))
|
|
import Zenith.Utils (jsonNumber)
|
|
|
|
data ZenithMethod
|
|
= GetInfo
|
|
| ListWallets
|
|
| ListAccounts
|
|
| UnknownMethod
|
|
deriving (Eq, Prelude.Show)
|
|
|
|
instance ToJSON ZenithMethod where
|
|
toJSON GetInfo = Data.Aeson.String "getinfo"
|
|
toJSON ListWallets = Data.Aeson.String "listwallets"
|
|
toJSON ListAccounts = Data.Aeson.String "listaccounts"
|
|
toJSON UnknownMethod = Data.Aeson.Null
|
|
|
|
instance FromJSON ZenithMethod where
|
|
parseJSON =
|
|
withText "ZenithMethod" $ \case
|
|
"getinfo" -> pure GetInfo
|
|
"listwallets" -> pure ListWallets
|
|
"listaccounts" -> pure ListAccounts
|
|
_ -> pure UnknownMethod
|
|
|
|
data ZenithParams
|
|
= BlankParams
|
|
| BadParams
|
|
| AccountsParams !Int
|
|
| TestParams !T.Text
|
|
deriving (Eq, Prelude.Show)
|
|
|
|
instance ToJSON ZenithParams where
|
|
toJSON BlankParams = Data.Aeson.Array V.empty
|
|
toJSON BadParams = Data.Aeson.Null
|
|
toJSON (AccountsParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n]
|
|
toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t]
|
|
|
|
data ZenithResponse
|
|
= InfoResponse !T.Text !ZenithInfo
|
|
| WalletListResponse !T.Text ![ZcashWalletAPI]
|
|
| AccountListResponse !T.Text ![ZcashAccountAPI]
|
|
| ErrorResponse !T.Text !Double !T.Text
|
|
deriving (Eq, Prelude.Show)
|
|
|
|
instance ToJSON ZenithResponse where
|
|
toJSON (InfoResponse t i) =
|
|
object ["jsonrpc" .= ("2.0" :: String), "id" .= t, "result" .= i]
|
|
toJSON (WalletListResponse i w) =
|
|
object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= w]
|
|
toJSON (AccountListResponse i a) =
|
|
object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= a]
|
|
toJSON (ErrorResponse i c m) =
|
|
object
|
|
[ "jsonrpc" .= ("2.0" :: String)
|
|
, "id" .= i
|
|
, "error" .= object ["code" .= c, "message" .= m]
|
|
]
|
|
|
|
instance FromJSON ZenithResponse where
|
|
parseJSON =
|
|
withObject "ZenithParams" $ \obj -> do
|
|
jr <- obj .: "jsonrpc"
|
|
i <- obj .: "id"
|
|
e <- obj .:? "error"
|
|
r <- obj .:? "result"
|
|
if jr /= ("2.0" :: String)
|
|
then fail "Malformed JSON"
|
|
else do
|
|
case e of
|
|
Nothing -> do
|
|
case r of
|
|
Nothing -> fail "Malformed JSON"
|
|
Just r1 ->
|
|
case r1 of
|
|
Object k -> do
|
|
v <- k .:? "version"
|
|
case (v :: Maybe String) of
|
|
Nothing -> fail "Unknown result"
|
|
Just _v' -> do
|
|
k1 <- parseJSON r1
|
|
pure $ InfoResponse i k1
|
|
Array n -> do
|
|
if V.null n
|
|
then fail "Malformed JSON"
|
|
else do
|
|
case V.head n of
|
|
Object n' -> do
|
|
v1 <- n' .:? "lastSync"
|
|
case (v1 :: Maybe Int) of
|
|
Just _v1' -> do
|
|
k2 <- parseJSON r1
|
|
pure $ WalletListResponse i k2
|
|
Nothing -> fail "Unknown object"
|
|
_anyOther -> fail "Malformed JSON"
|
|
_anyOther -> fail "Malformed JSON"
|
|
Just e1 -> pure $ ErrorResponse i (ecode e1) (emessage e1)
|
|
|
|
data ZenithInfo = ZenithInfo
|
|
{ zi_version :: !T.Text
|
|
, zi_network :: !ZcashNet
|
|
, zi_zebra :: !T.Text
|
|
} deriving (Eq, Prelude.Show)
|
|
|
|
instance ToJSON ZenithInfo where
|
|
toJSON (ZenithInfo v n z) =
|
|
object ["version" .= v, "network" .= n, "zebraVersion" .= z]
|
|
|
|
instance FromJSON ZenithInfo where
|
|
parseJSON =
|
|
withObject "ZenithInfo" $ \obj -> do
|
|
v <- obj .: "version"
|
|
n <- obj .: "network"
|
|
z <- obj .: "zebraVersion"
|
|
pure $ ZenithInfo v n z
|
|
|
|
-- | A type to model Zenith RPC calls
|
|
data RpcCall = RpcCall
|
|
{ jsonrpc :: !T.Text
|
|
, callId :: !T.Text
|
|
, method :: !ZenithMethod
|
|
, parameters :: !ZenithParams
|
|
} deriving (Eq, Prelude.Show)
|
|
|
|
instance ToJSON RpcCall where
|
|
toJSON (RpcCall jr i m p) =
|
|
object ["jsonrpc" .= jr, "id" .= i, "method" .= m, "params" .= p]
|
|
|
|
instance FromJSON RpcCall where
|
|
parseJSON =
|
|
withObject "RpcCall" $ \obj -> do
|
|
v <- obj .: "jsonrpc"
|
|
i <- obj .: "id"
|
|
m <- obj .: "method"
|
|
case m of
|
|
UnknownMethod -> pure $ RpcCall v i UnknownMethod BlankParams
|
|
ListWallets -> do
|
|
p <- obj .: "params"
|
|
if null (p :: [Value])
|
|
then pure $ RpcCall v i ListWallets BlankParams
|
|
else pure $ RpcCall v i ListWallets BadParams
|
|
GetInfo -> do
|
|
p <- obj .: "params"
|
|
if null (p :: [Value])
|
|
then pure $ RpcCall v i GetInfo BlankParams
|
|
else pure $ RpcCall v i GetInfo BadParams
|
|
ListAccounts -> do
|
|
p <- obj .: "params"
|
|
case p of
|
|
Array a ->
|
|
if V.length a == 1
|
|
then do
|
|
w <- parseJSON $ V.head a
|
|
pure $ RpcCall v i ListAccounts (AccountsParams w)
|
|
else pure $ RpcCall v i ListAccounts BadParams
|
|
_anyOther -> pure $ RpcCall v i ListAccounts BadParams
|
|
|
|
type ZenithRPC
|
|
= "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody
|
|
'[ JSON]
|
|
RpcCall :> Post '[ JSON] ZenithResponse
|
|
|
|
zenithServer :: Config -> Server ZenithRPC
|
|
zenithServer config = getinfo :<|> handleRPC
|
|
where
|
|
getinfo :: Handler Value
|
|
getinfo =
|
|
return $
|
|
object
|
|
[ "version" .= ("0.7.0.0-beta" :: String)
|
|
, "network" .= ("testnet" :: String)
|
|
]
|
|
handleRPC :: Bool -> RpcCall -> Handler ZenithResponse
|
|
handleRPC isAuth req =
|
|
case method req of
|
|
UnknownMethod ->
|
|
return $ ErrorResponse (callId req) (-32601) "Method not found"
|
|
ListWallets ->
|
|
case parameters req of
|
|
BlankParams -> do
|
|
let dbPath = c_dbPath config
|
|
let host = c_zebraHost config
|
|
let port = c_zebraPort config
|
|
bc <-
|
|
liftIO $ try $ checkBlockChain host port :: Handler
|
|
(Either IOError ZebraGetBlockChainInfo)
|
|
case bc of
|
|
Left _e1 ->
|
|
return $
|
|
ErrorResponse (callId req) (-32000) "Zebra not available"
|
|
Right chainInfo -> do
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
walList <- liftIO $ getWallets pool $ zgb_net chainInfo
|
|
if not (null walList)
|
|
then return $
|
|
WalletListResponse
|
|
(callId req)
|
|
(map toZcashWalletAPI walList)
|
|
else return $
|
|
ErrorResponse
|
|
(callId req)
|
|
(-32001)
|
|
"No wallets available. Please create one first"
|
|
_anyOther ->
|
|
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
|
ListAccounts ->
|
|
case parameters req of
|
|
AccountsParams w -> do
|
|
let dbPath = c_dbPath config
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
accList <-
|
|
liftIO $
|
|
runNoLoggingT $ getAccounts pool (toSqlKey $ fromIntegral w)
|
|
if not (null accList)
|
|
then return $
|
|
AccountListResponse
|
|
(callId req)
|
|
(map toZcashAccountAPI accList)
|
|
else return $
|
|
ErrorResponse
|
|
(callId req)
|
|
(-32002)
|
|
"No accounts available for this wallet. Please create one first"
|
|
_anyOther ->
|
|
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
|
GetInfo ->
|
|
case parameters req of
|
|
BlankParams -> do
|
|
let host = c_zebraHost config
|
|
let port = c_zebraPort config
|
|
zInfo <-
|
|
liftIO $ try $ checkZebra host port :: Handler
|
|
(Either IOError ZebraGetInfo)
|
|
case zInfo of
|
|
Left _e ->
|
|
return $
|
|
ErrorResponse (callId req) (-32000) "Zebra not available"
|
|
Right zI -> do
|
|
bInfo <-
|
|
liftIO $ try $ checkBlockChain host port :: Handler
|
|
(Either IOError ZebraGetBlockChainInfo)
|
|
case bInfo of
|
|
Left _e1 ->
|
|
return $
|
|
ErrorResponse (callId req) (-32000) "Zebra not available"
|
|
Right bI ->
|
|
return $
|
|
InfoResponse
|
|
(callId req)
|
|
(ZenithInfo "0.7.0.0-beta" (zgb_net bI) (zgi_build zI))
|
|
_anyOtherParams ->
|
|
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
|
|
|
authenticate :: Config -> BasicAuthCheck Bool
|
|
authenticate config = BasicAuthCheck check
|
|
where
|
|
check (BasicAuthData username password) =
|
|
if username == c_zenithUser config && password == c_zenithPwd config
|
|
then return $ Authorized True
|
|
else return Unauthorized
|