{-# 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 Data.Int import qualified Data.Text as T import qualified Data.Vector as V import Database.Esqueleto.Experimental (toSqlKey) import Servant import Text.Read (readMaybe) import ZcashHaskell.Types ( RpcError(..) , ZcashNet(..) , ZebraGetBlockChainInfo(..) , ZebraGetInfo(..) ) import Zenith.Core (checkBlockChain, checkZebra) import Zenith.DB ( getAccounts , getAddressById , getAddresses , getWalletNotes , getWallets , initPool , toZcashAccountAPI , toZcashAddressAPI , toZcashWalletAPI ) import Zenith.Types ( Config(..) , ZcashAccountAPI(..) , ZcashAddressAPI(..) , ZcashNoteAPI(..) , ZcashWalletAPI(..) ) import Zenith.Utils (jsonNumber) data ZenithMethod = GetInfo | ListWallets | ListAccounts | ListAddresses | ListReceived | 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 ListAddresses = Data.Aeson.String "listaddresses" toJSON ListReceived = Data.Aeson.String "listreceived" toJSON UnknownMethod = Data.Aeson.Null instance FromJSON ZenithMethod where parseJSON = withText "ZenithMethod" $ \case "getinfo" -> pure GetInfo "listwallets" -> pure ListWallets "listaccounts" -> pure ListAccounts "listaddresses" -> pure ListAddresses "listreceived" -> pure ListReceived _ -> pure UnknownMethod data ZenithParams = BlankParams | BadParams | AccountsParams !Int | AddressesParams !Int | NotesParams !T.Text | 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 (AddressesParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n] toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] toJSON (NotesParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] data ZenithResponse = InfoResponse !T.Text !ZenithInfo | WalletListResponse !T.Text ![ZcashWalletAPI] | AccountListResponse !T.Text ![ZcashAccountAPI] | AddressListResponse !T.Text ![ZcashAddressAPI] | NoteListResponse !T.Text ![ZcashNoteAPI] | ErrorResponse !T.Text !Double !T.Text deriving (Eq, Prelude.Show) instance ToJSON ZenithResponse where 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 toJSON (ErrorResponse i c m) = object [ "jsonrpc" .= ("2.0" :: String) , "id" .= i , "error" .= object ["code" .= c, "message" .= m] ] instance FromJSON ZenithResponse where parseJSON = withObject "ZenithResponse" $ \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" v2 <- n' .:? "wallet" v3 <- n' .:? "ua" case (v1 :: Maybe Int) of Just _v1' -> do k2 <- parseJSON r1 pure $ WalletListResponse i k2 Nothing -> case (v2 :: Maybe Int) of Just _v2' -> do k3 <- parseJSON r1 pure $ AccountListResponse i k3 Nothing -> case (v3 :: Maybe String) of Just _v3' -> do k4 <- parseJSON r1 pure $ AddressListResponse i k4 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 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 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 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" 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" 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" ListReceived -> case parameters req of NotesParams x -> do case (readMaybe (T.unpack x) :: Maybe Int64) of Just x' -> do let dbPath = c_dbPath config pool <- liftIO $ runNoLoggingT $ initPool dbPath a <- liftIO $ getAddressById pool $ toSqlKey x' case a of Just a' -> do nList <- liftIO $ getWalletNotes pool a' return $ NoteListResponse (callId req) nList Nothing -> return $ ErrorResponse (callId req) (-32004) "Address does not belong to the wallet" Nothing -> undefined -- search by address _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 packRpcResponse :: ToJSON a => T.Text -> a -> Value packRpcResponse i x = object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= x]