From f687b15d4d3f55fb231cd03b773b163ed131b129 Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Sun, 19 Jul 2015 18:50:49 +0200
Subject: Send the login token by email

---
 src/server/Application.hs   | 27 ++++++++++++++-------
 src/server/Mail.hs          | 58 +++++++++++++++++++++++++++++++++++++++++++++
 src/server/Model/Message.hs |  3 ++-
 3 files changed, 78 insertions(+), 10 deletions(-)
 create mode 100644 src/server/Mail.hs

(limited to 'src/server')

diff --git a/src/server/Application.hs b/src/server/Application.hs
index 6a18102..7bb305e 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -23,7 +23,6 @@ import Control.Monad.IO.Class (liftIO)
 
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
 import qualified Data.Text.Encoding as TE
 import Data.String (fromString)
 
@@ -41,6 +40,8 @@ import Model.Message
 
 import View.Page (page)
 
+import Mail
+
 getIndexAction :: ActionM ()
 getIndexAction = html page
 
@@ -87,14 +88,22 @@ signInAction login =
         (Just _, Just host) -> do
           token <- liftIO . runDb $ createSignInToken login
           let url = T.concat ["http://", host ,"/validateSignIn?token=", token]
-          liftIO . TIO.putStrLn $ url
-          status ok200
-        _ -> do
-          status badRequest400
-          json (Message "You are not authorized to sign in.")
-    else do
-      status badRequest400
-      json (Message "Please enter a valid email address.")
+          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."
+        _ ->
+          errorResponse "You are not authorized to sign in."
+    else
+      errorResponse "Please enter a valid email address."
+
+errorResponse :: Text -> ActionM ()
+errorResponse message = do
+  status badRequest400
+  json (Message message)
 
 validateSignInAction :: Text -> ActionM ()
 validateSignInAction token = do
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
+    }
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
index 6b4287e..d84aaa9 100644
--- a/src/server/Model/Message.hs
+++ b/src/server/Model/Message.hs
@@ -5,10 +5,11 @@ module Model.Message
   ) where
 
 import Data.Aeson
+import Data.Text (Text)
 import GHC.Generics
 
 data Message = Message
-  { message :: String
+  { message :: Text
   } deriving (Show, Generic)
 
 instance FromJSON Message
-- 
cgit v1.2.3