Sign in with email and password

1 files changed, 42 insertions, 86 deletions

diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 3788685..4f4ae77 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -1,120 +1,76 @@
 module Controller.Index
   ( get
-  , askSignIn
-  , trySignIn
+  , signIn
   , signOut
   ) where
 
 import           Control.Monad.IO.Class    (liftIO)
-import qualified Data.Aeson                as Json
 import           Data.Text                 (Text)
-import qualified Data.Text                 as T
 import qualified Data.Text.Lazy            as TL
-import           Data.Time.Clock           (diffUTCTime, getCurrentTime)
+import           Data.Validation           (Validation (..))
 import qualified Network.HTTP.Types.Status as Status
-import           Prelude                   hiding (error)
+import           Prelude                   hiding (error, init)
 import           Web.Scotty                (ActionM)
 import qualified Web.Scotty                as S
 
-import           Common.Model              (Email (..), Init (..),
-                                            InitResult (..), SignInForm (..),
+import           Common.Model              (Init (..), SignInForm (..),
                                             User (..))
-import           Common.Msg                (Key)
 import qualified Common.Msg                as Msg
-import qualified Common.Validation.SignIn  as SignInValidation
 
 import           Conf                      (Conf (..))
 import qualified LoginSession
+import           Model.Query               (Query)
 import qualified Model.Query               as Query
-import qualified Model.SignIn              as SignIn
+import           Model.SignIn              (SignIn (..))
 import qualified Persistence.User          as UserPersistence
-import qualified Secure
-import qualified SendMail
-import qualified View.Mail.SignIn          as SignIn
+import qualified Validation.SignIn         as SignInValidation
 import           View.Page                 (page)
 
 get :: Conf -> ActionM ()
 get conf = do
-  initResult <- do
-    mbLoggedUser <- getLoggedUser
-    case mbLoggedUser of
+  init <- do
+    mbToken <- LoginSession.get
+    case mbToken of
       Nothing ->
-        return InitEmpty
-      Just user -> do
-        users <- liftIO . Query.run $ UserPersistence.list
-        return . InitSuccess $ Init users (_user_id user) (Conf.currency conf)
-  S.html $ page initResult
+        return Nothing
+      Just token -> do
+        liftIO . Query.run $ getInit conf token
+  S.html $ page init
 
-askSignIn :: Conf -> SignInForm -> ActionM ()
-askSignIn conf form =
+signIn :: Conf -> SignInForm -> ActionM ()
+signIn conf form =
   case SignInValidation.signIn form of
-    Nothing ->
-      textKey Status.badRequest400 Msg.SignIn_EmailInvalid
-    Just (Email email) -> do
-      maybeUser <- liftIO . Query.run $ UserPersistence.get email
-      case maybeUser of
-        Just user -> do
-          token <- liftIO . Query.run $ SignIn.createSignInToken email
-          let url = T.concat [
-                      if Conf.https conf then "https://" else "http://",
-                      Conf.hostname conf,
-                      "/api/signIn/",
-                      token
-                    ]
-          maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
-          case maybeSentMail of
-            Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent)
-            Left _  -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail
-        Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized
-  where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+    Failure _ ->
+      textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+    Success (SignIn email password) -> do
+      result <- liftIO . Query.run $ do
+        isPasswordValid <- UserPersistence.checkPassword email password
+        if isPasswordValid then
+          do
+            signInToken <- UserPersistence.createSignInToken email
+            init <- getInit conf signInToken
+            return $ Just (signInToken, init)
+        else
+          return Nothing
+      case result of
+        Just (signInToken, init) -> do
+          LoginSession.put conf signInToken
+          S.json init
 
-trySignIn :: Conf -> Text -> ActionM ()
-trySignIn conf token = do
-  userOrError <- validateSignIn conf token
-  case userOrError of
-    Left errorKey ->
-      S.html $ page (InitError $ Msg.get errorKey)
-    Right _ ->
-      S.redirect "/"
-
-validateSignIn :: Conf -> Text -> ActionM (Either Key User)
-validateSignIn conf textToken = do
-  mbLoggedUser <- getLoggedUser
-  case mbLoggedUser of
-    Just loggedUser ->
-      return . Right $ loggedUser
-    Nothing -> do
-      mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken
-      now <- liftIO getCurrentTime
-      case mbSignIn of
         Nothing ->
-          return . Left $ Msg.SignIn_LinkInvalid
-        Just signIn ->
-          if SignIn.isUsed signIn
-            then
-              return . Left $ Msg.SignIn_LinkUsed
-            else
-              let diffTime = now `diffUTCTime` (SignIn.creation signIn)
-              in  if diffTime > signInExpiration conf
-                    then
-                      return . Left $ Msg.SignIn_LinkExpired
-                    else do
-                      LoginSession.put conf (SignIn.token signIn)
-                      mbUser <- liftIO . Query.run $ do
-                        SignIn.signInTokenToUsed . SignIn.id $ signIn
-                        UserPersistence.get . SignIn.email $ signIn
-                      return $ case mbUser of
-                        Nothing   -> Left Msg.Secure_Unauthorized
-                        Just user -> Right user
+          textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+  where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
 
-getLoggedUser :: ActionM (Maybe User)
-getLoggedUser = do
-  mbToken <- LoginSession.get
-  case mbToken of
+getInit :: Conf -> Text -> Query (Maybe Init)
+getInit conf signInToken = do
+  user <- UserPersistence.get signInToken
+  case user of
+    Just u ->
+      do
+        users <- UserPersistence.list
+        return . Just $ Init users (_user_id u) (Conf.currency conf)
     Nothing ->
       return Nothing
-    Just token -> do
-      liftIO . Query.run . Secure.getUserFromToken $ token
 
 signOut :: Conf -> ActionM ()
 signOut conf = LoginSession.delete conf >> S.status Status.ok200