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