Add Zenith server executable
This commit is contained in:
parent
abf02cf90d
commit
0d5ff79b96
5 changed files with 239 additions and 38 deletions
|
@ -11,23 +11,26 @@
|
|||
|
||||
module Zenith.RPC where
|
||||
|
||||
import Control.Exception (try)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Aeson
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
import GHC.Generics (Generic)
|
||||
import Servant
|
||||
import ZcashHaskell.Types (RpcError(..), RpcResponse(..))
|
||||
import ZcashHaskell.Types (ZebraGetBlockChainInfo(..), ZebraGetInfo(..))
|
||||
import Zenith.Core (checkBlockChain, checkZebra)
|
||||
import Zenith.Types
|
||||
( Config(..)
|
||||
, RpcCall(..)
|
||||
, ZenithInfo(..)
|
||||
, ZenithMethod(..)
|
||||
, ZenithParams(..)
|
||||
, ZenithResponse(..)
|
||||
)
|
||||
|
||||
type ZenithRPC
|
||||
= "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody
|
||||
'[ JSON]
|
||||
RpcCall :> Post '[ JSON] (RpcResponse Value)
|
||||
RpcCall :> Post '[ JSON] ZenithResponse
|
||||
|
||||
zenithServer :: Config -> Server ZenithRPC
|
||||
zenithServer config = getinfo :<|> handleRPC
|
||||
|
@ -39,40 +42,38 @@ zenithServer config = getinfo :<|> handleRPC
|
|||
[ "version" .= ("0.7.0.0-beta" :: String)
|
||||
, "network" .= ("testnet" :: String)
|
||||
]
|
||||
handleRPC :: Bool -> RpcCall -> Handler (RpcResponse Value)
|
||||
handleRPC :: Bool -> RpcCall -> Handler ZenithResponse
|
||||
handleRPC isAuth req =
|
||||
case method req of
|
||||
UnknownMethod ->
|
||||
return $
|
||||
MakeRpcResponse
|
||||
(Just $ RpcError (-32601) "Method not found")
|
||||
(callId req)
|
||||
Nothing
|
||||
return $ ErrorResponse (callId req) (-32601) "Method not found"
|
||||
GetInfo ->
|
||||
case parameters req of
|
||||
BlankParams ->
|
||||
return $
|
||||
MakeRpcResponse
|
||||
Nothing
|
||||
(callId req)
|
||||
(Just $ object ["data" .= ("Here's your info" :: String)])
|
||||
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 $
|
||||
MakeRpcResponse
|
||||
(Just $ RpcError (-32602) "Invalid params")
|
||||
(callId req)
|
||||
Nothing
|
||||
Test ->
|
||||
case parameters req of
|
||||
TestParams x ->
|
||||
return $
|
||||
MakeRpcResponse Nothing (callId req) (Just $ object ["data" .= x])
|
||||
_anyOtherParams ->
|
||||
return $
|
||||
MakeRpcResponse
|
||||
(Just $ RpcError (-32602) "Invalid params")
|
||||
(callId req)
|
||||
Nothing
|
||||
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
||||
|
||||
authenticate :: Config -> BasicAuthCheck Bool
|
||||
authenticate config = BasicAuthCheck check
|
||||
|
|
|
@ -18,11 +18,13 @@ import Data.Maybe (fromMaybe)
|
|||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Vector as V
|
||||
import Database.Persist.TH
|
||||
import GHC.Generics
|
||||
import ZcashHaskell.Types
|
||||
( OrchardSpendingKey(..)
|
||||
, Phrase(..)
|
||||
, RpcError(..)
|
||||
, Rseed(..)
|
||||
, SaplingSpendingKey(..)
|
||||
, Scope(..)
|
||||
|
@ -100,15 +102,17 @@ data Config = Config
|
|||
-- ** Zenith methods
|
||||
data ZenithMethod
|
||||
= GetInfo
|
||||
| Test
|
||||
| UnknownMethod
|
||||
deriving (Eq, Prelude.Show)
|
||||
|
||||
instance ToJSON ZenithMethod where
|
||||
toJSON GetInfo = Data.Aeson.String "getinfo"
|
||||
toJSON UnknownMethod = Data.Aeson.Null
|
||||
|
||||
instance FromJSON ZenithMethod where
|
||||
parseJSON =
|
||||
withText "ZenithMethod" $ \case
|
||||
"getinfo" -> pure GetInfo
|
||||
"test" -> pure Test
|
||||
_ -> pure UnknownMethod
|
||||
|
||||
data ZenithParams
|
||||
|
@ -117,6 +121,71 @@ data ZenithParams
|
|||
| TestParams !T.Text
|
||||
deriving (Eq, Prelude.Show)
|
||||
|
||||
instance ToJSON ZenithParams where
|
||||
toJSON BlankParams = Data.Aeson.Array V.empty
|
||||
toJSON BadParams = Data.Aeson.Null
|
||||
toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t]
|
||||
|
||||
data ZenithResponse
|
||||
= InfoResponse !T.Text !ZenithInfo
|
||||
| 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 (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 -> undefined
|
||||
_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
|
||||
|
@ -125,6 +194,10 @@ data RpcCall = RpcCall
|
|||
, 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
|
||||
|
@ -138,9 +211,6 @@ instance FromJSON RpcCall where
|
|||
if null (p :: [Value])
|
||||
then pure $ RpcCall v i GetInfo BlankParams
|
||||
else pure $ RpcCall v i GetInfo BadParams
|
||||
Test -> do
|
||||
p <- obj .: "params"
|
||||
pure $ RpcCall v i Test (TestParams $ head p)
|
||||
|
||||
-- ** `zebrad`
|
||||
-- | Type for modeling the tree state response
|
||||
|
|
100
test/ServerSpec.hs
Normal file
100
test/ServerSpec.hs
Normal file
|
@ -0,0 +1,100 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Exception (SomeException, try)
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Configurator
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Network.HTTP.Simple
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Servant
|
||||
import Test.HUnit
|
||||
import Test.Hspec
|
||||
import ZcashHaskell.Types (ZcashNet(..))
|
||||
import Zenith.RPC (ZenithRPC(..), authenticate, zenithServer)
|
||||
import Zenith.Types
|
||||
( Config(..)
|
||||
, RpcCall(..)
|
||||
, ZenithInfo(..)
|
||||
, ZenithMethod(..)
|
||||
, ZenithParams(..)
|
||||
, ZenithResponse(..)
|
||||
)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
config <- load ["$(HOME)/Zenith/zenith.cfg"]
|
||||
dbFilePath <- require config "dbFilePath"
|
||||
nodeUser <- require config "nodeUser"
|
||||
nodePwd <- require config "nodePwd"
|
||||
zebraPort <- require config "zebraPort"
|
||||
zebraHost <- require config "zebraHost"
|
||||
nodePort <- require config "nodePort"
|
||||
let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort
|
||||
hspec $ do
|
||||
describe "RPC methods" $ do
|
||||
beforeAll_ (startAPI myConfig) $ do
|
||||
describe "getinfo" $ do
|
||||
it "bad credentials" $ do
|
||||
res <-
|
||||
makeZenithCall
|
||||
"127.0.0.1"
|
||||
nodePort
|
||||
"baduser"
|
||||
"idontknow"
|
||||
GetInfo
|
||||
BlankParams
|
||||
res `shouldBe` Left "Invalid credentials"
|
||||
it "correct credentials" $ do
|
||||
res <-
|
||||
makeZenithCall
|
||||
"127.0.0.1"
|
||||
nodePort
|
||||
nodeUser
|
||||
nodePwd
|
||||
GetInfo
|
||||
BlankParams
|
||||
case res of
|
||||
Left e -> assertFailure e
|
||||
Right r ->
|
||||
r `shouldBe`
|
||||
InfoResponse "zh" (ZenithInfo "0.7.0.0-beta" TestNet "v1.8.0")
|
||||
|
||||
startAPI :: Config -> IO ()
|
||||
startAPI config = do
|
||||
putStrLn "Starting test RPC server"
|
||||
let ctx = authenticate config :. EmptyContext
|
||||
forkIO $
|
||||
run (c_zenithPort config) $
|
||||
serveWithContext
|
||||
(Servant.Proxy :: Servant.Proxy ZenithRPC)
|
||||
ctx
|
||||
(zenithServer config)
|
||||
threadDelay 1000000
|
||||
putStrLn "Test server is up!"
|
||||
|
||||
-- | Make a Zebra RPC call
|
||||
makeZenithCall ::
|
||||
T.Text -- ^ Hostname for `zebrad`
|
||||
-> Int -- ^ Port for `zebrad`
|
||||
-> BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> ZenithMethod -- ^ RPC method to call
|
||||
-> ZenithParams -- ^ List of parameters
|
||||
-> IO (Either String ZenithResponse)
|
||||
makeZenithCall host port usr pwd m params = do
|
||||
let payload = RpcCall "2.0" "zh" m params
|
||||
let myRequest =
|
||||
setRequestBodyJSON payload $
|
||||
setRequestPort port $
|
||||
setRequestHost (E.encodeUtf8 host) $
|
||||
setRequestBasicAuth usr pwd $ setRequestMethod "POST" defaultRequest
|
||||
r <- httpJSONEither myRequest
|
||||
case getResponseStatusCode r of
|
||||
403 -> return $ Left "Invalid credentials"
|
||||
200 ->
|
||||
case getResponseBody r of
|
||||
Left e -> return $ Left $ show e
|
||||
Right r' -> return $ Right r'
|
|
@ -1 +1 @@
|
|||
Subproject commit e8074419cfb54559a4c09731ad2448d5930869a2
|
||||
Subproject commit cc72fadef36ee8ac235dfd9b8bea4de4ce3122bf
|
30
zenith.cabal
30
zenith.cabal
|
@ -166,3 +166,33 @@ test-suite zenith-tests
|
|||
, zenith
|
||||
pkgconfig-depends: rustzcash_wrapper
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite zenithserver-tests
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
main-is: ServerSpec.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, bytestring
|
||||
, aeson
|
||||
, configurator
|
||||
, monad-logger
|
||||
, data-default
|
||||
, sort
|
||||
, text
|
||||
, time
|
||||
, http-conduit
|
||||
, persistent
|
||||
, persistent-sqlite
|
||||
, hspec
|
||||
, hexstring
|
||||
, warp
|
||||
, servant-server
|
||||
, HUnit
|
||||
, directory
|
||||
, zcash-haskell
|
||||
, zenith
|
||||
pkgconfig-depends: rustzcash_wrapper
|
||||
default-language: Haskell2010
|
||||
|
|
Loading…
Reference in a new issue