{-# LANGUAGE OverloadedStrings #-} module Spec where import Config import Control.Concurrent (forkIO, threadDelay) import Control.Exception (bracket) import Control.Monad.IO.Class import qualified Data.Aeson as A import qualified Data.ByteString as B import Data.Configurator import Data.Either import Data.Maybe import Data.SecureMem import qualified Data.Text as T import Data.Time import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX import Database.MongoDB import Item import LangComponent import Network.HTTP.Simple import Network.HTTP.Types.Status import Order import Owner import Payment import System.IO.Unsafe import Test.Hspec import Test.Hspec.Expectations.Json import Test.Hspec.QuickCheck import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Monadic import User import Web.Scotty import WooCommerce import Xero import ZGoBackend import ZGoTx main :: IO () main = do putStrLn "Reading config..." loadedConfig <- loadZGoConfig "zgotest.cfg" hspec $ do describe "Helper functions" $ do describe "decodeHexText" $ do it "converts to readable text" $ do decodeHexText "5a474f3a3a35643364343439342d353163302d343332642d383439352d3035303431393935376165610a5265706c792d546f3a0a7a733177366e6b616d65617a633567756a6d363933353073796c35773874677679617068756d73337077386579747a7935796d303878376476736b6d796b6b61746d777275636d67763365723865" `shouldBe` "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" describe "hex strings" $ do prop "encoding and decoding are inverse" $ \x -> (decodeHexText . encodeHexText) x == x describe "zToZGoTx" $ do it "converts ZecWallet tx to ZGo tx" $ do let t = ZcashTx "someId" 0.5 50000000 1602000 18732456 False 5 "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" zToZGoTx t `shouldBe` ZGoTx Nothing "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "5d3d4494-51c0-432d-8495-050419957aea" 5 18732456 0.5 "someId" "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" it "converts YWallet tx to ZGo tx" $ do let t = ZcashTx "someId" 0.5 50000000 1602000 18732456 False 5 "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1" zToZGoTx t `shouldBe` ZGoTx Nothing "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "ad8477d3-4fdd-4c97-90b2-76630b5f77e1" 5 18732456 0.5 "someId" "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1" it "converts ZecWallet payment tx to ZGo tx" $ do let t = ZcashTx "someId" 0.5 50000000 1602000 18732456 False 5 "ZGOp::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" zToZGoTx t `shouldBe` ZGoTx Nothing "" "5d3d4494-51c0-432d-8495-050419957aea" 5 18732456 0.5 "someId" "ZGOp::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" it "converts YWallet payment tx to ZGo tx" $ do let t = ZcashTx "someId" 0.5 50000000 1602000 18732456 False 5 "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGOp::ad8477d3-4fdd-4c97-90b2-76630b5f77e1" zToZGoTx t `shouldBe` ZGoTx Nothing "" "ad8477d3-4fdd-4c97-90b2-76630b5f77e1" 5 18732456 0.5 "someId" "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGOp::ad8477d3-4fdd-4c97-90b2-76630b5f77e1" describe "PIN generator" $ do it "should give a 7 digit" $ do pin <- generatePin 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" [ ("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" [ ("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" [("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" [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x -> x > 1600000 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 <- testGet "/api/user" [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpJSON req getResponseStatus (res :: Response A.Value) `shouldBe` ok200 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` 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 "Owner endpoint" $ --prop "add owner" testOwnerAdd do it "return owner by address" $ do req <- testGet "/api/owner" [ ( "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") , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") ] res <- httpLBS req getResponseStatus res `shouldBe` ok200 describe "Order endpoints" $ do prop "upsert order" testOrderAdd it "get order by session" $ do req <- testGet "/api/order" [("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" [("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" [("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") , ("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 describe "Item endpoint" $ do prop "add item" testItemAdd it "get items" $ do 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" [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] res <- httpLBS req getResponseStatus res `shouldBe` ok200 describe "WooCommerce endpoints" $ do it "generate token" $ do req <- testPost "/api/wootoken" [ ("ownerid", Just "627ad3492b05a76be3000001") , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") ] res <- httpLBS req getResponseStatus res `shouldBe` accepted202 it "authenticate with incorrect owner" $ do req <- testPublicGet "/auth" [ ("ownerid", Just "62cca13f5530331e2a900001") , ( "token" , Just "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("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 "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("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 "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("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 "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee") , ("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 describe "Language endpoint" $ do it "existing component" $ do req <- testGet "/api/getlang" [ ("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") , ("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") , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd") ] res <- httpLBS req getResponseStatus res `shouldBe` noContent204 around handleDb $ describe "Database actions" $ do describe "authentication" $ do it "should succeed with good creds" $ \p -> do r <- liftIO $ access p master "zgo" (auth "zgo" "zcashrules") r `shouldBe` True it "should fail with bad creds" $ \p -> do r <- liftIO $ access p master "zgo" (auth "user" "pwd") r `shouldBe` False describe "ZGo Pro sessions" $ do it "find in DB" $ \p -> do doc <- access p master "test" $ findProSession "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" doc `shouldNotBe` Nothing it "upsert to DB" $ const pending describe "Zcash prices" $ do it "should update" $ \p -> do doc <- access p master "test" $ findPrice "usd" case doc of Nothing -> True `shouldBe` False Just d -> do let q = parseZGoPrice d case q of Nothing -> True `shouldBe` False Just r -> do let t1 = ZGoBackend.timestamp r _ <- checkZcashPrices p "test" doc2 <- access p master "test" $ findPrice "usd" case doc2 of Nothing -> True `shouldBe` False Just d2 -> do let q2 = parseZGoPrice d2 case q2 of Nothing -> True `shouldBe` False Just r2 -> do let t2 = ZGoBackend.timestamp r2 t2 `shouldSatisfy` (t1 <) describe "user is" $ do xit "validated" $ \p -> do t <- access p master "test" $ findOne (select ["validated" =: False] "users") case t of Nothing -> True `shouldBe` False Just r -> do let s = parseUserBson r case s of Nothing -> True `shouldBe` False Just z -> do _ <- access p master "test" $ validateUser (usession z) q <- access p master "test" $ findOne (select ["validated" =: True, "session" =: usession z] "users") isNothing q `shouldBe` False it "deleted" $ \p -> do t <- access p master "test" $ findOne (select [] "users") let s = parseUserBson =<< t let userId = u_id =<< s let idString = maybe "" show userId _ <- access p master "test" $ deleteUser idString q <- access p master "test" $ findOne (select ["_id" =: userId] "users") isNothing q `shouldBe` True describe "Orders" $ do it "marked as paid" $ \p -> do myTs <- liftIO getCurrentTime let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000001")) "Zaddy" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False "usd" 102.0 0 0 [] False "" "" 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) o <- access p master "test" $ findOrderById "627ab3ea2b05a76be3000001" let o1 = (cast' . Doc) =<< o case o1 of Nothing -> True `shouldBe` False 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" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False Just t2 -> t_address t2 `shouldBe` "Zaddy" it "code is saved" $ \p -> do _ <- access p master "test" $ addAccCode "Zaddy" "ZEC" t <- access p master "test" $ findToken "Zaddy" let t1 = (cast' . Doc) =<< t case t1 of Nothing -> True `shouldBe` False Just t2 -> t_code t2 `shouldBe` "ZEC" describe "Zcash transactions" $ do xit "logins are added to db" $ \p -> do _ <- access p master "test" (Database.MongoDB.delete (select [] "txs")) _ <- scanZcash loadedConfig p threadDelay 1000000 t <- access p master "test" $ findOne (select [] "txs") let s = parseZGoTxBson =<< t let conf = maybe 0 confirmations s conf `shouldSatisfy` (> 0) xit "payments are added to db" $ \p -> do _ <- access p master "test" (Database.MongoDB.delete (select [] "payments")) _ <- scanZcash loadedConfig p threadDelay 1000000 t <- access p master "test" $ findOne (select [] "payments") let s = (cast' . Doc) =<< t let payDelta = maybe 0 pdelta s payDelta `shouldSatisfy` (> 0) it "owners are marked as paid" $ \p -> do let myUser = User (Just (read "6272a90f2b05a74cf1000002" :: ObjectId)) "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb" 1613487 "1234567" True _ <- access p master "test" (insert_ "users" [ "address" =: uaddress myUser , "_id" =: u_id myUser , "session" =: usession myUser , "blocktime" =: ublocktime myUser , "pin" =: upin myUser , "validated" =: uvalidated myUser ]) tstamp <- getCurrentTime let myPay = Payment Nothing 86400 False "" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb" ((round . utcTimeToPOSIXSeconds) tstamp) 0.005 "myrandom123tx464id" "coolest memo ever!" let parsedPay = val myPay case parsedPay of Doc d -> do _ <- access p master "test" (insert_ "payments" d) _ <- checkPayments p "test" threadDelay 1000000 t <- access p master "test" $ findOne (select [ "address" =: ("zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" :: T.Text) ] "owners") let s = (cast' . Doc) =<< t let ownerPaid = maybe False opaid s ownerPaid `shouldBe` True _ -> True `shouldBe` False `debug` "Failed parsing payment" xit "owners are expired" $ \p -> do _ <- expireOwners p "test" now <- getCurrentTime res <- access p master "test" (rest =<< find (select ["expiration" =: ["$lt" =: now], "paid" =: True] "owners")) res `shouldBe` [] xit "login txs are converted to users" $ \p -> do let myTx = ZGoTx Nothing "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca" 3 1613487 0.00000001 "abcdef" "Super Memo" _ <- access p master "test" (Database.MongoDB.delete (select [] "users")) _ <- access p master "test" (insert_ "txs" (encodeZGoTxBson myTx)) _ <- updateLogins p loadedConfig threadDelay 1000000 t <- access p master "test" $ findOne (select [] "users") case t of Nothing -> True `shouldBe` False Just r -> do let s = parseUserBson r case s of Nothing -> True `shouldBe` False Just z -> length (T.unpack (usession z)) `shouldSatisfy` (> 0) testGet :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request testGet endpoint body = do let user = "user" let pwd = "superSecret" let testRequest = setRequestQueryString body $ setRequestPort 3000 $ setRequestBasicAuth user pwd $ 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" let pwd = "superSecret" let testRequest = setRequestQueryString body $ setRequestPort 3000 $ setRequestBasicAuth user pwd $ setRequestMethod "POST" $ setRequestPath endpoint defaultRequest return testRequest testPostJson :: B.ByteString -> A.Value -> IO Request testPostJson endpoint body = do let user = "user" let pwd = "superSecret" let testRequest = setRequestBodyJSON body $ setRequestPort 3000 $ setRequestBasicAuth user pwd $ setRequestMethod "POST" $ setRequestPath endpoint defaultRequest return testRequest 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" $ setRequestPath (B.append endpoint par) defaultRequest return testRequest testOwnerAdd :: Owner -> Property testOwnerAdd o = monadicIO $ do req <- run $ testPostJson "/api/owner" (A.object ["payload" A..= A.toJSON o]) --`debug` show o res <- httpLBS req if opayconf o then assert $ getResponseStatus res == internalServerError500 else assert $ getResponseStatus res == created201 testOrderAdd :: ZGoOrder -> Property testOrderAdd o = monadicIO $ do req <- run $ testPostJson "/api/order" (A.object ["payload" A..= A.toJSON o]) 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 $ setRequestQueryString [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")] req assert $ getResponseStatus res == created201 -- | Open the MongoDB connection openDbConnection :: IO Pipe openDbConnection = do pipe <- connect $ host "127.0.0.1" access pipe master "zgo" (auth "zgo" "zcashrules") return pipe -- | Close the MongoDB pipe closeDbConnection :: Pipe -> IO () closeDbConnection = close -- | DB handling function handleDb :: (Pipe -> Expectation) -> IO () handleDb = bracket openDbConnection closeDbConnection startAPI :: Config -> IO () startAPI config = do putStrLn "Starting test server ..." pipe <- connect $ host "127.0.0.1" 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")) _ <- 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)) "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" 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)) "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")) "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 2023 2 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" _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders")) myTs <- liftIO getCurrentTime let myOrder = ZGoOrder (Just (read "627ab3ea2b05a76be3000000")) "Zaddy" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd" myTs False "usd" 102.0 0 0 [] False "" "" 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")) "Chair" "Made of wood" "Zaddy" 101.99 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 proSession1 = ZGoProSession Nothing "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e" myTs False let proSessionTest = val proSession1 case proSessionTest of Doc pS1 -> access pipe master "test" (insert_ "prosessions" pS1) _ -> fail "Couldn't save test ZGoProSession 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!" --QuickCheck instances instance Arbitrary ZGoOrder where arbitrary = do i <- arbitrary a <- arbitrary s <- arbitrary ts <- arbitrary c <- arbitrary cur <- arbitrary p <- arbitrary t <- arbitrary tZ <- arbitrary l <- arbitrary pd <- arbitrary eI <- arbitrary ZGoOrder i a s ts c cur p t tZ l pd eI <$> arbitrary instance Arbitrary LineItem where arbitrary = do i <- arbitrary q <- arbitrary LineItem i q <$> arbitrary instance Arbitrary ObjectId where arbitrary = do x <- arbitrary Oid x <$> arbitrary instance Arbitrary Owner where arbitrary = do i <- arbitrary a <- arbitrary n <- arbitrary c <- arbitrary t <- arbitrary tV <- arbitrary v <- arbitrary vV <- arbitrary f <- arbitrary l <- arbitrary e <- arbitrary s <- arbitrary ct <- arbitrary st <- arbitrary p <- arbitrary ph <- arbitrary w <- arbitrary co <- arbitrary paid <- arbitrary zats <- arbitrary inv <- arbitrary exp <- arbitrary payconf <- arbitrary vk <- arbitrary Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp payconf vk <$> arbitrary instance Arbitrary Item where arbitrary = do i <- arbitrary n <- arbitrary d <- arbitrary o <- arbitrary Item i n d o <$> arbitrary instance Arbitrary XeroToken where arbitrary = do i <- arbitrary a <- arbitrary t <- arbitrary e <- arbitrary r <- arbitrary aD <- arbitrary dt <- arbitrary XeroToken i a t e r aD dt <$> arbitrary