Implement API server access control

CHANGELOG.md

@@ -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

package.yaml

@@ -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"

src/User.hs

@@ -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

src/ZGoBackend.hs

@@ -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
+  {-post "/api/setlang" $ do-}
-    langComp <- jsonData
+    {-langComp <- jsonData-}
-    _ <-
+    {-_ <--}
-      liftAndCatchIO $
+      {-liftAndCatchIO $-}
-      mapM (run . loadLangComponent) (langComp :: [LangComponent])
+      {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-}
-    status created201
+    {-status created201-}
 
 -- | Make a Zcash RPC call
 makeZcashCall ::

stack.yaml

@@ -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.

stack.yaml.lock

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

test/Spec.hs

@@ -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
+        describe "Xero endpoints" $ do
-          it "returns the config" $ do
+          describe "xero" $ do
-            req <- testGet "/api/xero" []
+            it "returns the xero config" $ do
-            res <- httpJSON req
+              req <-
-            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+                testGet
-          it "returns the account code" $ do
+                  "/api/xero"
-            req <- testGet "/api/xeroaccount" [("address", Just "Zaddy")]
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
-            res <- httpJSON req
+              res <- httpJSON req
-            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+              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
+            getResponseStatus res `shouldBe` unauthorized401
-          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"
+            req <-
+              testDelete
+                "/api/user/"
+                "6272a90f2b05a74cf1000003"
+                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` ok200
-        describe "Owner endpoint" $ do
+        describe "Owner endpoint" $
-          prop "add owner" testOwnerAdd
+          --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 ::
-testDelete endpoint par = do
+     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"))

zgo-backend.cabal

@@ -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