CHANGELOG.md

@@ -4,22 +4,6 @@ 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.5.0
+version:             1.4.1
 git:                 "https://git.vergara.tech/Vergara_Tech/zgo-backend"
 license:             BOSL
 author:              "Rene Vergara"

src/Owner.hs

@@ -275,120 +275,6 @@ 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 ()
@@ -420,23 +306,6 @@ 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,16 +94,6 @@ 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 =
@@ -116,3 +106,11 @@ 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,7 +30,8 @@ data Xero =
   deriving (Eq, Show)
 
 instance ToJSON Xero where
-  toJSON (Xero i cI s) = object ["_id" .= show i, "clientId" .= cI]
+  toJSON (Xero i cI s) =
+    object ["_id" .= show i, "clientId" .= cI, "clientSecret" .= s]
 
 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 (Application, Middleware, Request(..), pathInfo, responseLBS)
+import Network.Wai (Request, pathInfo)
 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 -> print $ "Failed to parse ZGo memo: " ++ show e
+      Left e -> error "Failed to parse ZGo memo"
 
 -- |Type to model a price in the ZGo database
 data ZGoPrice =
@@ -545,32 +545,6 @@ 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
@@ -592,7 +566,6 @@ 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
@@ -844,29 +817,20 @@ 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 -> do
-        status ok200
+      Just u ->
         Web.Scotty.json
           (object
              [ "message" .= ("User found" :: String)
              , "user" .= toJSON (parseUserBson u)
              ])
     --Validate user, updating record
-  post "/validateuser" $ do
+  post "/api/validateuser" $ do
     providedPin <- param "pin"
     sess <- param "session"
     let pinHash =
@@ -900,7 +864,7 @@ routes pipe config = do
         status ok200
       else status noContent204
   --Get current blockheight from Zcash node
-  get "/blockheight" $ do
+  get "/api/blockheight" $ do
     blockInfo <-
       liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"]
     let content = getResponseBody blockInfo :: RpcResponse Block
@@ -911,23 +875,23 @@ routes pipe config = do
       else do
         status internalServerError500
   --Get the ZGo node's shielded address
-  get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
+  get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
   --Get owner by address
   get "/api/owner" $ do
-    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
+    addr <- param "address"
+    owner <- liftAndCatchIO $ run (findOwner addr)
+    case 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" .= getOwnerSettings o
+                 , "owner" .= toJSON (q :: Owner)
                  ])
   get "/api/ownerid" $ do
     id <- param "id"
@@ -943,78 +907,37 @@ routes pipe config = do
             Web.Scotty.json
               (object
                  [ "message" .= ("Owner found!" :: String)
-                 , "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
-                     ]
+                 , "owner" .= toJSON (q :: Owner)
                  ])
   --Upsert owner to DB
   post "/api/owner" $ do
-    s <- param "session"
-    u <- liftAndCatchIO $ run (findUser s)
     o <- jsonData
-    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'
+    let q = payload (o :: Payload Owner)
+    if not (opayconf q)
       then do
-            liftAndCatchIO $ run $ updateOwnerSettings q
-            status accepted202
-          else status noContent204
+        _ <- 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 <-
+              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
     --Get items associated with the given address
   get "/api/items" $ do
     addr <- param "address"
@@ -1043,7 +966,7 @@ routes pipe config = do
         status ok200
       else status noContent204
     --Get price for Zcash
-  get "/price" $ do
+  get "/api/price" $ do
     curr <- param "currency"
     pr <- liftAndCatchIO $ run (findPrice curr)
     case pr of
@@ -1140,30 +1063,6 @@ 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"
@@ -1174,12 +1073,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,7 +119,6 @@ type Parser = Parsec Void T.Text
 
 pSession :: Parser MemoToken
 pSession = do
-  optional spaceChar
   string "ZGO"
   pay <- optional $ char 'p'
   string "::"
@@ -143,7 +142,9 @@ pSaplingAddress = do
 pMsg :: Parser MemoToken
 pMsg = do
   Msg . T.pack <$>
-    some (alphaNumChar <|> punctuationChar <|> charCategory OtherSymbol)
+    some
+      (alphaNumChar <|> punctuationChar <|> symbolChar <|>
+       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.19
+resolver: lts-20.17
   #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: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64
-    size: 649618
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/19.yaml
-  original: lts-20.19
+    sha256: 14ca51a9a597c32dd7804c10d079feea3d0ae40c5fbbb346cbd67b3ae49f6d01
+    size: 649598
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/17.yaml
+  original: lts-20.17

test/Spec.hs

@@ -144,99 +144,35 @@ 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"
-                [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                , ("currency", Just "usd")
-                ]
+            req <- testGet "/api/price" [("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"
-                [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                , ("currency", Just "jpy")
-                ]
+            req <- testGet "/api/price" [("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"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+            req <- testGet "/api/countries" []
             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"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+            req <- testGet "/api/blockheight" []
             res <- httpJSON req
             height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x ->
               x > 1600000
-        describe "Xero endpoints" $ do
-          describe "xero" $ do
-            it "returns the xero config" $ do
-              req <-
-                testGet
-                  "/api/xero"
-                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+        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 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")
-                  ]
+            req <- testGet "/api/xeroaccount" [("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 <-
@@ -245,24 +181,28 @@ main = do
                 [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
-          it "returns 401 when user doesn't exist" $ do
+          it "returns 204 when no user" $ do
             req <-
               testGet
                 "/api/user"
                 [("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
             res <- httpLBS req
-            getResponseStatus res `shouldBe` unauthorized401
-          it "deletes user by id" $ do
+            getResponseStatus res `shouldBe` noContent204
+          it "validate with correct pin" $ do
             req <-
-              testDelete
-                "/api/user/"
-                "6272a90f2b05a74cf1000003"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+              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"
             res <- httpLBS req
             getResponseStatus res `shouldBe` ok200
-        describe "Owner endpoint" $
-          --prop "add owner" testOwnerAdd
-         do
+        describe "Owner endpoint" $ do
+          prop "add owner" testOwnerAdd
           it "return owner by address" $ do
             req <-
               testGet
@@ -270,31 +210,15 @@ 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")
-                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                ]
+              testGet "/api/ownerid" [("id", Just "627ad3492b05a76be3000001")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` ok200
-        describe "Order endpoints" $ do
+        describe "Order endpoint" $ do
           prop "upsert order" testOrderAdd
           it "get order by session" $ do
             req <-
@@ -303,85 +227,30 @@ 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"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+            req <- testGet "/api/order/627ab3ea2b05a76be3000000" []
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
           it "get order with wrong id" $ do
-            req <-
-              testGet
-                "/api/order/6273hrb"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+            req <- testGet "/api/order/6273hrb" []
             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")
-                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                ]
+            req <- testGet "/api/allorders" [("address", Just "Zaddy")]
             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"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+            req <- testDelete "/api/order/" "627ab3ea2b05a76be3000000"
             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")
-                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                ]
+            req <- testGet "/api/items" [("address", Just "Zaddy")]
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
           it "delete item" $ do
-            req <-
-              testDelete
-                "/api/item/"
-                "627d7ba92b05a76be3000003"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+            req <- testDelete "/api/item/" "627d7ba92b05a76be3000003"
             res <- httpLBS req
             getResponseStatus res `shouldBe` ok200
         describe "WooCommerce endpoints" $ do
@@ -389,9 +258,7 @@ main = do
             req <-
               testPost
                 "/api/wootoken"
-                [ ("ownerid", Just "627ad3492b05a76be3000001")
-                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                ]
+                [("ownerid", Just "627ad3492b05a76be3000001")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` accepted202
           it "authenticate with incorrect owner" $ do
@@ -462,40 +329,21 @@ main = do
             req <-
               testGet
                 "/api/getlang"
-                [ ("lang", Just "en-US")
-                , ("component", Just "login")
-                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                ]
+                [("lang", Just "en-US"), ("component", Just "login")]
             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")
-                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                ]
+                [("lang", Just "en-US"), ("component", Just "test")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` noContent204
           it "wrong language" $ do
             req <-
               testGet
                 "/api/getlang"
-                [ ("lang", Just "fr-FR")
-                , ("component", Just "login")
-                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
-                ]
+                [("lang", Just "fr-FR"), ("component", Just "login")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` noContent204
     around handleDb $
@@ -784,16 +632,11 @@ testPostJson endpoint body = do
         setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
   return testRequest
 
-testDelete ::
-     B.ByteString
-  -> B.ByteString
-  -> [(B.ByteString, Maybe B.ByteString)]
-  -> IO Request
-testDelete endpoint par body = do
+testDelete :: B.ByteString -> B.ByteString -> IO Request
+testDelete endpoint par = do
   let user = "user"
   let pwd = "superSecret"
   let testRequest =
-        setRequestQueryString body $
         setRequestPort 3000 $
         setRequestBasicAuth user pwd $
         setRequestMethod "DELETE" $
@@ -815,22 +658,14 @@ testOrderAdd o =
   monadicIO $ do
     req <-
       run $ testPostJson "/api/order" (A.object ["payload" A..= A.toJSON o])
-    res <-
-      httpLBS $
-      setRequestQueryString
-        [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
-        req
+    res <- httpLBS 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 $
-      setRequestQueryString
-        [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
-        req
+    res <- httpLBS req
     assert $ getResponseStatus res == created201
 
 -- | Open the MongoDB connection
@@ -857,9 +692,6 @@ 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))
@@ -882,28 +714,6 @@ 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.5.0
+version:        1.4.1
 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