Mailgun.hs

{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Network.Mail.Newsletter.Mailgun where

import           Control.Lens
import           Control.Monad.Catch
import           Control.Monad.Reader
import           Data.Machine
import           Data.Machine as M
import           Data.Text (Text)
import           Network.Mail.Mime
import qualified Network.Mail.Mailgun as MG
import           Network.Mail.Newsletter.Class

data MailgunNewsletterContext
 = MGNL
   { _mgnlMailgunContext :: MG.MailgunConfig
   , _mgnlName :: Address
   }

makeLenses ''MailgunNewsletterContext

instance MG.HasMailgunConfig MailgunNewsletterContext where
  mailgunConfig = mgnlMailgunContext

newtype MailgunNewsT m a =
    MailgunNewsT { runMailgunNewsT :: MailgunNewsletterContext -> m a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch
           ,MonadReader MailgunNewsletterContext)
     via (ReaderT MailgunNewsletterContext m)
  deriving (MonadTrans)
     via (ReaderT MailgunNewsletterContext)

instance (MonadIO m, MonadThrow m) => Newsletter (MailgunNewsT m) where
  subscribe   = M.mapping (\(addr, d) ->
                  MG.ListMember (maybe "" id . addressName $ addr) (addressEmail addr) True d) ~>
                preplan ((fmap (const ())) <$> ((MG.addMembers False . addressEmail) <$> view mgnlName))
  unsubscribe = M.mapping addressEmail ~>
                preplan (autoM <$> ((MG.removeMember . addressEmail) <$> view mgnlName))
  subscribers = preplan ((MG.listMembers (Just True) . addressEmail) <$> view mgnlName) ~>
                M.mapping (\(MG.ListMember mn addr _ d) ->
                  (Address (if mn=="" then Just mn else Nothing) addr, d))
  sendEmail mkMail = do
    ml <- view mgnlName
    void $ MG.send Nothing [ml] (mkMail ml)
  sendSubscribe newUser mkMail =
    join $ void . MG.send Nothing [newUser] <$> (mkMail <$> view mgnlName)