zgo-backend/src/ZGoTx.hs

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

module ZGoTx where

import Data.Aeson
import qualified Data.Bson as B
import Data.Char
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.UUID as U
import Data.Void
import Database.MongoDB
import GHC.Generics
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import ZcashHaskell.Orchard
import ZcashHaskell.Sapling (isValidShieldedAddress)

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

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
  bt <- B.lookup "blocktime" d
  pure $ ZGoTx i a s c bt am t m

encodeZGoTxBson :: ZGoTx -> B.Document
encodeZGoTxBson (ZGoTx i a s c bt am t m) =
  if not (null i)
    then [ "_id" =: i
         , "address" =: a
         , "session" =: s
         , "confirmations" =: c
         , "blocktime" =: bt
         , "amount" =: am
         , "txid" =: t
         , "memo" =: m
         ]
    else [ "address" =: a
         , "session" =: s
         , "confirmations" =: c
         , "blocktime" =: bt
         , "amount" =: am
         , "txid" =: t
         , "memo" =: m
         ]

instance Val ZGoTx where
  cast' (Doc 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
    bt <- B.lookup "blocktime" d
    Just (ZGoTx i a s c bt am t m)
  cast' _ = Nothing
  val (ZGoTx i a s c bt am t m) =
    case i of
      Just oid ->
        Doc
          [ "_id" =: i
          , "address" =: a
          , "session" =: s
          , "confirmations" =: c
          , "blocktime" =: bt
          , "amount" =: am
          , "txid" =: t
          , "memo" =: m
          ]
      Nothing ->
        Doc
          [ "address" =: a
          , "session" =: s
          , "confirmations" =: c
          , "blocktime" =: bt
          , "amount" =: am
          , "txid" =: t
          , "memo" =: m
          ]

-- | Type to represent and parse ZGo memos
data ZGoMemo = ZGoMemo
  { m_session :: Maybe U.UUID
  , m_address :: Maybe T.Text
  , m_payment :: Bool
  , m_orderId :: Maybe T.Text
  } deriving (Eq, Show)

data MemoToken
  = Login !U.UUID
  | PayMsg !U.UUID
  | Address !T.Text
  | Msg !T.Text
  | OrderId !T.Text
  deriving (Show, Eq)

type Parser = Parsec Void T.Text

pSession :: Parser MemoToken
pSession = do
  string "ZGO"
  pay <- optional $ char 'p'
  string "::"
  s <- some $ hexDigitChar <|> char '-'
  let u = U.fromString s
  case u of
    Nothing -> fail "Invalid UUID"
    Just u' -> do
      if isJust pay
        then pure $ PayMsg u'
        else pure $ Login u'

pSaplingAddress :: Parser MemoToken
pSaplingAddress = do
  string "zs"
  a <- some alphaNumChar
  if isValidShieldedAddress (E.encodeUtf8 $ "zs" <> T.pack a)
    then pure $ Address $ T.pack ("zs" <> a)
    else fail "Failed to parse Sapling address"

pUnifiedAddress :: Parser MemoToken
pUnifiedAddress = do
  string "u1"
  a <- some alphaNumChar
  if isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a)
    then pure $ Address $ T.pack ("u1" <> a)
    else fail "Failed to parse Unified Address"

pOrderId :: Parser MemoToken
pOrderId = do
  string "ZGo Order::"
  a <- some hexDigitChar
  pure $ OrderId . T.pack $ a

pMsg :: Parser MemoToken
pMsg = do
  msg <-
    some
      (alphaNumChar <|> punctuationChar <|> symbolChar <|>
       charCategory OtherSymbol)
  pure $ Msg . T.pack $ msg

pMemo :: Parser MemoToken
pMemo = do
  optional $ some spaceChar
  t <- pSession <|> pSaplingAddress <|> pUnifiedAddress <|> pOrderId <|> pMsg
  optional $ some spaceChar
  return t

isMemoToken :: T.Text -> MemoToken -> Bool
isMemoToken kind t =
  case kind of
    "session" ->
      case t of
        PayMsg i -> True
        Login j -> True
        _ -> False
    "address" ->
      case t of
        Address a -> True
        _ -> False
    "payment" ->
      case t of
        PayMsg i -> True
        _ -> False
    _ -> False

pZGoMemo :: Parser ZGoMemo
pZGoMemo = do
  tks <- some pMemo
  pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks) (isOrder tks)
  where
    isOrder [] = Nothing
    isOrder tks =
      if not (null tks)
        then case head tks of
               OrderId x -> Just x
               _ -> isOrder $ tail tks
        else Nothing
    isPayment [] = False
    isPayment tks =
      not (null tks) &&
      case head tks of
        PayMsg x -> True
        _ -> isPayment $ tail tks
    isAddress [] = Nothing
    isAddress tks =
      if not (null tks)
        then case head tks of
               Address x -> Just x
               _ -> isAddress $ tail tks
        else Nothing
    isSession [] = Nothing
    isSession tks =
      if not (null tks)
        then case head tks of
               Login x -> Just x
               PayMsg y -> Just y
               _ -> isSession $ tail tks
        else Nothing