Add Zenith server executable

This commit is contained in:
Rene Vergara 2024-08-03 07:01:11 -05:00
parent abf02cf90d
commit 0d5ff79b96
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
5 changed files with 239 additions and 38 deletions

View file

@ -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

View file

@ -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
View 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

View file

@ -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