Implement memo parser

app/Tasks.hs

@@ -4,6 +4,7 @@ module Tasks where
 
 import Config
 import Database.MongoDB
+import Text.Megaparsec hiding (State)
 import ZGoBackend
 
 main :: IO ()

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:

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

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

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 <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
 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