Wording for sign in email

8 files changed, 177 insertions, 99 deletions

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/Application.hs b/src/server/Controller/SignIn.hs
index 5306e17..a46894a 100644
--- a/src/server/Application.hs
+++ b/src/server/Controller/SignIn.hs
@@ -1,17 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Application
+module Controller.SignIn
   ( signInAction
   , validateSignInAction
-  , getUserName
-  , getPaymentsAction
-  , createPaymentAction
-  , signOutAction
-
-  , getIndexAction
-  , getUsersAction
-  , addUserAction
-  , deleteUserAction
   ) where
 
 import Web.Scotty
@@ -26,49 +17,48 @@ 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 Config
+
+import SendMail
+
+import Text.Email.Validate (isValid)
 
 import Model.Database
 import Model.User
-import Model.Payment
 import Model.SignIn
 import Model.Message
 
-import Config
-
-import View.Page (page)
-
-import Mail
+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
-      if isJust maybeUser
-        then do
+      case maybeUser of
+        Just user -> 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
+          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."
-        else
+        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
@@ -93,55 +83,3 @@ validateSignInAction token = do
 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/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/Mail.hs b/src/server/SendMail.hs
index c649d59..74d48ab 100644
--- a/src/server/Mail.hs
+++ b/src/server/SendMail.hs
@@ -1,55 +1,42 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Mail
-  ( Mail(..)
-  , sendMail
+module SendMail
+  ( 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 Control.Arrow (left)
 
 import qualified Network.Mail.Mime as M
 
-data Mail = Mail
-  { to :: [Text]
-  , subject :: Text
-  , plainBody :: Text
-  , htmlBody :: Text
-  } deriving (Eq, Show)
+import Model.Mail
 
 sendMail :: Mail -> IO (Either Text ())
 sendMail mail = do
-  result <- mapLeft (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ()))
+  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
 
-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.plainPart plainBody
+              , M.htmlPart htmlBody
               ]
             ]
         , M.mailHeaders = [("Subject", subject)]
         }
 
-strictToLazy :: Text -> LT.Text
-strictToLazy = toLazyText . fromText
-
 address :: Text -> M.Address
 address addressEmail =
   M.Address
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