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

{-# LANGUAGE OverloadedStrings #-}

module Controller.SignIn
  ( signIn
  ) 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 Conf (Conf)
import qualified Conf

import SendMail

import Text.Email.Validate as Email

import Model.Database
import Model.User
import Model.SignIn
import Model.Message.Key

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 [
                      if Conf.https conf then "https://" else "http://",
                      Conf.hostname conf,
                      "?signInToken=",
                      token
                    ]
          maybeSentMail <- liftIO . sendMail $ SignIn.mail 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