zgo-backend/test/Spec.hs

{-# LANGUAGE OverloadedStrings #-}

module Spec where

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.Char (isAscii)
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 ZGoBackend
import ZGoTx

main :: IO ()
main = do
  putStrLn "Reading config..."
  config <- load ["zgo.cfg"]
  let dbName = "test"
  nodeAddress <- require config "nodeAddress"
  nodeUser <- require config "nodeUser"
  nodePwd <- require config "nodePassword"
  passkey <- secureMemFromByteString <$> require config "passkey"
  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) (filter isAscii x) == filter isAscii x
      describe "zToZGoTx" $ do
        it "converts zcash tx to ZGo tx" $ do
          let t =
                ZcashTx
                  "someId"
                  0.5
                  50000000
                  1602000
                  18732456
                  False
                  20
                  "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
          zToZGoTx t `shouldBe`
            ZGoTx
              Nothing
              "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
              "5d3d4494-51c0-432d-8495-050419957aea"
              20
              18732456
              0.5
              "someId"
              "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
      describe "PIN generator" $ do
        it "should give a 7 digit" $ do
          length (T.unpack (unsafePerformIO generatePin)) `shouldBe` 7
    describe "API endpoints" $ do
      beforeAll_ (startAPI dbName passkey nodeAddress nodeUser nodePwd) $ 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
          it "returns a block number" $ do
            req <- testGet "/api/blockheight" []
            res <- httpJSON req
            height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x ->
              x > 1600000
        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" $ do
            req <-
              testGet
                "/api/owner"
                [ ( "address"
                  , Just
                      "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e")
                ]
            res <- httpJSON req
            getResponseStatus (res :: Response A.Value) `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` unprocessableEntity422
          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 "Zcash transactions" $ do
          it "logins are added to db" $ \p -> do
            _ <-
              access p master "test" (Database.MongoDB.delete (select [] "txs"))
            _ <- scanZcash nodeAddress p "test" nodeUser nodePwd
            threadDelay 1000000
            t <- access p master "test" $ findOne (select [] "txs")
            let s = parseZGoTxBson =<< t
            let conf = maybe 0 confirmations s
            conf `shouldSatisfy` (> 0)
          it "payments are added to db" $ \p -> do
            _ <-
              access
                p
                master
                "test"
                (Database.MongoDB.delete (select [] "payments"))
            _ <- scanZcash nodeAddress p "test" nodeUser nodePwd
            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"
          it "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` []
          it "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 nodeUser nodePwd nodeAddress p "test"
            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
    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 ::
     T.Text -> SecureMem -> T.Text -> B.ByteString -> B.ByteString -> IO ()
startAPI db passkey nodeAddress nodeUser nodePwd = do
  putStrLn "Starting test server ..."
  pipe <- connect $ host "127.0.0.1"
  c <- access pipe master "zgo" (auth "zgo" "zcashrules")
  let appRoutes = routes pipe db passkey nodeAddress nodeUser nodePwd
  _ <- 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))
  _ <- 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
    ZGoOrder i a s ts c cur p t tZ l <$> 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
    Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv <$> arbitrary

instance Arbitrary Item where
  arbitrary = do
    i <- arbitrary
    n <- arbitrary
    d <- arbitrary
    o <- arbitrary
    Item i n d o <$> arbitrary