zenith/src/Zenith/RPC.hs

376 lines
13 KiB
Haskell
Raw Normal View History

2024-07-23 18:46:37 +00:00
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
2024-07-24 21:03:49 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
2024-08-05 17:54:02 +00:00
{-# LANGUAGE LambdaCase #-}
2024-07-23 18:46:37 +00:00
module Zenith.RPC where
2024-08-03 12:01:11 +00:00
import Control.Exception (try)
import Control.Monad.IO.Class (liftIO)
2024-08-05 17:54:02 +00:00
import Control.Monad.Logger (runNoLoggingT)
2024-07-23 18:46:37 +00:00
import Data.Aeson
import qualified Data.Text as T
2024-08-05 17:54:02 +00:00
import qualified Data.Vector as V
2024-08-06 18:38:00 +00:00
import Database.Esqueleto.Experimental (toSqlKey)
2024-07-23 18:46:37 +00:00
import Servant
2024-08-05 17:54:02 +00:00
import ZcashHaskell.Types
( RpcError(..)
, ZcashNet(..)
, ZebraGetBlockChainInfo(..)
, ZebraGetInfo(..)
2024-07-24 21:03:49 +00:00
)
2024-08-05 17:54:02 +00:00
import Zenith.Core (checkBlockChain, checkZebra)
2024-08-06 18:38:00 +00:00
import Zenith.DB
( getAccounts
2024-08-07 15:21:04 +00:00
, getAddresses
2024-08-06 18:38:00 +00:00
, getWallets
, initDb
, initPool
, toZcashAccountAPI
2024-08-07 15:21:04 +00:00
, toZcashAddressAPI
2024-08-06 18:38:00 +00:00
, toZcashWalletAPI
)
2024-08-07 15:21:04 +00:00
import Zenith.Types
( Config(..)
, ZcashAccountAPI(..)
, ZcashAddressAPI(..)
2024-08-10 12:04:40 +00:00
, ZcashNoteAPI(..)
2024-08-07 15:21:04 +00:00
, ZcashWalletAPI(..)
)
2024-08-06 18:38:00 +00:00
import Zenith.Utils (jsonNumber)
2024-08-05 17:54:02 +00:00
data ZenithMethod
= GetInfo
| ListWallets
2024-08-06 18:38:00 +00:00
| ListAccounts
2024-08-07 15:21:04 +00:00
| ListAddresses
2024-08-10 12:04:40 +00:00
| ListReceived
2024-08-05 17:54:02 +00:00
| UnknownMethod
deriving (Eq, Prelude.Show)
instance ToJSON ZenithMethod where
toJSON GetInfo = Data.Aeson.String "getinfo"
toJSON ListWallets = Data.Aeson.String "listwallets"
2024-08-06 18:38:00 +00:00
toJSON ListAccounts = Data.Aeson.String "listaccounts"
2024-08-07 15:21:04 +00:00
toJSON ListAddresses = Data.Aeson.String "listaddresses"
2024-08-10 12:04:40 +00:00
toJSON ListReceived = Data.Aeson.String "listreceived"
2024-08-05 17:54:02 +00:00
toJSON UnknownMethod = Data.Aeson.Null
instance FromJSON ZenithMethod where
parseJSON =
withText "ZenithMethod" $ \case
"getinfo" -> pure GetInfo
"listwallets" -> pure ListWallets
2024-08-06 18:38:00 +00:00
"listaccounts" -> pure ListAccounts
2024-08-07 15:21:04 +00:00
"listaddresses" -> pure ListAddresses
2024-08-10 12:04:40 +00:00
"listreceived" -> pure ListReceived
2024-08-05 17:54:02 +00:00
_ -> pure UnknownMethod
data ZenithParams
= BlankParams
| BadParams
2024-08-06 18:38:00 +00:00
| AccountsParams !Int
2024-08-07 15:21:04 +00:00
| AddressesParams !Int
2024-08-10 12:04:40 +00:00
| NotesParams !T.Text
2024-08-05 17:54:02 +00:00
| TestParams !T.Text
deriving (Eq, Prelude.Show)
instance ToJSON ZenithParams where
toJSON BlankParams = Data.Aeson.Array V.empty
toJSON BadParams = Data.Aeson.Null
2024-08-06 18:38:00 +00:00
toJSON (AccountsParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n]
2024-08-07 15:21:04 +00:00
toJSON (AddressesParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n]
2024-08-05 17:54:02 +00:00
toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t]
2024-08-10 12:04:40 +00:00
toJSON (NotesParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t]
2024-08-05 17:54:02 +00:00
data ZenithResponse
= InfoResponse !T.Text !ZenithInfo
| WalletListResponse !T.Text ![ZcashWalletAPI]
2024-08-06 18:38:00 +00:00
| AccountListResponse !T.Text ![ZcashAccountAPI]
2024-08-07 15:21:04 +00:00
| AddressListResponse !T.Text ![ZcashAddressAPI]
2024-08-10 12:04:40 +00:00
| NoteListResponse !T.Text ![ZcashNoteAPI]
2024-08-05 17:54:02 +00:00
| ErrorResponse !T.Text !Double !T.Text
deriving (Eq, Prelude.Show)
instance ToJSON ZenithResponse where
2024-08-10 12:04:40 +00:00
toJSON (InfoResponse t i) = packRpcResponse t i
toJSON (WalletListResponse i w) = packRpcResponse i w
toJSON (AccountListResponse i a) = packRpcResponse i a
toJSON (AddressListResponse i a) = packRpcResponse i a
toJSON (NoteListResponse i n) = packRpcResponse i n
2024-08-05 17:54:02 +00:00
toJSON (ErrorResponse i c m) =
object
[ "jsonrpc" .= ("2.0" :: String)
, "id" .= i
, "error" .= object ["code" .= c, "message" .= m]
]
instance FromJSON ZenithResponse where
parseJSON =
2024-08-10 12:04:40 +00:00
withObject "ZenithResponse" $ \obj -> do
2024-08-05 17:54:02 +00:00
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 -> do
if V.null n
then fail "Malformed JSON"
else do
case V.head n of
Object n' -> do
v1 <- n' .:? "lastSync"
2024-08-07 15:21:04 +00:00
v2 <- n' .:? "wallet"
2024-08-10 12:04:40 +00:00
v3 <- n' .:? "ua"
2024-08-05 17:54:02 +00:00
case (v1 :: Maybe Int) of
Just _v1' -> do
k2 <- parseJSON r1
pure $ WalletListResponse i k2
2024-08-07 15:21:04 +00:00
Nothing ->
case (v2 :: Maybe Int) of
Just _v2' -> do
k3 <- parseJSON r1
pure $ AccountListResponse i k3
2024-08-10 12:04:40 +00:00
Nothing ->
case (v3 :: Maybe String) of
Just _v3' -> do
k4 <- parseJSON r1
pure $ AddressListResponse i k4
Nothing -> fail "Unknown object"
2024-08-05 17:54:02 +00:00
_anyOther -> fail "Malformed JSON"
_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
, callId :: !T.Text
, method :: !ZenithMethod
, 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
v <- obj .: "jsonrpc"
i <- obj .: "id"
m <- obj .: "method"
case m of
UnknownMethod -> pure $ RpcCall v i UnknownMethod BlankParams
ListWallets -> do
p <- obj .: "params"
if null (p :: [Value])
then pure $ RpcCall v i ListWallets BlankParams
else pure $ RpcCall v i ListWallets BadParams
GetInfo -> do
p <- obj .: "params"
if null (p :: [Value])
then pure $ RpcCall v i GetInfo BlankParams
else pure $ RpcCall v i GetInfo BadParams
2024-08-06 18:38:00 +00:00
ListAccounts -> do
p <- obj .: "params"
case p of
Array a ->
if V.length a == 1
then do
w <- parseJSON $ V.head a
pure $ RpcCall v i ListAccounts (AccountsParams w)
else pure $ RpcCall v i ListAccounts BadParams
_anyOther -> pure $ RpcCall v i ListAccounts BadParams
2024-08-07 15:21:04 +00:00
ListAddresses -> do
p <- obj .: "params"
case p of
Array a ->
if V.length a == 1
then do
x <- parseJSON $ V.head a
pure $ RpcCall v i ListAddresses (AddressesParams x)
else pure $ RpcCall v i ListAddresses BadParams
_anyOther -> pure $ RpcCall v i ListAddresses BadParams
2024-08-10 12:04:40 +00:00
ListReceived -> do
p <- obj .: "params"
case p of
Array a ->
if V.length a == 1
then do
x <- parseJSON $ V.head a
pure $ RpcCall v i ListReceived (NotesParams x)
else pure $ RpcCall v i ListReceived BadParams
_anyOther -> pure $ RpcCall v i ListReceived BadParams
2024-07-23 18:46:37 +00:00
type ZenithRPC
2024-07-24 21:13:13 +00:00
= "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody
2024-07-23 18:46:37 +00:00
'[ JSON]
2024-08-03 12:01:11 +00:00
RpcCall :> Post '[ JSON] ZenithResponse
2024-07-23 18:46:37 +00:00
2024-07-24 21:03:49 +00:00
zenithServer :: Config -> Server ZenithRPC
zenithServer config = getinfo :<|> handleRPC
2024-07-23 18:46:37 +00:00
where
getinfo :: Handler Value
getinfo =
return $
object
[ "version" .= ("0.7.0.0-beta" :: String)
, "network" .= ("testnet" :: String)
]
2024-08-03 12:01:11 +00:00
handleRPC :: Bool -> RpcCall -> Handler ZenithResponse
2024-07-24 21:13:13 +00:00
handleRPC isAuth req =
2024-07-23 18:46:37 +00:00
case method req of
2024-07-24 21:03:49 +00:00
UnknownMethod ->
2024-08-03 12:01:11 +00:00
return $ ErrorResponse (callId req) (-32601) "Method not found"
2024-08-05 17:54:02 +00:00
ListWallets ->
case parameters req of
BlankParams -> do
let dbPath = c_dbPath config
let host = c_zebraHost config
let port = c_zebraPort config
bc <-
liftIO $ try $ checkBlockChain host port :: Handler
(Either IOError ZebraGetBlockChainInfo)
case bc of
Left _e1 ->
return $
ErrorResponse (callId req) (-32000) "Zebra not available"
Right chainInfo -> do
pool <- liftIO $ runNoLoggingT $ initPool dbPath
walList <- liftIO $ getWallets pool $ zgb_net chainInfo
if not (null walList)
then return $
WalletListResponse
(callId req)
(map toZcashWalletAPI walList)
else return $
ErrorResponse
(callId req)
(-32001)
"No wallets available. Please create one first"
_anyOther ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
2024-08-06 18:38:00 +00:00
ListAccounts ->
case parameters req of
AccountsParams w -> do
let dbPath = c_dbPath config
pool <- liftIO $ runNoLoggingT $ initPool dbPath
accList <-
liftIO $
runNoLoggingT $ getAccounts pool (toSqlKey $ fromIntegral w)
if not (null accList)
then return $
AccountListResponse
(callId req)
(map toZcashAccountAPI accList)
else return $
ErrorResponse
(callId req)
(-32002)
"No accounts available for this wallet. Please create one first"
_anyOther ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
2024-08-07 15:21:04 +00:00
ListAddresses ->
case parameters req of
AddressesParams a -> do
let dbPath = c_dbPath config
pool <- liftIO $ runNoLoggingT $ initPool dbPath
addrList <-
liftIO $
runNoLoggingT $ getAddresses pool (toSqlKey $ fromIntegral a)
if not (null addrList)
then return $
AddressListResponse
(callId req)
(map toZcashAddressAPI addrList)
else return $
ErrorResponse
(callId req)
(-32003)
"No addresses available for this account. Please create one first"
_anyOther ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
2024-07-23 18:46:37 +00:00
GetInfo ->
case parameters req of
2024-08-03 12:01:11 +00:00
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
2024-08-05 17:54:02 +00:00
Left _e ->
2024-08-03 12:01:11 +00:00
return $
ErrorResponse (callId req) (-32000) "Zebra not available"
Right zI -> do
bInfo <-
liftIO $ try $ checkBlockChain host port :: Handler
(Either IOError ZebraGetBlockChainInfo)
case bInfo of
2024-08-05 17:54:02 +00:00
Left _e1 ->
2024-08-03 12:01:11 +00:00
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))
2024-07-23 18:46:37 +00:00
_anyOtherParams ->
2024-08-03 12:01:11 +00:00
return $ ErrorResponse (callId req) (-32602) "Invalid params"
2024-08-10 12:04:40 +00:00
ListReceived ->
case parameters req of
NotesParams x -> undefined
_anyOtherParams ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
2024-07-24 21:03:49 +00:00
authenticate :: Config -> BasicAuthCheck Bool
authenticate config = BasicAuthCheck check
where
check (BasicAuthData username password) =
if username == c_zenithUser config && password == c_zenithPwd config
then return $ Authorized True
else return Unauthorized
2024-08-10 12:04:40 +00:00
packRpcResponse :: ToJSON a => T.Text -> a -> Value
packRpcResponse i x =
object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= x]