blob: fbda527ee3a2c527743b792277e34578ad75f184 (
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
119
|
module Controller.Index
( get
, askSignIn
, trySignIn
, signOut
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as Json
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import qualified Network.HTTP.Types.Status as Status
import Prelude hiding (error)
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
import Common.Model (Email (..), InitResult (..),
SignInForm (..), User (..))
import Common.Msg (Key)
import qualified Common.Msg as Msg
import qualified Common.Validation.SignIn as SignInValidation
import Conf (Conf (..))
import qualified LoginSession
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
import qualified Persistence.Init as InitPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
import qualified SendMail
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
Just user ->
liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf
S.html $ page initResult
askSignIn :: Conf -> SignInForm -> ActionM ()
askSignIn conf form =
case SignInValidation.signIn form of
Nothing ->
textKey Status.badRequest400 Msg.SignIn_EmailInvalid
Just (Email email) -> do
maybeUser <- liftIO . Query.run $ UserPersistence.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 _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent)
Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail
Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized
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 (InitError $ 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
UserPersistence.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 . Secure.getUserFromToken $ token
signOut :: Conf -> ActionM ()
signOut conf = LoginSession.delete conf >> S.status Status.ok200
|
