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/Application.hs | 147 --------------------------------------- src/server/Controller/Index.hs | 58 +++++++++++++++ src/server/Controller/Payment.hs | 31 +++++++++ src/server/Controller/SignIn.hs | 85 ++++++++++++++++++++++ src/server/Mail.hs | 58 --------------- src/server/Main.hs | 4 +- src/server/Model/Mail.hs | 13 ++++ src/server/SendMail.hs | 45 ++++++++++++ src/server/View/Mail/SignIn.hs | 48 +++++++++++++ src/server/View/Page.hs | 1 + 10 files changed, 284 insertions(+), 206 deletions(-) delete mode 100644 src/server/Application.hs create mode 100644 src/server/Controller/Index.hs create mode 100644 src/server/Controller/Payment.hs create mode 100644 src/server/Controller/SignIn.hs delete mode 100644 src/server/Mail.hs create mode 100644 src/server/Model/Mail.hs create mode 100644 src/server/SendMail.hs create mode 100644 src/server/View/Mail/SignIn.hs (limited to 'src/server') diff --git a/src/server/Application.hs b/src/server/Application.hs deleted file mode 100644 index 5306e17..0000000 --- a/src/server/Application.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Application - ( signInAction - , validateSignInAction - , getUserName - , getPaymentsAction - , createPaymentAction - , signOutAction - - , getIndexAction - , getUsersAction - , addUserAction - , deleteUserAction - ) 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.String (fromString) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Data.Maybe (isJust) - -import Text.Email.Validate (isValid) - -import qualified LoginSession - -import qualified Secure - -import Model.Database -import Model.User -import Model.Payment -import Model.SignIn -import Model.Message - -import Config - -import View.Page (page) - -import Mail - -signInAction :: Config -> Text -> ActionM () -signInAction config login = - if isValid (TE.encodeUtf8 login) - then do - maybeUser <- liftIO . runDb $ getUser login - if isJust maybeUser - then do - token <- liftIO . runDb $ createSignInToken login - let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token] - let mail = Mail [login] "Sign in" url url - maybeSentMail <- liftIO . sendMail $ mail - case maybeSentMail of - Right _ -> - status ok200 - Left _ -> - errorResponse "Sorry, we failed to send you the sign up email." - else - errorResponse "You are not authorized to sign in." - else - errorResponse "Please enter a valid email address." - -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] - -getUserName :: ActionM () -getUserName = - Secure.loggedAction (\user -> do - json . Message . userName . entityVal $ user - ) - -getPaymentsAction :: ActionM () -getPaymentsAction = - Secure.loggedAction (\_ -> do - payments <- liftIO $ runDb getPayments - json payments - ) - -createPaymentAction :: Text -> Int -> ActionM () -createPaymentAction name cost = - Secure.loggedAction (\user -> do - _ <- liftIO . runDb $ createPayment (entityKey user) name cost - return () - ) - -signOutAction :: ActionM () -signOutAction = do - LoginSession.delete - status ok200 - -errorResponse :: Text -> ActionM () -errorResponse msg = do - status badRequest400 - json (Message msg) - - - - - -getIndexAction :: ActionM () -getIndexAction = html page - -getUsersAction :: ActionM () -getUsersAction = do - users <- liftIO $ runDb getUsers - html . fromString . show $ users - -addUserAction :: Text -> Text -> ActionM () -addUserAction email name = do - _ <- liftIO . runDb $ createUser email name - status ok200 - -deleteUserAction :: Text -> ActionM () -deleteUserAction email = do - _ <- liftIO . runDb $ deleteUser email - status ok200 diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs new file mode 100644 index 0000000..610c57c --- /dev/null +++ b/src/server/Controller/Index.hs @@ -0,0 +1,58 @@ +module Controller.Index + ( getIndexAction + , getUserName + , signOutAction + , getUsersAction + , addUserAction + , deleteUserAction + ) where + +import Web.Scotty + +import Network.HTTP.Types.Status (ok200) + +import Database.Persist + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import Data.String (fromString) + +import qualified LoginSession + +import qualified Secure + +import Model.Database +import Model.User +import Model.Message + +import View.Page (page) + +getIndexAction :: ActionM () +getIndexAction = html page + +getUserName :: ActionM () +getUserName = + Secure.loggedAction (\user -> do + json . Message . userName . entityVal $ user + ) + +signOutAction :: ActionM () +signOutAction = do + LoginSession.delete + status ok200 + +getUsersAction :: ActionM () +getUsersAction = do + users <- liftIO $ runDb getUsers + html . fromString . show $ users + +addUserAction :: Text -> Text -> ActionM () +addUserAction email name = do + _ <- liftIO . runDb $ createUser email name + status ok200 + +deleteUserAction :: Text -> ActionM () +deleteUserAction email = do + _ <- liftIO . runDb $ deleteUser email + status ok200 diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs new file mode 100644 index 0000000..1287825 --- /dev/null +++ b/src/server/Controller/Payment.hs @@ -0,0 +1,31 @@ +module Controller.Payment + ( getPaymentsAction + , createPaymentAction + ) where + +import Web.Scotty + +import Database.Persist + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) + +import qualified Secure + +import Model.Database +import Model.Payment + +getPaymentsAction :: ActionM () +getPaymentsAction = + Secure.loggedAction (\_ -> do + payments <- liftIO $ runDb getPayments + json payments + ) + +createPaymentAction :: Text -> Int -> ActionM () +createPaymentAction name cost = + Secure.loggedAction (\user -> do + _ <- liftIO . runDb $ createPayment (entityKey user) name cost + return () + ) 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] diff --git a/src/server/Mail.hs b/src/server/Mail.hs deleted file mode 100644 index c649d59..0000000 --- a/src/server/Mail.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mail - ( Mail(..) - , sendMail - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Builder (toLazyText, fromText) -import Data.Either (isLeft) - -import Control.Exception (SomeException, try) - -import qualified Network.Mail.Mime as M - -data Mail = Mail - { to :: [Text] - , subject :: Text - , plainBody :: Text - , htmlBody :: Text - } deriving (Eq, Show) - -sendMail :: Mail -> IO (Either Text ()) -sendMail mail = do - result <- mapLeft (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) - if isLeft result - then putStrLn ("Error sending the following email:" ++ (show mail)) - else return () - return result - -mapLeft :: (a -> c) -> Either a b -> Either c b -mapLeft f (Left l) = Left (f l) -mapLeft _ (Right r) = (Right r) - -getMimeMail :: Mail -> M.Mail -getMimeMail (Mail to subject plainBody htmlBody) = - let fromMail = M.emptyMail (address "no-reply@shared-cost.guyonvarch.me") - in fromMail - { M.mailTo = map address to - , M.mailParts = - [ [ M.plainPart . strictToLazy $ plainBody - , M.htmlPart . strictToLazy $ htmlBody - ] - ] - , M.mailHeaders = [("Subject", subject)] - } - -strictToLazy :: Text -> LT.Text -strictToLazy = toLazyText . fromText - -address :: Text -> M.Address -address addressEmail = - M.Address - { M.addressName = Nothing - , M.addressEmail = addressEmail - } diff --git a/src/server/Main.hs b/src/server/Main.hs index 3033f58..e7e759b 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -6,7 +6,9 @@ import Network.Wai.Middleware.Static import Data.Text (Text) -import Application +import Controller.Index +import Controller.SignIn +import Controller.Payment import Model.Database (runMigrations) diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs new file mode 100644 index 0000000..7ee8a8e --- /dev/null +++ b/src/server/Model/Mail.hs @@ -0,0 +1,13 @@ +module Model.Mail + ( Mail(..) + ) where + +import Data.Text (Text) +import qualified Data.Text.Lazy as LT + +data Mail = Mail + { to :: [Text] + , subject :: Text + , plainBody :: LT.Text + , htmlBody :: LT.Text + } deriving (Eq, Show) diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs new file mode 100644 index 0000000..74d48ab --- /dev/null +++ b/src/server/SendMail.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SendMail + ( sendMail + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Either (isLeft) + +import Control.Exception (SomeException, try) +import Control.Arrow (left) + +import qualified Network.Mail.Mime as M + +import Model.Mail + +sendMail :: Mail -> IO (Either Text ()) +sendMail mail = do + result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + if isLeft result + then putStrLn ("Error sending the following email:" ++ (show mail)) + else return () + return result + +getMimeMail :: Mail -> M.Mail +getMimeMail (Mail to subject plainBody htmlBody) = + let fromMail = M.emptyMail (address "no-reply@shared-cost.guyonvarch.me") + in fromMail + { M.mailTo = map address to + , M.mailParts = + [ [ M.plainPart plainBody + , M.htmlPart htmlBody + ] + ] + , M.mailHeaders = [("Subject", subject)] + } + +address :: Text -> M.Address +address addressEmail = + M.Address + { M.addressName = Nothing + , M.addressEmail = addressEmail + } diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs new file mode 100644 index 0000000..e11b876 --- /dev/null +++ b/src/server/View/Mail/SignIn.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Mail.SignIn + ( getMail + ) where + +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (toLazyText, fromText) + +import Text.Blaze.Html +import Text.Blaze.Html5 +import Text.Blaze.Html.Renderer.Text (renderHtml) + +import Model.Database (User(..)) +import qualified Model.Mail as M + +getMail :: User -> Text -> [Text] -> M.Mail +getMail user url to = + M.Mail + { M.to = to + , M.subject = "Sign in to Shared Cost" + , M.plainBody = plainBody user url + , M.htmlBody = htmlBody user url + } + +plainBody :: User -> Text -> LT.Text +plainBody user url = + LT.intercalate + "\n" + [ LT.concat ["Hi ", strictToLazy . userName $ user, ","] + , "" + , "Click to the following link in order to sign in to Shared Cost:" + , strictToLazy url + ] + +htmlBody :: User -> Text -> LT.Text +htmlBody user url = + renderHtml . docTypeHtml . body $ do + toHtml $ LT.concat ["Hi ", strictToLazy . userName $ user, ","] + br + br + "Click to the following link in order to sign in to Shared Cost:" + br + toHtml url + +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index a397a96..5b9f06e 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -5,6 +5,7 @@ module View.Page ) where import Data.Text.Internal.Lazy (Text) +import Data.Text.Internal.Lazy as TL import Text.Blaze.Html import Text.Blaze.Html5 -- cgit v1.2.3