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

Implement API server access control

This commit is contained in:
Rene Vergara 2023-05-08 11:21:09 -05:00
parent 855dba666b
commit cbc4e02766
Signed by: pitmutt
GPG Key ID: 65122AD495A7F5B2
8 changed files with 296 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
CHANGELOG.md
View File

@ -4,6 +4,17 @@ 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
### Changed
- Modified API tests to use `session` parameter.
## [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"

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

43
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
@ -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
@ -830,7 +857,7 @@ routes pipe config = do
, "user" .= toJSON (parseUserBson u)
])
--Validate user, updating record
post "/api/validateuser" $ do
post "/validateuser" $ do
providedPin <- param "pin"
sess <- param "session"
let pinHash =
@ -1073,12 +1100,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 ::

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

276
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" []
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 "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"
[ ("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