diff --git a/src/Zenith/RPC.hs b/src/Zenith/RPC.hs index 9e190e9..30b7f5b 100644 --- a/src/Zenith/RPC.hs +++ b/src/Zenith/RPC.hs @@ -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 diff --git a/src/Zenith/Types.hs b/src/Zenith/Types.hs index 89a7b29..ed2749f 100644 --- a/src/Zenith/Types.hs +++ b/src/Zenith/Types.hs @@ -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 diff --git a/test/ServerSpec.hs b/test/ServerSpec.hs new file mode 100644 index 0000000..52a5a56 --- /dev/null +++ b/test/ServerSpec.hs @@ -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' diff --git a/zcash-haskell b/zcash-haskell index e807441..cc72fad 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit e8074419cfb54559a4c09731ad2448d5930869a2 +Subproject commit cc72fadef36ee8ac235dfd9b8bea4de4ce3122bf diff --git a/zenith.cabal b/zenith.cabal index 57dcb43..e6cccf1 100644 --- a/zenith.cabal +++ b/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