aboutsummaryrefslogtreecommitdiff
path: root/src/server/Controller
diff options
context:
space:
mode:
Diffstat (limited to 'src/server/Controller')
-rw-r--r--src/server/Controller/SignIn.hs84
1 files changed, 14 insertions, 70 deletions
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 31cd510..8eceb56 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -2,32 +2,21 @@
module Controller.SignIn
( signIn
- , validateSignIn
) where
import Web.Scotty
import Network.HTTP.Types.Status (ok200)
-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 Data.Maybe (isJust)
import qualified LoginSession
import Config
-import SendMail
-
-import Text.Email.Validate as Email
-
import Model.Database
import Model.User
import Model.SignIn
@@ -36,65 +25,20 @@ import Model.Message (getMessage)
import Json (jsonError)
-import Secure (getUserFromToken)
-
-import qualified View.Mail.SignIn as SignIn
+import Persona (verifyEmail)
signIn :: Config -> Text -> ActionM ()
-signIn config login =
- if Email.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 _ ->
- jsonError (getMessage SendEmailFail)
- Nothing ->
- jsonError (getMessage Unauthorized)
- else
- jsonError (getMessage EnterValidEmail)
-
-validateSignIn :: Config -> Text -> ActionM ()
-validateSignIn config textToken = do
- alreadySigned <- isAlreadySigned
- if alreadySigned
- then
- redirect "/"
- else do
- mbSignIn <- liftIO . runDb $ getSignInToken textToken
- now <- liftIO getCurrentTime
- case mbSignIn of
- Just signIn ->
- if signInIsUsed . entityVal $ signIn
- then
- redirectError (getMessage SignInUsed)
- else
- let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
- in if diffTime > (fromIntegral $ (signInExpirationMn config) * 60)
- then
- redirectError (getMessage SignInExpired)
- else do
- LoginSession.put (signInToken . entityVal $ signIn)
- liftIO . runDb . signInTokenToUsed . entityKey $ signIn
- redirect "/"
- Nothing ->
- redirectError (getMessage SignInInvalid)
-
-isAlreadySigned :: ActionM Bool
-isAlreadySigned = do
- mbToken <- LoginSession.get
- case mbToken of
+signIn config assertion = do
+ mbEmail <- liftIO $ verifyEmail config assertion
+ case mbEmail of
Nothing ->
- return False
- Just token -> do
- liftIO . runDb . fmap isJust $ getUserFromToken token
-
-redirectError :: Text -> ActionM ()
-redirectError msg =
- redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
+ jsonError (getMessage InvalidEmail)
+ Just email -> do
+ isAuthorized <- liftIO . fmap isJust . runDb $ getUser email
+ if isAuthorized
+ then do
+ token <- liftIO . runDb $ createSignInToken email
+ LoginSession.put token
+ status ok200
+ else
+ jsonError (getMessage Unauthorized)