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 Servant
import ZcashHaskell.Types
  ( RpcError(..)
  , ZcashNet(..)
  , ZebraGetBlockChainInfo(..)
  , ZebraGetInfo(..)
  )
import Zenith.Core (checkBlockChain, checkZebra)
import Zenith.DB (getWallets, initDb, initPool, toZcashWalletAPI)
import Zenith.Types (Config(..), ZcashWalletAPI(..))

data ZenithMethod
  = GetInfo
  | ListWallets
  | UnknownMethod
  deriving (Eq, Prelude.Show)

instance ToJSON ZenithMethod where
  toJSON GetInfo = Data.Aeson.String "getinfo"
  toJSON ListWallets = Data.Aeson.String "listwallets"
  toJSON UnknownMethod = Data.Aeson.Null

instance FromJSON ZenithMethod where
  parseJSON =
    withText "ZenithMethod" $ \case
      "getinfo" -> pure GetInfo
      "listwallets" -> pure ListWallets
      _ -> pure UnknownMethod

data ZenithParams
  = BlankParams
  | BadParams
  | TestParams !T.Text
  deriving (Eq, Prelude.Show)

instance ToJSON ZenithParams where
  toJSON BlankParams = Data.Aeson.Array V.empty
  toJSON BadParams = Data.Aeson.Null
  toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t]

data ZenithResponse
  = InfoResponse !T.Text !ZenithInfo
  | WalletListResponse !T.Text ![ZcashWalletAPI]
  | 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 (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

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"
        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