blob: 33c19b4276c1fdd57324f97f003de726905ec43c (
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
|
{-# LANGUAGE OverloadedStrings #-}
module Controller.SignIn
( signIn
, validateSignIn
) where
import Web.Scotty
import Network.HTTP.Types.Status (ok200, badRequest400)
import Database.Persist hiding (Key)
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 Conf
import SendMail
import Text.Email.Validate as Email
import Model.Database
import Model.User
import Model.SignIn
import Model.Message.Key
import Secure (getUserFromToken)
import qualified View.Mail.SignIn as SignIn
signIn :: Conf -> Text -> ActionM ()
signIn conf 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 conf, "?signInToken=", token]
maybeSentMail <- liftIO . sendMail $ SignIn.getMail conf (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 :: Conf -> Text -> ActionM (Either Key ())
validateSignIn conf textToken = do
alreadySigned <- isAlreadySigned
if alreadySigned
then
return . Right $ ()
else do
mbSignIn <- liftIO . runDb $ getSignIn textToken
now <- liftIO getCurrentTime
case mbSignIn of
Just signInValue ->
if signInIsUsed . entityVal $ signInValue
then
return . Left $ SignInUsed
else
let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signInValue)
in if diffTime > signInExpiration conf
then
return . Left $ SignInExpired
else do
LoginSession.put (signInToken . entityVal $ signInValue)
liftIO . runDb . signInTokenToUsed . entityKey $ signInValue
return . Right $ ()
Nothing ->
return . Left $ SignInInvalid
isAlreadySigned :: ActionM Bool
isAlreadySigned = do
mbToken <- LoginSession.get
case mbToken of
Nothing ->
return False
Just token -> do
liftIO . runDb . fmap isJust $ getUserFromToken token
|
