1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.Service.Mail 3 ( MonadMail 4 , sendMail 5 -- below for testing 6 , wrapText 7 ) where 8 9 import Control.Monad.IO.Class (liftIO) 10 import Data.Aeson (decode) 11 import qualified Data.ByteString as BS 12 import qualified Data.ByteString.Lazy as LBS 13 import Data.Int (Int64) 14 import Data.Monoid ((<>)) 15 import qualified Data.Text as T 16 import qualified Data.Text.Encoding as TE 17 import qualified Data.Text.Lazy as TL 18 import qualified Data.Text.Lazy.Encoding as TLE 19 import Data.Time.Clock (getCurrentTime) 20 import Network.Mail.Mime 21 import Network.Mail.SMTP (sendMailWithLogin', sendMail') 22 23 import Databrary.Has 24 import Databrary.Model.Party 25 import Databrary.Service.Log 26 27 type MonadMail c m = (MonadLog c m) 28 29 -- |Wrap text to the given line length where possibleby changing some ' ' to '\n'. 30 -- >>> wrapText 10 $ TL.pack "hello there this is a test wherethereareexactlyvery long.\nLines.\n\nThing with multiple.\n" 31 -- "hello\nthere this\nis a test\nwherethereareexactlyvery\nlong.\nLines.\n\nThing with\nmultiple.\n" 32 wrapText :: Int64 -> TL.Text -> TL.Text 33 wrapText n = TL.unlines . concatMap wrap . TL.lines where 34 wrap s 35 | short s = [s] 36 | (h:l) <- TL.breakOnAll " " s = let (p,r) = fb h l in p : wrap (TL.tail r) 37 | otherwise = [s] 38 fb p [] = p 39 fb p (h@(t,_):l) 40 | short t = fb h l 41 | otherwise = p 42 short s = TL.compareLength s n <= EQ 43 44 baseMail :: Mail 45 baseMail = emptyMail (Address (Just "Databrary") "help@databrary.org") 46 47 mailHeader :: TL.Text 48 mailHeader = TL.empty 49 50 mailFooter :: TL.Text 51 mailFooter = "\n\ 52 \Sincerely,\n\ 53 \The Databrary Team\n\ 54 \-- \n\ 55 \Databrary\n\ 56 \196 Mercer Street, Suite 807\n\ 57 \212-998-5800\n\ 58 \contact@databrary.org\n\ 59 \databrary.org\n" 60 61 sendMail :: MonadMail c m => [Either BS.ByteString Account] -> [Either BS.ByteString Account] -> T.Text -> TL.Text -> m () 62 sendMail [] [] _ _ = return () 63 sendMail to cc subj body = do 64 t <- liftIO getCurrentTime 65 liftIO $ putStrLn "Retrieving mail config..." 66 Just (host, port :: Int, user, pass) <- fmap decode $ liftIO $ LBS.readFile "config/email" 67 focusIO $ logMsg t $ "mail " <> BS.intercalate ", " (map (either id accountEmail) to) <> ": " <> TE.encodeUtf8 subj 68 liftIO $ sendMailImpl host port user pass $ addPart 69 [Part "text/plain; charset=utf-8" None Nothing [] $ TLE.encodeUtf8 $ mailHeader <> wrapText 78 body <> mailFooter] baseMail 70 { mailTo = map addr to 71 , mailCc = map addr cc 72 , mailHeaders = [("Subject", subj)] 73 } 74 where 75 sendMailImpl :: String -> Int -> String -> String -> Mail -> IO () 76 sendMailImpl host port "" _ = sendMail' host (fromIntegral port) 77 sendMailImpl host port user pass = 78 sendMailWithLogin' host (fromIntegral port) user pass 79 addr (Left e) = Address Nothing (TE.decodeLatin1 e) 80 addr (Right Account{ accountEmail = email, accountParty = p }) = 81 Address (Just $ partyName $ partyRow p) (TE.decodeLatin1 email) 82