Start RPC server

CHANGELOG.md

@@ -5,6 +5,12 @@ All notable changes to this project will be documented in this file.
 The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
 and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
 
+## [Unreleased]
+
+### Added
+
+- RPC module
+
 ## [0.6.0.0-beta]
 
 ### Added

app/Server.hs

@@ -0,0 +1,8 @@
+module Server where
+
+import Network.Wai.Handler.Warp (run)
+import Servant
+import Zenith.RPC (ZenithRPC(..), zenithServer)
+
+main :: IO ()
+main = run 8081 (serve (Proxy :: Proxy ZenithRPC) zenithServer)

cabal.project.freeze

@@ -41,8 +41,8 @@ constraints: any.Cabal ==3.10.3.0,
              any.authenticate-oauth ==1.7,
              any.auto-update ==0.2.1,
              any.base ==4.18.2.1,
-             any.base-compat ==0.14.0,
+             any.base-compat ==0.13.1,
-             any.base-compat-batteries ==0.14.0,
+             any.base-compat-batteries ==0.13.1,
              any.base-orphans ==0.9.2,
              any.base16 ==1.0,
              any.base16-bytestring ==1.0.2.0,
@@ -59,9 +59,12 @@ constraints: any.Cabal ==3.10.3.0,
              any.blaze-builder ==0.4.2.3,
              any.blaze-html ==0.9.2.0,
              any.blaze-markup ==0.8.3.0,
+             any.boring ==0.2.2,
+             boring +tagged,
              any.borsh ==0.3.0,
              any.brick ==2.4,
              brick -demos,
+             any.bsb-http-chunked ==0.0.0.4,
              any.byteorder ==1.0.4,
              any.bytes ==0.17.3,
              any.bytestring ==0.11.5.3,
@@ -90,6 +93,7 @@ constraints: any.Cabal ==3.10.3.0,
              config-ini -enable-doctests,
              any.configurator ==0.3.0.0,
              configurator -developer,
+             any.constraints ==0.14.2,
              any.containers ==0.6.7,
              any.contravariant ==1.5.5,
              contravariant +semigroups +statevar +tagged,
@@ -113,6 +117,7 @@ constraints: any.Cabal ==3.10.3.0,
              any.data-default-instances-dlist ==0.0.1,
              any.data-default-instances-old-locale ==0.0.1,
              any.data-fix ==0.3.4,
+             any.dec ==0.0.6,
              any.deepseq ==1.4.8.1,
              any.directory ==1.3.8.4,
              any.distributive ==0.6.2.1,
@@ -129,6 +134,7 @@ constraints: any.Cabal ==3.10.3.0,
              any.exceptions ==0.10.7,
              any.extra ==1.7.16,
              any.fast-logger ==3.2.3,
+             any.file-embed ==0.0.16.0,
              any.filepath ==1.4.300.1,
              any.fixed ==0.3,
              any.foreign-rust ==0.1.0,
@@ -169,7 +175,12 @@ constraints: any.Cabal ==3.10.3.0,
              any.http-client-tls ==0.3.6.3,
              any.http-conduit ==2.3.8.3,
              http-conduit +aeson,
+             any.http-date ==0.0.11,
+             any.http-media ==0.8.1.1,
+             any.http-semantics ==0.1.2,
              any.http-types ==0.12.4,
+             any.http2 ==5.2.6,
+             http2 -devel -h2spec,
              any.indexed-traversable ==0.1.4,
              any.indexed-traversable-instances ==0.1.2,
              any.integer-conversion ==0.1.1,
@@ -196,6 +207,7 @@ constraints: any.Cabal ==3.10.3.0,
              any.microlens-mtl ==0.2.0.3,
              any.microlens-th ==0.4.3.15,
              any.mime-types ==0.1.2.0,
+             any.mmorph ==1.2.0,
              any.monad-control ==1.0.3.1,
              any.monad-logger ==0.3.40,
              monad-logger +template_haskell,
@@ -210,9 +222,13 @@ constraints: any.Cabal ==3.10.3.0,
              nanovg -examples -gl2 -gles3 -stb_truetype,
              any.network ==3.2.1.0,
              network -devel,
+             any.network-byte-order ==0.1.7,
+             any.network-control ==0.1.1,
              any.network-uri ==2.6.4.2,
              any.old-locale ==1.0.0.7,
              any.old-time ==1.1.0.4,
+             any.optparse-applicative ==0.18.1.0,
+             optparse-applicative +process,
              any.os-string ==2.0.6,
              any.parallel ==3.2.2.0,
              any.parsec ==3.1.16.1,
@@ -225,6 +241,9 @@ constraints: any.Cabal ==3.10.3.0,
              persistent-sqlite -build-sanity-exe +full-text-search +have-usleep +json1 -systemlib +uri-filenames -use-pkgconfig -use-stat3 +use-stat4,
              any.persistent-template ==2.12.0.0,
              any.pretty ==1.1.3.6,
+             any.prettyprinter ==1.7.1,
+             prettyprinter -buildreadme +text,
+             any.prettyprinter-ansi-terminal ==1.1.3,
              any.primitive ==0.9.0.0,
              any.process ==1.6.19.0,
              any.profunctors ==5.6.2,
@@ -236,6 +255,7 @@ constraints: any.Cabal ==3.10.3.0,
              any.quickcheck-io ==0.2.0,
              any.quickcheck-transformer ==0.3.1.2,
              any.random ==1.2.1.2,
+             any.recv ==0.1.0,
              any.reflection ==2.1.8,
              reflection -slow +template-haskell,
              any.regex-base ==0.94.0.2,
@@ -260,8 +280,15 @@ constraints: any.Cabal ==3.10.3.0,
              semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
              any.serialise ==0.2.6.1,
              serialise +newtime15,
+             any.servant ==0.20.1,
+             any.servant-server ==0.20,
              any.silently ==1.2.5.3,
+             any.simple-sendfile ==0.2.32,
+             simple-sendfile +allow-bsd -fallback,
+             any.singleton-bool ==0.1.8,
              any.socks ==0.6.1,
+             any.some ==1.0.6,
+             some +newtype-unsafe,
              any.sop-core ==0.5.0.2,
              any.sort ==1.0.0.0,
              any.split ==0.2.5,
@@ -296,6 +323,7 @@ constraints: any.Cabal ==3.10.3.0,
              any.time-compat ==1.9.7,
              any.time-locale-compat ==0.1.1.5,
              time-locale-compat -old-locale,
+             any.time-manager ==0.1.0,
              any.tls ==2.1.0,
              tls -devel,
              any.transformers ==0.6.1.0,
@@ -326,9 +354,18 @@ constraints: any.Cabal ==3.10.3.0,
              any.vty-crossplatform ==0.4.0.0,
              vty-crossplatform -demos,
              any.vty-unix ==0.2.0.0,
+             any.wai ==3.2.4,
+             any.wai-app-static ==3.1.9,
+             wai-app-static +crypton -print,
+             any.wai-extra ==3.1.15,
+             wai-extra -build-example,
+             any.wai-logger ==2.4.0,
+             any.warp ==3.4.1,
+             warp +allow-sendfilefd -network-bytestring -warp-debug +x509,
              any.wide-word ==0.1.6.0,
              any.witherable ==0.5,
              any.word-wrap ==0.5,
+             any.word8 ==0.1.3,
              any.wreq ==0.5.4.3,
              wreq -aws -developer +doctest -httpbin,
              any.zlib ==0.7.1.0,

src/Zenith/GUI.hs

@@ -1040,10 +1040,9 @@ handleEvent wenv node model evt =
                    Nothing -> return $ ShowError "No wallet available"
                    Just cW -> do
                      syncWallet (model ^. configuration) cW
-                     return $ SwitchAddr (model ^. selAddr)
-             , Task $ do
                      pool <-
-                   runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
+                       runNoLoggingT $
+                       initPool $ c_dbPath $ model ^. configuration
                      wL <- getWallets pool (model ^. network)
                      return $ LoadWallets wL
              ]

src/Zenith/RPC.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Zenith.RPC where
+
+import Data.Aeson
+import qualified Data.Text as T
+import Servant
+import ZcashHaskell.Types (RpcError(..), RpcResponse(..))
+import Zenith.Types (RpcCall(..), ZenithMethod(..), ZenithParams(..))
+
+type ZenithRPC
+  = "getinfo" :> Get '[ JSON] Value :<|> ReqBody '[ JSON] RpcCall :> Post
+      '[ JSON]
+      (RpcResponse Value)
+
+zenithServer :: Server ZenithRPC
+zenithServer = getinfo :<|> handleRPC
+  where
+    getinfo :: Handler Value
+    getinfo =
+      return $
+      object
+        [ "version" .= ("0.7.0.0-beta" :: String)
+        , "network" .= ("testnet" :: String)
+        ]
+    handleRPC :: RpcCall -> Handler (RpcResponse Value)
+    handleRPC req =
+      case method req of
+        GetInfo ->
+          case parameters req of
+            GetInfoParams ->
+              return $
+              MakeRpcResponse
+                Nothing
+                (callId req)
+                (Just $ object ["data" .= ("Here's your info" :: String)])
+            _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

src/Zenith/Types.hs

@@ -94,6 +94,44 @@ data Config = Config
   , c_zebraPort :: !Int
   } deriving (Eq, Prelude.Show)
 
+-- ** Zenith methods
+data ZenithMethod
+  = GetInfo
+  | Test
+  deriving (Eq, Prelude.Show)
+
+instance FromJSON ZenithMethod where
+  parseJSON =
+    withText "ZenithMethod" $ \case
+      "getinfo" -> pure GetInfo
+      "test" -> pure Test
+      _ -> fail "Invalid method"
+
+data ZenithParams
+  = GetInfoParams
+  | TestParams !T.Text
+  deriving (Eq, Prelude.Show)
+
+-- | 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 FromJSON RpcCall where
+  parseJSON =
+    withObject "RpcCall" $ \obj -> do
+      v <- obj .: "jsonrpc"
+      i <- obj .: "id"
+      m <- obj .: "method"
+      case m of
+        GetInfo -> pure $ RpcCall v i GetInfo GetInfoParams
+        Test -> do
+          p <- obj .: "params"
+          pure $ RpcCall v i Test (TestParams $ head p)
+
 -- ** `zebrad`
 -- | Type for modeling the tree state response
 data ZebraTreeInfo = ZebraTreeInfo

zenith.cabal

@@ -35,6 +35,7 @@ library
     Zenith.Utils
     Zenith.Zcashd
     Zenith.Scanner
+    Zenith.RPC
   hs-source-dirs:
     src
   build-depends:
@@ -80,6 +81,7 @@ library
     , regex-compat
     , regex-posix
     , scientific
+    , servant-server
     , text
     , text-show
     , time
@@ -123,6 +125,20 @@ executable zenscan
   pkgconfig-depends: rustzcash_wrapper
   default-language: Haskell2010
 
+executable zenithserver
+  ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N
+  main-is: Server.hs
+  hs-source-dirs:
+    app
+  build-depends:
+      base >=4.12 && <5
+    , wai-extra
+    , warp
+    , servant-server
+    , zenith
+  pkgconfig-depends: rustzcash_wrapper
+  default-language: Haskell2010
+
 test-suite zenith-tests
   type: exitcode-stdio-1.0
   ghc-options: -threaded -rtsopts -with-rtsopts=-N