Send the login token by email

1 files changed, 58 insertions, 0 deletions

diff --git a/src/server/Mail.hs b/src/server/Mail.hs
new file mode 100644
index 0000000..c649d59
--- /dev/null
+++ b/src/server/Mail.hs
@@ -0,0 +1,58 @@
+{-# 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
+    }