{-# LANGUAGE OverloadedStrings #-} module Controller.SignIn ( signIn , validateSignIn ) where import Web.Scotty import Network.HTTP.Types.Status (ok200, badRequest400) import Database.Persist import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE import Data.Time.Clock (getCurrentTime, diffUTCTime) import qualified Data.Aeson.Types as Json import qualified LoginSession import Config import SendMail import Text.Email.Validate (isValid) import Model.Database import Model.User import Model.SignIn import Model.Message.Key import Model.Message (getMessage) import Json (jsonObject) import qualified View.Mail.SignIn as SignIn signIn :: Config -> Text -> ActionM () signIn config login = if isValid (TE.encodeUtf8 login) then do maybeUser <- liftIO . runDb $ getUser login case maybeUser of Just user -> do token <- liftIO . runDb $ createSignInToken login let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token] maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login] case maybeSentMail of Right _ -> status ok200 Left _ -> errorResponse (getMessage SendEmailFail) Nothing -> errorResponse (getMessage Unauthorized) else errorResponse (getMessage EnterValidEmail) errorResponse :: Text -> ActionM () errorResponse msg = do status badRequest400 jsonObject [("error", Json.String msg)] validateSignIn :: Config -> Text -> ActionM () validateSignIn config textToken = do mbToken <- liftIO . runDb $ getSignInToken textToken now <- liftIO getCurrentTime case mbToken of Just token -> if signInIsUsed . entityVal $ token then redirectError (getMessage SignInUsed) else let diffTime = now `diffUTCTime` (signInCreation . entityVal $ token) in if diffTime > (fromIntegral $ (signInExpirationMn config) * 60) then redirectError (getMessage SignInExpired) else do LoginSession.put (signInEmail . entityVal $ token) liftIO . runDb . signInTokenToUsed . entityKey $ token redirect "/" Nothing -> redirectError (getMessage SignInInvalid) redirectError :: Text -> ActionM () redirectError msg = redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]