{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} module Zenith.RPC where import Control.Exception (try) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (runNoLoggingT) import Data.Aeson import qualified Data.Text as T import qualified Data.Vector as V import Database.Esqueleto.Experimental (toSqlKey) import Servant import ZcashHaskell.Types ( RpcError(..) , ZcashNet(..) , ZebraGetBlockChainInfo(..) , ZebraGetInfo(..) ) import Zenith.Core (checkBlockChain, checkZebra) import Zenith.DB ( getAccounts , getWallets , initDb , initPool , toZcashAccountAPI , toZcashWalletAPI ) import Zenith.Types (Config(..), ZcashAccountAPI(..), ZcashWalletAPI(..)) import Zenith.Utils (jsonNumber) data ZenithMethod = GetInfo | ListWallets | ListAccounts | UnknownMethod deriving (Eq, Prelude.Show) instance ToJSON ZenithMethod where toJSON GetInfo = Data.Aeson.String "getinfo" toJSON ListWallets = Data.Aeson.String "listwallets" toJSON ListAccounts = Data.Aeson.String "listaccounts" toJSON UnknownMethod = Data.Aeson.Null instance FromJSON ZenithMethod where parseJSON = withText "ZenithMethod" $ \case "getinfo" -> pure GetInfo "listwallets" -> pure ListWallets "listaccounts" -> pure ListAccounts _ -> pure UnknownMethod data ZenithParams = BlankParams | BadParams | AccountsParams !Int | TestParams !T.Text deriving (Eq, Prelude.Show) instance ToJSON ZenithParams where toJSON BlankParams = Data.Aeson.Array V.empty toJSON BadParams = Data.Aeson.Null toJSON (AccountsParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n] toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] data ZenithResponse = InfoResponse !T.Text !ZenithInfo | WalletListResponse !T.Text ![ZcashWalletAPI] | AccountListResponse !T.Text ![ZcashAccountAPI] | 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 (WalletListResponse i w) = object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= w] toJSON (AccountListResponse i a) = object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= a] 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 -> do if V.null n then fail "Malformed JSON" else do case V.head n of Object n' -> do v1 <- n' .:? "lastSync" case (v1 :: Maybe Int) of Just _v1' -> do k2 <- parseJSON r1 pure $ WalletListResponse i k2 Nothing -> fail "Unknown object" _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 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 type ZenithRPC = "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody '[ JSON] RpcCall :> Post '[ JSON] ZenithResponse zenithServer :: Config -> Server ZenithRPC zenithServer config = getinfo :<|> handleRPC where getinfo :: Handler Value getinfo = return $ object [ "version" .= ("0.7.0.0-beta" :: String) , "network" .= ("testnet" :: String) ] handleRPC :: Bool -> RpcCall -> Handler ZenithResponse handleRPC isAuth req = case method req of UnknownMethod -> return $ ErrorResponse (callId req) (-32601) "Method not found" 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" 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" GetInfo -> case parameters req of 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 $ ErrorResponse (callId req) (-32602) "Invalid params" 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