Vergara_Tech/zgo-backend
Vergara_Tech/zgo-backend
2
1
Fork 0
Code Issues Pull requests Projects Releases 4 Packages Wiki Activity

Merge branch 'hotfix-a1'

Browse source
This commit is contained in:
Rene Vergara 2023-05-15 09:51:32 -05:00
commit a8d4329e7d
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
11 changed files with 549 additions and 111 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
CHANGELOG.md
View file

@ -4,6 +4,22 @@ All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
## [1.5.0]
### Added
- `isUserValid` function
- New middleware to validated requests come from an existing user
- New endpoint for the language data of the login page
- New `OwnerData` to represent informational values
- New `OwnerSettings` to abstract configuration settings for owners
### Changed
- Modified API tests to use `session` parameter.
- Modified `api/owner` endpoint to use a specific data structure to create new owners
- Modified `api/owner` endpoint to use session as input
## [1.4.1] - 2023-05-02
### Fixed

2
package.yaml
View file

@ -1,5 +1,5 @@
name: zgo-backend
version: 1.4.1
version: 1.5.0
git: "https://git.vergara.tech/Vergara_Tech/zgo-backend"
license: BOSL
author: "Rene Vergara"

131
src/Owner.hs
View file

@ -275,6 +275,120 @@ instance Val Owner where
, "crmToken" =: cT
]
-- | Type to represent informational data for Owners from UI
data OwnerData =
OwnerData
{ od_first :: T.Text
, od_last :: T.Text
, od_name :: T.Text
, od_street :: T.Text
, od_city :: T.Text
, od_state :: T.Text
, od_postal :: T.Text
, od_country :: T.Text
, od_email :: T.Text
, od_website :: T.Text
, od_phone :: T.Text
}
deriving (Eq, Show, Generic)
instance FromJSON OwnerData where
parseJSON =
withObject "OwnerData" $ \obj -> do
f <- obj .: "first"
l <- obj .: "last"
n <- obj .: "name"
s <- obj .: "street"
c <- obj .: "city"
st <- obj .: "state"
p <- obj .: "postal"
co <- obj .: "country"
e <- obj .: "email"
w <- obj .: "website"
ph <- obj .: "phone"
pure $ OwnerData f l n s c st p co e w ph
data OwnerSettings =
OwnerSettings
{ os_id :: Maybe ObjectId
, os_address :: T.Text
, os_name :: T.Text
, os_currency :: T.Text
, os_tax :: Bool
, os_taxValue :: Double
, os_vat :: Bool
, os_vatValue :: Double
, os_paid :: Bool
, os_zats :: Bool
, os_invoices :: Bool
, os_expiration :: UTCTime
, os_payconf :: Bool
, os_crmToken :: T.Text
, os_viewKey :: T.Text
}
deriving (Eq, Show, Generic)
instance FromJSON OwnerSettings where
parseJSON =
withObject "OwnerSettings" $ \obj -> do
i <- obj .:? "_id"
a <- obj .: "address"
n <- obj .: "name"
c <- obj .: "currency"
t <- obj .: "tax"
tV <- obj .: "taxValue"
v <- obj .: "vat"
vV <- obj .: "vatValue"
p <- obj .: "paid"
z <- obj .: "zats"
inv <- obj .: "invoices"
e <- obj .: "expiration"
pc <- obj .: "payconf"
cT <- obj .: "crmToken"
vK <- obj .: "viewkey"
pure $
OwnerSettings ((Just . read) =<< i) a n c t tV v vV p z inv e pc cT vK
instance ToJSON OwnerSettings where
toJSON (OwnerSettings i a n c t tV v vV p z inv e pc cT vK) =
object
[ "_id" .= maybe "" show i
, "address" .= a
, "name" .= n
, "currency" .= c
, "tax" .= t
, "taxValue" .= tV
, "vat" .= v
, "vatValue" .= vV
, "paid" .= p
, "zats" .= z
, "invoices" .= inv
, "expiration" .= e
, "payconf" .= pc
, "crmToken" .= cT
, "viewkey" .= (T.take 8 vK <> "...." <> T.takeEnd 8 vK)
]
-- Helper Functions
getOwnerSettings :: Owner -> OwnerSettings
getOwnerSettings o =
OwnerSettings
(o_id o)
(oaddress o)
(oname o)
(ocurrency o)
(otax o)
(otaxValue o)
(ovat o)
(ovatValue o)
(opaid o)
(ozats o)
(oinvoices o)
(oexpiration o)
(opayconf o)
(ocrmToken o)
(oviewkey o)
-- Database actions
-- | Function to upsert an Owner
upsertOwner :: Owner -> Action IO ()
@ -306,6 +420,23 @@ removePro :: T.Text -> Action IO ()
removePro o =
modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
updateOwnerSettings :: OwnerSettings -> Action IO ()
updateOwnerSettings os =
modify
(select ["_id" =: os_id os] "owners")
[ "$set" =:
[ "name" =: os_name os
, "currency" =: os_currency os
, "tax" =: os_tax os
, "taxValue" =: os_taxValue os
, "vat" =: os_vat os
, "vatValue" =: os_vatValue os
, "zats" =: os_zats os
, "payconf" =: os_payconf os
, "crmToken" =: os_crmToken os
]
]
-- | Type for a pro session
data ZGoProSession =
ZGoProSession

18
src/User.hs
View file

@ -94,6 +94,16 @@ isUserNew p db tx =
isNothing <$>
access p master db (findOne (select ["session" =: session tx] "users"))
-- | Function to verify if the given session has a valid user
isUserValid :: Pipe -> T.Text -> T.Text -> IO Bool
isUserValid p db s =
isJust <$>
access
p
master
db
(findOne (select ["session" =: s, "validated" =: True] "users"))
-- | Function to mark user as validated
validateUser :: T.Text -> Action IO ()
validateUser session =
@ -106,11 +116,3 @@ generatePin = do
rngState <- newCryptoRNGState
runCryptoRNGT rngState $
randomString 7 ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
-- | Helper function to pad a string to a given length
padLeft :: String -> Char -> Int -> String
padLeft s c m =
let isBaseLarger = length s > m
padder st ch m False = [ch | _ <- [1 .. (m - length st)]] ++ s
padder st _ _ True = st
in padder s c m isBaseLarger

3
src/Xero.hs
View file

@ -30,8 +30,7 @@ data Xero =
deriving (Eq, Show)
instance ToJSON Xero where
toJSON (Xero i cI s) =
object ["_id" .= show i, "clientId" .= cI, "clientSecret" .= s]
toJSON (Xero i cI s) = object ["_id" .= show i, "clientId" .= cI]
instance Val Xero where
val (Xero i cI s) = Doc ["_id" =: i, "clientId" =: cI, "clientSecret" =: s]

193
src/ZGoBackend.hs
View file

@ -44,7 +44,7 @@ import Item
import LangComponent
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.Wai (Request, pathInfo)
import Network.Wai (Application, Middleware, Request(..), pathInfo, responseLBS)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.HttpAuth
import Numeric
@ -376,7 +376,7 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
if m_payment zM'
then upsertPayment pipe (c_dbName config) tx
else access pipe master (c_dbName config) $ upsertZGoTx "txs" tx
Left e -> error "Failed to parse ZGo memo"
Left e -> print $ "Failed to parse ZGo memo: " ++ show e
-- |Type to model a price in the ZGo database
data ZGoPrice =
@ -545,6 +545,32 @@ needsAuth req =
"api":_ -> True
_ -> False
zgoAuth :: Pipe -> T.Text -> Middleware
zgoAuth pipe dbName app req respond = do
let q = filter findSessionParam $ queryString req
isFenced <- needsAuth req
if isFenced
then do
if length q == 1
then do
isOk <- checkSession pipe dbName $ head q
if isOk
then app req respond
else respond $
responseLBS unauthorized401 [] "ZGo API access denied!"
else respond $ responseLBS unauthorized401 [] "ZGo API access denied!"
else app req respond
where
findSessionParam :: QueryItem -> Bool
findSessionParam (i, val) = i == "session"
checkSession ::
Pipe -> T.Text -> (BS.ByteString, Maybe BS.ByteString) -> IO Bool
checkSession p db (k, v) =
case v of
Just sessionId ->
isUserValid p db $ E.decodeUtf8With lenientDecode sessionId
Nothing -> return False
-- | Main API routes
routes :: Pipe -> Config -> ScottyM ()
routes pipe config = do
@ -566,6 +592,7 @@ routes pipe config = do
basicAuth
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
authSettings
middleware $ zgoAuth pipe $ c_dbName config
--Get list of countries for UI
get "/api/countries" $ do
countries <- liftAndCatchIO $ run listCountries
@ -817,20 +844,29 @@ routes pipe config = do
status accepted202
Web.Scotty.json
(object ["message" .= ("Incorrect plugin config" :: String)])
get "/checkuser" $ do
sess <- param "session"
user <- liftAndCatchIO $ run (findUser sess)
case parseUserBson =<< user of
Nothing -> status noContent204
Just u -> do
status ok200
Web.Scotty.json (object ["validated" .= uvalidated u])
--Get user associated with session
get "/api/user" $ do
sess <- param "session"
user <- liftAndCatchIO $ run (findUser sess)
case user of
Nothing -> status noContent204
Just u ->
Just u -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("User found" :: String)
, "user" .= toJSON (parseUserBson u)
])
--Validate user, updating record
post "/api/validateuser" $ do
post "/validateuser" $ do
providedPin <- param "pin"
sess <- param "session"
let pinHash =
@ -864,7 +900,7 @@ routes pipe config = do
status ok200
else status noContent204
--Get current blockheight from Zcash node
get "/api/blockheight" $ do
get "/blockheight" $ do
blockInfo <-
liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"]
let content = getResponseBody blockInfo :: RpcResponse Block
@ -875,23 +911,23 @@ routes pipe config = do
else do
status internalServerError500
--Get the ZGo node's shielded address
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
--Get owner by address
get "/api/owner" $ do
addr <- param "address"
owner <- liftAndCatchIO $ run (findOwner addr)
case owner of
session <- param "session"
user <- liftAndCatchIO $ run (findUser session)
case parseUserBson =<< user of
Nothing -> status noContent204
Just u -> do
owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
case cast' . Doc =<< owner of
Nothing -> status noContent204
Just o -> do
let pOwner = cast' (Doc o)
case pOwner of
Nothing -> status internalServerError500
Just q -> do
status ok200
Web.Scotty.json
(object
[ "message" .= ("Owner found!" :: String)
, "owner" .= toJSON (q :: Owner)
, "owner" .= getOwnerSettings o
])
get "/api/ownerid" $ do
id <- param "id"
@ -907,37 +943,78 @@ routes pipe config = do
Web.Scotty.json
(object
[ "message" .= ("Owner found!" :: String)
, "owner" .= toJSON (q :: Owner)
, "owner" .=
object
[ "_id" .= (maybe "" show $ o_id q :: String)
, "address" .= oaddress q
, "name" .= oname q
, "currency" .= ocurrency q
, "tax" .= otax q
, "taxValue" .= otaxValue q
, "vat" .= ovat q
, "vatValue" .= ovatValue q
, "paid" .= opaid q
, "zats" .= ozats q
, "invoices" .= oinvoices q
, "expiration" .= oexpiration q
, "payconf" .= opayconf q
, "crmToken" .= ocrmToken q
]
])
--Upsert owner to DB
post "/api/owner" $ do
s <- param "session"
u <- liftAndCatchIO $ run (findUser s)
o <- jsonData
let q = payload (o :: Payload Owner)
if not (opayconf q)
then do
_ <- liftAndCatchIO $ run (upsertOwner q)
status created201
else do
known <- liftAndCatchIO $ listAddresses nodeUser nodePwd
if oaddress q `elem` map addy known
then do
_ <- liftAndCatchIO $ run (upsertOwner q)
status created201
else do
vkInfo <-
now <- liftIO getCurrentTime
let q = payload (o :: Payload OwnerData)
case parseUserBson =<< u of
Nothing -> status internalServerError500
Just u' -> do
liftAndCatchIO $
makeZcashCall
nodeUser
nodePwd
"z_importviewingkey"
[Data.Aeson.String (T.strip (oviewkey q)), "no"]
let content = getResponseBody vkInfo :: RpcResponse Object
if isNothing (err content)
run $
upsertOwner $
Owner
Nothing
(uaddress u')
(od_name q)
"usd"
False
0
False
0
(od_first q)
(od_last q)
(od_email q)
(od_street q)
(od_city q)
(od_state q)
(od_postal q)
(od_phone q)
(od_website q)
(od_country q)
False
False
False
now
False
""
""
status accepted202
post "/api/ownersettings" $ do
s <- param "session"
u <- liftAndCatchIO $ run (findUser s)
o <- jsonData
now <- liftIO getCurrentTime
let q = payload (o :: Payload OwnerSettings)
case parseUserBson =<< u of
Nothing -> status internalServerError500
Just u' -> do
if os_address q == uaddress u'
then do
_ <- liftAndCatchIO $ run (upsertOwner q)
status created201
else do
status internalServerError500
liftAndCatchIO $ run $ updateOwnerSettings q
status accepted202
else status noContent204
--Get items associated with the given address
get "/api/items" $ do
addr <- param "address"
@ -966,7 +1043,7 @@ routes pipe config = do
status ok200
else status noContent204
--Get price for Zcash
get "/api/price" $ do
get "/price" $ do
curr <- param "currency"
pr <- liftAndCatchIO $ run (findPrice curr)
case pr of
@ -1063,6 +1140,30 @@ routes pipe config = do
liftAndCatchIO $ run (deleteOrder oId)
status ok200
-- Get language for component
get "/getmainlang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "main")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/getscanlang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "scan")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/getloginlang" $ do
lang <- param "lang"
txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login")
case cast' . Doc =<< txtPack' of
Nothing -> status noContent204
Just textPack -> do
status ok200
Web.Scotty.json $ toJSON (textPack :: LangComponent)
get "/api/getlang" $ do
component <- param "component"
lang <- param "lang"
@ -1073,12 +1174,12 @@ routes pipe config = do
Just tP -> do
status ok200
Web.Scotty.json $ toJSON (tP :: LangComponent)
post "/api/setlang" $ do
langComp <- jsonData
_ <-
liftAndCatchIO $
mapM (run . loadLangComponent) (langComp :: [LangComponent])
status created201
{-post "/api/setlang" $ do-}
{-langComp <- jsonData-}
{-_ <--}
{-liftAndCatchIO $-}
{-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
{-status created201-}
-- | Make a Zcash RPC call
makeZcashCall ::

5
src/ZGoTx.hs
View file

@ -119,6 +119,7 @@ type Parser = Parsec Void T.Text
pSession :: Parser MemoToken
pSession = do
optional spaceChar
string "ZGO"
pay <- optional $ char 'p'
string "::"
@ -142,9 +143,7 @@ pSaplingAddress = do
pMsg :: Parser MemoToken
pMsg = do
Msg . T.pack <$>
some
(alphaNumChar <|> punctuationChar <|> symbolChar <|>
charCategory OtherSymbol)
some (alphaNumChar <|> punctuationChar <|> charCategory OtherSymbol)
pMemo :: Parser MemoToken
pMemo = do

2
stack.yaml
View file

@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-20.17
resolver: lts-20.19
#url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
# User packages to be built.

8
stack.yaml.lock
View file

@ -31,7 +31,7 @@ packages:
hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
snapshots:
- completed:
sha256: 14ca51a9a597c32dd7804c10d079feea3d0ae40c5fbbb346cbd67b3ae49f6d01
size: 649598
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/17.yaml
original: lts-20.17
sha256: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64
size: 649618
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/19.yaml
original: lts-20.19

266
test/Spec.hs
View file

@ -144,35 +144,99 @@ main = do
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" [("currency", Just "usd")]
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" [("currency", Just "jpy")]
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" []
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" []
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 config endpoint" $ do
it "returns the config" $ do
req <- testGet "/api/xero" []
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" [("address", Just "Zaddy")]
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 <-
@ -181,28 +245,24 @@ main = do
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpJSON req
getResponseStatus (res :: Response A.Value) `shouldBe` ok200
it "returns 204 when no user" $ do
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` 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
getResponseStatus res `shouldBe` unauthorized401
it "deletes user by id" $ do
req <- testDelete "/api/user/" "6272a90f2b05a74cf1000001"
req <-
testDelete
"/api/user/"
"6272a90f2b05a74cf1000003"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Owner endpoint" $ do
prop "add owner" testOwnerAdd
describe "Owner endpoint" $
--prop "add owner" testOwnerAdd
do
it "return owner by address" $ do
req <-
testGet
@ -210,15 +270,31 @@ main = do
[ ( "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")]
testGet
"/api/ownerid"
[ ("id", Just "627ad3492b05a76be3000001")
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "Order endpoint" $ do
describe "Order endpoints" $ do
prop "upsert order" testOrderAdd
it "get order by session" $ do
req <-
@ -227,30 +303,85 @@ main = do
[("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" []
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" []
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")]
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"
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")]
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"
req <-
testDelete
"/api/item/"
"627d7ba92b05a76be3000003"
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
res <- httpLBS req
getResponseStatus res `shouldBe` ok200
describe "WooCommerce endpoints" $ do
@ -258,7 +389,9 @@ main = do
req <-
testPost
"/api/wootoken"
[("ownerid", Just "627ad3492b05a76be3000001")]
[ ("ownerid", Just "627ad3492b05a76be3000001")
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
]
res <- httpLBS req
getResponseStatus res `shouldBe` accepted202
it "authenticate with incorrect owner" $ do
@ -329,21 +462,40 @@ main = do
req <-
testGet
"/api/getlang"
[("lang", Just "en-US"), ("component", Just "login")]
[ ("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")]
[ ("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")]
[ ("lang", Just "fr-FR")
, ("component", Just "login")
, ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
]
res <- httpLBS req
getResponseStatus res `shouldBe` noContent204
around handleDb $
@ -632,11 +784,16 @@ testPostJson endpoint body = do
setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
return testRequest
testDelete :: B.ByteString -> B.ByteString -> IO Request
testDelete endpoint par = do
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" $
@ -658,14 +815,22 @@ testOrderAdd o =
monadicIO $ do
req <-
run $ testPostJson "/api/order" (A.object ["payload" A..= A.toJSON o])
res <- httpLBS req
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 req
res <-
httpLBS $
setRequestQueryString
[("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
req
assert $ getResponseStatus res == created201
-- | Open the MongoDB connection
@ -692,6 +857,9 @@ startAPI config = do
_ <- 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))
@ -714,6 +882,28 @@ startAPI config = do
, "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"))

2
zgo-backend.cabal
View file

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: zgo-backend
version: 1.4.1
version: 1.5.0
synopsis: Haskell Back-end for the ZGo point-of-sale application
description: Please see the README at <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
category: Web