Harden user endpoints and corresponding tests

src/User.hs

@@ -69,6 +69,36 @@ instance FromJSON User where
           ""
           v
 
+instance Val User where
+  cast' (Doc d) = do
+    i <- B.lookup "_id" d
+    a <- B.lookup "address" d
+    s <- B.lookup "session" d
+    b <- B.lookup "blocktime" d
+    p <- B.lookup "pin" d
+    v <- B.lookup "validated" d
+    Just $ User i a s b p v
+  cast' _ = Nothing
+  val (User i a s b p v) =
+    case i of
+      Just oid ->
+        Doc
+          [ "_id" =: oid
+          , "address" =: a
+          , "session" =: s
+          , "blocktime" =: b
+          , "pin" =: p
+          , "validated" =: v
+          ]
+      Nothing ->
+        Doc
+          [ "address" =: a
+          , "session" =: s
+          , "blocktime" =: b
+          , "pin" =: p
+          , "validated" =: v
+          ]
+
 parseUserBson :: B.Document -> Maybe User
 parseUserBson d = do
   i <- B.lookup "_id" d
@@ -84,6 +114,9 @@ parseUserBson d = do
 findUser :: T.Text -> Action IO (Maybe Document)
 findUser s = findOne (select ["session" =: s] "users")
 
+findUserById :: String -> Action IO (Maybe Document)
+findUserById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "users")
+
 -- | Function to delete user by ID
 deleteUser :: String -> Action IO ()
 deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users")

src/ZGoBackend.hs

@@ -893,12 +893,20 @@ routes pipe config = do
     --Delete user
   Web.Scotty.delete "/api/user/:id" $ do
     userId <- param "id"
+    session <- param "session"
     let r = mkRegex "^[a-f0-9]{24}$"
     if matchTest r userId
       then do
-        liftAndCatchIO $ run (deleteUser userId)
-        status ok200
-      else status noContent204
+        u <- liftAndCatchIO $ run (findUserById userId)
+        case cast' . Doc =<< u of
+          Nothing -> status badRequest400
+          Just u' ->
+            if session == usession u'
+              then do
+                liftAndCatchIO $ run (deleteUser userId)
+                status ok200
+              else status forbidden403
+      else status badRequest400
   --Get current blockheight from Zcash node
   get "/blockheight" $ do
     blockInfo <-

test/Spec.hs

@@ -259,14 +259,39 @@ main = do
                 [("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` unauthorized401
-          it "deletes user by id" $ do
-            req <-
-              testDelete
-                "/api/user/"
-                "6272a90f2b05a74cf1000003"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
-            res <- httpLBS req
-            getResponseStatus res `shouldBe` ok200
+          describe "delete" $ do
+            it "returns 401 when session is invalid" $ do
+              req <-
+                testDelete
+                  "/api/user/"
+                  "6272a90f2b05a74cf1000005"
+                  [("session", Just "suchafak-euui-dican-eve-nbelieveitca")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` unauthorized401
+            it "returns 403 when user and session don't match" $ do
+              req <-
+                testDelete
+                  "/api/user/"
+                  "6272a90f2b05a74cf1000005"
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` forbidden403
+            it "returns 400 when user is invalid" $ do
+              req <-
+                testDelete
+                  "/api/user/"
+                  "000000000000000000000000"
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` badRequest400
+            it "deletes user by id" $ do
+              req <-
+                testDelete
+                  "/api/user/"
+                  "6272a90f2b05a74cf1000003"
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` ok200
         describe "Owner endpoint" $
           --prop "add owner" testOwnerAdd
          do
@@ -872,6 +897,14 @@ closeDbConnection = close
 handleDb :: (Pipe -> Expectation) -> IO ()
 handleDb = bracket openDbConnection closeDbConnection
 
+filterDocs :: Value -> Bool
+filterDocs (Doc v) = True
+filterDocs _ = False
+
+unwrapDoc :: Value -> Document
+unwrapDoc (Doc v) = v
+unwrapDoc _ = []
+
 startAPI :: Config -> IO ()
 startAPI config = do
   putStrLn "Starting test server ..."
@@ -892,20 +925,6 @@ startAPI config = do
           1613487
           "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
           False
-  _ <-
-    access
-      pipe
-      master
-      "test"
-      (insert_
-         "users"
-         [ "address" =: uaddress myUser
-         , "_id" =: u_id myUser
-         , "session" =: usession myUser
-         , "blocktime" =: ublocktime myUser
-         , "pin" =: upin myUser
-         , "validated" =: uvalidated myUser
-         ])
   let myUser1 =
         User
           (Just (read "6272a90f2b05a74cf1000003" :: ObjectId))
@@ -914,20 +933,45 @@ startAPI config = do
           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 myUser2 =
+        User
+          (Just (read "6272a90f2b05a74cf1000005" :: ObjectId))
+          "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3fake"
+          "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake"
+          1613487
+          "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
+          True
+  let userList =
+        map unwrapDoc $ filter filterDocs $ val <$> [myUser, myUser1, myUser2]
+  _ <- access pipe master "test" (insertAll_ "users" userList)
+  --_ <-
+    --access
+      --pipe
+      --master
+      --"test"
+      --(insert_
+         --"users"
+         --[ "address" =: uaddress myUser
+         --, "_id" =: u_id myUser
+         --, "session" =: usession myUser
+         --, "blocktime" =: ublocktime myUser
+         --, "pin" =: upin myUser
+         --, "validated" =: uvalidated myUser
+         --])
+  --_ <-
+    --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"))