diff --git a/CHANGELOG.md b/CHANGELOG.md index c91ec3c..b1d7ebe 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,7 +4,21 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [Unreleased] +## [1.2.0] - 2023-01-09 + +### Added + +- New utility to refresh Xero tokens periodically. +- New module for WooCommerce interaction. +- New `/auth` endpoint to authenticate with the WooCommerce plugin and corresponding tests +- New `/woopayment` endpoint to generate a new order from the WooCommerce plugin and corresponding tests +- New `/wootoken` endpoint to generate a new token and query the token from the database. + +### Changed + +- Refactored code for requesting Xero tokens to make it reusable. +- Changed API authentication to allow for endpoints that don't require an `Authorization` header to support the WooCommerce integration +- Enhanced the on-chain order confirmation functionality to support WooCommerce integration and future integrations. ## [1.1.1] - 2022-10-08 diff --git a/app/Main.hs b/app/Server.hs similarity index 98% rename from app/Main.hs rename to app/Server.hs index 76b677f..5c6ee4f 100644 --- a/app/Main.hs +++ b/app/Server.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Main where +module Server where import Config import Control.Concurrent (forkIO) diff --git a/app/TokenRefresh.hs b/app/TokenRefresh.hs new file mode 100644 index 0000000..81b5168 --- /dev/null +++ b/app/TokenRefresh.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TokenRefresh where + +import Config +import Data.Time.Clock +import Database.MongoDB +import Xero + +main :: IO () +main = do + putStrLn "Reading config..." + now <- getCurrentTime + loadedConfig <- loadZGoConfig "zgo.cfg" + pipe <- connect $ host (c_dbHost loadedConfig) + let db = c_dbName loadedConfig + j <- + access + pipe + master + db + (auth (c_dbUser loadedConfig) (c_dbPassword loadedConfig)) + if j + then putStrLn "Connected to MongoDB!" + else fail "MongoDB connection failed!" + credsData <- access pipe master db findXero + let creds = cast' . Doc =<< credsData + tokens <- access pipe master db (findExpiringTokens now) + if not (null tokens) + then do + let t = map (cast' . Doc) tokens + case creds of + Just c -> mapM_ (refreshToken pipe db c "") t + Nothing -> fail "No credentials" + else putStrLn "No tokens to refresh1" diff --git a/package.yaml b/package.yaml index dad45bd..8c5b0b3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,6 +1,6 @@ name: zgo-backend -version: 1.1.1 -git: "https://gitlab.com/pitmutt/zgo-backend" +version: 1.2.0 +git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" license: BOSL author: "Rene Vergara" maintainer: "rene@vergara.network" @@ -18,7 +18,7 @@ category: Web # To avoid duplicated efforts in documentation and dealing with the # complications of embedding Haddock markup inside cabal files, it is # common to point users to the README.md file. -description: Please see the README on GitLab at +description: Please see the README at dependencies: - base >= 4.7 && < 5 @@ -53,32 +53,65 @@ library: - scientific - jwt - containers + - base64-bytestring + - wai + - blake3 + - memory + - ghc-prim executables: zgo-backend-exe: - main: Main.hs + main: Server.hs source-dirs: app ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall + - -main-is Server + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall dependencies: - - zgo-backend - - base - - scotty - - wai-extra - - securemem - - text - - aeson - - mongoDB - - http-types - - http-conduit - - time - - bytestring - - configurator - - warp-tls - - warp + - zgo-backend + - base + - scotty + - wai-extra + - securemem + - text + - aeson + - mongoDB + - http-types + - http-conduit + - time + - bytestring + - configurator + - warp-tls + - warp + zgo-token-refresh: + main: TokenRefresh.hs + source-dirs: app + ghc-options: + - -main-is TokenRefresh + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall + dependencies: + - base + - zgo-backend + - base + - scotty + - wai-extra + - securemem + - text + - aeson + - mongoDB + - http-types + - http-conduit + - time + - bytestring + - configurator + - warp-tls + - warp + tests: zgo-backend-test: diff --git a/src/Order.hs b/src/Order.hs index d04b97c..b62d6ef 100644 --- a/src/Order.hs +++ b/src/Order.hs @@ -191,6 +191,13 @@ upsertOrder o = do else insert_ "orders" d _ -> return () +insertWooOrder :: ZGoOrder -> Action IO Database.MongoDB.Value +insertWooOrder o = do + let order = val $ updateOrderTotals o + case order of + Doc d -> insert "orders" d + _ -> fail "Couldn't parse order" + upsertXeroOrder :: ZGoOrder -> Action IO () upsertXeroOrder o = do let order = val $ updateOrderTotals o diff --git a/src/WooCommerce.hs b/src/WooCommerce.hs new file mode 100644 index 0000000..a7b16b4 --- /dev/null +++ b/src/WooCommerce.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module WooCommerce where + +import qualified BLAKE3 as BLK +import Data.Aeson +import qualified Data.Bson as B +import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Text.Encoding.Error (lenientDecode) +import Database.MongoDB +import Network.HTTP.Simple +import Network.HTTP.Types.Status +import Owner + +-- | Type to represent the WooCommerce token +data WooToken = + WooToken + { w_id :: Maybe ObjectId + , w_owner :: ObjectId + , w_token :: T.Text + , w_url :: Maybe T.Text + } + deriving (Eq, Show) + +instance Val WooToken where + val (WooToken i o t u) = + if isJust i + then Doc ["_id" =: i, "owner" =: o, "token" =: t, "url" =: u] + else Doc ["owner" =: o, "token" =: t, "url" =: u] + cast' (Doc d) = do + i <- B.lookup "_id" d + o <- B.lookup "owner" d + t <- B.lookup "token" d + u <- B.lookup "url" d + Just + (WooToken + i + o + t + (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack <$> u)) + cast' _ = Nothing + +-- Database actions +findWooToken :: ObjectId -> Action IO (Maybe Document) +findWooToken oid = findOne (select ["owner" =: oid] "wootokens") + +addUrl :: WooToken -> T.Text -> Action IO () +addUrl t u = + modify (select ["_id" =: w_id t] "wootokens") ["$set" =: ["url" =: u]] + +payWooOrder :: + String -- url + -> BS.ByteString -- WooCommerce order ID + -> BS.ByteString -- ZGo order id + -> BS.ByteString -- ZGo token + -> BS.ByteString -- Zcash price + -> BS.ByteString -- Total ZEC for order + -> IO () +payWooOrder u i o t p z = do + wooReq <- parseRequest $ u ++ "/wc-api/zpmtcallback" + let req = + setRequestQueryString + [ ("token", Just t) + , ("orderid", Just o) + , ("wc_orderid", Just i) + , ("rate", Just p) + , ("totalzec", Just z) + ] + wooReq + print req + res <- httpLBS req + if getResponseStatus res == ok200 + then return () + else error "Failed to report payment to WooCommerce" + +generateWooToken :: Owner -> Action IO () +generateWooToken o = + 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 + case wooToken of + Doc wT -> insert_ "wootokens" wT + _ -> error "Couldn't create the WooCommerce token" + Nothing -> error "Bad owner id" diff --git a/src/Xero.hs b/src/Xero.hs index 8d67b4f..e98921d 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -280,17 +280,24 @@ upsertToken t = do findToken :: T.Text -> Action IO (Maybe Document) findToken a = findOne (select ["address" =: a] "xerotokens") +findExpiringTokens :: UTCTime -> Action IO [Document] +findExpiringTokens now = + rest =<< + find + (select ["refExpires" =: ["$lte" =: addUTCTime 1728000 now]] "xerotokens") + -- | Function to request accesstoken requestXeroToken :: Pipe -> T.Text -> Xero -> T.Text -> T.Text -> IO Bool requestXeroToken pipe dbName cred code address = do token <- access pipe master dbName $ findToken address + let oToken = token >>= cast' . Doc + refreshToken pipe dbName cred code oToken + +refreshToken :: Pipe -> T.Text -> Xero -> T.Text -> Maybe XeroToken -> IO Bool +refreshToken pipe dbName cred code token = do let pars = case token of - Just xT -> do - let xToken = cast' (Doc xT) :: Maybe XeroToken - case xToken of - Nothing -> error "Failed to parse XeroToken BSON" - Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x + Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x Nothing -> "grant_type=authorization_code&code=" <> code <> "&redirect_uri=http://localhost:4200/xeroauth" @@ -309,8 +316,10 @@ requestXeroToken pipe dbName cred code address = do case rCode of 200 -> do let newToken = getResponseBody (res :: Response XeroToken) - let accCode = t_code <$> (token >>= cast' . Doc) - pToken <- processToken newToken address (fromMaybe "" accCode) + let accCode = t_code <$> token + let address = t_address <$> token + pToken <- + processToken newToken (fromMaybe "" address) (fromMaybe "" accCode) --print pToken _ <- access pipe master dbName $ upsertToken pToken _ <- getTenantId pipe dbName pToken @@ -429,6 +438,6 @@ payXeroInvoice pipe dbName inv address amt = do setRequestPath "/api.xro/2.0/Payments" $ setRequestHost "api.xero.com" $ setRequestMethod "PUT" defaultRequest - res <- httpJSON req - print (res :: Response Object) + res <- httpJSON req :: IO (Response Object) + return () else error "Invalid parameters" diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 3c55d77..78728e4 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -8,12 +8,15 @@ module ZGoBackend where import Config import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (try) import Control.Monad import Control.Monad.IO.Class import Data.Aeson import Data.Array import qualified Data.Bson as B import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C import Data.Char import qualified Data.HashMap.Strict as HM import Data.HexString @@ -26,6 +29,7 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as L import Data.Time.Clock import Data.Time.Clock.POSIX +import Data.Time.Format import Data.Typeable import qualified Data.Vector as V import Data.Vector.Internal.Check (doChecks) @@ -35,8 +39,8 @@ import Debug.Trace import GHC.Generics import Item import Network.HTTP.Simple -import Network.HTTP.Types (created201) import Network.HTTP.Types.Status +import Network.Wai (Request, pathInfo) import Network.Wai.Middleware.Cors import Network.Wai.Middleware.HttpAuth import Numeric @@ -52,6 +56,7 @@ import Text.Regex import Text.Regex.Base import User import Web.Scotty +import WooCommerce import Xero import ZGoTx @@ -487,6 +492,16 @@ upsertPayment pipe dbName p = do upsert (select ["txid" =: txid p] "payments") d _ -> return () +authSettings :: AuthSettings +authSettings = "ZGo Backend" {authIsProtected = needsAuth} + +needsAuth :: Network.Wai.Request -> IO Bool +needsAuth req = + return $ + case pathInfo req of + "api":_ -> True + _ -> False + -- | Main API routes routes :: Pipe -> Config -> ScottyM () routes pipe config = do @@ -507,7 +522,7 @@ routes pipe config = do middleware $ basicAuth (\u p -> return $ u == "user" && secureMemFromByteString p == passkey) - "ZGo Backend" + authSettings --Get list of countries for UI get "/api/countries" $ do countries <- liftAndCatchIO $ run listCountries @@ -604,6 +619,161 @@ routes pipe config = do c <- param "code" 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 + ]) + 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 + -- Authenticate the WooCommerce plugin + get "/auth" $ do + oid <- param "ownerid" + t <- param "token" + siteurl <- param "siteurl" + res <- liftAndCatchIO $ run (findWooToken (read oid)) + let c1 = cast' . Doc =<< res + case c1 of + Nothing -> do + status accepted202 + Web.Scotty.json + (object + ["authorized" .= False, "message" .= ("Owner not found" :: String)]) + Just c -> + if t == w_token c + then if isNothing (w_url c) + then do + liftAndCatchIO $ run (addUrl c siteurl) + status ok200 + Web.Scotty.json + (object + [ "authorized" .= True + , "message" .= ("Authorized!" :: String) + ]) + else do + if (E.decodeUtf8With lenientDecode . + B64.decodeLenient . C.pack . T.unpack) + siteurl == + fromMaybe "" (w_url c) + then do + status ok200 + Web.Scotty.json + (object + [ "authorized" .= True + , "message" .= ("Already authorized." :: String) + ]) + else do + status accepted202 + Web.Scotty.json + (object + [ "authorized" .= False + , "message" .= + ("ZGo shop already linked to " <> + fromMaybe "" (w_url c)) + ]) + else do + status accepted202 + Web.Scotty.json + (object + [ "authorized" .= False + , "message" .= ("Token mismatch" :: String) + ]) + get "/woopayment" $ do + oid <- param "ownerid" + t <- param "token" + ordId <- param "order_id" + date <- param "date" + curr <- param "currency" + amount <- param "amount" + sUrl <- param "siteurl" + orderKey <- param "orderkey" + res <- liftAndCatchIO $ run (findWooToken (read oid)) + let c = cast' . Doc =<< res + case c of + Nothing -> do + status accepted202 + Web.Scotty.json + (object ["message" .= ("Plugin not setup in ZGo" :: String)]) + Just x -> + if t == w_token x && + (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl == + fromMaybe "" (w_url x) + then do + zecPriceDb <- liftAndCatchIO (run (findPrice curr)) + let zecPrice = parseZGoPrice =<< zecPriceDb + case zecPrice of + Nothing -> do + status accepted202 + Web.Scotty.json + (object ["message" .= ("Currency not supported" :: String)]) + Just zP -> do + ownerDb <- + liftAndCatchIO $ + run (findOwnerById (T.pack . show $ w_owner x)) + let owner = cast' . Doc =<< ownerDb + case owner of + Nothing -> do + status accepted202 + Web.Scotty.json + (object ["message" .= ("Owner not found" :: String)]) + Just o -> + if opaid o + then do + let newOrder = + ZGoOrder + Nothing + (oaddress o) + (case o_id o of + Just o' -> "WC-" <> (T.pack . show $ o') + Nothing -> "") + (parseTimeOrError + True + defaultTimeLocale + "%Y-%0m-%0d" + date) + True + (T.pack curr) + (price zP) + 0.0 + 0.0 + [ LineItem + 1.0 + (oname o <> " order " <> ordId) + amount + ] + False + (T.concat + [T.pack sUrl, "-", ordId, "-", orderKey]) + "" + newId <- liftAndCatchIO $ run (insertWooOrder newOrder) + status ok200 + Web.Scotty.json (object ["order" .= show newId]) + else do + status accepted202 + Web.Scotty.json + (object + ["message" .= ("ZGo shop not paid for" :: String)]) + else do + status accepted202 + Web.Scotty.json + (object ["message" .= ("Incorrect plugin config" :: String)]) --Get user associated with session get "/api/user" $ do sess <- param "session" @@ -881,8 +1051,10 @@ getZcashPrices = do -- | Function to update the Zcash prices in the ZGo db checkZcashPrices :: Pipe -> T.Text -> IO () checkZcashPrices p db = do - q <- getZcashPrices - mapM_ (access p master db) (updatePrices (getResponseBody q)) + q <- try getZcashPrices + case q of + Left e -> print (e :: HttpException) + Right q1 -> mapM_ (access p master db) (updatePrices (getResponseBody q1)) -- | Function to search for transactions for an address listTxs :: @@ -967,20 +1139,57 @@ scanPayments config pipe = do case xOrder of Nothing -> error "Failed to retrieve order from database" Just xO -> - unless - (qpaid xO && qexternalInvoice xO == "" && qtotalZec xO == snd x) $ 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) + when + (not (qpaid xO) && + qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ 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) + "WC" -> do + let wOwner = fst $ head sResult ! 2 + wooT <- + access p master dbName $ findWooToken (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) + 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 diff --git a/stack.yaml b/stack.yaml index 90dff48..27fad16 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,8 +17,8 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml +resolver: lts-19.33 + #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml # User packages to be built. # Various formats can be used as shown in the example below. @@ -44,6 +44,7 @@ packages: extra-deps: - git: https://github.com/reach-sh/haskell-hexstring.git commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + - blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index fa7fbb1..ad88f96 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,20 +5,26 @@ packages: - completed: + commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + git: https://github.com/reach-sh/haskell-hexstring.git name: hexstring - version: 0.11.1 - git: https://github.com/reach-sh/haskell-hexstring.git pantry-tree: - size: 687 sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + size: 687 + version: 0.11.1 original: - git: https://github.com/reach-sh/haskell-hexstring.git commit: 085c16fb21b9f856a435a3faab980e7e0b319341 + git: https://github.com/reach-sh/haskell-hexstring.git +- completed: + hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 + pantry-tree: + sha256: 0264ef3e7919e7b0d668c4153f6ce0d88e6965626b52d9dfd2cafd70309501d3 + size: 1433 + original: + hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 snapshots: - completed: - size: 618683 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml - sha256: d4ee004c46ba878d2f304f5d748d493057be579192a8d148527f3ba55c9df57f - original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml + sha256: 6d1532d40621957a25bad5195bfca7938e8a06d923c91bc52aa0f3c41181f2d4 + size: 619204 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/33.yaml + original: lts-19.33 diff --git a/test/Spec.hs b/test/Spec.hs index f106b87..6d1137d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -33,6 +33,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Monadic import User import Web.Scotty +import WooCommerce import Xero import ZGoBackend import ZGoTx @@ -156,7 +157,7 @@ main = do res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 describe "blockheight endpoint" $ do - xit "returns a block number" $ do + it "returns a block number" $ do req <- testGet "/api/blockheight" [] res <- httpJSON req height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x -> @@ -250,6 +251,69 @@ main = do req <- testDelete "/api/item/" "627d7ba92b05a76be3000003" res <- httpLBS req getResponseStatus res `shouldBe` ok200 + describe "WooCommerce endpoints" $ do + it "generate token" $ do + req <- + testPost + "/api/wootoken" + [("ownerid", Just "627ad3492b05a76be5000001")] + res <- httpLBS req + getResponseStatus res `shouldBe` accepted202 + it "authenticate with incorrect owner" $ do + req <- + testPublicGet + "/auth" + [ ("ownerid", Just "62cca13f5530331e2a900001") + , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") + ] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` accepted202 + it "authenticate with incorrect token" $ do + req <- + testPublicGet + "/auth" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("token", Just "89bd9d8d69a674e0f467cc8796000000") + , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") + ] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` accepted202 + it "authenticate with correct token" $ do + req <- + testPublicGet + "/auth" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") + ] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 + it "authenticate with correct token on existing shop" $ do + req <- + testPublicGet + "/auth" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ("siteurl", Just "aHR0cHM6Ly93d3cuZ29vZ2xlLmNvbS8") + ] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` accepted202 + it "request order creation" $ do + req <- + testPublicGet + "/woopayment" + [ ("ownerid", Just "627ad3492b05a76be3000001") + , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a") + , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8") + , ("order_id", Just "1234") + , ("currency", Just "usd") + , ("amount", Just "100.0") + , ("date", Just "2022-12-01") + , ("orderkey", Just "wc_order_m7qiJ1dNrGDYE") + ] + res <- httpJSON req + getResponseStatus (res :: Response A.Value) `shouldBe` ok200 around handleDb $ describe "Database actions" $ do describe "authentication" $ do @@ -304,7 +368,7 @@ main = do it "deleted" $ \p -> do t <- access p master "test" $ findOne (select [] "users") let s = parseUserBson =<< t - let userId = maybe Nothing u_id s + let userId = u_id =<< s let idString = maybe "" show userId _ <- access p master "test" $ deleteUser idString q <- @@ -332,6 +396,7 @@ main = do let ordTest = val myOrder case ordTest of Doc oT -> access p master "test" (insert_ "orders" oT) + _ -> fail "Couldn't save Order in DB" _ <- access p master "test" $ markOrderPaid ("627ab3ea2b05a76be3000001", 0) @@ -496,6 +561,15 @@ testGet endpoint body = do setRequestMethod "GET" $ setRequestPath endpoint defaultRequest return testRequest +testPublicGet :: + B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request +testPublicGet endpoint body = do + let testRequest = + setRequestQueryString body $ + setRequestPort 3000 $ + setRequestMethod "GET" $ setRequestPath endpoint defaultRequest + return testRequest + testPost :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request testPost endpoint body = do let user = "user" @@ -576,6 +650,8 @@ startAPI config = do c <- access pipe master "zgo" (auth "zgo" "zcashrules") let appRoutes = routes pipe config _ <- forkIO (scotty 3000 appRoutes) + _ <- + access pipe master "test" (Database.MongoDB.delete (select [] "wootokens")) let myUser = User (Just (read "6272a90f2b05a74cf1000001" :: ObjectId)) @@ -618,8 +694,35 @@ startAPI config = do "" "bubbarocks.io" "United States" + True False False + (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0)) + False + "" + "" + let myOwner1 = + Owner + (Just (read "627ad3492b05a76be5000001")) + "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" + "Test shop" + "usd" + False + 0 + False + 0 + "Bubba" + "Gibou" + "bubba@zgo.cash" + "1 Main St" + "Mpls" + "Minnesota" + "55401" + "" + "bubbarocks.io" + "United States" + True + False False (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0)) False @@ -629,6 +732,7 @@ startAPI config = do let o = val myOwner case o of Doc d -> access pipe master "test" (insert_ "owners" d) + _ -> fail "Couldn't save Owner in DB" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders")) myTs <- liftIO getCurrentTime let myOrder = @@ -649,6 +753,7 @@ startAPI config = do let ordTest = val myOrder case ordTest of Doc oT -> access pipe master "test" (insert_ "orders" oT) + _ -> fail "Couldn't save Order in DB" let myItem1 = Item (Just (read "627d7ba92b05a76be3000003")) @@ -659,6 +764,17 @@ startAPI config = do let itemTest = val myItem1 case itemTest of Doc iT -> access pipe master "test" (insert_ "items" iT) + _ -> fail "Couldn't save test Item in DB" + let myWooToken = + WooToken + Nothing + (read "627ad3492b05a76be3000001") + "89bd9d8d69a674e0f467cc8796ed151a" + Nothing + let wooTest = val myWooToken + case wooTest of + Doc wT -> access pipe master "test" (insert_ "wootokens" wT) + _ -> fail "Couldn't save test WooToken in DB" threadDelay 1000000 putStrLn "Test server is up!" diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 4e33148..34fee47 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.1.0 +version: 1.1.1 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README on GitLab at category: Web @@ -32,6 +32,7 @@ library Owner Payment User + WooCommerce Xero ZGoBackend ZGoTx @@ -44,14 +45,18 @@ library , aeson , array , base >=4.7 && <5 + , base64-bytestring + , blake3 , bson , bytestring , configurator , containers + , ghc-prim , hexstring , http-conduit , http-types , jwt + , memory , mongoDB , quickcheck-instances , random @@ -64,18 +69,46 @@ library , time , unordered-containers , vector + , wai , wai-cors , wai-extra , warp-tls default-language: Haskell2010 executable zgo-backend-exe - main-is: Main.hs + main-is: Server.hs other-modules: + TokenRefresh Paths_zgo_backend hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson + , base + , bytestring + , configurator + , http-conduit + , http-types + , mongoDB + , scotty + , securemem + , text + , time + , wai-extra + , warp + , warp-tls + , zgo-backend + default-language: Haskell2010 + +executable zgo-token-refresh + main-is: TokenRefresh.hs + other-modules: + Server + Paths_zgo_backend + hs-source-dirs: + app + ghc-options: -main-is TokenRefresh -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: aeson , base