zenith/src/Zenith/RPC.hs

{-# 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
  , getAddresses
  , getWallets
  , initDb
  , 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 -> undefined
            _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]