557 lines
21 KiB
Haskell
557 lines
21 KiB
Haskell
{-# 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 Data.Scientific (floatingOrInteger)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as E
|
|
import qualified Data.Vector as V
|
|
import Database.Esqueleto.Experimental (entityKey, fromSqlKey, toSqlKey)
|
|
import Servant
|
|
import Text.Read (readMaybe)
|
|
import ZcashHaskell.Keys (generateWalletSeedPhrase)
|
|
import ZcashHaskell.Orchard (parseAddress)
|
|
import ZcashHaskell.Types (RpcError(..), ZcashNet(..))
|
|
import Zenith.Core (createZcashAccount)
|
|
import Zenith.DB
|
|
( ZcashAccount(..)
|
|
, ZcashWallet(..)
|
|
, findNotesByAddress
|
|
, getAccountById
|
|
, getAccounts
|
|
, getAddressById
|
|
, getAddresses
|
|
, getExternalAddresses
|
|
, getMaxAccount
|
|
, getPoolBalance
|
|
, getUnconfPoolBalance
|
|
, getWalletNotes
|
|
, getWallets
|
|
, initPool
|
|
, saveAccount
|
|
, saveWallet
|
|
, toZcashAccountAPI
|
|
, toZcashAddressAPI
|
|
, toZcashWalletAPI
|
|
, walletExists
|
|
)
|
|
import Zenith.Types
|
|
( AccountBalance(..)
|
|
, Config(..)
|
|
, PhraseDB(..)
|
|
, ZcashAccountAPI(..)
|
|
, ZcashAddressAPI(..)
|
|
, ZcashNetDB(..)
|
|
, ZcashNoteAPI(..)
|
|
, ZcashWalletAPI(..)
|
|
)
|
|
import Zenith.Utils (jsonNumber)
|
|
|
|
data ZenithMethod
|
|
= GetInfo
|
|
| ListWallets
|
|
| ListAccounts
|
|
| ListAddresses
|
|
| ListReceived
|
|
| GetBalance
|
|
| GetNewWallet
|
|
| GetNewAccount
|
|
| 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 GetBalance = Data.Aeson.String "getbalance"
|
|
toJSON GetNewWallet = Data.Aeson.String "getnewwallet"
|
|
toJSON GetNewAccount = Data.Aeson.String "getnewaccount"
|
|
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
|
|
"getbalance" -> pure GetBalance
|
|
"getnewwallet" -> pure GetNewWallet
|
|
"getnewaccount" -> pure GetNewAccount
|
|
_ -> pure UnknownMethod
|
|
|
|
data ZenithParams
|
|
= BlankParams
|
|
| BadParams
|
|
| AccountsParams !Int
|
|
| AddressesParams !Int
|
|
| NotesParams !T.Text
|
|
| BalanceParams !Int64
|
|
| NameParams !T.Text
|
|
| NameIdParams !T.Text !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 (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]
|
|
toJSON (NameParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t]
|
|
toJSON (NameIdParams t i) =
|
|
Data.Aeson.Array $ V.fromList [Data.Aeson.String t, jsonNumber i]
|
|
toJSON (BalanceParams n) =
|
|
Data.Aeson.Array $ V.fromList [jsonNumber $ fromIntegral n]
|
|
|
|
data ZenithResponse
|
|
= InfoResponse !T.Text !ZenithInfo
|
|
| WalletListResponse !T.Text ![ZcashWalletAPI]
|
|
| AccountListResponse !T.Text ![ZcashAccountAPI]
|
|
| AddressListResponse !T.Text ![ZcashAddressAPI]
|
|
| NoteListResponse !T.Text ![ZcashNoteAPI]
|
|
| BalanceResponse !T.Text !AccountBalance !AccountBalance
|
|
| NewItemResponse !T.Text !Int64
|
|
| 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]
|
|
]
|
|
toJSON (BalanceResponse i c u) =
|
|
packRpcResponse i $ object ["confirmed" .= c, "unconfirmed" .= u]
|
|
toJSON (NewItemResponse i ix) = packRpcResponse i ix
|
|
|
|
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"
|
|
v5 <- k .:? "unconfirmed"
|
|
case (v :: Maybe String) of
|
|
Just _v' -> do
|
|
k1 <- parseJSON r1
|
|
pure $ InfoResponse i k1
|
|
Nothing ->
|
|
case (v5 :: Maybe AccountBalance) of
|
|
Just _v5' -> do
|
|
k6 <- parseJSON r1
|
|
j1 <- k6 .: "confirmed"
|
|
j2 <- k6 .: "unconfirmed"
|
|
pure $ BalanceResponse i j1 j2
|
|
Nothing -> fail "Unknown object"
|
|
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"
|
|
v4 <- n' .:? "amountZats"
|
|
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 ->
|
|
case (v4 :: Maybe Int) of
|
|
Just _v4' -> do
|
|
k5 <- parseJSON r1
|
|
pure $ NoteListResponse i k5
|
|
Nothing -> fail "Unknown object"
|
|
_anyOther -> fail "Malformed JSON"
|
|
Number k -> do
|
|
case floatingOrInteger k of
|
|
Left _e -> fail "Unknown value"
|
|
Right k' -> pure $ NewItemResponse i k'
|
|
_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
|
|
GetBalance -> 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 GetBalance (BalanceParams x)
|
|
else pure $ RpcCall v i GetBalance BadParams
|
|
_anyOther -> pure $ RpcCall v i GetBalance BadParams
|
|
GetNewWallet -> 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 GetNewWallet (NameParams x)
|
|
else pure $ RpcCall v i GetNewWallet BadParams
|
|
_anyOther -> pure $ RpcCall v i GetNewWallet BadParams
|
|
GetNewAccount -> do
|
|
p <- obj .: "params"
|
|
case p of
|
|
Array a ->
|
|
if V.length a == 2
|
|
then do
|
|
x <- parseJSON $ a V.! 0
|
|
y <- parseJSON $ a V.! 1
|
|
pure $ RpcCall v i GetNewAccount (NameIdParams x y)
|
|
else pure $ RpcCall v i GetNewAccount BadParams
|
|
_anyOther -> pure $ RpcCall v i GetNewAccount BadParams
|
|
|
|
type ZenithRPC
|
|
= "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody
|
|
'[ JSON]
|
|
RpcCall :> Post '[ JSON] ZenithResponse
|
|
|
|
data State = State
|
|
{ w_network :: !ZcashNet
|
|
, w_host :: !T.Text
|
|
, w_port :: !Int
|
|
, w_dbPath :: !T.Text
|
|
, w_build :: !T.Text
|
|
, w_startBlock :: !Int
|
|
}
|
|
|
|
zenithServer :: State -> Server ZenithRPC
|
|
zenithServer state = 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
|
|
pool <- liftIO $ runNoLoggingT $ initPool $ w_dbPath state
|
|
walList <- liftIO $ getWallets pool $ w_network state
|
|
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 = w_dbPath state
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
wl <- liftIO $ walletExists pool w
|
|
case wl of
|
|
Just wl' -> do
|
|
accList <-
|
|
liftIO $ runNoLoggingT $ getAccounts pool (entityKey wl')
|
|
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"
|
|
Nothing ->
|
|
return $
|
|
ErrorResponse (callId req) (-32008) "Wallet does not exist."
|
|
_anyOther ->
|
|
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
|
ListAddresses ->
|
|
case parameters req of
|
|
AddressesParams a -> do
|
|
let dbPath = w_dbPath state
|
|
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 ->
|
|
return $
|
|
InfoResponse
|
|
(callId req)
|
|
(ZenithInfo "0.7.0.0-beta" (w_network state) (w_build state))
|
|
_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 = w_dbPath state
|
|
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 ->
|
|
case parseAddress (E.encodeUtf8 x) of
|
|
Nothing ->
|
|
return $
|
|
ErrorResponse
|
|
(callId req)
|
|
(-32005)
|
|
"Unable to parse address"
|
|
Just x' -> do
|
|
let dbPath = w_dbPath state
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
addrs <- liftIO $ getExternalAddresses pool
|
|
nList <-
|
|
liftIO $
|
|
concat <$> mapM (findNotesByAddress pool x') addrs
|
|
return $ NoteListResponse (callId req) nList
|
|
_anyOtherParams ->
|
|
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
|
GetBalance ->
|
|
case parameters req of
|
|
BalanceParams i -> do
|
|
let dbPath = w_dbPath state
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
acc <- liftIO $ getAccountById pool $ toSqlKey i
|
|
case acc of
|
|
Just acc' -> do
|
|
c <- liftIO $ getPoolBalance pool $ entityKey acc'
|
|
u <- liftIO $ getUnconfPoolBalance pool $ entityKey acc'
|
|
return $ BalanceResponse (callId req) c u
|
|
Nothing ->
|
|
return $
|
|
ErrorResponse (callId req) (-32006) "Account does not exist."
|
|
_anyOtherParams ->
|
|
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
|
GetNewWallet ->
|
|
case parameters req of
|
|
NameParams t -> do
|
|
let dbPath = w_dbPath state
|
|
sP <- liftIO generateWalletSeedPhrase
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
r <-
|
|
liftIO $
|
|
saveWallet pool $
|
|
ZcashWallet
|
|
t
|
|
(ZcashNetDB $ w_network state)
|
|
(PhraseDB sP)
|
|
(w_startBlock state)
|
|
0
|
|
case r of
|
|
Nothing ->
|
|
return $
|
|
ErrorResponse
|
|
(callId req)
|
|
(-32007)
|
|
"Entity with that name already exists."
|
|
Just r' ->
|
|
return $
|
|
NewItemResponse (callId req) $ fromSqlKey $ entityKey r'
|
|
_anyOtherParams ->
|
|
return $ ErrorResponse (callId req) (-32602) "Invalid params"
|
|
GetNewAccount ->
|
|
case parameters req of
|
|
NameIdParams t i -> do
|
|
let dbPath = w_dbPath state
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
w <- liftIO $ walletExists pool i
|
|
case w of
|
|
Just w' -> do
|
|
aIdx <- liftIO $ getMaxAccount pool $ entityKey w'
|
|
nAcc <-
|
|
liftIO
|
|
(try $ createZcashAccount t (aIdx + 1) w' :: IO
|
|
(Either IOError ZcashAccount))
|
|
case nAcc of
|
|
Left e ->
|
|
return $
|
|
ErrorResponse (callId req) (-32610) $ T.pack $ show e
|
|
Right nAcc' -> do
|
|
r <- liftIO $ saveAccount pool nAcc'
|
|
case r of
|
|
Nothing ->
|
|
return $
|
|
ErrorResponse
|
|
(callId req)
|
|
(-32007)
|
|
"Entity with that name already exists."
|
|
Just x ->
|
|
return $
|
|
NewItemResponse (callId req) $
|
|
fromSqlKey $ entityKey x
|
|
Nothing ->
|
|
return $
|
|
ErrorResponse (callId req) (-32608) "Wallet does not exist."
|
|
_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]
|