Add Zenith server executable

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

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

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'

zcash-haskell

@@ -1 +1 @@
-Subproject commit e8074419cfb54559a4c09731ad2448d5930869a2
+Subproject commit cc72fadef36ee8ac235dfd9b8bea4de4ce3122bf

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