blob: cf92c9ff58841a548ddece8d61f2e661e54eb7f4 (
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
|
module Controller.SignIn
( signIn
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Network.HTTP.Types.Status (badRequest400, ok200)
import Web.Scotty
import Common.Model (SignIn (..))
import qualified Common.Msg as Msg
import Conf (Conf)
import qualified Conf
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
import qualified Model.User as User
import qualified SendMail
import qualified Text.Email.Validate as Email
import qualified View.Mail.SignIn as SignIn
signIn :: Conf -> SignIn -> ActionM ()
signIn 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,
"?signInToken=",
token
]
maybeSentMail <- liftIO . SendMail.sendMail $ 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 = status st >> (text . TL.fromStrict $ Msg.get key)
|
