blob: 1fb62ec426d504e4a1a371fc42c26f478cd22b2c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
{-# 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 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
import Model.Message.Key
import Model.Message (getMessage)
import Secure (getUserFromToken)
import qualified View.Mail.SignIn as SignIn
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 _ -> do
status badRequest400
text (TL.pack $ show SendEmailFail)
Nothing -> do
status badRequest400
text (TL.pack $ show UnauthorizedSignIn)
else do
status badRequest400
text (TL.pack $ show 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
Nothing ->
return False
Just token -> do
liftIO . runDb . fmap isJust $ getUserFromToken token
redirectError :: Text -> ActionM ()
redirectError msg =
redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
|
