Add user validation and deletion

Tests included

src/ZGoBackend.hs

@@ -196,7 +196,27 @@ data User =
     , upin :: T.Text
     , uvalidated :: Bool
     }
-  deriving (Eq, Show, Generic, ToJSON)
+  deriving (Eq, Show, Generic)
+
+instance ToJSON User where
+  toJSON (User i a s bt p v) =
+    object
+      [ "_id" .= i
+      , "address" .= a
+      , "session" .= s
+      , "blocktime" .= bt
+      , "validated" .= v
+      ]
+
+instance FromJSON User where
+  parseJSON =
+    withObject "User" $ \obj -> do
+      i <- obj .: "_id"
+      a <- obj .: "address"
+      s <- obj .: "session"
+      bt <- obj .: "blocktime"
+      v <- obj .: "validated"
+      pure $ User i a s bt "" v
 
 parseUserBson :: B.Document -> Maybe User
 parseUserBson d = do
@@ -320,8 +340,7 @@ addUser :: Pipe -> T.Text -> T.Text -> Maybe ZGoTx -> Action IO ()
 addUser _ _ _ Nothing = return () --`debug` "addUser got Nothing"
 addUser p db node (Just tx) = do
   isNew <- liftIO $ isUserNew p db tx
-  if isNew
+  when isNew $ do
-    then do
     let newPin = unsafePerformIO generatePin
     _ <- sendPin node (address tx) newPin
     insert_
@@ -332,7 +351,23 @@ addUser p db node (Just tx) = do
       , "pin" =: newPin
       , "validated" =: False
       ]
-    else return ()
+
+-- | Function to delete user by ID
+deleteUser :: String -> Action IO ()
+deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users")
+
+-- | Function to verify if the given ZGoTx represents an already existing User
+isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool
+isUserNew p db tx =
+  isNothing <$>
+  access p master db (findOne (select ["session" =: session tx] "users"))
+
+-- | Function to mark user as validated
+validateUser :: T.Text -> Action IO ()
+validateUser session =
+  modify
+    (select ["session" =: session] "users")
+    ["$set" =: ["validated" =: True]]
 
 sendPin :: T.Text -> T.Text -> T.Text -> Action IO String
 sendPin nodeAddress addr pin = do
@@ -343,7 +378,7 @@ sendPin nodeAddress addr pin = do
                [ object
                    [ "address" .= addr
                    , "amount" .= (0.00000001 :: Double)
-                   , "memo" .= encodeHexText ("ZGo PIN: " ++ T.unpack (pin))
+                   , "memo" .= encodeHexText ("ZGo PIN: " ++ T.unpack pin)
                    ]
                ])
         ]
@@ -398,8 +433,6 @@ app pipe db passkey nodeAddress = do
       case countries of
         [] -> do
           status noContent204
-          Web.Scotty.json
-            (object ["message" .= ("No countries available" :: String)])
         _ -> do
           Web.Scotty.json
             (object
@@ -418,10 +451,29 @@ app pipe db passkey nodeAddress = do
                [ "message" .= ("User found" :: String)
                , "user" .= toJSON (parseUserBson u)
                ])
-    --Add user
+    --Validate user, updating record
-    post "/api/user" $ do text "Added that guy"
+    post "/api/validateuser" $ do
+      providedPin <- param "pin"
+      session <- param "session"
+      user <- liftIO $ run (findUser session)
+      case user of
+        Nothing -> status noContent204
+        Just u -> do
+          let parsedUser = parseUserBson u
+          case parsedUser of
+            Nothing -> status noContent204
+            Just pUser -> do
+              let result = upin pUser == providedPin
+              if result
+                then do
+                  liftIO $ run (validateUser session)
+                  status accepted202
+                else status noContent204
     --Delete user
-    Web.Scotty.delete "/api/user/:id" $ do text "Deleted that guy!"
+    Web.Scotty.delete "/api/user/:id" $ do
+      userId <- param "id"
+      liftIO $ run (deleteUser userId)
+      status ok200
     --Get txs from DB that have less than 10 confirmations
     get "/api/pending" $ do
       session <- param "session"
@@ -449,8 +501,6 @@ app pipe db passkey nodeAddress = do
     get "/api/owner" $ do text "Here's an owner for you"
     --Upsert owner to DB
     post "/api/owner" $ do text "I added an owner for you"
-    --Validate user, updating record
-    post "/api/validateuser" $ do text "Marked user as validated"
     --Get items associated with the given address
     get "/api/items" $ do text "Here are your items"
     --Upsert item
@@ -554,10 +604,4 @@ updateLogins addr pipe db = do
   mapM_ (access pipe master db . ZGoBackend.addUser pipe db addr) parsed
   putStrLn "Updated logins!"
 
-isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool
-isUserNew p db tx = do
-  res <-
-    (access p master db (findOne (select ["session" =: (session tx)] "users")))
-  return $ isNothing res
-
 debug = flip trace

test/Spec.hs

@@ -9,6 +9,7 @@ import qualified Data.Aeson as A
 import qualified Data.ByteString as B
 import Data.Char (isAscii)
 import Data.Either
+import Data.Maybe
 import Data.SecureMem
 import qualified Data.Text as T
 import Database.MongoDB
@@ -97,11 +98,33 @@ main =
         describe "unconfirmed Zcash txs" $ do
           it "returns txs with less than 2 confirmations" $ do pending
         describe "User endpoint" $ do
-          it "adds a user" $ do pending
+          it "returns a user for a session" $ do
-          it "returns a user for a session" $ do pending
+            req <-
-          it "returns 204 when no user" $ do pending
+              testGet
-          it "marks user as validated" $ do pending
+                "/api/user"
-          it "deletes user by id" $ do pending
+                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca")]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+          it "returns 204 when no user" $ 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-99d63b8dcdca")
+                , ("pin", Just "5989845")
+                ]
+            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" $ do
           it "add owner" $ do pending
           it "return owner" $ do pending
@@ -189,6 +212,41 @@ main =
                 case s of
                   Nothing -> True `shouldBe` False
                   Just z -> length (T.unpack (usession z)) `shouldSatisfy` (> 0)
+        describe "user is" $ do
+          it "validated" $ \p -> do
+            t <-
+              access p master "test" $
+              findOne (select ["validated" =: False] "users")
+            case t of
+              Nothing -> True `shouldBe` False
+              Just r -> do
+                let s = parseUserBson r
+                case s of
+                  Nothing -> True `shouldBe` False
+                  Just z -> do
+                    _ <- access p master "test" $ validateUser (usession z)
+                    q <-
+                      access p master "test" $
+                      findOne
+                        (select
+                           ["validated" =: True, "session" =: usession z]
+                           "users")
+                    isNothing q `shouldBe` False
+          it "deleted" $ \p -> do
+            t <- access p master "test" $ findOne (select [] "users")
+            case t of
+              Nothing -> True `shouldBe` False
+              Just r -> do
+                let s = parseUserBson r
+                case s of
+                  Nothing -> True `shouldBe` False
+                  Just z -> do
+                    _ <- access p master "test" $ deleteUser (u_id z)
+                    q <-
+                      access p master "test" $
+                      findOne
+                        (select ["_id" =: (read (u_id z) :: ObjectId)] "users")
+                    isNothing q `shouldBe` True
 
 testGet :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request
 testGet endpoint body = do
@@ -201,6 +259,28 @@ testGet endpoint body = do
         setRequestMethod "GET" $ setRequestPath endpoint defaultRequest
   return testRequest
 
+testPost :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request
+testPost endpoint body = do
+  let user = "user"
+  let pwd = "superSecret"
+  let testRequest =
+        setRequestQueryString body $
+        setRequestPort 4000 $
+        setRequestBasicAuth user pwd $
+        setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
+  return testRequest
+
+testDelete :: B.ByteString -> B.ByteString -> IO Request
+testDelete endpoint par = do
+  let user = "user"
+  let pwd = "superSecret"
+  let testRequest =
+        setRequestPort 4000 $
+        setRequestBasicAuth user pwd $
+        setRequestMethod "DELETE" $
+        setRequestPath (B.append endpoint par) defaultRequest
+  return testRequest
+
 -- | Open the MongoDB connection
 openDbConnection :: IO Pipe
 openDbConnection = do