From fb82923949d07e5512776a7bc258da45a6ec21e0 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 2 Feb 2023 15:14:28 -0600 Subject: [PATCH 01/11] Add language endpoints --- CHANGELOG.md | 12 +++++++ src/LangComponent.hs | 86 ++++++++++++++++++++++++++++++++++++++++++++ src/User.hs | 6 ---- src/ZGoBackend.hs | 16 +++++++++ test/Spec.hs | 72 ++++++++++++++++++++++++++----------- zgo-backend.cabal | 1 + zgo.cfg | 8 ++--- 7 files changed, 171 insertions(+), 30 deletions(-) create mode 100644 src/LangComponent.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 06f7a55..199c303 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,18 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [Unreleased] + +## Added + +- New type to handle UI translation objects +- New endpoints for API to get/set translation +- Tests for translation endpoints + +## Changed + +- Remove old code for PIN generation + ## [1.2.5] - 2023-02-01 ### Fixed diff --git a/src/LangComponent.hs b/src/LangComponent.hs new file mode 100644 index 0000000..dd17638 --- /dev/null +++ b/src/LangComponent.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LangComponent where + +import Data.Aeson +import Data.Aeson.KeyMap +import qualified Data.Bson as B +import Data.ByteString.Builder.Extra (AllocationStrategy) +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Database.MongoDB +import Xero (Xero(x_clientId)) + +-- | Type to represent a UI components text variables in different languages +data LangComponent = + LangComponent + { lc_id :: Maybe ObjectId + , lc_lang :: T.Text + , lc_component :: T.Text + , lc_data :: Data.Aeson.Object + } + deriving (Show, Eq) + +instance ToJSON LangComponent where + toJSON (LangComponent i l c d) = + case i of + Just oid -> + object + ["_id" .= show oid, "language" .= l, "component" .= c, "data" .= d] + Nothing -> + object + [ "_id" .= ("" :: String) + , "language" .= l + , "component" .= c + , "data" .= d + ] + +instance FromJSON LangComponent where + parseJSON = + withObject "LangComponent" $ \obj -> do + l <- obj .: "language" + c <- obj .: "component" + d <- obj .: "data" + pure $ LangComponent Nothing l c d + +instance Val LangComponent where + val (LangComponent i l c d) = + if isJust i + then Doc + [ "_id" =: i + , "language" =: l + , "component" =: c + , "data" =: (TL.toStrict . TLE.decodeUtf8 . encode) d + ] + else Doc + [ "language" =: l + , "component" =: c + , "data" =: (TL.toStrict . TLE.decodeUtf8 . encode) d + ] + cast' (Doc d) = do + i <- B.lookup "_id" d + l <- B.lookup "language" d + c <- B.lookup "component" d + dt <- B.lookup "data" d + pure $ + LangComponent + i + l + c + (fromMaybe + Data.Aeson.KeyMap.empty + ((decode . TLE.encodeUtf8 . TL.fromStrict) dt)) + +-- Database Actions +findLangComponent :: T.Text -> T.Text -> Action IO (Maybe Document) +findLangComponent lang component = + findOne (select ["language" =: lang, "component" =: component] "langcomps") + +loadLangComponent :: LangComponent -> Action IO () +loadLangComponent lc = do + let langComp = val lc + case langComp of + Doc x -> insert_ "langcomps" x + _ -> error "Couldn't parse language JSON" diff --git a/src/User.hs b/src/User.hs index 8d2817a..f455f1c 100644 --- a/src/User.hs +++ b/src/User.hs @@ -101,12 +101,6 @@ validateUser session = (select ["session" =: session] "users") ["$set" =: ["validated" =: True]] -generatePin' :: Int -> IO T.Text -generatePin' s = do - let g = mkStdGen s - pure $ - T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7) - generatePin :: IO String generatePin = do rngState <- newCryptoRNGState diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 10db309..502beef 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -40,6 +40,7 @@ import Database.MongoDB import Debug.Trace import GHC.Generics import Item +import LangComponent import Network.HTTP.Simple import Network.HTTP.Types.Status import Network.Wai (Request, pathInfo) @@ -1025,6 +1026,21 @@ routes pipe config = do oId <- param "id" liftAndCatchIO $ run (deleteOrder oId) status ok200 + -- Get language for component + get "/api/getlang" $ do + component <- param "component" + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang component) + let txtPack = cast' . Doc =<< txtPack' + case txtPack of + Nothing -> status noContent204 + Just tP -> do + status ok200 + Web.Scotty.json $ toJSON (tP :: LangComponent) + post "/api/setlang" $ do + langComp <- jsonData + _ <- liftAndCatchIO $ run (loadLangComponent langComp) + status created201 -- | Make a Zcash RPC call makeZcashCall :: diff --git a/test/Spec.hs b/test/Spec.hs index 18ad17f..4255bd8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,6 +19,7 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Database.MongoDB import Item +import LangComponent import Network.HTTP.Simple import Network.HTTP.Types.Status import Order @@ -139,7 +140,8 @@ main = do "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGOp::ad8477d3-4fdd-4c97-90b2-76630b5f77e1" describe "PIN generator" $ do it "should give a 7 digit" $ do - length (T.unpack (unsafePerformIO (generatePin 1010))) `shouldBe` 7 + pin <- generatePin + length pin `shouldBe` 7 describe "API endpoints" $ do beforeAll_ (startAPI loadedConfig) $ do describe "Price endpoint" $ do @@ -176,7 +178,7 @@ main = do req <- testGet "/api/user" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca")] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "returns 204 when no user" $ do @@ -190,8 +192,8 @@ main = do req <- testPost "/api/validateuser" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca") - , ("pin", Just "8227514") + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("pin", Just "1234567") ] res <- httpLBS req getResponseStatus res `shouldBe` accepted202 @@ -256,7 +258,7 @@ main = do req <- testPost "/api/wootoken" - [("ownerid", Just "627ad3492b05a76be5000001")] + [("ownerid", Just "627ad3492b05a76be3000001")] res <- httpLBS req getResponseStatus res `shouldBe` accepted202 it "authenticate with incorrect owner" $ do @@ -264,7 +266,9 @@ main = do testPublicGet "/auth" [ ("ownerid", Just "62cca13f5530331e2a900001") - , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ( "token" + , Just + "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") ] res <- httpJSON req @@ -284,7 +288,9 @@ main = do testPublicGet "/auth" [ ("ownerid", Just "627ad3492b05a76be3000001") - , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ( "token" + , Just + "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") ] res <- httpJSON req @@ -294,7 +300,9 @@ main = do testPublicGet "/auth" [ ("ownerid", Just "627ad3492b05a76be3000001") - , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ( "token" + , Just + "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("siteurl", Just "aHR0cHM6Ly93d3cuZ29vZ2xlLmNvbS8") ] res <- httpJSON req @@ -304,7 +312,9 @@ main = do testPublicGet "/woopayment" [ ("ownerid", Just "627ad3492b05a76be3000001") - , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ( "token" + , Just + "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") , ("order_id", Just "1234") , ("currency", Just "usd") @@ -314,6 +324,28 @@ main = do ] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + describe "Language endpoint" $ do + it "existing component" $ do + req <- + testGet + "/api/getlang" + [("lang", Just "en-US"), ("component", Just "login")] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "wrong component" $ do + req <- + testGet + "/api/getlang" + [("lang", Just "en-US"), ("component", Just "test")] + res <- httpLBS req + getResponseStatus res `shouldBe` noContent204 + it "wrong language" $ do + req <- + testGet + "/api/getlang" + [("lang", Just "fr-FR"), ("component", Just "login")] + res <- httpLBS req + getResponseStatus res `shouldBe` noContent204 around handleDb $ describe "Database actions" $ do describe "authentication" $ do @@ -658,7 +690,7 @@ startAPI config = do "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" 1613487 - "1234567" + "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" False _ <- access @@ -738,16 +770,16 @@ startAPI config = do case itemTest of Doc iT -> access pipe master "test" (insert_ "items" iT) _ -> fail "Couldn't save test Item in DB" - let myWooToken = - WooToken - Nothing - (read "627ad3492b05a76be3000001") - "89bd9d8d69a674e0f467cc8796ed151a" - Nothing - let wooTest = val myWooToken - case wooTest of - Doc wT -> access pipe master "test" (insert_ "wootokens" wT) - _ -> fail "Couldn't save test WooToken in DB" + --let myWooToken = + --WooToken + --Nothing + --(read "627ad3492b05a76be3000001") + --"89bd9d8d69a674e0f467cc8796ed151a" + --Nothing + --let wooTest = val myWooToken + --case wooTest of + --Doc wT -> access pipe master "test" (insert_ "wootokens" wT) + --_ -> fail "Couldn't save test WooToken in DB" threadDelay 1000000 putStrLn "Test server is up!" diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 6178642..c797e56 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -28,6 +28,7 @@ library exposed-modules: Config Item + LangComponent Order Owner Payment diff --git a/zgo.cfg b/zgo.cfg index aa2bbf8..1502706 100644 --- a/zgo.cfg +++ b/zgo.cfg @@ -10,7 +10,7 @@ port = 3000 tls = false certificate = "/path/to/cert.pem" key = "/path/to/key.pem" -mailHost = "127.0.0.1" -mailPort = 1025 -mailUser = "contact@zgo.cash" -mailPwd = "uib3K8BkCPexl_wr5bYfrg" +smtpHost = "127.0.0.1" +smtpPort = 1025 +smtpUser = "contact@zgo.cash" +smtpPwd = "uib3K8BkCPexl_wr5bYfrg" From de3293f6ec2f2636fb679fdb67315e42db11e4ec Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 2 Feb 2023 15:43:54 -0600 Subject: [PATCH 02/11] Add upsert of language component --- src/LangComponent.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/LangComponent.hs b/src/LangComponent.hs index dd17638..7c01839 100644 --- a/src/LangComponent.hs +++ b/src/LangComponent.hs @@ -82,5 +82,10 @@ loadLangComponent :: LangComponent -> Action IO () loadLangComponent lc = do let langComp = val lc case langComp of - Doc x -> insert_ "langcomps" x + Doc x -> + upsert + (select + ["language" =: lc_lang lc, "component" =: lc_component lc] + "langcomps") + x _ -> error "Couldn't parse language JSON" From 6a766ee0d85d8e2d02e32abd8343fa328c6e845b Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 16 Feb 2023 07:49:05 -0600 Subject: [PATCH 03/11] Add batch load of translation --- src/ZGoBackend.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 502beef..ca4a7f4 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1039,7 +1039,9 @@ routes pipe config = do Web.Scotty.json $ toJSON (tP :: LangComponent) post "/api/setlang" $ do langComp <- jsonData - _ <- liftAndCatchIO $ run (loadLangComponent langComp) + _ <- + liftAndCatchIO $ + mapM (run . loadLangComponent) (langComp :: [LangComponent]) status created201 -- | Make a Zcash RPC call From 25fad17363c42a6fb2c23180336488cc03d834e0 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 28 Feb 2023 11:19:08 -0600 Subject: [PATCH 04/11] Implement enhancements for #3 --- CHANGELOG.md | 1 + package.yaml | 2 +- src/Xero.hs | 8 +++++--- src/ZGoBackend.hs | 1 + zgo-backend.cabal | 2 +- 5 files changed, 9 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 199c303..199c223 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## Changed - Remove old code for PIN generation +- Xero reference field to include the amount of ZEC received ## [1.2.5] - 2023-02-01 diff --git a/package.yaml b/package.yaml index e1d9519..77e2dc7 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 1.2.5 +version: 1.2.6 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" diff --git a/src/Xero.hs b/src/Xero.hs index 14091ce..0f71d64 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -410,8 +410,9 @@ getXeroInvoice pipe dbName inv address = do Right iData -> return $ Just (head $ xir_invs iData) _ -> return Nothing -payXeroInvoice :: Pipe -> T.Text -> T.Text -> T.Text -> Double -> IO () -payXeroInvoice pipe dbName inv address amt = do +payXeroInvoice :: + Pipe -> T.Text -> T.Text -> T.Text -> Double -> Double -> IO () +payXeroInvoice pipe dbName inv address amt zec = do token <- access pipe master dbName $ findToken address let aToken = t_access <$> (token >>= cast' . Doc) let aCode = t_code <$> (token >>= cast' . Doc) @@ -426,7 +427,8 @@ payXeroInvoice pipe dbName inv address amt = do [ "Invoice" .= object ["InvoiceNumber" .= inv] , "Account" .= object ["Code" .= fromMaybe "" aCode] , "Date" .= utctDay today - , "Reference" .= ("Paid in Zcash through ZGo" :: String) + , "Reference" .= + ("Paid in Zcash through ZGo: " ++ show zec ++ " ZEC" :: String) , "Amount" .= amt ]) $ addRequestHeader "Accept" "application/json" $ diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index ca4a7f4..5f73786 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1192,6 +1192,7 @@ scanPayments config pipe = do (qexternalInvoice xO) (qaddress xO) (qtotal xO) + (qtotalZec xO) "WC" -> do let wOwner = fst $ head sResult ! 2 wooT <- diff --git a/zgo-backend.cabal b/zgo-backend.cabal index c797e56..24e686c 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.2.5 +version: 1.2.6 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web From 91b5a841f939844f0bb250099706ec234315270c Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 28 Feb 2023 14:58:41 -0600 Subject: [PATCH 05/11] Change confirmation window --- src/ZGoBackend.hs | 2 +- test/Spec.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 5f73786..a37765f 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1139,7 +1139,7 @@ scanZcash config pipe = do -- | Function to filter transactions isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool isRelevant re t - | zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True + | zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True | otherwise = False -- | Function to scan loaded viewing keys for payments diff --git a/test/Spec.hs b/test/Spec.hs index 4255bd8..b549218 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -473,7 +473,7 @@ main = do let s = parseZGoTxBson =<< t let conf = maybe 0 confirmations s conf `shouldSatisfy` (> 0) - xit "payments are added to db" $ \p -> do + it "payments are added to db" $ \p -> do _ <- access p From 44f14d6abd5ce17e4a360460659ec4b454b3a43f Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Sat, 4 Mar 2023 15:54:32 -0600 Subject: [PATCH 06/11] Separate periodic tasks from API server --- CHANGELOG.md | 5 +++-- app/Tasks.hs | 31 +++++++++++++++++++++++++++++++ package.yaml | 21 +++++++++++++++++++-- zgo-backend.cabal | 21 +++++++++++++++++++++ 4 files changed, 74 insertions(+), 4 deletions(-) create mode 100644 app/Tasks.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 199c223..5fe8488 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,16 +6,17 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] -## Added +### Added - New type to handle UI translation objects - New endpoints for API to get/set translation - Tests for translation endpoints -## Changed +### Changed - Remove old code for PIN generation - Xero reference field to include the amount of ZEC received +- Separate periodic tasks from API server ## [1.2.5] - 2023-02-01 diff --git a/app/Tasks.hs b/app/Tasks.hs new file mode 100644 index 0000000..402c561 --- /dev/null +++ b/app/Tasks.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tasks where + +import Config +import Database.MongoDB +import ZGoBackend + +main :: IO () +main = do + putStrLn "ZGo Recurring Tasks" + putStrLn "Reading config..." + loadedConfig <- loadZGoConfig "zgo.cfg" + pipe <- connect $ host (c_dbHost loadedConfig) + j <- + access + pipe + master + (c_dbName loadedConfig) + (auth (c_dbUser loadedConfig) (c_dbPassword loadedConfig)) + if j + then do + putStrLn "Connected to MongoDB!" + checkZcashPrices pipe (c_dbName loadedConfig) + scanZcash loadedConfig pipe + scanPayments loadedConfig pipe + checkPayments pipe (c_dbName loadedConfig) + expireOwners pipe (c_dbName loadedConfig) + updateLogins pipe loadedConfig + close pipe + else fail "MongoDB connection failed!" diff --git a/package.yaml b/package.yaml index 77e2dc7..bc2b54a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,10 +1,10 @@ name: zgo-backend -version: 1.2.6 +version: 1.3.0 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" maintainer: "rene@vergara.network" -copyright: "Copyright (c) 2022 Vergara Technologies LLC" +copyright: "Copyright (c) 2023 Vergara Technologies LLC" extra-source-files: - README.md @@ -113,6 +113,23 @@ executables: - configurator - warp-tls - warp + zgo-tasks: + main: Tasks.hs + source-dirs: app + ghc-options: + - -main-is Tasks + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall + dependencies: + - base + - mongoDB + - zgo-backend + - scotty + - warp-tls + - warp + - time tests: zgo-backend-test: diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 24e686c..c937442 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -81,6 +81,7 @@ library executable zgo-backend-exe main-is: Server.hs other-modules: + Tasks TokenRefresh Paths_zgo_backend hs-source-dirs: @@ -104,10 +105,30 @@ executable zgo-backend-exe , zgo-backend default-language: Haskell2010 +executable zgo-tasks + main-is: Tasks.hs + other-modules: + Server + TokenRefresh + Paths_zgo_backend + hs-source-dirs: + app + ghc-options: -main-is Tasks -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base + , mongoDB + , scotty + , time + , warp + , warp-tls + , zgo-backend + default-language: Haskell2010 + executable zgo-token-refresh main-is: TokenRefresh.hs other-modules: Server + Tasks Paths_zgo_backend hs-source-dirs: app From e437da2841019cee28c69e55faea9320a31a3655 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 10 Mar 2023 15:31:47 -0600 Subject: [PATCH 07/11] 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 From 63d372c2d580ab89613895add4161e3d8dc09ab9 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 14 Mar 2023 10:17:31 -0500 Subject: [PATCH 08/11] Change Zcash scan to use parser --- CHANGELOG.md | 2 ++ app/Server.hs | 15 ++++++++------- app/Tasks.hs | 3 +-- src/ZGoBackend.hs | 45 ++++++++++++++++++++++++++++++--------------- 4 files changed, 41 insertions(+), 24 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5fe8488..ce4161a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,12 +11,14 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - New type to handle UI translation objects - New endpoints for API to get/set translation - Tests for translation endpoints +- Formal parser of ZGo-related tokens in memos ### Changed - Remove old code for PIN generation - Xero reference field to include the amount of ZEC received - Separate periodic tasks from API server +- Zcash transaction monitoring changed to use memo parser ## [1.2.5] - 2023-02-01 diff --git a/app/Server.hs b/app/Server.hs index 5c6ee4f..229ebc6 100644 --- a/app/Server.hs +++ b/app/Server.hs @@ -3,7 +3,8 @@ module Server where import Config -import Control.Concurrent (forkIO) + +--import Control.Concurrent (forkIO) import Database.MongoDB import Network.Wai.Handler.Warp (defaultSettings, setPort) import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings) @@ -30,12 +31,12 @@ main = do if j then putStrLn "Connected to MongoDB!" else fail "MongoDB connection failed!" - _ <- forkIO (setInterval 60 (checkZcashPrices pipe (c_dbName loadedConfig))) - _ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe)) - _ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe)) - _ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig))) - _ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig))) - _ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig)) + {-_ <- forkIO (setInterval 60 (checkZcashPrices pipe (c_dbName loadedConfig)))-} + {-_ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe))-} + {-_ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe))-} + {-_ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig)))-} + {-_ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig)))-} + {-_ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig))-} let appRoutes = routes pipe loadedConfig case myTlsSettings of Nothing -> scotty (c_port loadedConfig) appRoutes diff --git a/app/Tasks.hs b/app/Tasks.hs index 90833a7..c3360a8 100644 --- a/app/Tasks.hs +++ b/app/Tasks.hs @@ -4,7 +4,6 @@ module Tasks where import Config import Database.MongoDB -import Text.Megaparsec hiding (State) import ZGoBackend main :: IO () @@ -23,7 +22,7 @@ main = do then do putStrLn "Connected to MongoDB!" checkZcashPrices pipe (c_dbName loadedConfig) - scanZcash loadedConfig pipe + scanZcash' loadedConfig pipe scanPayments loadedConfig pipe checkPayments pipe (c_dbName loadedConfig) expireOwners pipe (c_dbName loadedConfig) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 48792e4..17bb653 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -357,21 +357,26 @@ 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" +zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO () +zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do + when (conf < 100) $ do + let zM = runParser pZGoMemo (T.unpack t) m + case zM of + Right zM' -> do + let tx = + ZGoTx + Nothing + (fromMaybe "" $ m_address zM') + (maybe "" U.toText $ m_session zM') + conf + bt + a + t + m + if m_payment zM' + then upsertPayment pipe (c_dbName config) tx + else access pipe master (c_dbName config) $ upsertZGoTx "txs" tx + Left e -> error "Failed to parse ZGo memo" -- |Type to model a price in the ZGo database data ZGoPrice = @@ -1160,6 +1165,16 @@ isRelevant re t | zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True | otherwise = False +-- | New function to scan transactions with parser +scanZcash' :: Config -> Pipe -> IO () +scanZcash' config pipe = do + myTxs <- + listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1 + case myTxs of + Right txs -> mapM_ (zToZGoTx' config pipe) txs + Left e -> do + putStrLn $ "Error scanning node transactions: " ++ T.unpack e + -- | Function to scan loaded viewing keys for payments scanPayments :: Config -> Pipe -> IO () scanPayments config pipe = do From cce6811df28af133aeae7dec27f4520c9e72f96b Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 14 Mar 2023 12:55:23 -0500 Subject: [PATCH 09/11] Correct parsing of memos --- src/ZGoTx.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index 4089c3a..95278f8 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -106,7 +106,7 @@ data ZGoMemo = , m_address :: Maybe T.Text , m_payment :: Bool } - deriving (Eq) + deriving (Eq, Show) data MemoToken = Login !U.UUID @@ -174,21 +174,24 @@ pZGoMemo = do tks <- some pMemo pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks) where + isPayment [] = False isPayment tks = not (null tks) && case head tks of PayMsg x -> True - _ -> False + _ -> isPayment $ tail tks + isAddress [] = Nothing isAddress tks = if not (null tks) then case head tks of Address x -> Just x - _ -> Nothing + _ -> 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 - _ -> Nothing + _ -> isSession $ tail tks else Nothing From 75a6896ec85b84c00ead12101aefe1f89b5d21a4 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 15 Mar 2023 15:52:52 -0500 Subject: [PATCH 10/11] Fix Xero token request --- CHANGELOG.md | 4 ++++ app/TokenRefresh.hs | 2 +- src/Xero.hs | 14 +++++++++----- 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ce4161a..f08eaea 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Separate periodic tasks from API server - Zcash transaction monitoring changed to use memo parser +### Fixed + +- Xero token generation for brand new users + ## [1.2.5] - 2023-02-01 ### Fixed diff --git a/app/TokenRefresh.hs b/app/TokenRefresh.hs index 81b5168..83e2ac4 100644 --- a/app/TokenRefresh.hs +++ b/app/TokenRefresh.hs @@ -30,6 +30,6 @@ main = do then do let t = map (cast' . Doc) tokens case creds of - Just c -> mapM_ (refreshToken pipe db c "") t + Just c -> mapM_ (refreshToken pipe db c "" "") t Nothing -> fail "No credentials" else putStrLn "No tokens to refresh1" diff --git a/src/Xero.hs b/src/Xero.hs index 0f71d64..52fe641 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -290,10 +290,11 @@ requestXeroToken :: Pipe -> T.Text -> Xero -> T.Text -> T.Text -> IO Bool requestXeroToken pipe dbName cred code address = do token <- access pipe master dbName $ findToken address let oToken = token >>= cast' . Doc - refreshToken pipe dbName cred code oToken + refreshToken pipe dbName cred code address oToken -refreshToken :: Pipe -> T.Text -> Xero -> T.Text -> Maybe XeroToken -> IO Bool -refreshToken pipe dbName cred code token = do +refreshToken :: + Pipe -> T.Text -> Xero -> T.Text -> T.Text -> Maybe XeroToken -> IO Bool +refreshToken pipe dbName cred code address token = do let pars = case token of Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x @@ -316,9 +317,12 @@ refreshToken pipe dbName cred code token = do 200 -> do let newToken = getResponseBody (res :: Response XeroToken) let accCode = t_code <$> token - let address = t_address <$> token + {-let address = t_address <$> token-} pToken <- - processToken newToken (fromMaybe "" address) (fromMaybe "" accCode) + processToken + newToken + (maybe address t_address token) + (fromMaybe "" accCode) --print pToken _ <- access pipe master dbName $ upsertToken pToken _ <- getTenantId pipe dbName pToken From 42f77060b7562a0946a07fbce2f89fe55f0ddd9a Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 16 Mar 2023 10:20:49 -0500 Subject: [PATCH 11/11] Version update --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f08eaea..06645e8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,7 +4,7 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [Unreleased] +## [1.3.0] - 2023-03-16 ### Added