From 9f13cbf30277a85336a0cb07d79c9cc726126fdf Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 16 May 2023 14:27:10 -0500 Subject: [PATCH 01/41] Correct order payment logic --- CHANGELOG.md | 8 +++++++- package.yaml | 2 +- src/ZGoBackend.hs | 12 +++++++----- 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 03b9130..8355b61 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,7 +4,13 @@ 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). -## [1.5.0] +## [1.5.1] + +### Changed + +- Modified the process to mark paid orders to ensure only payments to the shop's wallet get marked as paid + +## [1.5.0] - 2023-05-15 ### Added diff --git a/package.yaml b/package.yaml index ca1e131..bf16a79 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 1.5.0 +version: 1.5.1 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 0243fb6..9c71ffa 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1307,8 +1307,7 @@ scanPayments config pipe = do let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" let k = filter (isRelevant r) txs let j = map (getOrderId r) k - mapM_ (recordPayment p (c_dbName config)) j - mapM_ (access p master (c_dbName config) . markOrderPaid) j + mapM_ (recordPayment p (c_dbName config) z) j Left e -> print e getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) getOrderId re t = do @@ -1316,8 +1315,8 @@ scanPayments config pipe = do if not (null reg) then (fst $ head reg ! 1, zamount t) else ("", 0) - recordPayment :: Pipe -> T.Text -> (String, Double) -> IO () - recordPayment p dbName x = do + recordPayment :: Pipe -> T.Text -> ZcashAddress -> (String, Double) -> IO () + recordPayment p dbName z x = do o <- access p master dbName $ findOrderById (fst x) let xOrder = o >>= (cast' . Doc) case xOrder of @@ -1325,7 +1324,8 @@ scanPayments config pipe = do Just xO -> when (not (qpaid xO) && - qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ do + qexternalInvoice xO /= "" && + qtotalZec xO == snd x && addy z == qaddress xO) $ do let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" let sResult = matchAllText sReg (T.unpack $ qsession xO) if not (null sResult) @@ -1344,6 +1344,7 @@ scanPayments config pipe = do (qaddress xO) (qtotal xO) (qtotalZec xO) + liftIO $ access p master dbName $ markOrderPaid x "WC" -> do let wOwner = fst $ head sResult ! 2 wooT <- @@ -1371,6 +1372,7 @@ scanPayments config pipe = do (C.pack . T.unpack $ w_token wt) (C.pack . show $ qprice xO) (C.pack . show $ qtotalZec xO) + liftIO $ access p master dbName $ markOrderPaid x else error "Couldn't parse externalInvoice for WooCommerce" _ -> putStrLn "Not an integration order" From ee95038a441f4c839ee23d985cbb7701780f19ee Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 17 May 2023 09:44:25 -0500 Subject: [PATCH 02/41] Update tests --- package.yaml | 2 ++ src/ZGoTx.hs | 14 ++++++---- test/Spec.hs | 70 +++++++++++++++++++++++++++++++---------------- zgo-backend.cabal | 4 ++- 4 files changed, 61 insertions(+), 29 deletions(-) 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 From 958f04ee11f2f7cc65121cebda502be99ffe954b Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 17 May 2023 11:46:24 -0500 Subject: [PATCH 03/41] Harden user endpoints and corresponding tests --- src/User.hs | 33 +++++++++++++ src/ZGoBackend.hs | 14 ++++-- test/Spec.hs | 116 ++++++++++++++++++++++++++++++++-------------- 3 files changed, 124 insertions(+), 39 deletions(-) diff --git a/src/User.hs b/src/User.hs index a393dc5..e7eb241 100644 --- a/src/User.hs +++ b/src/User.hs @@ -69,6 +69,36 @@ instance FromJSON User where "" v +instance Val User where + cast' (Doc d) = do + i <- B.lookup "_id" d + a <- B.lookup "address" d + s <- B.lookup "session" d + b <- B.lookup "blocktime" d + p <- B.lookup "pin" d + v <- B.lookup "validated" d + Just $ User i a s b p v + cast' _ = Nothing + val (User i a s b p v) = + case i of + Just oid -> + Doc + [ "_id" =: oid + , "address" =: a + , "session" =: s + , "blocktime" =: b + , "pin" =: p + , "validated" =: v + ] + Nothing -> + Doc + [ "address" =: a + , "session" =: s + , "blocktime" =: b + , "pin" =: p + , "validated" =: v + ] + parseUserBson :: B.Document -> Maybe User parseUserBson d = do i <- B.lookup "_id" d @@ -84,6 +114,9 @@ parseUserBson d = do findUser :: T.Text -> Action IO (Maybe Document) findUser s = findOne (select ["session" =: s] "users") +findUserById :: String -> Action IO (Maybe Document) +findUserById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "users") + -- | Function to delete user by ID deleteUser :: String -> Action IO () deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users") diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 9c71ffa..d5e8485 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -893,12 +893,20 @@ routes pipe config = do --Delete user Web.Scotty.delete "/api/user/:id" $ do userId <- param "id" + session <- param "session" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r userId then do - liftAndCatchIO $ run (deleteUser userId) - status ok200 - else status noContent204 + u <- liftAndCatchIO $ run (findUserById userId) + case cast' . Doc =<< u of + Nothing -> status badRequest400 + Just u' -> + if session == usession u' + then do + liftAndCatchIO $ run (deleteUser userId) + status ok200 + else status forbidden403 + else status badRequest400 --Get current blockheight from Zcash node get "/blockheight" $ do blockInfo <- diff --git a/test/Spec.hs b/test/Spec.hs index 929eec4..ca7d3ba 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -259,14 +259,39 @@ main = do [("session", Just "suchafak-euui-dican-eve-nbelieveitca")] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 - it "deletes user by id" $ do - req <- - testDelete - "/api/user/" - "6272a90f2b05a74cf1000003" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] - res <- httpLBS req - getResponseStatus res `shouldBe` ok200 + describe "delete" $ do + it "returns 401 when session is invalid" $ do + req <- + testDelete + "/api/user/" + "6272a90f2b05a74cf1000005" + [("session", Just "suchafak-euui-dican-eve-nbelieveitca")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "returns 403 when user and session don't match" $ do + req <- + testDelete + "/api/user/" + "6272a90f2b05a74cf1000005" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 + it "returns 400 when user is invalid" $ do + req <- + testDelete + "/api/user/" + "000000000000000000000000" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` badRequest400 + it "deletes user by id" $ do + req <- + testDelete + "/api/user/" + "6272a90f2b05a74cf1000003" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` ok200 describe "Owner endpoint" $ --prop "add owner" testOwnerAdd do @@ -872,6 +897,14 @@ closeDbConnection = close handleDb :: (Pipe -> Expectation) -> IO () handleDb = bracket openDbConnection closeDbConnection +filterDocs :: Value -> Bool +filterDocs (Doc v) = True +filterDocs _ = False + +unwrapDoc :: Value -> Document +unwrapDoc (Doc v) = v +unwrapDoc _ = [] + startAPI :: Config -> IO () startAPI config = do putStrLn "Starting test server ..." @@ -892,20 +925,6 @@ startAPI config = do 1613487 "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" False - _ <- - access - pipe - master - "test" - (insert_ - "users" - [ "address" =: uaddress myUser - , "_id" =: u_id myUser - , "session" =: usession myUser - , "blocktime" =: ublocktime myUser - , "pin" =: upin myUser - , "validated" =: uvalidated myUser - ]) let myUser1 = User (Just (read "6272a90f2b05a74cf1000003" :: ObjectId)) @@ -914,20 +933,45 @@ startAPI config = do 1613487 "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" True - _ <- - access - pipe - master - "test" - (insert_ - "users" - [ "address" =: uaddress myUser1 - , "_id" =: u_id myUser1 - , "session" =: usession myUser1 - , "blocktime" =: ublocktime myUser1 - , "pin" =: upin myUser1 - , "validated" =: uvalidated myUser1 - ]) + let myUser2 = + User + (Just (read "6272a90f2b05a74cf1000005" :: ObjectId)) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3fake" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake" + 1613487 + "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" + True + let userList = + map unwrapDoc $ filter filterDocs $ val <$> [myUser, myUser1, myUser2] + _ <- access pipe master "test" (insertAll_ "users" userList) + --_ <- + --access + --pipe + --master + --"test" + --(insert_ + --"users" + --[ "address" =: uaddress myUser + --, "_id" =: u_id myUser + --, "session" =: usession myUser + --, "blocktime" =: ublocktime myUser + --, "pin" =: upin myUser + --, "validated" =: uvalidated myUser + --]) + --_ <- + --access + --pipe + --master + --"test" + --(insert_ + --"users" + --[ "address" =: uaddress myUser1 + --, "_id" =: u_id myUser1 + --, "session" =: usession myUser1 + --, "blocktime" =: ublocktime myUser1 + --, "pin" =: upin myUser1 + --, "validated" =: uvalidated myUser1 + --]) let myOwner = Owner (Just (read "627ad3492b05a76be3000001")) From 857a298b966ef5dc12164b9f30a59fc69a9bb985 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 25 May 2023 10:42:40 -0500 Subject: [PATCH 04/41] Enhance `GET items` --- CHANGELOG.md | 3 ++- package.yaml | 2 +- src/Item.hs | 1 + src/ZGoBackend.hs | 26 ++++++++++++++++---------- zgo-backend.cabal | 2 +- 5 files changed, 21 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8355b61..9e827e1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,11 +4,12 @@ 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). -## [1.5.1] +## [1.6.0] ### Changed - Modified the process to mark paid orders to ensure only payments to the shop's wallet get marked as paid +- Modified the `items` endpoint to use the login session to identify records ## [1.5.0] - 2023-05-15 diff --git a/package.yaml b/package.yaml index 4dd5145..98fe2f8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 1.5.1 +version: 1.6.0 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" diff --git a/src/Item.hs b/src/Item.hs index 6fef76e..a249370 100644 --- a/src/Item.hs +++ b/src/Item.hs @@ -12,6 +12,7 @@ import Data.Time.Clock import Database.MongoDB import GHC.Generics import Test.QuickCheck +import User -- | Type to represent a ZGo item data Item = diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index d5e8485..4c9b92b 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1025,16 +1025,22 @@ routes pipe config = do else status noContent204 --Get items associated with the given address get "/api/items" $ do - addr <- param "address" - items <- liftAndCatchIO $ run (findItems addr) - case items of - [] -> status noContent204 - _ -> do - let pItems = map (cast' . Doc) items :: [Maybe Item] - status ok200 - Web.Scotty.json - (object - ["message" .= ("Items found!" :: String), "items" .= toJSON pItems]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + items <- liftAndCatchIO $ run (findItems $ uaddress u) + case items of + [] -> status noContent204 + _ -> do + let pItems = map (cast' . Doc) items :: [Maybe Item] + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Items found!" :: String) + , "items" .= toJSON pItems + ]) --Upsert item post "/api/item" $ do i <- jsonData diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 1ffd556..b70613d 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.1 +version: 1.6.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web From c8f1d250b5d12bd5270e6185beb7c52414532e52 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 26 May 2023 14:04:35 -0500 Subject: [PATCH 05/41] Add tests for Item endpoints --- src/Item.hs | 3 ++ src/ZGoBackend.hs | 44 ++++++++++++++----- test/Spec.hs | 105 ++++++++++++++++++++++++++++------------------ 3 files changed, 102 insertions(+), 50 deletions(-) diff --git a/src/Item.hs b/src/Item.hs index a249370..b6ac41c 100644 --- a/src/Item.hs +++ b/src/Item.hs @@ -88,6 +88,9 @@ findItems :: T.Text -> Action IO [Document] findItems a = rest =<< find (select ["owner" =: a] "items") {sort = ["name" =: (1 :: Int)]} +findItemById :: String -> Action IO (Maybe Document) +findItemById i = findOne (select ["_id" =: (read i :: ObjectId)] "items") + upsertItem :: Item -> Action IO () upsertItem i = do let item = val i diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 4c9b92b..f63cae6 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1028,7 +1028,7 @@ routes pipe config = do session <- param "session" user <- liftAndCatchIO $ run (findUser session) case cast' . Doc =<< user of - Nothing -> status unauthorized401 + Nothing -> status forbidden403 Just u -> do items <- liftAndCatchIO $ run (findItems $ uaddress u) case items of @@ -1044,18 +1044,34 @@ routes pipe config = do --Upsert item post "/api/item" $ do i <- jsonData - let q = payload (i :: Payload Item) - _ <- liftAndCatchIO $ run (upsertItem q) - status created201 + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status forbidden403 + Just u -> do + let q = payload (i :: Payload Item) + if uaddress u == iowner q + then do + _ <- liftAndCatchIO $ run (upsertItem q) + status created201 + else status forbidden403 --Delete item Web.Scotty.delete "/api/item/:id" $ do + session <- param "session" oId <- param "id" - let r = mkRegex "^[a-f0-9]{24}$" - if matchTest r oId - then do - liftAndCatchIO $ run (deleteItem oId) - status ok200 - else status noContent204 + u' <- liftAndCatchIO $ checkUser run session + case u' of + Nothing -> status forbidden403 + Just u -> do + i <- liftAndCatchIO $ run (findItemById oId) + case cast' . Doc =<< i of + Nothing -> status badRequest400 + Just i' -> do + if iowner i' == uaddress u + then do + liftAndCatchIO $ run (deleteItem oId) + status ok200 + else status forbidden403 --Get price for Zcash get "/price" $ do curr <- param "currency" @@ -1553,4 +1569,12 @@ expireProSessions pipe db = do access pipe master db $ removePro (psaddress z) access pipe master db $ closeProSession z +checkUser :: + (Action IO (Maybe Document) -> IO (Maybe Document)) + -> T.Text + -> IO (Maybe User) +checkUser run s = do + user <- run (findUser s) + return $ cast' . Doc =<< user + debug = flip trace diff --git a/test/Spec.hs b/test/Spec.hs index ca7d3ba..463c3bf 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -398,24 +398,77 @@ main = do res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 describe "Item endpoint" $ do - prop "add item" testItemAdd - it "get items" $ do + it "adding item with bad session fails" $ do + let item = + Item + Nothing + "Table" + "Oak" + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + 499.99 + req <- + testPostJson "/api/item" $ A.object ["payload" A..= A.toJSON item] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` unauthorized401 + it "adding item with good session succeeds" $ do + let item = + Item + (Just (read "627d7ba92b05a76be3000013")) + "Table" + "Oak" + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + 499.99 + req <- + testPostJson "/api/item" $ A.object ["payload" A..= A.toJSON item] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` created201 + it "get items with valid session succeeds" $ do req <- testGet "/api/items" - [ ("address", Just "Zaddy") - , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - ] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "delete item" $ do + it "get items with invalid session returns 401" $ do req <- - testDelete - "/api/item/" - "627d7ba92b05a76be3000003" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + testGet + "/api/items" + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] res <- httpLBS req - getResponseStatus res `shouldBe` ok200 + getResponseStatus res `shouldBe` unauthorized401 + describe "delete item" $ do + it "returns 401 with invalid session and item ID" $ do + req <- + testDelete + "/api/item/" + "627d7ba92b05a76be3000003" + [("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "returns 403 when item ID doesn't belong to session" $ do + req <- + testDelete + "/api/item/" + "627d7ba92b05a76be3000003" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 + it "succeeds with valid session and item ID" $ do + req <- + testDelete + "/api/item/" + "627d7ba92b05a76be3000013" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` ok200 describe "WooCommerce endpoints" $ do it "generate token" $ do req <- @@ -841,7 +894,7 @@ testMemoParser t1 t2 t3 = " zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e " <> t2 <> " ZGO::5d3d4494-51c0-432d-8495-050419957aea " <> t3 case res of - Left e -> assert False `debug` (errorBundlePretty e) + Left e -> assert False `debug` errorBundlePretty e Right zm -> assert $ U.fromString "5d3d4494-51c0-432d-8495-050419957aea" == m_session zm && @@ -944,34 +997,6 @@ startAPI config = do let userList = map unwrapDoc $ filter filterDocs $ val <$> [myUser, myUser1, myUser2] _ <- access pipe master "test" (insertAll_ "users" userList) - --_ <- - --access - --pipe - --master - --"test" - --(insert_ - --"users" - --[ "address" =: uaddress myUser - --, "_id" =: u_id myUser - --, "session" =: usession myUser - --, "blocktime" =: ublocktime myUser - --, "pin" =: upin myUser - --, "validated" =: uvalidated myUser - --]) - --_ <- - --access - --pipe - --master - --"test" - --(insert_ - --"users" - --[ "address" =: uaddress myUser1 - --, "_id" =: u_id myUser1 - --, "session" =: usession myUser1 - --, "blocktime" =: ublocktime myUser1 - --, "pin" =: upin myUser1 - --, "validated" =: uvalidated myUser1 - --]) let myOwner = Owner (Just (read "627ad3492b05a76be3000001")) From 9d81bd7472fb9d1848cd1c382d0bbbc6d8d22bae Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 1 Jun 2023 14:59:50 -0500 Subject: [PATCH 06/41] Order endpoints corrections --- src/ZGoBackend.hs | 16 +++++-- test/Spec.hs | 114 ++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 108 insertions(+), 22 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index f63cae6..6bb9fc7 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1100,7 +1100,7 @@ routes pipe config = do , "orders" .= toJSON pOrders ]) --Get order by id for receipts - get "/api/order/:id" $ do + get "/order/:id" $ do oId <- param "id" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r oId @@ -1119,7 +1119,7 @@ routes pipe config = do [ "message" .= ("Order found!" :: String) , "order" .= toJSON (pOrder :: ZGoOrder) ]) - else status noContent204 + else status badRequest400 --Get order by session get "/api/order" $ do sess <- param "session" @@ -1162,8 +1162,16 @@ routes pipe config = do post "/api/order" $ do newOrder <- jsonData let q = payload (newOrder :: Payload ZGoOrder) - _ <- liftAndCatchIO $ run (upsertOrder q) - status created201 + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + if uaddress u == qaddress q + then do + _ <- liftAndCatchIO $ run (upsertOrder q) + status created201 + else status forbidden403 --Delete order Web.Scotty.delete "/api/order/:id" $ do oId <- param "id" diff --git a/test/Spec.hs b/test/Spec.hs index 463c3bf..0aeb496 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -326,8 +326,87 @@ main = do ] res <- httpLBS req getResponseStatus res `shouldBe` ok200 - describe "Order endpoints" $ do - prop "upsert order" testOrderAdd + describe "Order endpoints" $ + --prop "upsert order" testOrderAdd + do + it "adding order with bad session fails with 401" $ do + myTs <- liftIO getCurrentTime + let testOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000011")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + False + "" + "" + req <- + testPostJson "/api/order" $ + A.object ["payload" A..= A.toJSON testOrder] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` unauthorized401 + it "adding order with mismatched session fails with 403" $ do + myTs <- liftIO getCurrentTime + let testOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000011")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + False + "" + "" + req <- + testPostJson "/api/order" $ + A.object ["payload" A..= A.toJSON testOrder] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")] + req + getResponseStatus res `shouldBe` forbidden403 + it "adding order with correct session succeeds" $ do + myTs <- liftIO getCurrentTime + let testOrder = + ZGoOrder + (Just (read "627ab3ea2b05a76be3000011")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + myTs + False + "usd" + 102.0 + 0 + 0 + [] + False + "" + "" + req <- + testPostJson "/api/order" $ + A.object ["payload" A..= A.toJSON testOrder] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` created201 it "get order by session" $ do req <- testGet @@ -335,7 +414,7 @@ main = do [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "get order by session fails when invalid" $ do + it "get order by session fails with bad session" $ do req <- testGet "/api/order" @@ -343,24 +422,15 @@ main = do res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 it "get order by id" $ do - req <- - testGet - "/api/order/627ab3ea2b05a76be3000000" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req <- testGet "/order/627ab3ea2b05a76be3000000" [] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "get order with wrong id" $ do - req <- - testGet - "/api/order/6273hrb" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + it "get order with invalid id fails with 400" $ do + req <- testGet "/order/6273hrb" [] res <- httpLBS req - getResponseStatus res `shouldBe` noContent204 - it "get order by id fails with bad session" $ do - req <- - testGet - "/api/order/627ab3ea2b05a76be3000000" - [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + getResponseStatus res `shouldBe` badRequest400 + it "get order by id fails with bad token" $ do + req <- testGet "/order/627ab3ea2b05a76be3000000" [] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 it "get all orders for owner" $ do @@ -397,6 +467,14 @@ main = do [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 + it "delete order by id fails with mismatched session" $ do + req <- + testDelete + "/api/order/" + "627ab3ea2b05a76be3000000" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 describe "Item endpoint" $ do it "adding item with bad session fails" $ do let item = From 31eb42c1d57a6e863292c1fb256e79de761c4d3c Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 2 Jun 2023 13:49:03 -0500 Subject: [PATCH 07/41] Upgrade Haskell packages --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index aff10dc..2f4c81f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-20.19 +resolver: lts-20.23 #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml # User packages to be built. From 88ae8561951d421a9cfdfdef6c313bf4dfe42394 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 2 Jun 2023 13:51:17 -0500 Subject: [PATCH 08/41] Add random token for orders --- src/Order.hs | 19 ++++++++++++++++--- src/ZGoBackend.hs | 20 ++++++++++++++++++-- 2 files changed, 34 insertions(+), 5 deletions(-) diff --git a/src/Order.hs b/src/Order.hs index b62d6ef..1aeefdb 100644 --- a/src/Order.hs +++ b/src/Order.hs @@ -29,11 +29,12 @@ data ZGoOrder = , qpaid :: Bool , qexternalInvoice :: T.Text , qshortCode :: T.Text + , qtoken :: T.Text } deriving (Eq, Show, Generic) instance ToJSON ZGoOrder where - toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC) = + toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC tk) = case i of Just oid -> object @@ -50,6 +51,7 @@ instance ToJSON ZGoOrder where , "paid" .= paid , "externalInvoice" .= eI , "shortCode" .= sC + , "token" .= tk ] Nothing -> object @@ -66,6 +68,7 @@ instance ToJSON ZGoOrder where , "paid" .= paid , "externalInvoice" .= eI , "shortCode" .= sC + , "token" .= tk ] instance FromJSON ZGoOrder where @@ -84,6 +87,7 @@ instance FromJSON ZGoOrder where pd <- obj .: "paid" eI <- obj .: "externalInvoice" sC <- obj .: "shortCode" + tk <- obj .: "token" pure $ ZGoOrder (if not (null i) @@ -101,9 +105,10 @@ instance FromJSON ZGoOrder where pd eI sC + tk instance Val ZGoOrder where - val (ZGoOrder i a s ts c cur p t tZ l pd eI sC) = + val (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) = if isJust i then Doc [ "_id" =: i @@ -119,6 +124,7 @@ instance Val ZGoOrder where , "paid" =: pd , "externalInvoice" =: eI , "shortCode" =: sC + , "token" =: tk ] else Doc [ "address" =: a @@ -133,6 +139,7 @@ instance Val ZGoOrder where , "paid" =: pd , "externalInvoice" =: eI , "shortCode" =: sC + , "token" =: tk ] cast' (Doc d) = do i <- B.lookup "_id" d @@ -148,7 +155,8 @@ instance Val ZGoOrder where pd <- B.lookup "paid" d eI <- B.lookup "externalInvoice" d sC <- B.lookup "shortCode" d - Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC) + tk <- B.lookup "token" d + Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) cast' _ = Nothing -- Type to represent an order line item @@ -224,12 +232,17 @@ updateOrderTotals o = (qpaid o) (qexternalInvoice o) (qshortCode o) + (qtoken o) where newTotal :: ZGoOrder -> Double newTotal x = foldr tallyItems 0 (qlines x) tallyItems :: LineItem -> Double -> Double tallyItems y z = (lqty y * lcost y) + z +setOrderToken :: T.Text -> ZGoOrder -> ZGoOrder +setOrderToken token (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) = + ZGoOrder i a s ts c cur p t tZ l pd eI sC token + findOrder :: T.Text -> Action IO (Maybe Document) findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders") diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 6bb9fc7..b032f89 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -12,6 +12,8 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Exception (try) import Control.Monad import Control.Monad.IO.Class +import Crypto.RNG (newCryptoRNGState, runCryptoRNGT) +import Crypto.RNG.Utils (randomString) import Data.Aeson import Data.Array import qualified Data.Bson as B @@ -832,6 +834,7 @@ routes pipe config = do (T.concat [T.pack sUrl, "-", ordId, "-", orderKey]) "" + "" newId <- liftAndCatchIO $ run (insertWooOrder newOrder) status ok200 Web.Scotty.json (object ["order" .= show newId]) @@ -1169,8 +1172,16 @@ routes pipe config = do Just u -> do if uaddress u == qaddress q then do - _ <- liftAndCatchIO $ run (upsertOrder q) - status created201 + if qtoken q == "" + then do + t <- liftIO generateToken + _ <- + liftAndCatchIO $ + run (upsertOrder $ setOrderToken (T.pack t) q) + status created201 + else do + _ <- liftAndCatchIO $ run (upsertOrder q) + status created201 else status forbidden403 --Delete order Web.Scotty.delete "/api/order/:id" $ do @@ -1585,4 +1596,9 @@ checkUser run s = do user <- run (findUser s) return $ cast' . Doc =<< user +generateToken :: IO String +generateToken = do + rngState <- newCryptoRNGState + runCryptoRNGT rngState $ randomString 16 "abcdef0123456789" + debug = flip trace From 33df90eb96bb4b7275667956f1142fe91b3c2058 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 5 Jun 2023 07:47:51 -0500 Subject: [PATCH 09/41] Correct order endpoints --- src/ZGoBackend.hs | 54 +++++++++++++++++++++++++---------------- stack.yaml.lock | 8 +++--- test/Spec.hs | 62 ++++++++++++++++++++++++++--------------------- 3 files changed, 72 insertions(+), 52 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index b032f89..7e6aca1 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1090,38 +1090,42 @@ routes pipe config = do ]) --Get all closed orders for the address get "/api/allorders" $ do - addr <- param "address" - myOrders <- liftAndCatchIO $ run (findAllOrders addr) - case myOrders of - [] -> status noContent204 - _ -> do - let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder] - status ok200 - Web.Scotty.json - (object - [ "message" .= ("Orders found!" :: String) - , "orders" .= toJSON pOrders - ]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u) + case myOrders of + [] -> status noContent204 + _ -> do + let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder] + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Orders found!" :: String) + , "orders" .= toJSON pOrders + ]) --Get order by id for receipts get "/order/:id" $ do oId <- param "id" + token <- param "token" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r oId then do myOrder <- liftAndCatchIO $ run (findOrderById oId) - case myOrder of + case cast' . Doc =<< myOrder of Nothing -> status noContent204 - Just o -> do - let o' = cast' (Doc o) - case o' of - Nothing -> status internalServerError500 - Just pOrder -> do + Just pOrder -> do + if qtoken pOrder == token + then do status ok200 Web.Scotty.json (object [ "message" .= ("Order found!" :: String) , "order" .= toJSON (pOrder :: ZGoOrder) ]) + else status forbidden403 else status badRequest400 --Get order by session get "/api/order" $ do @@ -1186,8 +1190,16 @@ routes pipe config = do --Delete order Web.Scotty.delete "/api/order/:id" $ do oId <- param "id" - liftAndCatchIO $ run (deleteOrder oId) - status ok200 + session <- param "session" + o <- liftAndCatchIO $ run (findOrderById oId) + case cast' . Doc =<< o of + Nothing -> status badRequest400 + Just order -> do + if qsession order == session + then do + liftAndCatchIO $ run (deleteOrder oId) + status ok200 + else status forbidden403 -- Get language for component get "/getmainlang" $ do lang <- param "lang" @@ -1599,6 +1611,6 @@ checkUser run s = do generateToken :: IO String generateToken = do rngState <- newCryptoRNGState - runCryptoRNGT rngState $ randomString 16 "abcdef0123456789" + runCryptoRNGT rngState $ randomString 24 "abcdef0123456789" debug = flip trace diff --git a/stack.yaml.lock b/stack.yaml.lock index 5a8e945..e7de262 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -31,7 +31,7 @@ packages: hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 snapshots: - completed: - sha256: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64 - size: 649618 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/19.yaml - original: lts-20.19 + sha256: 4c972e067bae16b95961dbfdd12e07f1ee6c8fffabbfa05c3d65100b03f548b7 + size: 650253 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/23.yaml + original: lts-20.23 diff --git a/test/Spec.hs b/test/Spec.hs index 0aeb496..3bf47c9 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -346,6 +346,7 @@ main = do False "" "" + "testToken4321" req <- testPostJson "/api/order" $ A.object ["payload" A..= A.toJSON testOrder] @@ -372,6 +373,7 @@ main = do False "" "" + "testToken4321" req <- testPostJson "/api/order" $ A.object ["payload" A..= A.toJSON testOrder] @@ -398,6 +400,7 @@ main = do False "" "" + "testToken4321" req <- testPostJson "/api/order" $ A.object ["payload" A..= A.toJSON testOrder] @@ -422,48 +425,34 @@ main = do res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 it "get order by id" $ do - req <- testGet "/order/627ab3ea2b05a76be3000000" [] + req <- + testGet + "/order/627ab3ea2b05a76be3000000" + [("token", Just "testToken1234")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "get order with invalid id fails with 400" $ do - req <- testGet "/order/6273hrb" [] + req <- testGet "/order/6273hrb" [("token", Just "testToken1234")] res <- httpLBS req getResponseStatus res `shouldBe` badRequest400 it "get order by id fails with bad token" $ do - req <- testGet "/order/627ab3ea2b05a76be3000000" [] + req <- + testGet + "/order/627ab3ea2b05a76be3000000" + [("token", Just "wrongToken1234")] res <- httpLBS req - getResponseStatus res `shouldBe` unauthorized401 + getResponseStatus res `shouldBe` forbidden403 it "get all orders for owner" $ do req <- testGet "/api/allorders" - [ ("address", Just "Zaddy") - , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - ] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "get all orders for owner fails with bad session" $ do req <- testGet "/api/allorders" - [ ("address", Just "Zaddy") - , ("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd") - ] - res <- httpLBS req - getResponseStatus res `shouldBe` unauthorized401 - it "delete order by id" $ do - req <- - testDelete - "/api/order/" - "627ab3ea2b05a76be3000000" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] - res <- httpLBS req - getResponseStatus res `shouldBe` ok200 - it "delete order by id fails with bad session" $ do - req <- - testDelete - "/api/order/" - "627ab3ea2b05a76be3000000" [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 @@ -475,6 +464,22 @@ main = do [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")] res <- httpLBS req getResponseStatus res `shouldBe` forbidden403 + it "delete order by id fails with bad session" $ do + req <- + testDelete + "/api/order/" + "627ab3ea2b05a76be3000000" + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "delete order by id" $ do + req <- + testDelete + "/api/order/" + "627ab3ea2b05a76be3000000" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` ok200 describe "Item endpoint" $ do it "adding item with bad session fails" $ do let item = @@ -748,6 +753,7 @@ main = do False "" "" + "testToken1234" let ordTest = val myOrder case ordTest of Doc oT -> access p master "test" (insert_ "orders" oT) @@ -1112,7 +1118,7 @@ startAPI config = do let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000000")) - "Zaddy" + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False @@ -1124,6 +1130,7 @@ startAPI config = do False "" "" + "testToken1234" let ordTest = val myOrder case ordTest of Doc oT -> access pipe master "test" (insert_ "orders" oT) @@ -1177,7 +1184,8 @@ instance Arbitrary ZGoOrder where l <- arbitrary pd <- arbitrary eI <- arbitrary - ZGoOrder i a s ts c cur p t tZ l pd eI <$> arbitrary + sc <- arbitrary + ZGoOrder i a s ts c cur p t tZ l pd eI sc <$> arbitrary instance Arbitrary LineItem where arbitrary = do From f625373e2e241bf58c0294caba431709b065bc6f Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 9 Jun 2023 10:51:42 -0500 Subject: [PATCH 10/41] Harden the wootoken endpoints --- src/WooCommerce.hs | 7 +++- src/ZGoBackend.hs | 101 ++++++++++++++++++++++++++++----------------- test/Spec.hs | 92 ++++++++++++++++++++++++++++++----------- 3 files changed, 137 insertions(+), 63 deletions(-) diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index a7b16b4..212a874 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -47,8 +47,11 @@ instance Val WooToken where cast' _ = Nothing -- Database actions -findWooToken :: ObjectId -> Action IO (Maybe Document) -findWooToken oid = findOne (select ["owner" =: oid] "wootokens") +findWooToken :: Maybe ObjectId -> Action IO (Maybe Document) +findWooToken oid = + case oid of + Nothing -> return Nothing + Just o -> findOne (select ["owner" =: o] "wootokens") addUrl :: WooToken -> T.Text -> Action IO () addUrl t u = diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 7e6aca1..e4702d7 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -673,54 +673,78 @@ routes pipe config = do else status noContent204 -- Get the xeroaccount code get "/api/xeroaccount" $ do - oAdd <- param "address" - res <- liftAndCatchIO $ run (findToken oAdd) - let c = cast' . Doc =<< res - case c of - Nothing -> status noContent204 - Just c1 -> do - status ok200 - Web.Scotty.json - (object - [ "message" .= ("Xero account code found" :: String) - , "code" .= t_code c1 - ]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + res <- liftAndCatchIO $ run (findToken $ uaddress u) + let c = cast' . Doc =<< res + case c of + Nothing -> status noContent204 + Just c1 -> do + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Xero account code found" :: String) + , "code" .= t_code c1 + ]) -- Save the xeroaccount code post "/api/xeroaccount" $ do - oAdd <- param "address" + session <- param "session" c <- param "code" - liftAndCatchIO $ run (addAccCode oAdd c) - status accepted202 + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + let oAdd = uaddress u + liftAndCatchIO $ run (addAccCode oAdd c) + status accepted202 -- Get the WooCommerce token get "/api/wootoken" $ do - oid <- param "ownerid" - res <- liftAndCatchIO $ run (findWooToken (read oid)) - let t1 = cast' . Doc =<< res - case t1 of - Nothing -> status noContent204 - Just t -> do - status ok200 - Web.Scotty.json - (object - [ "ownerid" .= show (w_owner t) - , "token" .= w_token t - , "siteurl" .= w_url t - ]) + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + owner <- liftAndCatchIO $ run (findOwner $ uaddress u) + case cast' . Doc =<< owner of + Nothing -> status internalServerError500 + Just o -> do + res <- liftAndCatchIO $ run (findWooToken $ o_id o) + let t1 = cast' . Doc =<< res + case t1 of + Nothing -> status noContent204 + Just t -> do + status ok200 + Web.Scotty.json + (object + [ "ownerid" .= show (w_owner t) + , "token" .= w_token t + , "siteurl" .= w_url t + ]) post "/api/wootoken" $ do oid <- param "ownerid" - res <- liftAndCatchIO $ run (findOwnerById oid) - let o1 = cast' . Doc =<< res - case o1 of - Nothing -> status noContent204 - Just o -> do - liftAndCatchIO $ run (generateWooToken o) - status accepted202 + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do + res <- liftAndCatchIO $ run (findOwnerById oid) + case cast' . Doc =<< res of + Nothing -> status badRequest400 + Just o -> do + if oaddress o == uaddress u + then do + liftAndCatchIO $ run (generateWooToken o) + status accepted202 + else status forbidden403 -- Authenticate the WooCommerce plugin get "/auth" $ do oid <- param "ownerid" t <- param "token" siteurl <- param "siteurl" - res <- liftAndCatchIO $ run (findWooToken (read oid)) + res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) let c1 = cast' . Doc =<< res case c1 of Nothing -> do @@ -776,7 +800,7 @@ routes pipe config = do amount <- param "amount" sUrl <- param "siteurl" orderKey <- param "orderkey" - res <- liftAndCatchIO $ run (findWooToken (read oid)) + res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) let c = cast' . Doc =<< res case c of Nothing -> do @@ -1409,7 +1433,8 @@ scanPayments config pipe = do "WC" -> do let wOwner = fst $ head sResult ! 2 wooT <- - access p master dbName $ findWooToken (read wOwner) + access p master dbName $ + findWooToken $ Just (read wOwner) let wT = wooT >>= (cast' . Doc) case wT of Nothing -> error "Failed to read WooCommerce token" diff --git a/test/Spec.hs b/test/Spec.hs index 3bf47c9..9feb956 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -232,18 +232,32 @@ main = do req <- testGet "/api/xeroaccount" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - , ("address", Just "Zaddy") - ] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "returns 401 with invalid session" $ do + it "reading returns 401 with invalid session" $ do req <- testGet "/api/xeroaccount" [("session", Just "fnelrkgnlyebrlvns82949")] res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 + it "setting returns 401 with invalid session" $ do + req <- + testPost + "/api/xeroaccount" + [("session", Just "fnelrkgnlyebrlvns82949")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "setting succeeds with valid session" $ do + req <- + testPost + "/api/xeroaccount" + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("code", Just "ZEC") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` accepted202 describe "User endpoint" $ do it "returns a user for a session" $ do req <- @@ -289,7 +303,7 @@ main = do testDelete "/api/user/" "6272a90f2b05a74cf1000003" - [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa")] res <- httpLBS req getResponseStatus res `shouldBe` ok200 describe "Owner endpoint" $ @@ -553,7 +567,25 @@ main = do res <- httpLBS req getResponseStatus res `shouldBe` ok200 describe "WooCommerce endpoints" $ do - it "generate token" $ do + it "generate token with invalid session gives 401" $ do + req <- + testPost + "/api/wootoken" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "generate token with mismatched session gives 403" $ do + req <- + testPost + "/api/wootoken" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` forbidden403 + it "generate token with valid session succeeds" $ do req <- testPost "/api/wootoken" @@ -741,7 +773,7 @@ main = do let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000001")) - "Zaddy" + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False @@ -769,25 +801,26 @@ main = do Just o2 -> qpaid o2 `shouldBe` True describe "Xero data" $ do it "token is saved" $ \p -> do - let myToken = - XeroToken - Nothing - "Zaddy" - "superFakeToken123" - 1800 - "anotherSuperFakeToken" - (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) - (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) - "" - _ <- access p master "test" $ upsertToken myToken - t <- access p master "test" $ findToken "Zaddy" + t <- + access p master "test" $ + findToken + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False - Just t2 -> t_address t2 `shouldBe` "Zaddy" + Just t2 -> + t_address t2 `shouldBe` + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" it "code is saved" $ \p -> do - _ <- access p master "test" $ addAccCode "Zaddy" "ZEC" - t <- access p master "test" $ findToken "Zaddy" + _ <- + access p master "test" $ + addAccCode + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "ZEC" + t <- + access p master "test" $ + findToken + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False @@ -1054,6 +1087,8 @@ startAPI config = do _ <- access pipe master "test" (Database.MongoDB.delete (select [] "users")) _ <- access pipe master "test" (Database.MongoDB.delete (select [] "items")) _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders")) + _ <- + access pipe master "test" (Database.MongoDB.delete (select [] "xerotokens")) let myUser = User (Just (read "6272a90f2b05a74cf1000001" :: ObjectId)) @@ -1066,7 +1101,7 @@ startAPI config = do User (Just (read "6272a90f2b05a74cf1000003" :: ObjectId)) "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" - "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa" 1613487 "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" True @@ -1156,6 +1191,17 @@ startAPI config = do case proSessionTest of Doc pS1 -> access pipe master "test" (insert_ "prosessions" pS1) _ -> fail "Couldn't save test ZGoProSession in DB" + let myToken = + XeroToken + Nothing + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "superFakeToken123" + 1800 + "anotherSuperFakeToken" + (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) + (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0)) + "" + _ <- access pipe master "test" $ upsertToken myToken --let myWooToken = --WooToken --Nothing From e4e95b81b2d60d57013d1d482137f18a9f348325 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 12 Jun 2023 15:09:13 -0500 Subject: [PATCH 11/41] Add new JSON serialization for WooToken --- CHANGELOG.md | 4 ++++ src/WooCommerce.hs | 41 ++++++++++++++++++++++++++++------------- src/ZGoBackend.hs | 9 +++++++-- 3 files changed, 39 insertions(+), 15 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9e827e1..92bddfd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [1.6.0] +### Added + +- New JSON serialization for WooTokens. + ### Changed - Modified the process to mark paid orders to ensure only payments to the shop's wallet get marked as paid diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index 212a874..2b7b160 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -28,6 +28,31 @@ data WooToken = } deriving (Eq, Show) +instance FromJSON WooToken where + parseJSON = + withObject "WooToken" $ \obj -> do + i <- obj .: "_id" + o <- obj .: "owner" + t <- obj .: "token" + u <- obj .: "url" + pure $ + WooToken + (if not (null i) + then Just (read i) + else Nothing) + (read o) + t + u + +instance ToJSON WooToken where + toJSON (WooToken i o t u) = + case i of + Just oid -> + object ["_id" .= show oid, "owner" .= show o, "token" .= t, "url" .= u] + Nothing -> + object + ["_id" .= ("" :: String), "owner" .= show o, "token" .= t, "url" .= u] + instance Val WooToken where val (WooToken i o t u) = if isJust i @@ -82,21 +107,11 @@ payWooOrder u i o t p z = do then return () else error "Failed to report payment to WooCommerce" -generateWooToken :: Owner -> Action IO () -generateWooToken o = +generateWooToken :: Owner -> String -> Action IO () +generateWooToken o s = case o_id o of Just ownerid -> do - let tokenHash = - BLK.hash - [ BA.pack . BS.unpack . C.pack . T.unpack $ oname o <> oaddress o :: BA.Bytes - ] - let wooToken = - val $ - WooToken - Nothing - ownerid - (T.pack . show $ (tokenHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN)) - Nothing + let wooToken = val $ WooToken Nothing ownerid (T.pack s) Nothing case wooToken of Doc wT -> insert_ "wootokens" wT _ -> error "Couldn't create the WooCommerce token" diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index e4702d7..7ba2709 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -736,7 +736,8 @@ routes pipe config = do Just o -> do if oaddress o == uaddress u then do - liftAndCatchIO $ run (generateWooToken o) + tk <- liftIO generateToken + liftAndCatchIO $ run (generateWooToken o tk) status accepted202 else status forbidden403 -- Authenticate the WooCommerce plugin @@ -753,7 +754,7 @@ routes pipe config = do (object ["authorized" .= False, "message" .= ("Owner not found" :: String)]) Just c -> - if t == w_token c + if blk3Hash t == blk3Hash (T.unpack $ w_token c) then if isNothing (w_url c) then do liftAndCatchIO $ run (addUrl c siteurl) @@ -791,6 +792,10 @@ routes pipe config = do [ "authorized" .= False , "message" .= ("Token mismatch" :: String) ]) + where blk3Hash :: String -> String + blk3Hash s = + show + (BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest BLK.DEFAULT_DIGEST_LEN) get "/woopayment" $ do oid <- param "ownerid" t <- param "token" From c2fc8b8ae9d9e602481d5daaf6d736755b1533d5 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 12 Jun 2023 15:48:23 -0500 Subject: [PATCH 12/41] Add tests for random WooToken --- src/WooCommerce.hs | 24 ++++++++--------- test/Spec.hs | 66 +++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 71 insertions(+), 19 deletions(-) diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index 2b7b160..1699efc 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -31,27 +31,25 @@ data WooToken = instance FromJSON WooToken where parseJSON = withObject "WooToken" $ \obj -> do - i <- obj .: "_id" - o <- obj .: "owner" + i <- obj .:? "_id" + o <- obj .: "ownerid" t <- obj .: "token" - u <- obj .: "url" - pure $ - WooToken - (if not (null i) - then Just (read i) - else Nothing) - (read o) - t - u + u <- obj .: "siteurl" + pure $ WooToken (read <$> i) (read o) t u instance ToJSON WooToken where toJSON (WooToken i o t u) = case i of Just oid -> - object ["_id" .= show oid, "owner" .= show o, "token" .= t, "url" .= u] + object + ["_id" .= show oid, "ownerid" .= show o, "token" .= t, "siteurl" .= u] Nothing -> object - ["_id" .= ("" :: String), "owner" .= show o, "token" .= t, "url" .= u] + [ "_id" .= ("" :: String) + , "ownerid" .= show o + , "token" .= t + , "siteurl" .= u + ] instance Val WooToken where val (WooToken i o t u) = diff --git a/test/Spec.hs b/test/Spec.hs index 9feb956..ac402f4 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,6 +13,7 @@ import Data.Either import Data.Maybe import Data.SecureMem import qualified Data.Text as T +import qualified Data.Text.Encoding as E import Data.Time import Data.Time.Calendar import Data.Time.Clock @@ -594,6 +595,20 @@ main = do ] res <- httpLBS req getResponseStatus res `shouldBe` accepted202 + it "read token gives 401 with bad session" $ do + req <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + it "read token succeeds with valid session" $ do + req <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "authenticate with incorrect owner" $ do req <- testPublicGet @@ -617,13 +632,17 @@ main = do res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` accepted202 it "authenticate with correct token" $ do + req1 <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res1 <- httpJSON req1 + let tk = getResponseBody (res1 :: Response WooToken) req <- testPublicGet "/auth" [ ("ownerid", Just "627ad3492b05a76be3000001") - , ( "token" - , Just - "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") + , ("token", Just $ (E.encodeUtf8 . w_token) tk) , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") ] res <- httpJSON req @@ -641,13 +660,17 @@ main = do res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` accepted202 it "request order creation" $ do + req1 <- + testGet + "/api/wootoken" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res1 <- httpJSON req1 + let tk = getResponseBody (res1 :: Response WooToken) req <- testPublicGet "/woopayment" [ ("ownerid", Just "627ad3492b05a76be3000001") - , ( "token" - , Just - "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") + , ("token", Just $ (E.encodeUtf8 . w_token) tk) , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") , ("order_id", Just "1234") , ("currency", Just "usd") @@ -1143,11 +1166,42 @@ startAPI config = do False "" "" + let myOwner1 = + Owner + (Just (read "627ad3492b05a76be3000008")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3fake" + "Test shop 2" + "usd" + False + 0 + False + 0 + "Roxy" + "Foo" + "roxy@zgo.cash" + "1 Main St" + "Mpls" + "Minnesota" + "55401" + "" + "missyfoo.io" + "United States" + True + False + False + (UTCTime (fromGregorian 2023 8 6) (secondsToDiffTime 0)) + False + "" + "" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners")) let o = val myOwner case o of Doc d -> access pipe master "test" (insert_ "owners" d) _ -> fail "Couldn't save Owner in DB" + let o1 = val myOwner1 + case o1 of + Doc d1 -> access pipe master "test" (insert_ "owners" d1) + _ -> fail "Couldn't save Owner1 in DB" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders")) myTs <- liftIO getCurrentTime let myOrder = From 353c91204a642ca96cf27fbd45a1b0c05202f729 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 15 Jun 2023 08:55:39 -0500 Subject: [PATCH 13/41] Enhance payment confirmation logic --- CHANGELOG.md | 1 + src/Owner.hs | 4 ++ src/ZGoBackend.hs | 178 +++++++++++++++++++++++++--------------------- 3 files changed, 101 insertions(+), 82 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 92bddfd..d127dc7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Modified the process of scanning for payments to only scan addresses that have an active ZGo session and have enabled payment confirmations - Modified the process to mark paid orders to ensure only payments to the shop's wallet get marked as paid - Modified the `items` endpoint to use the login session to identify records diff --git a/src/Owner.hs b/src/Owner.hs index 867f923..267fa2e 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -407,6 +407,10 @@ findOwnerById :: T.Text -> Action IO (Maybe Document) findOwnerById i = findOne (select ["_id" =: (read (T.unpack i) :: ObjectId)] "owners") +findActiveOwners :: Action IO [Document] +findActiveOwners = + rest =<< find (select ["paid" =: True, "payconf" =: True] "owners") + -- | Function to find Owners about to expire findExpiringOwners :: UTCTime -> Action IO [Document] findExpiringOwners now = diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 7ba2709..52e9ae5 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1386,88 +1386,102 @@ scanZcash' config pipe = do -- | Function to scan loaded viewing keys for payments scanPayments :: Config -> Pipe -> IO () scanPayments config pipe = do - shops <- listAddresses (c_nodeUser config) (c_nodePwd config) - mapM_ (findPaidOrders config pipe) shops - where - findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO () - findPaidOrders c p z = do - paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5 - case paidTxs of - Right txs -> do - let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" - let k = filter (isRelevant r) txs - let j = map (getOrderId r) k - mapM_ (recordPayment p (c_dbName config) z) j - Left e -> print e - getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) - getOrderId re t = do - let reg = matchAllText re (T.unpack $ zmemo t) - if not (null reg) - then (fst $ head reg ! 1, zamount t) - else ("", 0) - recordPayment :: Pipe -> T.Text -> ZcashAddress -> (String, Double) -> IO () - recordPayment p dbName z x = do - o <- access p master dbName $ findOrderById (fst x) - let xOrder = o >>= (cast' . Doc) - case xOrder of - Nothing -> error "Failed to retrieve order from database" - Just xO -> - when - (not (qpaid xO) && - qexternalInvoice xO /= "" && - qtotalZec xO == snd x && addy z == qaddress xO) $ do - let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" - let sResult = matchAllText sReg (T.unpack $ qsession xO) - if not (null sResult) - then case fst $ head sResult ! 1 of - "Xero" -> do - xeroConfig <- access p master dbName findXero - let xC = xeroConfig >>= (cast' . Doc) - case xC of - Nothing -> error "Failed to read Xero config" - Just xConf -> do - requestXeroToken p dbName xConf "" (qaddress xO) - payXeroInvoice - p - dbName - (qexternalInvoice xO) - (qaddress xO) - (qtotal xO) - (qtotalZec xO) - liftIO $ access p master dbName $ markOrderPaid x - "WC" -> do - let wOwner = fst $ head sResult ! 2 - wooT <- - access p master dbName $ - findWooToken $ Just (read wOwner) - let wT = wooT >>= (cast' . Doc) - case wT of - Nothing -> error "Failed to read WooCommerce token" - Just wt -> do - let iReg = mkRegex "(.*)-(.*)-.*" - let iResult = - matchAllText - iReg - (T.unpack $ qexternalInvoice xO) - if not (null iResult) - then do - let wUrl = - E.decodeUtf8With lenientDecode . - B64.decodeLenient . C.pack $ - fst $ head iResult ! 1 - let iNum = fst $ head iResult ! 2 - payWooOrder - (T.unpack wUrl) - (C.pack iNum) - (C.pack $ maybe "" show (q_id xO)) - (C.pack . T.unpack $ w_token wt) - (C.pack . show $ qprice xO) - (C.pack . show $ qtotalZec xO) - liftIO $ access p master dbName $ markOrderPaid x - else error - "Couldn't parse externalInvoice for WooCommerce" - _ -> putStrLn "Not an integration order" - else putStrLn "Not an integration order" + shopRecords <- access pipe master (c_dbName config) findActiveOwners + case shopRecords of + [] -> return () + _ -> do + let shops = cast' . Doc <$> shopRecords :: [Maybe Owner] + let validShopAddresses = map (maybe "" oaddress) $ filter isJust shops + mapM_ (findPaidOrders config pipe) validShopAddresses + where findPaidOrders :: Config -> Pipe -> T.Text -> IO () + findPaidOrders c p z = do + paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) z 5 + case paidTxs of + Right txs -> do + let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" + let k = filter (isRelevant r) txs + let j = map (getOrderId r) k + mapM_ (recordPayment p (c_dbName config) z) j + Left e -> print e + getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) + getOrderId re t = do + let reg = matchAllText re (T.unpack $ zmemo t) + if not (null reg) + then (fst $ head reg ! 1, zamount t) + else ("", 0) + recordPayment :: + Pipe -> T.Text -> T.Text -> (String, Double) -> IO () + recordPayment p dbName z x = do + o <- access p master dbName $ findOrderById (fst x) + let xOrder = o >>= (cast' . Doc) + case xOrder of + Nothing -> error "Failed to retrieve order from database" + Just xO -> + when + (not (qpaid xO) && + qexternalInvoice xO /= "" && + qtotalZec xO == snd x && z == qaddress xO) $ do + let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" + let sResult = matchAllText sReg (T.unpack $ qsession xO) + if not (null sResult) + then case fst $ head sResult ! 1 of + "Xero" -> do + xeroConfig <- access p master dbName findXero + let xC = xeroConfig >>= (cast' . Doc) + case xC of + Nothing -> error "Failed to read Xero config" + Just xConf -> do + requestXeroToken + p + dbName + xConf + "" + (qaddress xO) + payXeroInvoice + p + dbName + (qexternalInvoice xO) + (qaddress xO) + (qtotal xO) + (qtotalZec xO) + liftIO $ + access p master dbName $ markOrderPaid x + "WC" -> do + let wOwner = fst $ head sResult ! 2 + wooT <- + access p master dbName $ + findWooToken $ Just (read wOwner) + let wT = wooT >>= (cast' . Doc) + case wT of + Nothing -> + error "Failed to read WooCommerce token" + Just wt -> do + let iReg = mkRegex "(.*)-(.*)-.*" + let iResult = + matchAllText + iReg + (T.unpack $ qexternalInvoice xO) + if not (null iResult) + then do + let wUrl = + E.decodeUtf8With lenientDecode . + B64.decodeLenient . C.pack $ + fst $ head iResult ! 1 + let iNum = fst $ head iResult ! 2 + payWooOrder + (T.unpack wUrl) + (C.pack iNum) + (C.pack $ maybe "" show (q_id xO)) + (C.pack . T.unpack $ w_token wt) + (C.pack . show $ qprice xO) + (C.pack . show $ qtotalZec xO) + liftIO $ + access p master dbName $ + markOrderPaid x + else error + "Couldn't parse externalInvoice for WooCommerce" + _ -> putStrLn "Not an integration order" + else putStrLn "Not an integration order" -- | RPC methods -- | List addresses with viewing keys loaded From 9f6468347458c6313d88b2d0872324889862b9e9 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 15 Jun 2023 19:40:58 -0500 Subject: [PATCH 14/41] Implement new endpoint for viewing keys Mantis Issue 28 --- CHANGELOG.md | 2 ++ package.yaml | 1 + src/Owner.hs | 4 ++++ src/ZGoBackend.hs | 37 ++++++++++++++++++++++++++++ stack.yaml | 10 ++++++++ stack.yaml.lock | 61 +++++++++++++++++++++++++++++++++++++++++++++++ zgo-backend.cabal | 1 + 7 files changed, 116 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index d127dc7..26e1ba3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added - New JSON serialization for WooTokens. +- New `/api/ownervk` endpoint to save viewing keys +- Use of `zcash-haskell` library to validate Sapling viewing keys ### Changed diff --git a/package.yaml b/package.yaml index 98fe2f8..9a60c9a 100644 --- a/package.yaml +++ b/package.yaml @@ -62,6 +62,7 @@ library: - crypto-rng - megaparsec - uuid + - zcash-haskell executables: zgo-backend-exe: diff --git a/src/Owner.hs b/src/Owner.hs index 267fa2e..9649779 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -441,6 +441,10 @@ updateOwnerSettings os = ] ] +upsertViewingKey :: Owner -> String -> Action IO () +upsertViewingKey o vk = + modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]] + -- | Type for a pro session data ZGoProSession = ZGoProSession diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 52e9ae5..ac1a5bb 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -66,6 +66,7 @@ import Web.Scotty import WooCommerce import Xero import ZGoTx +import ZcashHaskell.Sapling -- Models for API objects -- | A type to model Zcash RPC calls @@ -1055,6 +1056,42 @@ routes pipe config = do liftAndCatchIO $ run $ updateOwnerSettings q status accepted202 else status noContent204 + post "/api/ownervk" $ do + s <- param "session" + u <- liftAndCatchIO $ run (findUser s) + o <- jsonData + let q = payload (o :: Payload String) + case cast' . Doc =<< u of + Nothing -> status unauthorized401 + Just u' -> do + if isValidSaplingViewingKey $ C.pack q + then if matchSaplingAddress + (C.pack q) + (C.pack . T.unpack $ uaddress u') + then do + owner <- liftAndCatchIO $ run (findOwner $ uaddress u') + case cast' . Doc =<< owner of + Nothing -> status badRequest400 + Just o' -> do + unless (oviewkey o' /= "") $ do + vkInfo <- + liftAndCatchIO $ + makeZcashCall + nodeUser + nodePwd + "z_importviewingkey" + [Data.Aeson.String (T.strip . T.pack $ q), "no"] + let content = + getResponseBody vkInfo :: RpcResponse Object + if isNothing (err content) + then do + _ <- liftAndCatchIO $ run (upsertViewingKey o' q) + status created201 + else do + text $ L.pack . show $ err content + status badRequest400 + else status forbidden403 + else status badRequest400 --Get items associated with the given address get "/api/items" $ do session <- param "session" diff --git a/stack.yaml b/stack.yaml index 2f4c81f..d65ab03 100644 --- a/stack.yaml +++ b/stack.yaml @@ -44,6 +44,16 @@ packages: extra-deps: - git: https://github.com/reach-sh/haskell-hexstring.git commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git + commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git + commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 + - git: https://github.com/well-typed/borsh.git + commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 + - aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 + - vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 + - generically-0.1.1 + - vector-algorithms-0.9.0.1 - blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 - crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 # Override default flag values for local packages and extra-deps diff --git a/stack.yaml.lock b/stack.yaml.lock index e7de262..552f32f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -15,6 +15,67 @@ packages: original: commit: 085c16fb21b9f856a435a3faab980e7e0b319341 git: https://github.com/reach-sh/haskell-hexstring.git +- completed: + commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git + name: zcash-haskell + pantry-tree: + sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21 + size: 1126 + version: 0.1.0 + original: + commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git +- completed: + commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 + git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git + name: foreign-rust + pantry-tree: + sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42 + size: 2315 + version: 0.1.0 + original: + commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 + git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git +- completed: + commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 + git: https://github.com/well-typed/borsh.git + name: borsh + pantry-tree: + sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b + size: 2268 + version: 0.3.0 + original: + commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 + git: https://github.com/well-typed/borsh.git +- completed: + hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 + pantry-tree: + sha256: 58d33beedd6e0ff79920c636d8a4295deb684b6e97c9b1ca94d3c780958d6302 + size: 82465 + original: + hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 +- completed: + hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 + pantry-tree: + sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a + size: 4092 + original: + hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 +- completed: + hackage: generically-0.1.1@sha256:2b9b5efb6eea2fb65377565d53d85b0ccc5b37404fba4bef1d60277caa877e5e,1155 + pantry-tree: + sha256: 98a8fe89d516d3752a9cc0af22cfa652f098cc6613da080762b63aa1d596e56d + size: 233 + original: + hackage: generically-0.1.1 +- completed: + hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826 + pantry-tree: + sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0 + size: 1510 + original: + hackage: vector-algorithms-0.9.0.1 - completed: hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 pantry-tree: diff --git a/zgo-backend.cabal b/zgo-backend.cabal index b70613d..ab2c428 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -78,6 +78,7 @@ library , wai-cors , wai-extra , warp-tls + , zcash-haskell default-language: Haskell2010 executable zgo-backend-exe From 05d0042a60c0330b64d732b2c96acabe0fef9817 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 16 Jun 2023 10:22:38 -0500 Subject: [PATCH 15/41] Add tests for new viewing key endpoint --- package.yaml | 1 + src/ZGoBackend.hs | 72 ++++++++++++++++++++---------------- test/Spec.hs | 93 ++++++++++++++++++++++++++++++++++++++--------- zgo-backend.cabal | 1 + 4 files changed, 118 insertions(+), 49 deletions(-) diff --git a/package.yaml b/package.yaml index 9a60c9a..60fdc9a 100644 --- a/package.yaml +++ b/package.yaml @@ -164,3 +164,4 @@ tests: - scotty - megaparsec - uuid + - zcash-haskell diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index ac1a5bb..4f8b38a 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -67,6 +67,8 @@ import WooCommerce import Xero import ZGoTx import ZcashHaskell.Sapling +import ZcashHaskell.Types (RawData(..)) +import ZcashHaskell.Utils (decodeBech32) -- Models for API objects -- | A type to model Zcash RPC calls @@ -1061,37 +1063,45 @@ routes pipe config = do u <- liftAndCatchIO $ run (findUser s) o <- jsonData let q = payload (o :: Payload String) - case cast' . Doc =<< u of - Nothing -> status unauthorized401 - Just u' -> do - if isValidSaplingViewingKey $ C.pack q - then if matchSaplingAddress - (C.pack q) - (C.pack . T.unpack $ uaddress u') - then do - owner <- liftAndCatchIO $ run (findOwner $ uaddress u') - case cast' . Doc =<< owner of - Nothing -> status badRequest400 - Just o' -> do - unless (oviewkey o' /= "") $ do - vkInfo <- - liftAndCatchIO $ - makeZcashCall - nodeUser - nodePwd - "z_importviewingkey" - [Data.Aeson.String (T.strip . T.pack $ q), "no"] - let content = - getResponseBody vkInfo :: RpcResponse Object - if isNothing (err content) - then do - _ <- liftAndCatchIO $ run (upsertViewingKey o' q) - status created201 - else do - text $ L.pack . show $ err content - status badRequest400 - else status forbidden403 - else status badRequest400 + let qRaw = decodeBech32 $ C.pack q + if hrp qRaw == "fail" + then status badRequest400 + else do + let qBytes = bytes qRaw + case cast' . Doc =<< u of + Nothing -> status unauthorized401 + Just u' -> do + if isValidSaplingViewingKey qBytes + then if matchSaplingAddress + qBytes + (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') + then do + owner <- liftAndCatchIO $ run (findOwner $ uaddress u') + case cast' . Doc =<< owner of + Nothing -> status badRequest400 + Just o' -> do + unless (oviewkey o' /= "") $ do + vkInfo <- + liftAndCatchIO $ + makeZcashCall + nodeUser + nodePwd + "z_importviewingkey" + [ Data.Aeson.String (T.strip . T.pack $ q) + , "no" + ] + let content = + getResponseBody vkInfo :: RpcResponse Object + if isNothing (err content) + then do + _ <- + liftAndCatchIO $ run (upsertViewingKey o' q) + status created201 + else do + text $ L.pack . show $ err content + status badRequest400 + else status forbidden403 + else status badRequest400 --Get items associated with the given address get "/api/items" $ do session <- param "session" diff --git a/test/Spec.hs b/test/Spec.hs index ac402f4..5f17d11 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -403,7 +403,7 @@ main = do let testOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000011")) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False @@ -518,7 +518,7 @@ main = do (Just (read "627d7ba92b05a76be3000013")) "Table" "Oak" - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" 499.99 req <- testPostJson "/api/item" $ A.object ["payload" A..= A.toJSON item] @@ -721,6 +721,63 @@ main = do ] res <- httpLBS req getResponseStatus res `shouldBe` noContent204 + describe "Viewing Key endpoint" $ do + let vk0 = + "zxviews1qwrw0jlxqqqqpqr9faepwqpgj09f0ee55mfwl60eumv6duk5pwncntweah0xdlhqrwre2fgmgersah9atx92z6pmxec8t32mpz59t47yuplkcdcaw3873aalv7e59xhwv846g9q9qjy0ypc68ceypg6pux490dr4snsc4m482l57rvnzj2lsh4f3dv6mltc75z72pypkx0dchwpumdwfuajstfhwulv30kjt5l0x7juwe523ufwz2xleplxf37gk2pfh59gmdjr4zsql4ga9p" + let vk1 = + "zxviews1qdjagrrpqqqqpq8es75mlu6rref0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs" + let vk2 = + "zxviews1qdjagrrpqqqqpq8es75mlufakef0qyrstchf8dxzeygtsejwfqu8ckhwl2qj5m8am7lmupxk3vkvdjm8pawjpmesjfapvsqw96pa46c2z0kk7letrxf7mkltwz54fwpxc7kc79mm5kce3rwn5ssl009zwsra2spppwgrx25s9k5hq65f69l4jz2tjmqgy0pl49qmtaj3nudk6wglwe2hpa327hydlchtyq9av6wjd6hu68e04ahwk9a9n2kt0kj3nj99nue65awtu5cwwcpjs" + it "returns 401 with bad session" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk0 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` unauthorized401 + it "returns 403 with mismatched session" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk0 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` forbidden403 + it "returns 400 with malformed key" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk2 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` badRequest400 + it "returns 400 with non-key valid bech32" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= ("bech321qqqsyrhqy2a" :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` badRequest400 + it "succeeds with correct key" $ do + req <- + testPostJson "/api/ownervk" $ + A.object ["payload" A..= (vk1 :: String)] + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req + getResponseStatus res `shouldBe` created201 around handleDb $ describe "Database actions" $ do describe "authentication" $ do @@ -735,7 +792,7 @@ main = do doc <- access p master "test" $ findProSession - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" doc `shouldNotBe` Nothing it "upsert to DB" $ const pending describe "Zcash prices" $ do @@ -796,7 +853,7 @@ main = do let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000001")) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False @@ -827,23 +884,23 @@ main = do t <- access p master "test" $ findToken - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False Just t2 -> t_address t2 `shouldBe` - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" it "code is saved" $ \p -> do _ <- access p master "test" $ addAccCode - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "ZEC" t <- access p master "test" $ findToken - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False @@ -875,7 +932,7 @@ main = do let myUser = User (Just (read "6272a90f2b05a74cf1000002" :: ObjectId)) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb" 1613487 "1234567" @@ -917,13 +974,13 @@ main = do findOne (select [ "address" =: - ("zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" :: T.Text) + ("zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" :: T.Text) ] "owners") let s = (cast' . Doc) =<< t let ownerPaid = maybe False opaid s ownerPaid `shouldBe` True - _ -> True `shouldBe` False `debug` "Failed parsing payment" + _ -> True `shouldBe` False --`debug` "Failed parsing payment" xit "owners are expired" $ \p -> do _ <- expireOwners p "test" now <- getCurrentTime @@ -942,7 +999,7 @@ main = do let myTx = ZGoTx Nothing - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca" 3 1613487 @@ -1115,7 +1172,7 @@ startAPI config = do let myUser = User (Just (read "6272a90f2b05a74cf1000001" :: ObjectId)) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" 1613487 "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" @@ -1123,7 +1180,7 @@ startAPI config = do let myUser1 = User (Just (read "6272a90f2b05a74cf1000003" :: ObjectId)) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa" 1613487 "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162" @@ -1142,7 +1199,7 @@ startAPI config = do let myOwner = Owner (Just (read "627ad3492b05a76be3000001")) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "Test shop" "usd" False @@ -1207,7 +1264,7 @@ startAPI config = do let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000000")) - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False @@ -1238,7 +1295,7 @@ startAPI config = do let proSession1 = ZGoProSession Nothing - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" myTs False let proSessionTest = val proSession1 @@ -1248,7 +1305,7 @@ startAPI config = do let myToken = XeroToken Nothing - "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "zs1g2ne5w2r8kvalwzngsk3kfzppx3qcx5560pnfmw9rj5xfd3zfg9dkm7hyxnfyhc423fev5wuue4" "superFakeToken123" 1800 "anotherSuperFakeToken" diff --git a/zgo-backend.cabal b/zgo-backend.cabal index ab2c428..264cfbf 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -183,5 +183,6 @@ test-suite zgo-backend-test , text , time , uuid + , zcash-haskell , zgo-backend default-language: Haskell2010 From e35304f030931f6bf3eee5d7ccc0109c77378e53 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 16 Jun 2023 14:00:22 -0500 Subject: [PATCH 16/41] Adjust CORS --- src/ZGoBackend.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 4f8b38a..5e82036 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -591,7 +591,7 @@ routes pipe config = do simpleCorsResourcePolicy { corsRequestHeaders = ["Authorization", "Content-Type"] , corsMethods = "DELETE" : simpleMethods - --, corsOrigins = Nothing + , corsOrigins = Nothing } middleware $ basicAuth From f21700f88bbb08fc1c5b4c142eeb5b5b4e43e74b Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 19 Jun 2023 16:58:39 -0500 Subject: [PATCH 17/41] Improve payment confirmation --- src/Owner.hs | 6 +++++- src/ZGoBackend.hs | 1 + 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Owner.hs b/src/Owner.hs index 9649779..e1dbfa2 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -366,8 +366,12 @@ instance ToJSON OwnerSettings where , "expiration" .= e , "payconf" .= pc , "crmToken" .= cT - , "viewkey" .= (T.take 8 vK <> "...." <> T.takeEnd 8 vK) + , "viewkey" .= keyObfuscate vK ] + where + keyObfuscate s + | s == "" = "" + | otherwise = T.take 8 s <> "...." <> T.takeEnd 8 s -- Helper Functions getOwnerSettings :: Owner -> OwnerSettings diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 5e82036..dfb8bb7 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1442,6 +1442,7 @@ scanPayments config pipe = do mapM_ (findPaidOrders config pipe) validShopAddresses where findPaidOrders :: Config -> Pipe -> T.Text -> IO () findPaidOrders c p z = do + print z paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) z 5 case paidTxs of Right txs -> do From 9a87d43459f94bdff50063dad68cbd45df6de5d7 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 19 Jun 2023 17:54:21 -0500 Subject: [PATCH 18/41] Fix problem with payment confirmations --- src/ZGoBackend.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index dfb8bb7..5f261d3 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1466,9 +1466,7 @@ scanPayments config pipe = do Nothing -> error "Failed to retrieve order from database" Just xO -> when - (not (qpaid xO) && - qexternalInvoice xO /= "" && - qtotalZec xO == snd x && z == qaddress xO) $ do + (not (qpaid xO) && qtotalZec xO == snd x && z == qaddress xO) $ do let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" let sResult = matchAllText sReg (T.unpack $ qsession xO) if not (null sResult) @@ -1529,7 +1527,7 @@ scanPayments config pipe = do else error "Couldn't parse externalInvoice for WooCommerce" _ -> putStrLn "Not an integration order" - else putStrLn "Not an integration order" + else liftIO $ access p master dbName $ markOrderPaid x -- | RPC methods -- | List addresses with viewing keys loaded From ae198541eed2b88a64195af0dd08d86301435fad Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 19 Jun 2023 18:06:21 -0500 Subject: [PATCH 19/41] Add debugging to order payment --- src/ZGoBackend.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 5f261d3..c9b9a21 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1460,6 +1460,7 @@ scanPayments config pipe = do recordPayment :: Pipe -> T.Text -> T.Text -> (String, Double) -> IO () recordPayment p dbName z x = do + print x o <- access p master dbName $ findOrderById (fst x) let xOrder = o >>= (cast' . Doc) case xOrder of From aff5e4f03df36c29ab7297c504933cab3a121817 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 19 Jun 2023 18:54:18 -0500 Subject: [PATCH 20/41] Add more debugging to payment confirmation --- src/ZGoBackend.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index c9b9a21..603eea8 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1448,6 +1448,7 @@ scanPayments config pipe = do Right txs -> do let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" let k = filter (isRelevant r) txs + print k let j = map (getOrderId r) k mapM_ (recordPayment p (c_dbName config) z) j Left e -> print e From f632b48f324bc75b0f18252d143511903b402256 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 20 Jun 2023 07:54:24 -0500 Subject: [PATCH 21/41] Add parameter for confirmation window --- src/Config.hs | 3 +++ src/ZGoBackend.hs | 34 ++++------------------------------ zgo.cfg | 1 + zgotest.cfg | 1 + 4 files changed, 9 insertions(+), 30 deletions(-) diff --git a/src/Config.hs b/src/Config.hs index 9455cca..0804305 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -26,6 +26,7 @@ data Config = , c_smtpPort :: Integer , c_smtpUser :: String , c_smtpPwd :: String + , c_confirmations :: Integer } deriving (Eq, Show) @@ -48,6 +49,7 @@ loadZGoConfig path = do mailPort <- require config "smtpPort" mailUser <- require config "smtpUser" mailPwd <- require config "smtpPwd" + conf <- require config "confirmations" return $ Config dbHost @@ -66,3 +68,4 @@ loadZGoConfig path = do mailPort mailUser mailPwd + conf diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 603eea8..675a665 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1388,36 +1388,10 @@ listTxs user pwd a confs = do Just e -> return $ Left $ "Error reading transactions: " <> emessage e Left ex -> return $ Left $ (T.pack . show) ex --- | Function to check the ZGo full node for new txs -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 -> do - let r = - mkRegex - ".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*" - let p = - mkRegex - ".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*" - let y = - mkRegex - ".*MSG\\s(zs[a-z0-9]{76})\\s+ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*" - let k = map zToZGoTx (filter (isRelevant r) txs) - mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k - let j = map zToZGoTx (filter (isRelevant p) txs) - mapM_ (upsertPayment pipe (c_dbName config)) j - let l = map zToZGoTx (filter (isRelevant y) txs) - mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") l - Left e -> do - putStrLn $ "Error scanning node transactions: " ++ T.unpack e - return () - -- | Function to filter transactions -isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool -isRelevant re t - | zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True +isRelevant :: Integer -> Text.Regex.Regex -> ZcashTx -> Bool +isRelevant conf re t + | zconfirmations t < conf && (matchTest re . T.unpack . zmemo) t = True | otherwise = False -- | New function to scan transactions with parser @@ -1447,7 +1421,7 @@ scanPayments config pipe = do case paidTxs of Right txs -> do let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" - let k = filter (isRelevant r) txs + let k = filter (isRelevant (c_confirmations c) r) txs print k let j = map (getOrderId r) k mapM_ (recordPayment p (c_dbName config) z) j diff --git a/zgo.cfg b/zgo.cfg index 1502706..d7db771 100644 --- a/zgo.cfg +++ b/zgo.cfg @@ -6,6 +6,7 @@ dbUser = "zgo" dbPassword = "zcashrules" nodeUser = "zecwallet" nodePassword = "rdsxlun6v4a" +confirmations = 100 port = 3000 tls = false certificate = "/path/to/cert.pem" diff --git a/zgotest.cfg b/zgotest.cfg index 4fc6230..a703b28 100644 --- a/zgotest.cfg +++ b/zgotest.cfg @@ -6,6 +6,7 @@ dbUser = "zgo" dbPassword = "zcashrules" nodeUser = "zecwallet" nodePassword = "rdsxlun6v4a" +confirmations = 100 port = 3000 tls = false certificate = "/path/to/cert.pem" From f469ed6763c7f0e42119f95b3099bf51ef582bc9 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 20 Jun 2023 08:54:28 -0500 Subject: [PATCH 22/41] Add shop name to receipt endpoint --- src/ZGoBackend.hs | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 675a665..e4182d3 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1195,12 +1195,17 @@ routes pipe config = do Just pOrder -> do if qtoken pOrder == token then do - status ok200 - Web.Scotty.json - (object - [ "message" .= ("Order found!" :: String) - , "order" .= toJSON (pOrder :: ZGoOrder) - ]) + shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder) + case cast' . Doc =<< shop of + Nothing -> status badRequest400 + Just s -> do + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Order found!" :: String) + , "order" .= toJSON (pOrder :: ZGoOrder) + , "shop" .= (oname s :: T.Text) + ]) else status forbidden403 else status badRequest400 --Get order by session @@ -1301,6 +1306,14 @@ routes pipe config = do Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) + get "/getinvoicelang" $ do + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice") + case cast' . Doc =<< txtPack' of + Nothing -> status noContent204 + Just textPack -> do + status ok200 + Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/api/getlang" $ do component <- param "component" lang <- param "lang" From aa3794b504055838a701d8c443a60b4375953e38 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 20 Jun 2023 13:27:53 -0500 Subject: [PATCH 23/41] Modify xero endpoints --- src/ZGoBackend.hs | 80 +++++++++++++++++------------------------------ 1 file changed, 29 insertions(+), 51 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index e4182d3..aaed2d4 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -628,52 +628,46 @@ routes pipe config = do ]) get "/api/xerotoken" $ do code <- param "code" - address <- param "address" + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) xeroConfig <- liftAndCatchIO $ run findXero - case xeroConfig of + case cast' . Doc =<< xeroConfig of Nothing -> status noContent204 - Just x -> do - let xConfig = cast' (Doc x) - case xConfig of - Nothing -> status noContent204 - Just c -> do + Just c -> do + case cast' . Doc =<< user of + Nothing -> status unauthorized401 + Just u -> do res <- liftAndCatchIO $ - requestXeroToken pipe (c_dbName config) c code address + requestXeroToken pipe (c_dbName config) c code $ uaddress u if res then status ok200 else status noContent204 - get "/api/invdata" $ do + get "/invdata" $ do inv <- param "inv" oAddress <- param "address" xeroConfig <- liftAndCatchIO $ run findXero - case xeroConfig of + case cast' . Doc =<< xeroConfig of Nothing -> do status noContent204 - text "Xero App credentials not found" - Just x -> do - let xConfig = cast' (Doc x) - case xConfig of - Nothing -> do - status noContent204 - text "Xero App credentials corrupted" - Just c -> do - res <- + text "Xero App credentials not available" + Just c -> do + res <- + liftAndCatchIO $ + requestXeroToken pipe (c_dbName config) c "none" oAddress + if res + then do + resInv <- liftAndCatchIO $ - requestXeroToken pipe (c_dbName config) c "none" oAddress - if res - then do - resInv <- - liftAndCatchIO $ - getXeroInvoice pipe (c_dbName config) inv oAddress - case resInv of - Nothing -> do - status noContent204 - text "Xero invoice not found" - Just xI -> do - status ok200 - Web.Scotty.json (object ["invdata" .= toJSON xI]) - else status noContent204 + getXeroInvoice pipe (c_dbName config) inv oAddress + case resInv of + Nothing -> do + status noContent204 + text "Xero invoice not found" + Just xI -> do + status ok200 + Web.Scotty.json (object ["invdata" .= toJSON xI]) + else status noContent204 -- Get the xeroaccount code get "/api/xeroaccount" $ do session <- param "session" @@ -972,7 +966,7 @@ routes pipe config = do [ "message" .= ("Owner found!" :: String) , "owner" .= getOwnerSettings o ]) - get "/api/ownerid" $ do + get "/ownerid" $ do id <- param "id" owner <- liftAndCatchIO $ run (findOwnerById id) case owner of @@ -986,23 +980,7 @@ routes pipe config = do Web.Scotty.json (object [ "message" .= ("Owner found!" :: String) - , "owner" .= - object - [ "_id" .= (maybe "" show $ o_id q :: String) - , "address" .= oaddress q - , "name" .= oname q - , "currency" .= ocurrency q - , "tax" .= otax q - , "taxValue" .= otaxValue q - , "vat" .= ovat q - , "vatValue" .= ovatValue q - , "paid" .= opaid q - , "zats" .= ozats q - , "invoices" .= oinvoices q - , "expiration" .= oexpiration q - , "payconf" .= opayconf q - , "crmToken" .= ocrmToken q - ] + , "owner" .= getOwnerSettings q ]) --Upsert owner to DB post "/api/owner" $ do From f29c5ecb0374957ecb55efd5d65837ec6fcffa57 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 21 Jun 2023 11:15:30 -0500 Subject: [PATCH 24/41] Rebuild `invdata` endpoint for Xero invoices --- src/Xero.hs | 20 ++++++ src/ZGoBackend.hs | 164 +++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 166 insertions(+), 18 deletions(-) diff --git a/src/Xero.hs b/src/Xero.hs index 009caf2..9970352 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -171,6 +171,26 @@ instance FromJSON XeroTenant where --u <- obj .: "updatedDateUtc" pure $ XeroTenant i aei tI tT tN +data XeroInvoiceRequest = + XeroInvoiceRequest + { xr_owner :: T.Text + , xr_invNo :: T.Text + , xr_amount :: Double + , xr_currency :: T.Text + , xr_shortCode :: T.Text + } + deriving (Show, Eq) + +instance FromJSON XeroInvoiceRequest where + parseJSON = + withObject "XeroInvoiceRequest" $ \obj -> do + o <- obj .: "ownerId" + i <- obj .: "invoice" + a <- obj .: "amount" + c <- obj .: "currency" + s <- obj .: "shortcode" + pure $ XeroInvoiceRequest (read o) i a c s + data XeroInvoice = XeroInvoice { xi_id :: Maybe ObjectId diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index aaed2d4..a91066e 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -39,7 +39,7 @@ import qualified Data.UUID as U import qualified Data.Vector as V import Data.Vector.Internal.Check (doChecks) import Data.Word -import Database.MongoDB +import Database.MongoDB hiding (Order) import Debug.Trace import GHC.Generics import Item @@ -644,30 +644,158 @@ routes pipe config = do then status ok200 else status noContent204 get "/invdata" $ do - inv <- param "inv" - oAddress <- param "address" + invReq <- jsonData xeroConfig <- liftAndCatchIO $ run findXero case cast' . Doc =<< xeroConfig of Nothing -> do status noContent204 - text "Xero App credentials not available" + Web.Scotty.json + (object + [ "reportType" .= (1 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + ]) Just c -> do - res <- - liftAndCatchIO $ - requestXeroToken pipe (c_dbName config) c "none" oAddress - if res - then do - resInv <- + o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq + case cast' . Doc =<< o of + Nothing -> do + status noContent204 + Web.Scotty.json + (object + [ "reportType" .= (2 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + ]) + Just o' -> do + res <- liftAndCatchIO $ - getXeroInvoice pipe (c_dbName config) inv oAddress - case resInv of - Nothing -> do + requestXeroToken pipe (c_dbName config) c "none" $ oaddress o' + if res + then do + resInv <- + liftAndCatchIO $ + getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $ + oaddress o' + case resInv of + Nothing -> do + status noContent204 + Web.Scotty.json + (object + [ "reportType" .= (2 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + ]) + Just xI -> do + if xi_type xI == "ACCREC" + then if xi_status xI == "AUTHORISED" + then if xi_currency xI == ocurrency o' + then if xi_total xI == xr_amount invReq + then do + now <- liftIO getCurrentTime + tk <- liftIO generateToken + pr <- + liftAndCatchIO $ + run + (findPrice $ + T.unpack . ocurrency $ o') + case cast' . Doc =<< pr of + Nothing -> do + status noContent204 + Web.Scotty.json + (object + [ "reportType" .= + (7 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + ]) + Just cp -> do + let newOrder = + ZGoOrder + Nothing + (oaddress o') + ("Xero-" <> + T.pack + (show $ o_id o')) + now + True + (ocurrency o') + cp + (xi_total xI) + (xi_total xI / cp) + [ LineItem + 1 + ("Invoice from " <> + oname o' <> + " [" <> + xi_number xI <> + "]") + (xi_total xI) + ] + False + (xi_number xI) + (xi_shortcode xI) + (T.pack tk) + _ <- + liftAndCatchIO $ + run $ upsertOrder newOrder + finalOrder <- + liftAndCatchIO $ + run $ + findXeroOrder + (oaddress o') + (xi_number xI) + (xi_shortcode xI) + case cast' . Doc =<< finalOrder of + Nothing -> do + status + internalServerError500 + text + "Unable to save order to DB" + Just fO -> do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= + (0 :: Integer) + , "order" .= + toJSON + (fO :: ZGoOrder) + ]) + else do + status noContent204 + Web.Scotty.json + (object + [ "reportType" .= + (8 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + ]) + else do + status noContent204 + Web.Scotty.json + (object + [ "reportType" .= (7 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + ]) + else do + status noContent204 + Web.Scotty.json + (object + [ "reportType" .= (6 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + ]) + else do + status noContent204 + Web.Scotty.json + (object + [ "reportType" .= (5 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + ]) + else do status noContent204 - text "Xero invoice not found" - Just xI -> do - status ok200 - Web.Scotty.json (object ["invdata" .= toJSON xI]) - else status noContent204 + Web.Scotty.json + (object + [ "reportType" .= (1 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do session <- param "session" From bd4d611d0417862f50aed4c8a21b1949f3709217 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 21 Jun 2023 14:29:41 -0500 Subject: [PATCH 25/41] Enhance `invdata` endpoint for Xero invoices --- src/ZGoBackend.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a91066e..9ef0d30 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -643,9 +643,10 @@ routes pipe config = do if res then status ok200 else status noContent204 - get "/invdata" $ do - invReq <- jsonData + post "/invdata" $ do + invData <- jsonData xeroConfig <- liftAndCatchIO $ run findXero + let invReq = payload (invData :: Payload XeroInvoiceRequest) case cast' . Doc =<< xeroConfig of Nothing -> do status noContent204 From b638b4bbce90c52d94dddbc6777283d06f945573 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 21 Jun 2023 14:59:34 -0500 Subject: [PATCH 26/41] Add shop name to `invdata` --- src/ZGoBackend.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 9ef0d30..7468370 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -654,6 +654,7 @@ routes pipe config = do (object [ "reportType" .= (1 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) ]) Just c -> do o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq @@ -664,6 +665,7 @@ routes pipe config = do (object [ "reportType" .= (2 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) ]) Just o' -> do res <- @@ -682,6 +684,7 @@ routes pipe config = do (object [ "reportType" .= (2 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) ]) Just xI -> do if xi_type xI == "ACCREC" @@ -705,6 +708,8 @@ routes pipe config = do (7 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= + (Nothing :: Maybe String) ]) Just cp -> do let newOrder = @@ -758,6 +763,7 @@ routes pipe config = do , "order" .= toJSON (fO :: ZGoOrder) + , "shop" .= oname o' ]) else do status noContent204 @@ -767,6 +773,8 @@ routes pipe config = do (8 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= + (Nothing :: Maybe String) ]) else do status noContent204 @@ -775,6 +783,7 @@ routes pipe config = do [ "reportType" .= (7 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) ]) else do status noContent204 @@ -782,6 +791,7 @@ routes pipe config = do (object [ "reportType" .= (6 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) ]) else do status noContent204 @@ -789,6 +799,7 @@ routes pipe config = do (object [ "reportType" .= (5 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) ]) else do status noContent204 @@ -796,6 +807,7 @@ routes pipe config = do (object [ "reportType" .= (1 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do From 547d5511fa88b893f9fab662639313ce89a70fa4 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 21 Jun 2023 15:49:23 -0500 Subject: [PATCH 27/41] Add languange endpoint for pmtservice --- src/ZGoBackend.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 7468370..72968f8 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1433,6 +1433,14 @@ routes pipe config = do Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) + get "/getpmtservicelang" $ do + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang "pmtservice") + case cast' . Doc =<< txtPack' of + Nothing -> status noContent204 + Just textPack -> do + status ok200 + Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/api/getlang" $ do component <- param "component" lang <- param "lang" From 87efbf0613123c30163d095b5f1aa809d2f9954f Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 21 Jun 2023 16:09:04 -0500 Subject: [PATCH 28/41] Correct type of ownerId in XeroInvoiceRequest --- src/Xero.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Xero.hs b/src/Xero.hs index 9970352..49073f2 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -189,7 +189,7 @@ instance FromJSON XeroInvoiceRequest where a <- obj .: "amount" c <- obj .: "currency" s <- obj .: "shortcode" - pure $ XeroInvoiceRequest (read o) i a c s + pure $ XeroInvoiceRequest o i a c s data XeroInvoice = XeroInvoice From cd93f0031dba3fd9a8315a9742c4ebb18ea90a79 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 22 Jun 2023 08:26:55 -0500 Subject: [PATCH 29/41] Correct HTTP codes for `invdata` --- src/ZGoBackend.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 72968f8..d32c0da 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -649,7 +649,7 @@ routes pipe config = do let invReq = payload (invData :: Payload XeroInvoiceRequest) case cast' . Doc =<< xeroConfig of Nothing -> do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= (1 :: Integer) @@ -660,7 +660,7 @@ routes pipe config = do o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq case cast' . Doc =<< o of Nothing -> do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= (2 :: Integer) @@ -679,7 +679,7 @@ routes pipe config = do oaddress o' case resInv of Nothing -> do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= (2 :: Integer) @@ -701,7 +701,7 @@ routes pipe config = do T.unpack . ocurrency $ o') case cast' . Doc =<< pr of Nothing -> do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= @@ -755,7 +755,7 @@ routes pipe config = do text "Unable to save order to DB" Just fO -> do - status ok200 + status created201 Web.Scotty.json (object [ "reportType" .= @@ -766,7 +766,7 @@ routes pipe config = do , "shop" .= oname o' ]) else do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= @@ -777,7 +777,7 @@ routes pipe config = do (Nothing :: Maybe String) ]) else do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= (7 :: Integer) @@ -786,7 +786,7 @@ routes pipe config = do , "shop" .= (Nothing :: Maybe String) ]) else do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= (6 :: Integer) @@ -794,7 +794,7 @@ routes pipe config = do , "shop" .= (Nothing :: Maybe String) ]) else do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= (5 :: Integer) @@ -802,7 +802,7 @@ routes pipe config = do , "shop" .= (Nothing :: Maybe String) ]) else do - status noContent204 + status ok200 Web.Scotty.json (object [ "reportType" .= (1 :: Integer) From fb0144bbe146a5eb5ada8242c7b82cf63b92fba7 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 22 Jun 2023 10:10:19 -0500 Subject: [PATCH 30/41] Correct currency check in `invdata` --- src/ZGoBackend.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index d32c0da..d72b484 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -689,7 +689,7 @@ routes pipe config = do Just xI -> do if xi_type xI == "ACCREC" then if xi_status xI == "AUTHORISED" - then if xi_currency xI == ocurrency o' + then if xi_currency xI == T.toUpper (ocurrency o') then if xi_total xI == xr_amount invReq then do now <- liftIO getCurrentTime From 4bd49c76d4ddc8b5e73168c1c30eeecc729b5005 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 22 Jun 2023 11:52:36 -0500 Subject: [PATCH 31/41] Correct Zcash price handling in `invdata` --- src/ZGoBackend.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index d72b484..ee724cd 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -699,7 +699,7 @@ routes pipe config = do run (findPrice $ T.unpack . ocurrency $ o') - case cast' . Doc =<< pr of + case parseZGoPrice =<< pr of Nothing -> do status ok200 Web.Scotty.json @@ -722,9 +722,9 @@ routes pipe config = do now True (ocurrency o') - cp + (price cp) (xi_total xI) - (xi_total xI / cp) + (xi_total xI / price cp) [ LineItem 1 ("Invoice from " <> From 6e0cb540320019c3db05d25750851aa3cdefce27 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 22 Jun 2023 13:38:33 -0500 Subject: [PATCH 32/41] Add check of existing order --- src/ZGoBackend.hs | 277 +++++++++++++++++++++++++--------------------- 1 file changed, 150 insertions(+), 127 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index ee724cd..906de71 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -668,146 +668,169 @@ routes pipe config = do , "shop" .= (Nothing :: Maybe String) ]) Just o' -> do - res <- + existingOrder <- liftAndCatchIO $ - requestXeroToken pipe (c_dbName config) c "none" $ oaddress o' - if res - then do - resInv <- + run $ + findXeroOrder + (oaddress o') + (xr_invNo invReq) + (xr_shortCode invReq) + case cast' . Doc =<< existingOrder of + Nothing -> do + res <- liftAndCatchIO $ - getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $ - oaddress o' - case resInv of - Nothing -> do - status ok200 - Web.Scotty.json - (object - [ "reportType" .= (2 :: Integer) - , "order" .= (Nothing :: Maybe ZGoOrder) - , "shop" .= (Nothing :: Maybe String) - ]) - Just xI -> do - if xi_type xI == "ACCREC" - then if xi_status xI == "AUTHORISED" - then if xi_currency xI == T.toUpper (ocurrency o') - then if xi_total xI == xr_amount invReq - then do - now <- liftIO getCurrentTime - tk <- liftIO generateToken - pr <- - liftAndCatchIO $ - run - (findPrice $ - T.unpack . ocurrency $ o') - case parseZGoPrice =<< pr of - Nothing -> do + requestXeroToken pipe (c_dbName config) c "none" $ oaddress o' + if res + then do + resInv <- + liftAndCatchIO $ + getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $ + oaddress o' + case resInv of + Nothing -> do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (2 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + Just xI -> do + if xi_type xI == "ACCREC" + then if xi_status xI == "AUTHORISED" + then if xi_currency xI == + T.toUpper (ocurrency o') + then if xi_total xI == xr_amount invReq + then do + now <- liftIO getCurrentTime + tk <- liftIO generateToken + pr <- + liftAndCatchIO $ + run + (findPrice $ + T.unpack . ocurrency $ o') + case parseZGoPrice =<< pr of + Nothing -> do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= + (7 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + , "shop" .= + (Nothing :: Maybe String) + ]) + Just cp -> do + let newOrder = + ZGoOrder + Nothing + (oaddress o') + ("Xero-" <> + T.pack + (show $ o_id o')) + now + True + (ocurrency o') + (price cp) + (xi_total xI) + (xi_total xI / + price cp) + [ LineItem + 1 + ("Invoice from " <> + oname o' <> + " [" <> + xi_number xI <> + "]") + (xi_total xI) + ] + False + (xi_number xI) + (xi_shortcode xI) + (T.pack tk) + _ <- + liftAndCatchIO $ + run $ + upsertOrder newOrder + finalOrder <- + liftAndCatchIO $ + run $ + findXeroOrder + (oaddress o') + (xi_number xI) + (xi_shortcode xI) + case cast' . Doc =<< + finalOrder of + Nothing -> do + status + internalServerError500 + text + "Unable to save order to DB" + Just fO -> do + status created201 + Web.Scotty.json + (object + [ "reportType" .= + (0 :: Integer) + , "order" .= + toJSON + (fO :: ZGoOrder) + , "shop" .= + oname o' + ]) + else do status ok200 Web.Scotty.json (object [ "reportType" .= - (7 :: Integer) + (8 :: Integer) , "order" .= (Nothing :: Maybe ZGoOrder) , "shop" .= (Nothing :: Maybe String) ]) - Just cp -> do - let newOrder = - ZGoOrder - Nothing - (oaddress o') - ("Xero-" <> - T.pack - (show $ o_id o')) - now - True - (ocurrency o') - (price cp) - (xi_total xI) - (xi_total xI / price cp) - [ LineItem - 1 - ("Invoice from " <> - oname o' <> - " [" <> - xi_number xI <> - "]") - (xi_total xI) - ] - False - (xi_number xI) - (xi_shortcode xI) - (T.pack tk) - _ <- - liftAndCatchIO $ - run $ upsertOrder newOrder - finalOrder <- - liftAndCatchIO $ - run $ - findXeroOrder - (oaddress o') - (xi_number xI) - (xi_shortcode xI) - case cast' . Doc =<< finalOrder of - Nothing -> do - status - internalServerError500 - text - "Unable to save order to DB" - Just fO -> do - status created201 - Web.Scotty.json - (object - [ "reportType" .= - (0 :: Integer) - , "order" .= - toJSON - (fO :: ZGoOrder) - , "shop" .= oname o' - ]) - else do - status ok200 - Web.Scotty.json - (object - [ "reportType" .= - (8 :: Integer) - , "order" .= - (Nothing :: Maybe ZGoOrder) - , "shop" .= - (Nothing :: Maybe String) - ]) - else do - status ok200 - Web.Scotty.json - (object - [ "reportType" .= (7 :: Integer) - , "order" .= - (Nothing :: Maybe ZGoOrder) - , "shop" .= (Nothing :: Maybe String) - ]) - else do - status ok200 - Web.Scotty.json - (object - [ "reportType" .= (6 :: Integer) - , "order" .= (Nothing :: Maybe ZGoOrder) - , "shop" .= (Nothing :: Maybe String) - ]) - else do - status ok200 - Web.Scotty.json - (object - [ "reportType" .= (5 :: Integer) - , "order" .= (Nothing :: Maybe ZGoOrder) - , "shop" .= (Nothing :: Maybe String) - ]) - else do - status ok200 + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (7 :: Integer) + , "order" .= + (Nothing :: Maybe ZGoOrder) + , "shop" .= + (Nothing :: Maybe String) + ]) + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (6 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (5 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + else do + status ok200 + Web.Scotty.json + (object + [ "reportType" .= (1 :: Integer) + , "order" .= (Nothing :: Maybe ZGoOrder) + , "shop" .= (Nothing :: Maybe String) + ]) + Just eO -> do + status created201 Web.Scotty.json (object - [ "reportType" .= (1 :: Integer) - , "order" .= (Nothing :: Maybe ZGoOrder) - , "shop" .= (Nothing :: Maybe String) + [ "reportType" .= (0 :: Integer) + , "order" .= toJSON (eO :: ZGoOrder) + , "shop" .= oname o' ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do From 013feabd2016a24e26a0ce2713df7f3cee98fb45 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 22 Jun 2023 16:16:33 -0500 Subject: [PATCH 33/41] Correct Xero payment confirmation --- src/Xero.hs | 1 + src/ZGoBackend.hs | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Xero.hs b/src/Xero.hs index 49073f2..2540e10 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -463,5 +463,6 @@ payXeroInvoice pipe dbName inv address amt zec = do setRequestHost "api.xero.com" $ setRequestMethod "PUT" defaultRequest res <- httpJSON req :: IO (Response Object) + print res return () else error "Invalid parameters" diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 906de71..ff68a61 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -747,7 +747,8 @@ routes pipe config = do ] False (xi_number xI) - (xi_shortcode xI) + (xr_shortCode + invReq) (T.pack tk) _ <- liftAndCatchIO $ From b49a996bf591d3f10b3741551e1c1dc30873dc54 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 22 Jun 2023 16:39:31 -0500 Subject: [PATCH 34/41] Correct session generation for Xero orders --- src/ZGoBackend.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index ff68a61..bb1f5ea 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -727,8 +727,10 @@ routes pipe config = do Nothing (oaddress o') ("Xero-" <> - T.pack - (show $ o_id o')) + maybe + "" + (T.pack . show) + (o_id o')) now True (ocurrency o') From ac0e74c8188fc89d8bb4e45127609513338d34d7 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 22 Jun 2023 16:51:58 -0500 Subject: [PATCH 35/41] Correct `invdata` check of correct creation --- src/ZGoBackend.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index bb1f5ea..62d04df 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -762,7 +762,7 @@ routes pipe config = do findXeroOrder (oaddress o') (xi_number xI) - (xi_shortcode xI) + (xr_shortCode invReq) case cast' . Doc =<< finalOrder of Nothing -> do From 7672cdc083b2c75c6794218d7aa3c408df6d05f3 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 23 Jun 2023 11:26:03 -0500 Subject: [PATCH 36/41] Update WooCommerce endpoint --- src/ZGoBackend.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 62d04df..99d5cde 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1001,6 +1001,7 @@ routes pipe config = do Just o -> if opaid o then do + tk <- liftIO generateToken let newOrder = ZGoOrder Nothing @@ -1027,10 +1028,11 @@ routes pipe config = do (T.concat [T.pack sUrl, "-", ordId, "-", orderKey]) "" - "" + (T.pack tk) newId <- liftAndCatchIO $ run (insertWooOrder newOrder) status ok200 - Web.Scotty.json (object ["order" .= show newId]) + Web.Scotty.json + (object ["order" .= show newId, "token" .= tk]) else do status accepted202 Web.Scotty.json From 5ffb1b4a837e185436a7f17c2db3a5ea8a291dc3 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 23 Jun 2023 11:45:07 -0500 Subject: [PATCH 37/41] Add debugging to WooCommerce endpoint --- src/WooCommerce.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index 1699efc..7c35823 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -103,7 +103,9 @@ payWooOrder u i o t p z = do res <- httpLBS req if getResponseStatus res == ok200 then return () - else error "Failed to report payment to WooCommerce" + else do + print $ getResponseStatus res + error "Failed to report payment to WooCommerce" generateWooToken :: Owner -> String -> Action IO () generateWooToken o s = From 51471cd58f48aa75fd7c78e1c81ff03fdcbc5467 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 23 Jun 2023 13:13:20 -0500 Subject: [PATCH 38/41] adjust WooCommerce callback --- src/WooCommerce.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index 7c35823..dbe82a6 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -89,7 +89,7 @@ payWooOrder :: -> BS.ByteString -- Total ZEC for order -> IO () payWooOrder u i o t p z = do - wooReq <- parseRequest $ u ++ "/wc-api/zpmtcallback" + wooReq <- parseRequest $ u ++ "/wc-api/zconfirm" let req = setRequestQueryString [ ("token", Just t) From e0c07091e9da318dee15bdbd2db4b64a92baf0a5 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 23 Jun 2023 14:16:56 -0500 Subject: [PATCH 39/41] Fix WooCommerce callback --- src/WooCommerce.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index dbe82a6..f0ebce6 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -89,7 +89,7 @@ payWooOrder :: -> BS.ByteString -- Total ZEC for order -> IO () payWooOrder u i o t p z = do - wooReq <- parseRequest $ u ++ "/wc-api/zconfirm" + wooReq <- parseRequest $ u ++ "/?wc-api=zpmtcallback" let req = setRequestQueryString [ ("token", Just t) From 6ae6dd8430ee269e18d2b5128d4feafa410faaa5 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 26 Jun 2023 09:50:12 -0500 Subject: [PATCH 40/41] Update payment confirmation for new API endpoint --- CHANGELOG.md | 6 ++++++ src/WooCommerce.hs | 3 ++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 26e1ba3..6eb85f0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,12 @@ 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). +## [1.7.0] + +### Changed + +- Modified payment confirmation to use new WooCommerce plugin API endpoint. + ## [1.6.0] ### Added diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs index f0ebce6..5530e18 100644 --- a/src/WooCommerce.hs +++ b/src/WooCommerce.hs @@ -89,8 +89,9 @@ payWooOrder :: -> BS.ByteString -- Total ZEC for order -> IO () payWooOrder u i o t p z = do - wooReq <- parseRequest $ u ++ "/?wc-api=zpmtcallback" + wooReq <- parseRequest u let req = + setRequestPath "/wp-json/wc/v3/zgocallback" $ setRequestQueryString [ ("token", Just t) , ("orderid", Just o) From 9376d959f87fe41a1070cea13ceee4aed6c404be Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 26 Jun 2023 11:27:27 -0500 Subject: [PATCH 41/41] New version preparation --- CHANGELOG.md | 12 ++++++++++++ README.md | 3 ++- package.yaml | 2 +- 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6eb85f0..28ec2bc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,9 +6,21 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [1.7.0] +### Added + +- Parameter to config for number of confirmations for scan +- Endpoint for language for invoices + ### Changed - Modified payment confirmation to use new WooCommerce plugin API endpoint. +- Consolidated the `invdata`, `orderid` and `orderx` endpoints +- The `xerotoken` endpoint uses `session` for authentication +- The order by ID/token endpoint includes shop name + +### Fixed + +- The viewing key obfuscation of blank viewing keys ## [1.6.0] diff --git a/README.md b/README.md index e57f8f3..bdb9759 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,8 @@ The API server behind the [ZGo.cash](https://zgo.cash) app. ## Dependencies -- Zcash Full node +- Zcash Full node (`zcashd`) +- [Zcash Haskell](https://git.vergara.tech/Vergara_Tech/zcash-haskell) - MongoDB ## Configuration diff --git a/package.yaml b/package.yaml index 60fdc9a..6953890 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 1.6.0 +version: 1.7.0 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara"