{-# 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 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 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
length (T.unpack (unsafePerformIO (generatePin 1010))) `shouldBe` 7
describe "API endpoints" $ do
beforeAll_ (startAPI loadedConfig) $ do
describe "Price endpoint" $ do
it "returns a price for an existing currency" $ do
req <- testGet "/api/price" [("currency", Just "usd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "returns 204 when the currency is not supported" $ do
req <- testGet "/api/price" [("currency", Just "jpy")]
res <- httpLBS req
getResponseStatus res `shouldBe` noContent204
describe "Countries endpoint" $ do
it "returns a list of countries" $ do
req <- testGet "/api/countries" []
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
describe "blockheight endpoint" $ do
xit "returns a block number" $ do
req <- testGet "/api/blockheight" []
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 "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 204 when no user" $ 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
it "deletes user by id" $ do
req <- testDelete "/api/user/" "6272a90f2b05a74cf1000001"
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Owner endpoint" $ do
prop "add owner" testOwnerAdd
it "return owner by address" $ do
req <-
testGet
"/api/owner"
[ ( "address"
, Just
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e")
]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "return owner by id" $ do
req <-
testGet "/api/ownerid" [("id", Just "627ad3492b05a76be3000001")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Order endpoint" $ 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 id" $ do
req <- testGet "/api/order/627ab3ea2b05a76be3000000" []
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "get order with wrong id" $ do
req <- testGet "/api/order/6273hrb" []
res <- httpLBS req
getResponseStatus res `shouldBe` noContent204
it "get all orders for owner" $ do
req <- testGet "/api/allorders" [("address", Just "Zaddy")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "delete order by id" $ do
req <- testDelete "/api/order/" "627ab3ea2b05a76be3000000"
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Item endpoint" $ do
prop "add item" testItemAdd
it "get items" $ do
req <- testGet "/api/items" [("address", Just "Zaddy")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "delete item" $ do
req <- testDelete "/api/item/" "627d7ba92b05a76be3000003"
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
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 "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
it "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 = maybe Nothing 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)
_ <-
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)
xit "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
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 -> IO Request
testDelete endpoint par = do
let user = "user"
let pwd = "superSecret"
let testRequest =
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 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
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)
let myUser =
User
(Just (read "6272a90f2b05a74cf1000001" :: ObjectId))
"zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
1613487
"1234567"
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 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"
False
False
False
(UTCTime (fromGregorian 2022 4 16) (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)
_ <- 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)
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)
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