zgo-backend/src/ZGoBackend.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}

module ZGoBackend where

import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Bson as B
import Data.Char
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import Data.Time.Clock
import Database.MongoDB
import GHC.Generics

-- Models for API objects
-- | A type to model Zcash RPC calls
data RpcCall =
  RpcCall
    { jsonrpc :: T.Text
    , callId :: T.Text
    , method :: T.Text
    , parameters :: [T.Text]
    }
  deriving (Show, Generic)

instance ToJSON RpcCall where
  toJSON (RpcCall j c m p) =
    object ["jsonrpc" .= j, "id" .= c, "method" .= m, "params" .= p]

-- | A type to model the response of the Zcash RPC
data RpcResponse r =
  MakeRpcResponse
    { err :: Maybe T.Text
    , respId :: T.Text
    , result :: r
    }
  deriving (Show, Generic, ToJSON)

instance (FromJSON r) => FromJSON (RpcResponse r) where
  parseJSON (Object obj) =
    MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result"
  parseJSON _ = mzero

-- | Type to model a (simplified) block of Zcash blockchain
data Block =
  Block
    { height :: Integer
    , size :: Integer
    }
  deriving (Show, Generic, ToJSON)

instance FromJSON Block where
  parseJSON (Object obj) = Block <$> obj .: "height" <*> obj .: "size"
  parseJSON _ = mzero

-- | Type to model a Zcash shielded transaction
data ZcashTx =
  ZcashTx
    { txid :: T.Text
    , amount :: Double
    , amountZat :: Integer
    , blockheight :: Integer
    , blocktime :: Integer
    , change :: Bool
    , confirmations :: Integer
    , memo :: String
    }
  deriving (Show, Generic)

instance FromJSON ZcashTx where
  parseJSON =
    withObject "ZcashTx" $ \obj -> do
      t <- obj .: "txid"
      a <- obj .: "amount"
      aZ <- obj .: "amountZat"
      bh <- obj .: "blockheight"
      bt <- obj .: "blocktime"
      c <- obj .: "change"
      conf <- obj .: "confirmations"
      m <- obj .: "memo"
      pure $ ZcashTx t a aZ bh bt c conf (decodeHexText m)

instance ToJSON ZcashTx where
  toJSON (ZcashTx t a aZ bh bt c conf m) =
    object
      [ "amount" .= a
      , "amountZat" .= aZ
      , "txid" .= t
      , "blockheight" .= bh
      , "blocktime" .= bt
      , "change" .= c
      , "confirmations" .= conf
      , "memo" .= m
      ]

-- | Helper function to turn a hex-encoded memo strings to readable text
decodeHexText :: String -> String
decodeHexText hexText
  | chunk == "00" = decodeHexText (drop 2 hexText)
  | null chunk = ""
  | otherwise = chr (read ("0x" <> chunk)) : decodeHexText (drop 2 hexText)
  where
    chunk = take 2 hexText

-- Types for the ZGo database documents
-- | Type to model a country for the database's country list
data Country =
  Country
    { _id :: String
    , name :: T.Text
    , code :: T.Text
    }
  deriving (Eq, Show, Generic, ToJSON)

parseCountryBson :: B.Document -> Maybe Country
parseCountryBson d = do
  i <- B.lookup "_id" d
  n <- B.lookup "name" d
  c <- B.lookup "code" d
  pure $ Country (show (i :: B.ObjectId)) n c

data User =
  User
    { _id :: String
    , address :: T.Text
    , session :: T.Text
    , blocktime :: Integer
    , pin :: T.Text
    , validated :: Bool
    , expired :: Bool
    }
  deriving (Eq, Show, Generic, ToJSON)

parseUserBson :: B.Document -> Maybe User
parseUserBson d = do
  i <- B.lookup "_id" d
  a <- B.lookup "address" d
  s <- B.lookup "session" d
  b <- B.lookup "blocktime" d
  p <- B.lookup "pin" d
  v <- B.lookup "validated" d
  e <- B.lookup "expired" d
  pure $ User (show (i :: B.ObjectId)) a s b p v e

-- | Type to model a ZGo transaction
data ZGoTx =
  ZGoTx
    { _id :: String
    , address :: T.Text
    , session :: T.Text
    , confirmations :: Integer
    , amount :: Double
    , txid :: T.Text
    , memo :: T.Text
    }
  deriving (Eq, Show, Generic, ToJSON)

parseZGoTxBson :: B.Document -> Maybe ZGoTx
parseZGoTxBson d = do
  i <- B.lookup "_id" d
  a <- B.lookup "address" d
  s <- B.lookup "session" d
  c <- B.lookup "confirmations" d
  am <- B.lookup "amount" d
  t <- B.lookup "txid" d
  m <- B.lookup "memo" d
  pure $ ZGoTx (show (i :: B.ObjectId)) a s c am t m

-- |Type to model a price in the ZGo database
data ZGoPrice =
  ZGoPrice
    { _id :: String
    , currency :: T.Text
    , price :: Double
    , timestamp :: String
    }
  deriving (Eq, Show, Generic, ToJSON)

parseZGoPrice :: B.Document -> Maybe ZGoPrice
parseZGoPrice d = do
  i <- B.lookup "_id" d
  c <- B.lookup "currency" d
  p <- B.lookup "price" d
  t <- B.lookup "timestamp" d
  pure $ ZGoPrice (show (i :: B.ObjectId)) c p (show (t :: B.Value))

-- | Type for the CoinGecko response
newtype CoinGeckoPrices =
  CoinGeckoPrices [(T.Text, Double)]
  deriving (Eq, Show)

instance FromJSON CoinGeckoPrices where
  parseJSON =
    withObject "CoinGeckoPrices" $ \obj -> do
      z <- obj .: "zcash"
      pure $ CoinGeckoPrices (HM.toList z)

-- Functions for querying the ZGo database
-- | Function to query DB for countries list
listCountries :: Action IO [Document]
listCountries = rest =<< find (select [] "countries")

-- | Function to query DB for unexpired user by session ID
findUser :: String -> Action IO (Maybe Document)
findUser s = findOne (select ["session" =: s, "expired" =: False] "users")

-- | Function to query DB for transactions with less than 10 confirmations
findPending :: String -> Action IO [Document]
findPending s =
  rest =<<
  find
    (select
       ["session" =: s, "confirmations" =: ["$lt" =: (10 :: Integer)]]
       "txs")

-- | Function to query DB for price by currency
findPrice :: String -> Action IO (Maybe Document)
findPrice c = findOne (select ["currency" =: c] "prices")

-- | Function to update prices in ZGo db
updatePrices :: CoinGeckoPrices -> [Action IO ()]
updatePrices (CoinGeckoPrices []) = []
updatePrices (CoinGeckoPrices x) = do
  updateOnePrice (head x) : updatePrices (CoinGeckoPrices (tail x))

-- | Function to update one price in ZGo db
updateOnePrice :: (T.Text, Double) -> Action IO ()
updateOnePrice (c, v) = do
  t <- liftIO getCurrentTime
  upsert
    (select ["currency" =: c] "prices")
    ["currency" =: c, "price" =: v, "timestamp" =: t]