blob: 9a3e2b7628f7828b4188a936bc986fb28af888a3 (
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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
module Controller.Index
( get
, askSignIn
, trySignIn
, signOut
) where
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Network.HTTP.Types.Status (badRequest400, ok200)
import Prelude hiding (error)
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
import Common.Model (InitResult (..), SignIn (..),
User (..))
import Common.Msg (Key)
import qualified Common.Msg as Msg
import Conf (Conf (..))
import qualified LoginSession
import Model.Init (getInit)
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
import qualified Model.User as User
import Secure (getUserFromToken)
import qualified SendMail
import qualified Text.Email.Validate as Email
import qualified View.Mail.SignIn as SignIn
import View.Page (page)
get :: Conf -> ActionM ()
get conf = do
initResult <- do
mbLoggedUser <- getLoggedUser
case mbLoggedUser of
Nothing ->
return . InitEmpty . Right $ Nothing
Just user ->
liftIO . Query.run . fmap InitSuccess $ getInit user conf
S.html $ page initResult
askSignIn :: Conf -> SignIn -> ActionM ()
askSignIn conf (SignIn email) =
if Email.isValid (TE.encodeUtf8 email)
then do
maybeUser <- liftIO . Query.run $ User.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,
"/signIn/",
token
]
maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
case maybeSentMail of
Right _ -> textKey ok200 Msg.SignIn_EmailSent
Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
else textKey badRequest400 Msg.SignIn_EmailInvalid
where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
trySignIn :: Conf -> Text -> ActionM ()
trySignIn conf token = do
userOrError <- validateSignIn conf token
case userOrError of
Left errorKey ->
S.html $ page (InitEmpty . Left . 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
User.get . SignIn.email $ signIn
return $ case mbUser of
Nothing -> Left Msg.Secure_Unauthorized
Just user -> Right user
getLoggedUser :: ActionM (Maybe User)
getLoggedUser = do
mbToken <- LoginSession.get
case mbToken of
Nothing ->
return Nothing
Just token -> do
liftIO . Query.run . getUserFromToken $ token
signOut :: Conf -> ActionM ()
signOut conf = LoginSession.delete conf >> S.status ok200
|
