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