src/server/Controller/SignIn.hs


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

{-# 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 qualified Data.Aeson.Types as Json

import qualified LoginSession

import Config

import SendMail

import Text.Email.Validate (isValid)

import Model.Database
import Model.User
import Model.SignIn
import Model.Message.Key
import Model.Message (getMessage)

import Json (jsonObject)

import qualified View.Mail.SignIn as SignIn

signIn :: Config -> Text -> ActionM ()
signIn config login =
  if 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 _ ->
              errorResponse (getMessage SendEmailFail)
        Nothing ->
            errorResponse (getMessage Unauthorized)
    else
      errorResponse (getMessage EnterValidEmail)

errorResponse :: Text -> ActionM ()
errorResponse msg = do
  status badRequest400
  jsonObject [("error", Json.String msg)]

validateSignIn :: Config -> Text -> ActionM ()
validateSignIn config textToken = do
  mbToken <- liftIO . runDb $ getSignInToken textToken
  now <- liftIO getCurrentTime
  case mbToken of
    Just token ->
      if signInIsUsed . entityVal $ token
        then
          redirectError (getMessage SignInUsed)
        else
          let diffTime = now `diffUTCTime` (signInCreation . entityVal $ token)
          in  if diffTime > (fromIntegral $ (signInExpirationMn config) * 60)
                then
                  redirectError (getMessage SignInExpired)
                else do
                  LoginSession.put (signInEmail . entityVal $ token)
                  liftIO . runDb . signInTokenToUsed . entityKey $ token
                  redirect "/"
    Nothing ->
      redirectError (getMessage SignInInvalid)

redirectError :: Text -> ActionM ()
redirectError msg =
  redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]