From e437da2841019cee28c69e55faea9320a31a3655 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 10 Mar 2023 15:31:47 -0600 Subject: [PATCH] Implement memo parser --- app/Tasks.hs | 1 + package.yaml | 5 +++ src/ZGoBackend.hs | 18 +++++++++ src/ZGoTx.hs | 100 ++++++++++++++++++++++++++++++++++++++++++++++ zgo-backend.cabal | 9 ++++- 5 files changed, 131 insertions(+), 2 deletions(-) diff --git a/app/Tasks.hs b/app/Tasks.hs index 402c561..90833a7 100644 --- a/app/Tasks.hs +++ b/app/Tasks.hs @@ -4,6 +4,7 @@ module Tasks where import Config import Database.MongoDB +import Text.Megaparsec hiding (State) import ZGoBackend main :: IO () diff --git a/package.yaml b/package.yaml index bc2b54a..631b58e 100644 --- a/package.yaml +++ b/package.yaml @@ -60,6 +60,8 @@ library: - ghc-prim - network - crypto-rng + - megaparsec + - uuid executables: zgo-backend-exe: @@ -87,6 +89,7 @@ executables: - configurator - warp-tls - warp + - megaparsec zgo-token-refresh: main: TokenRefresh.hs source-dirs: app @@ -113,6 +116,7 @@ executables: - configurator - warp-tls - warp + - megaparsec zgo-tasks: main: Tasks.hs source-dirs: app @@ -130,6 +134,7 @@ executables: - warp-tls - warp - time + - megaparsec tests: zgo-backend-test: diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a37765f..48792e4 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -33,6 +33,7 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Time.Format import Data.Typeable +import qualified Data.UUID as U import qualified Data.Vector as V import Data.Vector.Internal.Check (doChecks) import Data.Word @@ -55,6 +56,7 @@ import System.Random import Test.QuickCheck import Test.QuickCheck.Instances import Test.QuickCheck.Property (Result(ok)) +import Text.Megaparsec (runParser) import Text.Regex import Text.Regex.Base import User @@ -355,6 +357,22 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do ZGoTx Nothing nAddy sess conf bt a t m else ZGoTx Nothing "" "" conf bt a t m +zToZGoTx' :: ZcashTx -> ZGoTx +zToZGoTx' (ZcashTx t a aZ bh bt c conf m) = do + let zM = runParser pZGoMemo (T.unpack t) m + case zM of + Right zM' -> + ZGoTx + Nothing + (fromMaybe "" $ m_address zM') + (maybe "" U.toText $ m_session zM') + conf + bt + a + t + m + Left e -> error "Failed to parse ZGo memo" + -- |Type to model a price in the ZGo database data ZGoPrice = ZGoPrice diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index 0abbe96..4089c3a 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -6,9 +6,15 @@ 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.UUID as U +import Data.Void import Database.MongoDB import GHC.Generics +import Text.Megaparsec hiding (State) +import Text.Megaparsec.Char -- | Type to model a ZGo transaction data ZGoTx = @@ -92,3 +98,97 @@ instance Val ZGoTx where , "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 + } + deriving (Eq) + +data MemoToken + = Login !U.UUID + | PayMsg !U.UUID + | Address !T.Text + | Msg !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 length a /= 76 + then fail "Failed to parse Sapling address" + else pure $ Address $ T.pack ("zs" <> a) + +pMsg :: Parser MemoToken +pMsg = do + Msg . T.pack <$> + some + (alphaNumChar <|> punctuationChar <|> symbolChar <|> + charCategory OtherSymbol) + +pMemo :: Parser MemoToken +pMemo = do + optional spaceChar + pSession <|> pSaplingAddress <|> pMsg + +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) + where + isPayment tks = + not (null tks) && + case head tks of + PayMsg x -> True + _ -> False + isAddress tks = + if not (null tks) + then case head tks of + Address x -> Just x + _ -> Nothing + else Nothing + isSession tks = + if not (null tks) + then case head tks of + Login x -> Just x + PayMsg y -> Just y + _ -> Nothing + else Nothing diff --git a/zgo-backend.cabal b/zgo-backend.cabal index c937442..270d63d 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -5,13 +5,13 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.2.6 +version: 1.3.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web author: Rene Vergara maintainer: rene@vergara.network -copyright: Copyright (c) 2022 Vergara Technologies LLC +copyright: Copyright (c) 2023 Vergara Technologies LLC license: BOSL license-file: LICENSE build-type: Simple @@ -58,6 +58,7 @@ library , http-conduit , http-types , jwt + , megaparsec , memory , mongoDB , network @@ -71,6 +72,7 @@ library , text , time , unordered-containers + , uuid , vector , wai , wai-cors @@ -94,6 +96,7 @@ executable zgo-backend-exe , configurator , http-conduit , http-types + , megaparsec , mongoDB , scotty , securemem @@ -116,6 +119,7 @@ executable zgo-tasks ghc-options: -main-is Tasks -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: base + , megaparsec , mongoDB , scotty , time @@ -140,6 +144,7 @@ executable zgo-token-refresh , configurator , http-conduit , http-types + , megaparsec , mongoDB , scotty , securemem