From 169d52bfbe8b7f95dcece3cef245cdd62336e2f8 Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Sun, 9 Aug 2015 00:21:03 +0200
Subject: Wording for sign in email

---
 src/server/Controller/SignIn.hs | 85 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 85 insertions(+)
 create mode 100644 src/server/Controller/SignIn.hs

(limited to 'src/server/Controller/SignIn.hs')

diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
new file mode 100644
index 0000000..a46894a
--- /dev/null
+++ b/src/server/Controller/SignIn.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Controller.SignIn
+  ( signInAction
+  , validateSignInAction
+  ) 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 LoginSession
+
+import Config
+
+import SendMail
+
+import Text.Email.Validate (isValid)
+
+import Model.Database
+import Model.User
+import Model.SignIn
+import Model.Message
+
+import qualified View.Mail.SignIn as SignIn
+
+signInAction :: Config -> Text -> ActionM ()
+signInAction 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 "Sorry, we failed to send you the sign up email."
+        Nothing ->
+            errorResponse "You are not authorized to sign in."
+    else
+      errorResponse "Please enter a valid email address."
+
+errorResponse :: Text -> ActionM ()
+errorResponse msg = do
+  status badRequest400
+  json (Message msg)
+
+validateSignInAction :: Text -> ActionM ()
+validateSignInAction token = do
+  maybeSignIn <- liftIO . runDb $ getSignInToken token
+  now <- liftIO getCurrentTime
+  case maybeSignIn of
+    Just signIn ->
+      if signInIsUsed . entityVal $ signIn
+        then
+          redirectError "The token has already been used."
+        else
+          let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
+          in  if diffTime > 2 * 60 -- 2 minutes
+                then
+                  redirectError "The token has expired."
+                else do
+                  LoginSession.put (signInEmail . entityVal $ signIn)
+                  liftIO . runDb . signInTokenToUsed . entityKey $ signIn
+                  redirect "/"
+    Nothing ->
+      redirectError "The token is invalid."
+
+redirectError :: Text -> ActionM ()
+redirectError msg =
+  redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
-- 
cgit v1.2.3