zgo-backend/src/ZGoTx.hs

223 lines
5.3 KiB
Haskell

{-# 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