Wording for sign in email

1 files changed, 45 insertions, 0 deletions

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
+    }