diff --git a/package.yaml b/package.yaml index 8933323..9e0ee60 100644 --- a/package.yaml +++ b/package.yaml @@ -98,3 +98,5 @@ tests: - hspec-wai - securemem - time + - configurator + - scotty diff --git a/src/Order.hs b/src/Order.hs index dbde3b0..986ac0e 100644 --- a/src/Order.hs +++ b/src/Order.hs @@ -26,11 +26,12 @@ data ZGoOrder = , qtotal :: Double , qtotalZec :: Double , qlines :: [LineItem] + , qpaid :: Bool } deriving (Eq, Show, Generic) instance ToJSON ZGoOrder where - toJSON (ZGoOrder i a s ts c cur p t tZ l) = + toJSON (ZGoOrder i a s ts c cur p t tZ l paid) = case i of Just oid -> object @@ -44,6 +45,7 @@ instance ToJSON ZGoOrder where , "total" .= t , "totalZec" .= tZ , "lines" .= l + , "paid" .= paid ] Nothing -> object @@ -57,6 +59,7 @@ instance ToJSON ZGoOrder where , "total" .= t , "totalZec" .= tZ , "lines" .= l + , "paid" .= paid ] instance FromJSON ZGoOrder where @@ -72,6 +75,7 @@ instance FromJSON ZGoOrder where t <- obj .: "total" tZ <- obj .: "totalZec" l <- obj .: "lines" + pd <- obj .: "paid" pure $ ZGoOrder (if not (null i) @@ -86,9 +90,10 @@ instance FromJSON ZGoOrder where t tZ l + pd instance Val ZGoOrder where - val (ZGoOrder i a s ts c cur p t tZ l) = + val (ZGoOrder i a s ts c cur p t tZ l pd) = if isJust i then Doc [ "_id" =: i @@ -101,6 +106,7 @@ instance Val ZGoOrder where , "total" =: t , "totalZec" =: tZ , "lines" =: l + , "paid" =: pd ] else Doc [ "address" =: a @@ -112,6 +118,7 @@ instance Val ZGoOrder where , "total" =: t , "totalZec" =: tZ , "lines" =: l + , "paid" =: pd ] cast' (Doc d) = do i <- B.lookup "_id" d @@ -124,7 +131,8 @@ instance Val ZGoOrder where t <- B.lookup "total" d tZ <- B.lookup "totalZec" d l <- B.lookup "lines" d - Just (ZGoOrder i a s ts c cur p t tZ l) + pd <- B.lookup "paid" d + Just (ZGoOrder i a s ts c cur p t tZ l pd) cast' _ = Nothing -- Type to represent an order line item @@ -159,7 +167,7 @@ instance Val LineItem where -- Database actions upsertOrder :: ZGoOrder -> Action IO () upsertOrder o = do - let order = val o + let order = val $ updateOrderTotals o case order of Doc d -> if isJust (q_id o) @@ -167,6 +175,29 @@ upsertOrder o = do else insert_ "orders" d _ -> return () +-- | Function to update order totals from items +updateOrderTotals :: ZGoOrder -> ZGoOrder +updateOrderTotals o = + ZGoOrder + (q_id o) + (qaddress o) + (qsession o) + (qtimestamp o) + (qclosed o) + (qcurrency o) + (qprice o) + (newTotal o) + (if qprice o /= 0 + then newTotal o / qprice o + else 0) + (qlines o) + (qpaid o) + where + newTotal :: ZGoOrder -> Double + newTotal x = foldr tallyItems 0 (qlines x) + tallyItems :: LineItem -> Double -> Double + tallyItems y z = (lqty y * lcost y) + z + findOrder :: T.Text -> Action IO (Maybe Document) findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders") diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 9ab70c0..633652a 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -255,7 +255,7 @@ sendPin :: -> T.Text -> Action IO String sendPin nodeUser nodePwd nodeAddress addr pin = do - let payload = + let pd = [ Data.Aeson.String nodeAddress , Data.Aeson.Array (V.fromList @@ -266,7 +266,7 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do ] ]) ] - r <- makeZcashCall nodeUser nodePwd "z_sendmany" payload + r <- makeZcashCall nodeUser nodePwd "z_sendmany" pd let sCode = getResponseStatus (r :: Response Object) if sCode == ok200 then return "Pin sent!" @@ -344,7 +344,7 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do simpleCorsResourcePolicy { corsRequestHeaders = ["Authorization", "Content-Type"] , corsMethods = "DELETE" : simpleMethods - , corsOrigins = Nothing + --, corsOrigins = Nothing } middleware $ basicAuth @@ -395,32 +395,19 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do --Delete user Web.Scotty.delete "/api/user/:id" $ do userId <- param "id" - liftIO $ run (deleteUser userId) - status ok200 - --Get txs from DB that have less than 10 confirmations - {-get "/api/pending" $ do-} - {-sess <- param "session"-} - {-pending <- liftIO $ run (findPending sess)-} - {-case pending of-} - {-[] -> do-} - {-status noContent204-} - {-_ -> do-} - {-Web.Scotty.json-} - {-(object-} - {-[ "message" .= ("Found pending transactions" :: String)-} - {-, "txs" .= toJSON (map parseZGoTxBson pending)-} - {-])-} - --Get current blockheight from Zcash node + let r = mkRegex "^[a-f0-9]{24}$" + if matchTest r userId + then do + liftIO $ run (deleteUser userId) + status ok200 + else status unprocessableEntity422 + --Get current blockheight from Zcash node get "/api/blockheight" $ do blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"] Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block)) - --Get transactions associated with ZGo node - --get "/api/txs" $ do - --txs <- makeZcashCall "z_listreceivedbyaddress" [nodeAddress] - --Web.Scotty.json (result (getResponseBody txs :: RpcResponse [ZcashTx])) - --Get the ZGo node's shielded address + --Get the ZGo node's shielded address get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) - --Get owner by address + --Get owner by address get "/api/owner" $ do addr <- param "address" owner <- liftIO $ run (findOwner addr) @@ -437,7 +424,7 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do [ "message" .= ("Owner found!" :: String) , "owner" .= toJSON (q :: Owner) ]) - --Upsert owner to DB + --Upsert owner to DB post "/api/owner" $ do o <- jsonData let q = payload (o :: Payload Owner) @@ -464,8 +451,12 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do --Delete item Web.Scotty.delete "/api/item/:id" $ do oId <- param "id" - liftIO $ run (deleteItem oId) - status ok200 + let r = mkRegex "^[a-f0-9]{24}$" + if matchTest r oId + then do + liftIO $ run (deleteItem oId) + status ok200 + else status unprocessableEntity422 --Get price for Zcash get "/api/price" $ do curr <- param "currency" @@ -473,7 +464,6 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do case pr of Nothing -> do status noContent204 - --Web.Scotty.json (object ["message" .= ("No price" :: T.Text)]) Just p -> do Web.Scotty.json (object @@ -497,20 +487,24 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do --Get order by id for receipts get "/api/order/:id" $ do oId <- param "id" - myOrder <- liftIO $ run (findOrderById oId) - case myOrder of - Nothing -> status noContent204 - Just o -> do - let o' = cast' (Doc o) - case o' of - Nothing -> status internalServerError500 - Just pOrder -> do - status ok200 - Web.Scotty.json - (object - [ "message" .= ("Order found!" :: String) - , "order" .= toJSON (pOrder :: ZGoOrder) - ]) + let r = mkRegex "^[a-f0-9]{24}$" + if matchTest r oId + then do + myOrder <- liftIO $ run (findOrderById oId) + case myOrder of + Nothing -> status noContent204 + Just o -> do + let o' = cast' (Doc o) + case o' of + Nothing -> status internalServerError500 + Just pOrder -> do + status ok200 + Web.Scotty.json + (object + [ "message" .= ("Order found!" :: String) + , "order" .= toJSON (pOrder :: ZGoOrder) + ]) + else status unprocessableEntity422 --Get order by session get "/api/order" $ do sess <- param "session" diff --git a/test/Spec.hs b/test/Spec.hs index b586d96..87c7470 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,6 +8,7 @@ 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 @@ -15,6 +16,7 @@ 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 @@ -30,24 +32,19 @@ import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Monadic import User +import Web.Scotty import ZGoBackend import ZGoTx -passkey :: SecureMem -passkey = secureMemFromByteString "superSecret" - -nodeAddress :: T.Text -nodeAddress = - "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy" - -dbUser :: T.Text -dbUser = "zgo" - -dbPassword :: T.Text -dbPassword = "zcashrules" - main :: IO () -main = +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 @@ -84,7 +81,7 @@ main = it "should give a 7 digit" $ do length (T.unpack (unsafePerformIO generatePin)) `shouldBe` 7 describe "API endpoints" $ do - beforeAll_ startAPI $ 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")] @@ -158,6 +155,10 @@ main = 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 @@ -239,16 +240,22 @@ main = isNothing q `shouldBe` True describe "Zcash transactions" $ do it "logins are added to db" $ \p -> do - _ <- access p master "test" (delete (select [] "txs")) - _ <- scanZcash nodeAddress p "test" + _ <- + 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" (delete (select [] "payments")) - _ <- scanZcash nodeAddress p "test" + _ <- + 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 @@ -277,6 +284,7 @@ main = , "pin" =: upin myUser , "validated" =: uvalidated myUser ]) + tstamp <- getCurrentTime let myPay = Payment Nothing @@ -284,7 +292,7 @@ main = False "" "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb" - 1652811930 + ((round . utcTimeToPOSIXSeconds) tstamp) 0.005 "myrandom123tx464id" "coolest memo ever!" @@ -331,9 +339,14 @@ main = 0.00000001 "abcdef" "Super Memo" - _ <- access p master "test" (delete (select [] "users")) + _ <- + access + p + master + "test" + (Database.MongoDB.delete (select [] "users")) _ <- access p master "test" (insert_ "txs" (encodeZGoTxBson myTx)) - _ <- updateLogins nodeAddress p "test" + _ <- updateLogins nodeUser nodePwd nodeAddress p "test" threadDelay 1000000 t <- access p master "test" $ findOne (select [] "users") case t of @@ -399,14 +412,15 @@ testOwnerAdd o = testOrderAdd :: ZGoOrder -> Property testOrderAdd o = monadicIO $ do - req <- run $ testPostJson "/api/order" (A.toJSON o) + 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.toJSON i) + req <- run $ testPostJson "/api/item" (A.object ["payload" A..= A.toJSON i]) res <- httpLBS req assert $ getResponseStatus res == created201 @@ -425,12 +439,14 @@ closeDbConnection = close handleDb :: (Pipe -> Expectation) -> IO () handleDb = bracket openDbConnection closeDbConnection -startAPI :: IO () -startAPI = do +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") - _ <- forkIO (app pipe "test" passkey nodeAddress) + let appRoutes = routes pipe db passkey nodeAddress nodeUser nodePwd + _ <- forkIO (scotty 3000 appRoutes) let myUser = User (Just (read "6272a90f2b05a74cf1000001" :: ObjectId)) @@ -477,11 +493,11 @@ startAPI = do False False (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0)) - _ <- access pipe master "test" (delete (select [] "owners")) + _ <- 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" (delete (select [] "orders")) + _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders")) myTs <- liftIO getCurrentTime let myOrder = ZGoOrder @@ -495,6 +511,7 @@ startAPI = do 0 0 [] + False let ordTest = val myOrder case ordTest of Doc oT -> access pipe master "test" (insert_ "orders" oT) @@ -523,14 +540,14 @@ instance Arbitrary ZGoOrder where p <- arbitrary t <- arbitrary tZ <- arbitrary - ZGoOrder i a s ts c cur p t 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 - n <- arbitrary - LineItem i q n <$> arbitrary + LineItem i q <$> arbitrary instance Arbitrary ObjectId where arbitrary = do diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 9f2aa65..46414d7 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -100,12 +100,14 @@ test-suite zgo-backend-test , aeson , base >=4.7 && <5 , bytestring + , configurator , hspec , hspec-expectations-json , hspec-wai , http-conduit , http-types , mongoDB + , scotty , securemem , text , time