aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Application.hs27
-rw-r--r--src/server/Mail.hs58
-rw-r--r--src/server/Model/Message.hs3
3 files changed, 78 insertions, 10 deletions
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