From cbc4e02766cd713df2c0cade5d1567543b56126c Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 8 May 2023 11:21:09 -0500 Subject: [PATCH 01/21] Implement API server access control --- CHANGELOG.md | 11 ++ package.yaml | 2 +- src/User.hs | 18 +-- src/ZGoBackend.hs | 43 ++++++-- stack.yaml | 2 +- stack.yaml.lock | 8 +- test/Spec.hs | 276 ++++++++++++++++++++++++++++++++++++++-------- zgo-backend.cabal | 2 +- 8 files changed, 296 insertions(+), 66 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9c81a3d..164d3b7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,17 @@ 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] + +### Added + +- `isUserValid` function +- New middleware to validated requests come from an existing user + +### Changed + +- Modified API tests to use `session` parameter. + ## [1.4.1] - 2023-05-02 ### Fixed diff --git a/package.yaml b/package.yaml index 354f8ff..ca1e131 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zgo-backend -version: 1.4.1 +version: 1.5.0 git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" diff --git a/src/User.hs b/src/User.hs index f455f1c..a393dc5 100644 --- a/src/User.hs +++ b/src/User.hs @@ -94,6 +94,16 @@ isUserNew p db tx = isNothing <$> access p master db (findOne (select ["session" =: session tx] "users")) +-- | Function to verify if the given session has a valid user +isUserValid :: Pipe -> T.Text -> T.Text -> IO Bool +isUserValid p db s = + isJust <$> + access + p + master + db + (findOne (select ["session" =: s, "validated" =: True] "users")) + -- | Function to mark user as validated validateUser :: T.Text -> Action IO () validateUser session = @@ -106,11 +116,3 @@ generatePin = do rngState <- newCryptoRNGState runCryptoRNGT rngState $ randomString 7 ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] - --- | Helper function to pad a string to a given length -padLeft :: String -> Char -> Int -> String -padLeft s c m = - let isBaseLarger = length s > m - padder st ch m False = [ch | _ <- [1 .. (m - length st)]] ++ s - padder st _ _ True = st - in padder s c m isBaseLarger diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 188a7c5..44f7bbb 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -44,7 +44,7 @@ import Item import LangComponent import Network.HTTP.Simple import Network.HTTP.Types.Status -import Network.Wai (Request, pathInfo) +import Network.Wai (Application, Middleware, Request(..), pathInfo, responseLBS) import Network.Wai.Middleware.Cors import Network.Wai.Middleware.HttpAuth import Numeric @@ -545,6 +545,32 @@ needsAuth req = "api":_ -> True _ -> False +zgoAuth :: Pipe -> T.Text -> Middleware +zgoAuth pipe dbName app req respond = do + let q = filter findSessionParam $ queryString req + isFenced <- needsAuth req + if isFenced + then do + if length q == 1 + then do + isOk <- checkSession pipe dbName $ head q + if isOk + then app req respond + else respond $ + responseLBS unauthorized401 [] "ZGo API access denied!" + else respond $ responseLBS unauthorized401 [] "ZGo API access denied!" + else app req respond + where + findSessionParam :: QueryItem -> Bool + findSessionParam (i, val) = i == "session" + checkSession :: + Pipe -> T.Text -> (BS.ByteString, Maybe BS.ByteString) -> IO Bool + checkSession p db (k, v) = + case v of + Just sessionId -> + isUserValid p db $ E.decodeUtf8With lenientDecode sessionId + Nothing -> return False + -- | Main API routes routes :: Pipe -> Config -> ScottyM () routes pipe config = do @@ -566,6 +592,7 @@ routes pipe config = do basicAuth (\u p -> return $ u == "user" && secureMemFromByteString p == passkey) authSettings + middleware $ zgoAuth pipe $ c_dbName config --Get list of countries for UI get "/api/countries" $ do countries <- liftAndCatchIO $ run listCountries @@ -830,7 +857,7 @@ routes pipe config = do , "user" .= toJSON (parseUserBson u) ]) --Validate user, updating record - post "/api/validateuser" $ do + post "/validateuser" $ do providedPin <- param "pin" sess <- param "session" let pinHash = @@ -1073,12 +1100,12 @@ routes pipe config = do Just tP -> do status ok200 Web.Scotty.json $ toJSON (tP :: LangComponent) - post "/api/setlang" $ do - langComp <- jsonData - _ <- - liftAndCatchIO $ - mapM (run . loadLangComponent) (langComp :: [LangComponent]) - status created201 + {-post "/api/setlang" $ do-} + {-langComp <- jsonData-} + {-_ <--} + {-liftAndCatchIO $-} + {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-} + {-status created201-} -- | Make a Zcash RPC call makeZcashCall :: diff --git a/stack.yaml b/stack.yaml index 442eff8..aff10dc 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.17 +resolver: lts-20.19 #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml # User packages to be built. diff --git a/stack.yaml.lock b/stack.yaml.lock index 358549d..5a8e945 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: 14ca51a9a597c32dd7804c10d079feea3d0ae40c5fbbb346cbd67b3ae49f6d01 - size: 649598 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/17.yaml - original: lts-20.17 + sha256: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64 + size: 649618 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/19.yaml + original: lts-20.19 diff --git a/test/Spec.hs b/test/Spec.hs index 4527b03..cbee780 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -144,35 +144,99 @@ main = do length pin `shouldBe` 7 describe "API endpoints" $ do beforeAll_ (startAPI loadedConfig) $ do + describe "Validate user session" $ do + it "validate with correct pin" $ do + req <- + testPost + "/validateuser" + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("pin", Just "1234567") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` accepted202 describe "Price endpoint" $ do it "returns a price for an existing currency" $ do - req <- testGet "/api/price" [("currency", Just "usd")] + req <- + testGet + "/api/price" + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("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" [("currency", Just "jpy")] + req <- + testGet + "/api/price" + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("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 <- testGet "/api/countries" [] + req <- + testGet + "/api/countries" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "returns 401 with invalid session" $ do + req <- + testGet + "/api/countries" + [("session", Just "fake-id-string-283that0")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 describe "blockheight endpoint" $ do it "returns a block number" $ do - req <- testGet "/api/blockheight" [] + req <- + testGet + "/api/blockheight" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x -> x > 1600000 - describe "xero config endpoint" $ do - it "returns the config" $ do - req <- testGet "/api/xero" [] - res <- httpJSON req - getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "returns the account code" $ do - req <- testGet "/api/xeroaccount" [("address", Just "Zaddy")] - res <- httpJSON req - getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + describe "Xero endpoints" $ do + describe "xero" $ do + it "returns the xero config" $ do + req <- + testGet + "/api/xero" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "returns 401 with invalid session" $ do + req <- + testGet "/api/xero" [("session", Just "fnelrkgnlyebrlvns82949")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 + describe "xeroaccount" $ do + it "returns the account code" $ do + req <- + testGet + "/api/xeroaccount" + [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + , ("address", Just "Zaddy") + ] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "returns 401 with invalid session" $ do + req <- + testGet + "/api/xeroaccount" + [("session", Just "fnelrkgnlyebrlvns82949")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 describe "User endpoint" $ do it "returns a user for a session" $ do req <- @@ -181,28 +245,24 @@ main = do [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 - it "returns 204 when no user" $ do + it "returns 401 when user doesn't exist" $ do req <- testGet "/api/user" [("session", Just "suchafak-euui-dican-eve-nbelieveitca")] res <- httpLBS req - getResponseStatus res `shouldBe` noContent204 - it "validate with correct pin" $ do - req <- - testPost - "/api/validateuser" - [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") - , ("pin", Just "1234567") - ] - res <- httpLBS req - getResponseStatus res `shouldBe` accepted202 + getResponseStatus res `shouldBe` unauthorized401 it "deletes user by id" $ do - req <- testDelete "/api/user/" "6272a90f2b05a74cf1000001" + req <- + testDelete + "/api/user/" + "6272a90f2b05a74cf1000003" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpLBS req getResponseStatus res `shouldBe` ok200 - describe "Owner endpoint" $ do - prop "add owner" testOwnerAdd + describe "Owner endpoint" $ + --prop "add owner" testOwnerAdd + do it "return owner by address" $ do req <- testGet @@ -210,15 +270,31 @@ main = do [ ( "address" , Just "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") ] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "owner by address returns 401 with bad session" $ do + req <- + testGet + "/api/owner" + [ ( "address" + , Just + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e") + , ("session", Just "3fake94j-rbal-jeber-nvlke-4bal8dcdcd") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 it "return owner by id" $ do req <- - testGet "/api/ownerid" [("id", Just "627ad3492b05a76be3000001")] + testGet + "/api/ownerid" + [ ("id", Just "627ad3492b05a76be3000001") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + ] res <- httpLBS req getResponseStatus res `shouldBe` ok200 - describe "Order endpoint" $ do + describe "Order endpoints" $ do prop "upsert order" testOrderAdd it "get order by session" $ do req <- @@ -227,30 +303,85 @@ 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 + req <- + testGet + "/api/order" + [("session", Just "35bfb9c2-9ad2-4fe5-fake-99d63b8dcdcd")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 it "get order by id" $ do - req <- testGet "/api/order/627ab3ea2b05a76be3000000" [] + req <- + testGet + "/api/order/627ab3ea2b05a76be3000000" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "get order with wrong id" $ do - req <- testGet "/api/order/6273hrb" [] + req <- + testGet + "/api/order/6273hrb" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] 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")] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 it "get all orders for owner" $ do - req <- testGet "/api/allorders" [("address", Just "Zaddy")] + req <- + testGet + "/api/allorders" + [ ("address", Just "Zaddy") + , ("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" + 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 describe "Item endpoint" $ do prop "add item" testItemAdd it "get items" $ do - req <- testGet "/api/items" [("address", Just "Zaddy")] + req <- + testGet + "/api/items" + [ ("address", Just "Zaddy") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + ] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 it "delete item" $ do - req <- testDelete "/api/item/" "627d7ba92b05a76be3000003" + req <- + testDelete + "/api/item/" + "627d7ba92b05a76be3000003" + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpLBS req getResponseStatus res `shouldBe` ok200 describe "WooCommerce endpoints" $ do @@ -258,7 +389,9 @@ main = do req <- testPost "/api/wootoken" - [("ownerid", Just "627ad3492b05a76be3000001")] + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + ] res <- httpLBS req getResponseStatus res `shouldBe` accepted202 it "authenticate with incorrect owner" $ do @@ -329,21 +462,40 @@ main = do req <- testGet "/api/getlang" - [("lang", Just "en-US"), ("component", Just "login")] + [ ("lang", Just "en-US") + , ("component", Just "login") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + ] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "existing component with bad session" $ do + req <- + testGet + "/api/getlang" + [ ("lang", Just "en-US") + , ("component", Just "login") + , ("session", Just "35bfb9c2-fake-4fe5-adda-99d63b8dcdcd") + ] + res <- httpLBS req + getResponseStatus res `shouldBe` unauthorized401 it "wrong component" $ do req <- testGet "/api/getlang" - [("lang", Just "en-US"), ("component", Just "test")] + [ ("lang", Just "en-US") + , ("component", Just "test") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + ] res <- httpLBS req getResponseStatus res `shouldBe` noContent204 it "wrong language" $ do req <- testGet "/api/getlang" - [("lang", Just "fr-FR"), ("component", Just "login")] + [ ("lang", Just "fr-FR") + , ("component", Just "login") + , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") + ] res <- httpLBS req getResponseStatus res `shouldBe` noContent204 around handleDb $ @@ -632,11 +784,16 @@ testPostJson endpoint body = do setRequestMethod "POST" $ setRequestPath endpoint defaultRequest return testRequest -testDelete :: B.ByteString -> B.ByteString -> IO Request -testDelete endpoint par = do +testDelete :: + B.ByteString + -> B.ByteString + -> [(B.ByteString, Maybe B.ByteString)] + -> IO Request +testDelete endpoint par body = do let user = "user" let pwd = "superSecret" let testRequest = + setRequestQueryString body $ setRequestPort 3000 $ setRequestBasicAuth user pwd $ setRequestMethod "DELETE" $ @@ -658,14 +815,22 @@ testOrderAdd o = monadicIO $ do req <- run $ testPostJson "/api/order" (A.object ["payload" A..= A.toJSON o]) - res <- httpLBS req + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req assert $ getResponseStatus res == created201 testItemAdd :: Item -> Property testItemAdd i = do monadicIO $ do req <- run $ testPostJson "/api/item" (A.object ["payload" A..= A.toJSON i]) - res <- httpLBS req + res <- + httpLBS $ + setRequestQueryString + [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] + req assert $ getResponseStatus res == created201 -- | Open the MongoDB connection @@ -692,6 +857,9 @@ startAPI config = do _ <- forkIO (scotty 3000 appRoutes) _ <- access pipe master "test" (Database.MongoDB.delete (select [] "wootokens")) + _ <- 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")) let myUser = User (Just (read "6272a90f2b05a74cf1000001" :: ObjectId)) @@ -714,6 +882,28 @@ startAPI config = do , "pin" =: upin myUser , "validated" =: uvalidated myUser ]) + let myUser1 = + User + (Just (read "6272a90f2b05a74cf1000003" :: ObjectId)) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" + 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 myOwner = Owner (Just (read "627ad3492b05a76be3000001")) diff --git a/zgo-backend.cabal b/zgo-backend.cabal index fee2033..1450cc8 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.4.1 +version: 1.5.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web From a2018101348f3be15884540207ba81459545ecfe Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 8 May 2023 16:01:46 -0500 Subject: [PATCH 02/21] Modify endpoint to create new owner --- CHANGELOG.md | 1 + src/Owner.hs | 33 +++++++++++++++++++++++++ src/ZGoBackend.hs | 63 ++++++++++++++++++++++++++++------------------- 3 files changed, 71 insertions(+), 26 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 164d3b7..54f0bf2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed - Modified API tests to use `session` parameter. +- Modified `api/owner` endpoint to use a specific data structure to create new owners ## [1.4.1] - 2023-05-02 diff --git a/src/Owner.hs b/src/Owner.hs index f426636..a7ebe1d 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -275,6 +275,39 @@ instance Val Owner where , "crmToken" =: cT ] +-- | Type to represent informational data for Owners from UI +data OwnerData = + OwnerData + { od_first :: T.Text + , od_last :: T.Text + , od_name :: T.Text + , od_street :: T.Text + , od_city :: T.Text + , od_state :: T.Text + , od_postal :: T.Text + , od_country :: T.Text + , od_email :: T.Text + , od_website :: T.Text + , od_phone :: T.Text + } + deriving (Eq, Show) + +instance FromJSON OwnerData where + parseJSON = + withObject "OwnerData" $ \obj -> do + f <- obj .: "first" + l <- obj .: "last" + n <- obj .: "name" + s <- obj .: "street" + c <- obj .: "city" + st <- obj .: "state" + p <- obj .: "postal" + co <- obj .: "country" + e <- obj .: "email" + w <- obj .: "website" + ph <- obj .: "phone" + pure $ OwnerData f l n s c st p co e w ph + -- Database actions -- | Function to upsert an Owner upsertOwner :: Owner -> Action IO () diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 44f7bbb..6cb8276 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -938,33 +938,44 @@ routes pipe config = do ]) --Upsert owner to DB post "/api/owner" $ do + s <- param "session" + u <- liftAndCatchIO $ run (findUser s) o <- jsonData - let q = payload (o :: Payload Owner) - if not (opayconf q) - then do - _ <- liftAndCatchIO $ run (upsertOwner q) - status created201 - else do - known <- liftAndCatchIO $ listAddresses nodeUser nodePwd - if oaddress q `elem` map addy known - then do - _ <- liftAndCatchIO $ run (upsertOwner q) - status created201 - else do - vkInfo <- - liftAndCatchIO $ - makeZcashCall - nodeUser - nodePwd - "z_importviewingkey" - [Data.Aeson.String (T.strip (oviewkey q)), "no"] - let content = getResponseBody vkInfo :: RpcResponse Object - if isNothing (err content) - then do - _ <- liftAndCatchIO $ run (upsertOwner q) - status created201 - else do - status internalServerError500 + now <- liftIO getCurrentTime + let q = payload (o :: Payload OwnerData) + case parseUserBson =<< u of + Nothing -> status internalServerError500 + Just u' -> do + liftAndCatchIO $ + run $ + upsertOwner $ + Owner + Nothing + (uaddress u') + (od_name q) + "usd" + False + 0 + False + 0 + (od_first q) + (od_last q) + (od_email q) + (od_street q) + (od_city q) + (od_state q) + (od_postal q) + (od_phone q) + (od_website q) + (od_country q) + False + False + False + now + False + "" + "" + status accepted202 --Get items associated with the given address get "/api/items" $ do addr <- param "address" From d67d1937f5afb0b095ba74f2a605e384776f9f18 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 9 May 2023 11:03:26 -0500 Subject: [PATCH 03/21] Rebuild owner endpoints --- src/ZGoBackend.hs | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 6cb8276..f74084e 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -918,7 +918,22 @@ routes pipe config = do Web.Scotty.json (object [ "message" .= ("Owner found!" :: String) - , "owner" .= toJSON (q :: Owner) + , "owner" .= + object + [ "_id" .= (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 + , "crmToken" .= ocrmToken q + ] ]) get "/api/ownerid" $ do id <- param "id" @@ -934,7 +949,22 @@ routes pipe config = do Web.Scotty.json (object [ "message" .= ("Owner found!" :: String) - , "owner" .= toJSON (q :: Owner) + , "owner" .= + object + [ "_id" .= (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 + , "crmToken" .= ocrmToken q + ] ]) --Upsert owner to DB post "/api/owner" $ do From 55d30b8b0f5f149310c8e6858dc8561956617de2 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 10 May 2023 10:42:40 -0500 Subject: [PATCH 04/21] Correct `OwnerData` --- src/Owner.hs | 4 +++- src/ZGoBackend.hs | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Owner.hs b/src/Owner.hs index a7ebe1d..9df5128 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -289,6 +289,7 @@ data OwnerData = , od_email :: T.Text , od_website :: T.Text , od_phone :: T.Text + , od_payconf :: Bool } deriving (Eq, Show) @@ -306,7 +307,8 @@ instance FromJSON OwnerData where e <- obj .: "email" w <- obj .: "website" ph <- obj .: "phone" - pure $ OwnerData f l n s c st p co e w ph + pc <- obj .: "payconf" + pure $ OwnerData f l n s c st p co e w ph pc -- Database actions -- | Function to upsert an Owner diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index f74084e..5641d45 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -932,6 +932,7 @@ routes pipe config = do , "zats" .= ozats q , "invoices" .= oinvoices q , "expiration" .= oexpiration q + , "payconf" .= opayconf q , "crmToken" .= ocrmToken q ] ]) @@ -963,6 +964,7 @@ routes pipe config = do , "zats" .= ozats q , "invoices" .= oinvoices q , "expiration" .= oexpiration q + , "payconf" .= opayconf q , "crmToken" .= ocrmToken q ] ]) From e1919be03a7c5ef7489035290cb9e8572a013b9d Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 10 May 2023 10:52:25 -0500 Subject: [PATCH 05/21] Correct `xero` endpoint --- src/Xero.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Xero.hs b/src/Xero.hs index 52fe641..009caf2 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -30,8 +30,7 @@ data Xero = deriving (Eq, Show) instance ToJSON Xero where - toJSON (Xero i cI s) = - object ["_id" .= show i, "clientId" .= cI, "clientSecret" .= s] + toJSON (Xero i cI s) = object ["_id" .= show i, "clientId" .= cI] instance Val Xero where val (Xero i cI s) = Doc ["_id" =: i, "clientId" =: cI, "clientSecret" =: s] From 4e8ecb24e621571b62eb875623990ed25723f550 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 10 May 2023 14:16:33 -0500 Subject: [PATCH 06/21] Correct owner id in API --- src/ZGoBackend.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 5641d45..156c791 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -920,7 +920,7 @@ routes pipe config = do [ "message" .= ("Owner found!" :: String) , "owner" .= object - [ "_id" .= (show $ o_id q :: String) + [ "_id" .= (maybe "" show $ o_id q :: String) , "address" .= oaddress q , "name" .= oname q , "currency" .= ocurrency q @@ -952,7 +952,7 @@ routes pipe config = do [ "message" .= ("Owner found!" :: String) , "owner" .= object - [ "_id" .= (show $ o_id q :: String) + [ "_id" .= (maybe "" show $ o_id q :: String) , "address" .= oaddress q , "name" .= oname q , "currency" .= ocurrency q From 0afcaed0764e0007de66f608103364e94b19851d Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 10 May 2023 14:58:31 -0500 Subject: [PATCH 07/21] Add new endpoint for login language --- CHANGELOG.md | 1 + src/ZGoBackend.hs | 8 ++++++++ 2 files changed, 9 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 54f0bf2..f4f81bd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - `isUserValid` function - New middleware to validated requests come from an existing user +- New endpoint for the language data of the login page ### Changed diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 156c791..116002a 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1133,6 +1133,14 @@ routes pipe config = do liftAndCatchIO $ run (deleteOrder oId) status ok200 -- Get language for component + get "getloginlang" $ do + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login") + 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 e80411d8bde977d91d202c9998af3e4adecc9584 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 10 May 2023 15:24:16 -0500 Subject: [PATCH 08/21] Fix new endpoint for login language --- src/ZGoBackend.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 116002a..99a6a49 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1133,7 +1133,7 @@ routes pipe config = do liftAndCatchIO $ run (deleteOrder oId) status ok200 -- Get language for component - get "getloginlang" $ do + get "/getloginlang" $ do lang <- param "lang" txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login") case cast' . Doc =<< txtPack' of From f68675af034579f2137abb190f6a551eea0e2bc9 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 11:36:28 -0500 Subject: [PATCH 09/21] Add `checkuser` endpoint --- src/ZGoBackend.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 99a6a49..e1e6749 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -844,13 +844,20 @@ routes pipe config = do status accepted202 Web.Scotty.json (object ["message" .= ("Incorrect plugin config" :: String)]) + get "/checkuser" $ do + sess <- param "session" + user <- liftAndCatchIO $ run (findUser sess) + case user of + Nothing -> status noContent204 + Just u -> status ok200 --Get user associated with session get "/api/user" $ do sess <- param "session" user <- liftAndCatchIO $ run (findUser sess) case user of Nothing -> status noContent204 - Just u -> + Just u -> do + status ok200 Web.Scotty.json (object [ "message" .= ("User found" :: String) @@ -891,7 +898,7 @@ routes pipe config = do status ok200 else status noContent204 --Get current blockheight from Zcash node - get "/api/blockheight" $ do + get "/blockheight" $ do blockInfo <- liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"] let content = getResponseBody blockInfo :: RpcResponse Block @@ -902,7 +909,7 @@ routes pipe config = do else do status internalServerError500 --Get the ZGo node's shielded address - get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) + get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) --Get owner by address get "/api/owner" $ do addr <- param "address" From 1c202cf81719da47652247d0f4f2717226a804ae Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 11:59:57 -0500 Subject: [PATCH 10/21] Add `getmainlang` endpoint --- src/ZGoBackend.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index e1e6749..399036e 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -849,7 +849,8 @@ routes pipe config = do user <- liftAndCatchIO $ run (findUser sess) case user of Nothing -> status noContent204 - Just u -> status ok200 + Just u -> do + status ok200 --Get user associated with session get "/api/user" $ do sess <- param "session" @@ -1140,6 +1141,14 @@ routes pipe config = do liftAndCatchIO $ run (deleteOrder oId) status ok200 -- Get language for component + get "/getmainlang" $ do + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang "main") + case cast' . Doc =<< txtPack' of + Nothing -> status noContent204 + Just textPack -> do + status ok200 + Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getloginlang" $ do lang <- param "lang" txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login") From f185c76fa096e50ae36fd0dbea2302e2aeec56a5 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 13:15:17 -0500 Subject: [PATCH 11/21] Place `price` endpoint outside of fence --- src/ZGoBackend.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 399036e..3e13d45 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1044,7 +1044,7 @@ routes pipe config = do status ok200 else status noContent204 --Get price for Zcash - get "/api/price" $ do + get "/price" $ do curr <- param "currency" pr <- liftAndCatchIO $ run (findPrice curr) case pr of From 04e0638752d4577d8f25278fb58f43ed29fab070 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 14:26:24 -0500 Subject: [PATCH 12/21] Add `getscanlang` endpoint --- src/ZGoBackend.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 3e13d45..56bbff3 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1149,6 +1149,14 @@ routes pipe config = do Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) + get "/getscanlang" $ do + lang <- param "lang" + txtPack' <- liftAndCatchIO $ run (findLangComponent lang "scan") + case cast' . Doc =<< txtPack' of + Nothing -> status noContent204 + Just textPack -> do + status ok200 + Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getloginlang" $ do lang <- param "lang" txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login") From e99db85febcd380f4187c223784f5dc9f6a01f86 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 14:44:45 -0500 Subject: [PATCH 13/21] Add validation status to `checkuser` --- src/ZGoBackend.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 56bbff3..244eed1 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -847,10 +847,11 @@ routes pipe config = do get "/checkuser" $ do sess <- param "session" user <- liftAndCatchIO $ run (findUser sess) - case user of + case parseUserBson =<< user of Nothing -> status noContent204 Just u -> do status ok200 + Web.Scotty.json (object ["validated" .= uvalidated u]) --Get user associated with session get "/api/user" $ do sess <- param "session" From feea097405be01ee08000375e80f04fdd8588595 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 15:25:38 -0500 Subject: [PATCH 14/21] Add debugging for memo parsing --- src/ZGoBackend.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 244eed1..27b0783 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -376,7 +376,7 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do if m_payment zM' then upsertPayment pipe (c_dbName config) tx else access pipe master (c_dbName config) $ upsertZGoTx "txs" tx - Left e -> error "Failed to parse ZGo memo" + Left e -> error $ "Failed to parse ZGo memo: " ++ show e -- |Type to model a price in the ZGo database data ZGoPrice = From 8e05df072734eadf11933c9a71982d35f724e14c Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 15:31:27 -0500 Subject: [PATCH 15/21] Improve debugging info --- src/ZGoBackend.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 27b0783..32d3190 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -376,7 +376,7 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do if m_payment zM' then upsertPayment pipe (c_dbName config) tx else access pipe master (c_dbName config) $ upsertZGoTx "txs" tx - Left e -> error $ "Failed to parse ZGo memo: " ++ show e + Left e -> print $ "Failed to parse ZGo memo: " ++ show e -- |Type to model a price in the ZGo database data ZGoPrice = From 849f1d9120d3e5dbe956bef1cbc6790f6b298c0d Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 11 May 2023 16:46:47 -0500 Subject: [PATCH 16/21] Fix bug for parsing YWallet memos --- src/ZGoTx.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index 95278f8..9c95872 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -119,6 +119,7 @@ type Parser = Parsec Void T.Text pSession :: Parser MemoToken pSession = do + optional spaceChar string "ZGO" pay <- optional $ char 'p' string "::" @@ -142,9 +143,7 @@ pSaplingAddress = do pMsg :: Parser MemoToken pMsg = do Msg . T.pack <$> - some - (alphaNumChar <|> punctuationChar <|> symbolChar <|> - charCategory OtherSymbol) + some (alphaNumChar <|> punctuationChar <|> charCategory OtherSymbol) pMemo :: Parser MemoToken pMemo = do From aef26675b417ef2148c06134e00d937bd89fceba Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 12 May 2023 08:32:55 -0500 Subject: [PATCH 17/21] Enhance owner endpoint --- CHANGELOG.md | 1 + src/ZGoBackend.hs | 44 ++++++++++++++++++++++---------------------- 2 files changed, 23 insertions(+), 22 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f4f81bd..98fb08a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Modified API tests to use `session` parameter. - Modified `api/owner` endpoint to use a specific data structure to create new owners +- Modified `api/owner` endpoint to use session as input ## [1.4.1] - 2023-05-02 diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 32d3190..d3dfc70 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -914,35 +914,35 @@ routes pipe config = do get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) --Get owner by address get "/api/owner" $ do - addr <- param "address" - owner <- liftAndCatchIO $ run (findOwner addr) - case owner of + session <- param "session" + user <- liftAndCatchIO $ run (findUser session) + case parseUserBson =<< user of Nothing -> status noContent204 - Just o -> do - let pOwner = cast' (Doc o) - case pOwner of - Nothing -> status internalServerError500 - Just q -> do + Just u -> do + owner <- liftAndCatchIO $ run (findOwner $ uaddress u) + case cast' . Doc =<< owner of + Nothing -> status noContent204 + Just o -> do status ok200 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 + [ "_id" .= (maybe "" show $ o_id o :: String) + , "address" .= oaddress o + , "name" .= oname o + , "currency" .= ocurrency o + , "tax" .= otax o + , "taxValue" .= otaxValue o + , "vat" .= ovat o + , "vatValue" .= ovatValue o + , "paid" .= opaid o + , "zats" .= ozats o + , "invoices" .= oinvoices o + , "expiration" .= oexpiration o + , "payconf" .= opayconf o + , "crmToken" .= ocrmToken o ] ]) get "/api/ownerid" $ do From d4b56ca641935da504520621bf385b52c193f7df Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 12 May 2023 13:57:56 -0500 Subject: [PATCH 18/21] Update owner data endpoints --- CHANGELOG.md | 2 ++ src/Owner.hs | 80 +++++++++++++++++++++++++++++++++++++++++++++-- src/ZGoBackend.hs | 18 +---------- 3 files changed, 80 insertions(+), 20 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 98fb08a..03b9130 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - `isUserValid` function - New middleware to validated requests come from an existing user - New endpoint for the language data of the login page +- New `OwnerData` to represent informational values +- New `OwnerSettings` to abstract configuration settings for owners ### Changed diff --git a/src/Owner.hs b/src/Owner.hs index 9df5128..45fdf68 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -289,9 +289,8 @@ data OwnerData = , od_email :: T.Text , od_website :: T.Text , od_phone :: T.Text - , od_payconf :: Bool } - deriving (Eq, Show) + deriving (Eq, Show, Generic) instance FromJSON OwnerData where parseJSON = @@ -307,8 +306,83 @@ instance FromJSON OwnerData where e <- obj .: "email" w <- obj .: "website" ph <- obj .: "phone" + pure $ OwnerData f l n s c st p co e w ph + +data OwnerSettings = + OwnerSettings + { os_id :: Maybe ObjectId + , os_address :: T.Text + , os_name :: T.Text + , os_currency :: T.Text + , os_tax :: Bool + , os_taxValue :: Double + , os_vat :: Bool + , os_vatValue :: Double + , os_paid :: Bool + , os_zats :: Bool + , os_invoices :: Bool + , os_expiration :: UTCTime + , os_payconf :: Bool + , os_crmToken :: T.Text + } + deriving (Eq, Show, Generic) + +instance FromJSON OwnerSettings where + parseJSON = + withObject "OwnerSettings" $ \obj -> do + i <- obj .:? "_id" + a <- obj .: "address" + n <- obj .: "name" + c <- obj .: "currency" + t <- obj .: "tax" + tV <- obj .: "taxValue" + v <- obj .: "vat" + vV <- obj .: "vatValue" + p <- obj .: "paid" + z <- obj .: "zats" + inv <- obj .: "invoices" + e <- obj .: "expiration" pc <- obj .: "payconf" - pure $ OwnerData f l n s c st p co e w ph pc + cT <- obj .: "crmToken" + pure $ OwnerSettings ((Just . read) =<< i) a n c t tV v vV p z inv e pc cT + +instance ToJSON OwnerSettings where + toJSON (OwnerSettings i a n c t tV v vV p z inv e pc cT) = + object + [ "_id" .= maybe "" show i + , "address" .= a + , "name" .= n + , "currency" .= c + , "tax" .= t + , "taxValue" .= tV + , "vat" .= v + , "vatValue" .= vV + , "paid" .= p + , "zats" .= z + , "invoices" .= inv + , "expiration" .= e + , "payconf" .= pc + , "crmToken" .= cT + ] + +-- Helper Functions +getOwnerSettings :: Owner -> OwnerSettings +getOwnerSettings o = + OwnerSettings + (o_id o) + (oaddress o) + (oname o) + (ocurrency o) + (otax o) + (otaxValue o) + (ovat o) + (ovatValue o) + (opaid o) + (ozats o) + (oinvoices o) + (oexpiration o) + (opayconf o) + (ocrmToken o) -- Database actions -- | Function to upsert an Owner diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index d3dfc70..7c82b52 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -927,23 +927,7 @@ routes pipe config = do Web.Scotty.json (object [ "message" .= ("Owner found!" :: String) - , "owner" .= - object - [ "_id" .= (maybe "" show $ o_id o :: String) - , "address" .= oaddress o - , "name" .= oname o - , "currency" .= ocurrency o - , "tax" .= otax o - , "taxValue" .= otaxValue o - , "vat" .= ovat o - , "vatValue" .= ovatValue o - , "paid" .= opaid o - , "zats" .= ozats o - , "invoices" .= oinvoices o - , "expiration" .= oexpiration o - , "payconf" .= opayconf o - , "crmToken" .= ocrmToken o - ] + , "owner" .= getOwnerSettings o ]) get "/api/ownerid" $ do id <- param "id" From 24d8f25ed1f0afa081c353cd42d530521a1e3024 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 12 May 2023 15:17:13 -0500 Subject: [PATCH 19/21] Add settings API endpoint --- src/Owner.hs | 17 +++++++++++++++++ src/ZGoBackend.hs | 14 ++++++++++++++ 2 files changed, 31 insertions(+) diff --git a/src/Owner.hs b/src/Owner.hs index 45fdf68..630a1fa 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -415,6 +415,23 @@ removePro :: T.Text -> Action IO () removePro o = modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]] +updateOwnerSettings :: OwnerSettings -> Action IO () +updateOwnerSettings os = + modify + (select ["_id" =: os_id os] "owners") + [ "$set" =: + [ "name" =: os_name os + , "currency" =: os_currency os + , "tax" =: os_tax os + , "taxValue" =: os_taxValue os + , "vat" =: os_vat os + , "vatValue" =: os_vatValue os + , "zats" =: os_zats os + , "payconf" =: os_payconf os + , "crmToken" =: os_crmToken os + ] + ] + -- | Type for a pro session data ZGoProSession = ZGoProSession diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 7c82b52..0243fb6 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1001,6 +1001,20 @@ routes pipe config = do "" "" status accepted202 + post "/api/ownersettings" $ do + s <- param "session" + u <- liftAndCatchIO $ run (findUser s) + o <- jsonData + now <- liftIO getCurrentTime + let q = payload (o :: Payload OwnerSettings) + case parseUserBson =<< u of + Nothing -> status internalServerError500 + Just u' -> do + if os_address q == uaddress u' + then do + liftAndCatchIO $ run $ updateOwnerSettings q + status accepted202 + else status noContent204 --Get items associated with the given address get "/api/items" $ do addr <- param "address" From e0f631fd0391aed03f5575d43f2b27c68c4501ea Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Sat, 13 May 2023 07:53:14 -0500 Subject: [PATCH 20/21] Add obfuscated viewing key --- src/Owner.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Owner.hs b/src/Owner.hs index 630a1fa..029ad4e 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -324,6 +324,7 @@ data OwnerSettings = , os_expiration :: UTCTime , os_payconf :: Bool , os_crmToken :: T.Text + , os_viewKey :: T.Text } deriving (Eq, Show, Generic) @@ -344,10 +345,12 @@ instance FromJSON OwnerSettings where e <- obj .: "expiration" pc <- obj .: "payconf" cT <- obj .: "crmToken" - pure $ OwnerSettings ((Just . read) =<< i) a n c t tV v vV p z inv e pc cT + vK <- obj .: "viewkey" + pure $ + OwnerSettings ((Just . read) =<< i) a n c t tV v vV p z inv e pc cT vK instance ToJSON OwnerSettings where - toJSON (OwnerSettings i a n c t tV v vV p z inv e pc cT) = + toJSON (OwnerSettings i a n c t tV v vV p z inv e pc cT vK) = object [ "_id" .= maybe "" show i , "address" .= a @@ -363,6 +366,7 @@ instance ToJSON OwnerSettings where , "expiration" .= e , "payconf" .= pc , "crmToken" .= cT + , "viewkey" .= (T.take 5 vK <> "...." <> T.takeEnd 5 vK) ] -- Helper Functions @@ -383,6 +387,7 @@ getOwnerSettings o = (oexpiration o) (opayconf o) (ocrmToken o) + (oviewkey o) -- Database actions -- | Function to upsert an Owner From 6122a2d423d589cb5fa7829a64263fa18b8cfaa1 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Sat, 13 May 2023 08:16:00 -0500 Subject: [PATCH 21/21] Adjust obfuscation of viewing key --- src/Owner.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Owner.hs b/src/Owner.hs index 029ad4e..867f923 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -366,7 +366,7 @@ instance ToJSON OwnerSettings where , "expiration" .= e , "payconf" .= pc , "crmToken" .= cT - , "viewkey" .= (T.take 5 vK <> "...." <> T.takeEnd 5 vK) + , "viewkey" .= (T.take 8 vK <> "...." <> T.takeEnd 8 vK) ] -- Helper Functions