Merge branch 'hotfix-a1'

CHANGELOG.md

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

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/Owner.hs

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

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/Xero.hs

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

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
@@ -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 o -> do
-        let pOwner = cast' (Doc o)
-        case pOwner of
-          Nothing -> status internalServerError500
-          Just q -> do
+      Just u -> do
+        owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
+        case cast' . Doc =<< owner of
+          Nothing -> status noContent204
+          Just o -> 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
+    now <- liftIO getCurrentTime
+    let q = payload (o :: Payload OwnerData)
+    case parseUserBson =<< u of
+      Nothing -> status internalServerError500
+      Just u' -> do
+        liftAndCatchIO $
+          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
-            vkInfo <-
-              liftAndCatchIO $
-              makeZcashCall
-                nodeUser
-                nodePwd
-                "z_importviewingkey"
-                [Data.Aeson.String (T.strip (oviewkey q)), "no"]
-            let content = getResponseBody vkInfo :: RpcResponse Object
-            if isNothing (err content)
-              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 ::

src/ZGoTx.hs

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

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

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

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