Authorizing only existing users

2 files changed, 31 insertions, 39 deletions

diff --git a/src/server/Application.hs b/src/server/Application.hs
index e480533..28ad3cd 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -1,21 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Application
-  ( getIndexAction
+  ( signIn
+  , signOut
+  , getIndexAction
   , getUsersAction
   , getPaymentsAction
   , addUserAction
   , deleteUserAction
   , insertPaymentAction
-
-  , signIn
-  , checkConnection
-  , signOut
   ) where
 
 import Web.Scotty
 
-import Network.HTTP.Types.Status (badRequest400)
+import Network.HTTP.Types.Status (ok200, badRequest400)
 
 import Database.Persist
 
@@ -54,12 +52,12 @@ getPaymentsAction =
 addUserAction :: Text -> Text -> ActionM ()
 addUserAction email name = do
   _ <- liftIO . runDb $ insertUser email name
-  html "Ok"
+  status ok200
 
 deleteUserAction :: Text -> ActionM ()
 deleteUserAction email = do
   _ <- liftIO . runDb $ deleteUser email
-  html "Ok"
+  status ok200
 
 insertPaymentAction :: Text -> Text -> Int -> ActionM ()
 insertPaymentAction email name cost = do
@@ -70,29 +68,19 @@ insertPaymentAction email name cost = do
       return ()
     Nothing -> do
       status badRequest400
-      html "Not found"
+      status ok200
 
 signIn :: Text -> ActionM ()
 signIn login = do
-  LoginSession.put login
-  html "Ok"
-
-checkConnection :: ActionM ()
-checkConnection = do
-  maybeLogin <- LoginSession.get
-  case maybeLogin of
-    Just login ->
-      html . TL.fromStrict $
-        T.intercalate
-          " "
-          [ "You are connected with the following login:"
-          , login
-          ]
-    Nothing -> do
+  maybeUser <- liftIO . runDb $ getUser login
+  case maybeUser of
+    Just _ -> do
+      LoginSession.put login
+      status ok200
+    Nothing ->
       status badRequest400
-      html "You are not connected"
 
 signOut :: ActionM ()
 signOut = do
   LoginSession.delete
-  html "Ok"
+  status ok200
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 8d5a625..4461945 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -14,10 +14,24 @@ main :: IO ()
 main = do
   runMigrations
   scotty 3000 $ do
-    middleware $ staticPolicy (noDots >-> addBase "public")
-    get "/" getIndexAction
+
+    middleware $
+      staticPolicy (noDots >-> addBase "public")
+
+    get "/" $
+      getIndexAction
+
+    post "/signIn" $ do
+      login <- param "login" :: ActionM Text
+      signIn login
+
+    post "/signOut" $
+      signOut
+
+    get "/payments" $
+      getPaymentsAction
+
     get "/users" getUsersAction
-    get "/payments" getPaymentsAction
     post "/user/add" $ do
       email <- param "email" :: ActionM Text
       name <- param "name" :: ActionM Text
@@ -30,13 +44,3 @@ main = do
       name <- param "name" :: ActionM Text
       cost <- param "cost" :: ActionM Int
       insertPaymentAction email name cost
-
-    post "/signIn" $ do
-      login <- param "login" :: ActionM Text
-      signIn login
-
-    post "/checkConnection" $
-      checkConnection
-
-    post "/signOut" $
-      signOut