1 {-# LANGUAGE OverloadedStrings #-} 2 module Service.Mail 3 ( initMailer 4 , Mailer(..) 5 , MonadMail 6 , sendMail 7 -- below for testing 8 , wrapText 9 ) where 10 11 import Control.Monad.IO.Class (liftIO) 12 import Data.Aeson (decode) 13 import qualified Data.ByteString as BS 14 import qualified Data.ByteString.Lazy as LBS 15 import Data.Int (Int64) 16 import Data.Monoid ((<>)) 17 import qualified Data.Text as T 18 import qualified Data.Text.Encoding as TE 19 import qualified Data.Text.Lazy as TL 20 import qualified Data.Text.Lazy.Encoding as TLE 21 import Data.Time.Clock (getCurrentTime) 22 import Network.Mail.Mime 23 import Network.Mail.SMTP (sendMailWithLogin', sendMail') 24 25 import Has 26 import Model.Party 27 import Service.Log 28 29 -- | Make an instance of Mailer with default sendMail implementation, for use in 30 -- settings where mailer is not being mocked 31 initMailer :: Mailer 32 initMailer = Mailer 33 { mlr = sendMailImpl 34 } 35 36 -- | Default implementation of sendMail to be used in most environments besides unit tests 37 sendMailImpl :: MailHost -> MailPort -> MailUser -> MailPass -> Mail -> IO () 38 sendMailImpl (MailHost host) (MailPort port) (MailUser "") (MailPass _) = 39 sendMail' host (fromIntegral port) 40 sendMailImpl (MailHost host) (MailPort port) (MailUser user) (MailPass pass) = 41 sendMailWithLogin' host (fromIntegral port) user pass 42 43 -- | Server hostname for smtp mail delivery 44 newtype MailHost = MailHost String 45 46 -- | Sever port for smtp mail delivery 47 newtype MailPort = MailPort Int 48 49 -- | Acount username for smtp mail delivery 50 newtype MailUser = MailUser String 51 52 -- | Account password for smtp mail delivery 53 newtype MailPass = MailPass String 54 55 -- | Parts of mailer that can be mocked 56 data Mailer = Mailer 57 { mlr :: MailHost -> MailPort -> MailUser -> MailPass -> Mail -> IO () 58 } 59 60 type MonadMail c m = (MonadLog c m, MonadHas Mailer c m) 61 62 -- |Wrap text to the given line length where possibleby changing some ' ' to '\n'. 63 -- >>> wrapText 10 $ TL.pack "hello there this is a test wherethereareexactlyvery long.\nLines.\n\nThing with multiple.\n" 64 -- "hello\nthere this\nis a test\nwherethereareexactlyvery\nlong.\nLines.\n\nThing with\nmultiple.\n" 65 wrapText :: Int64 -> TL.Text -> TL.Text 66 wrapText n = TL.unlines . concatMap wrap . TL.lines where 67 wrap s 68 | short s = [s] 69 | (h:l) <- TL.breakOnAll " " s = let (p,r) = fb h l in p : wrap (TL.tail r) 70 | otherwise = [s] 71 fb p [] = p 72 fb p (h@(t,_):l) 73 | short t = fb h l 74 | otherwise = p 75 short s = TL.compareLength s n <= EQ 76 77 baseMail :: Mail 78 baseMail = emptyMail (Address (Just "Databrary") "help@databrary.org") 79 80 mailHeader :: TL.Text 81 mailHeader = TL.empty 82 83 mailFooter :: TL.Text 84 mailFooter = "\n\ 85 \Sincerely,\n\ 86 \The Databrary Team\n\ 87 \-- \n\ 88 \Databrary\n\ 89 \196 Mercer Street, Suite 807\n\ 90 \212-998-5800\n\ 91 \contact@databrary.org\n\ 92 \databrary.org\n" 93 94 sendMail :: MonadMail c m => [Either BS.ByteString Account] -> [Either BS.ByteString Account] -> T.Text -> TL.Text -> m () 95 sendMail [] [] _ _ = return () 96 sendMail to cc subj body = do 97 mailer :: Mailer <- peek 98 t <- liftIO getCurrentTime 99 liftIO $ putStrLn "Retrieving mail config..." 100 Just (host, port :: Int, user, pass) <- fmap decode $ liftIO $ LBS.readFile "config/email" 101 focusIO $ logMsg t $ "mail " <> BS.intercalate ", " (map (either id accountEmail) to) <> ": " <> TE.encodeUtf8 subj 102 liftIO $ mlr mailer (MailHost host) (MailPort port) (MailUser user) (MailPass pass) $ addPart 103 [Part "text/plain; charset=utf-8" None Nothing [] $ TLE.encodeUtf8 $ mailHeader <> wrapText 78 body <> mailFooter] baseMail 104 { mailTo = map addr to 105 , mailCc = map addr cc 106 , mailHeaders = [("Subject", subj)] 107 } 108 where 109 addr (Left e) = Address Nothing (TE.decodeLatin1 e) 110 addr (Right Account{ accountEmail = email, accountParty = p }) = 111 Address (Just $ partyName $ partyRow p) (TE.decodeLatin1 email) 112