Fix #1
This commit is contained in:
parent
0934aa17bc
commit
31c11aafe7
GPG key ID:
65122AD495A7F5B2
5 changed files with 125 additions and 79 deletions
|
|
@ -98,3 +98,5 @@ tests:
|
|||
- hspec-wai
|
||||
- securemem
|
||||
- time
|
||||
- configurator
|
||||
- scotty
|
||||
|
|
|
|||
39
src/Order.hs
39
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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
81
test/Spec.hs
81
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue