diff --git a/package.yaml b/package.yaml index bf16a79..4dd5145 100644 --- a/package.yaml +++ b/package.yaml @@ -161,3 +161,5 @@ tests: - time - configurator - scotty + - megaparsec + - uuid diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index 9c95872..8f786b8 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -119,7 +119,6 @@ type Parser = Parsec Void T.Text pSession :: Parser MemoToken pSession = do - optional spaceChar string "ZGO" pay <- optional $ char 'p' string "::" @@ -142,13 +141,18 @@ pSaplingAddress = do pMsg :: Parser MemoToken pMsg = do - Msg . T.pack <$> - some (alphaNumChar <|> punctuationChar <|> charCategory OtherSymbol) + msg <- + some + (alphaNumChar <|> punctuationChar <|> symbolChar <|> + charCategory OtherSymbol) + pure $ Msg . T.pack $ msg pMemo :: Parser MemoToken pMemo = do - optional spaceChar - pSession <|> pSaplingAddress <|> pMsg + optional $ some spaceChar + t <- pSession <|> pSaplingAddress <|> pMsg + optional $ some spaceChar + return t isMemoToken :: T.Text -> MemoToken -> Bool isMemoToken kind t = diff --git a/test/Spec.hs b/test/Spec.hs index cbee780..929eec4 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,6 +17,7 @@ import Data.Time import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX +import qualified Data.UUID as U import Database.MongoDB import Item import LangComponent @@ -32,6 +33,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Monadic +import Text.Megaparsec import User import Web.Scotty import WooCommerce @@ -53,7 +55,31 @@ main = do describe "hex strings" $ do prop "encoding and decoding are inverse" $ \x -> (decodeHexText . encodeHexText) x == x - describe "zToZGoTx" $ do + describe "zToZGoTx" $ + --prop "memo parsing" testMemoParser + do + it "parse ZecWallet memo" $ do + let m = + runParser + pZGoMemo + "Zecwalllet memo" + "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + case m of + Left e -> putStrLn $ errorBundlePretty e + Right m' -> + m_session m' `shouldBe` + U.fromString "5d3d4494-51c0-432d-8495-050419957aea" + it "parse YWallet memo" $ do + let m = + runParser + pZGoMemo + "Ywallet memo" + "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1" + case m of + Left e -> putStrLn $ errorBundlePretty e + Right m' -> + m_session m' `shouldBe` + U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1" it "converts ZecWallet tx to ZGo tx" $ do let t = ZcashTx @@ -156,32 +182,13 @@ main = do getResponseStatus res `shouldBe` accepted202 describe "Price endpoint" $ do it "returns a price for an existing currency" $ do - req <- - testGet - "/api/price" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - , ("currency", Just "usd") - ] + req <- testGet "/price" [("currency", Just "usd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "returns 204 when the currency is not supported" $ do - req <- - testGet - "/api/price" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - , ("currency", Just "jpy") - ] + req <- testGet "/price" [("currency", Just "jpy")] res <- httpLBS req getResponseStatus res `shouldBe` noContent204 - it "returs 401 when the session is not valid" $ do - req <- - testGet - "/api/price" - [ ("session", Just "th7s1sa-fake-6u1d-7h47-1m4deuph3r3") - , ("currency", Just "usd") - ] - res <- httpLBS req - getResponseStatus res `shouldBe` unauthorized401 describe "Countries endpoint" $ do it "returns a list of countries" $ do req <- @@ -201,7 +208,7 @@ main = do it "returns a block number" $ do req <- testGet - "/api/blockheight" + "/blockheight" [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x -> @@ -800,6 +807,23 @@ testDelete endpoint par body = do setRequestPath (B.append endpoint par) defaultRequest return testRequest +testMemoParser :: T.Text -> T.Text -> T.Text -> Property +testMemoParser t1 t2 t3 = + monadicIO $ do + let res = + runParser pZGoMemo "Parser test" $ + t1 <> + " zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e " <> + t2 <> " ZGO::5d3d4494-51c0-432d-8495-050419957aea " <> t3 + case res of + Left e -> assert False `debug` (errorBundlePretty e) + Right zm -> + assert $ + U.fromString "5d3d4494-51c0-432d-8495-050419957aea" == m_session zm && + Just + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" == + m_address zm + testOwnerAdd :: Owner -> Property testOwnerAdd o = monadicIO $ do diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 1450cc8..1ffd556 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.5.0 +version: 1.5.1 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web @@ -175,10 +175,12 @@ test-suite zgo-backend-test , hspec-wai , http-conduit , http-types + , megaparsec , mongoDB , scotty , securemem , text , time + , uuid , zgo-backend default-language: Haskell2010