73 lines
2.2 KiB
Haskell
73 lines
2.2 KiB
Haskell
module Handler.Utils.Mail
|
|
( addRecipientsDB
|
|
, userMailT
|
|
, addFileDB
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Lens hiding (snoc)
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import System.FilePath (takeBaseName)
|
|
import Network.Mime (defaultMimeLookup)
|
|
|
|
import Control.Monad.Trans.State (StateT)
|
|
|
|
|
|
addRecipientsDB :: ( MonadMail m
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
) => [Filter User] -> m ()
|
|
-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
|
|
addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
|
|
where
|
|
addRecipient (Entity _ User{userEmail, userDisplayName}) = do
|
|
let addr = Address (Just userDisplayName) $ CI.original userEmail
|
|
_mailTo %= flip snoc addr
|
|
|
|
userMailT :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadBaseControl IO m
|
|
, MonadLogger m
|
|
) => UserId -> MailT m a -> m a
|
|
userMailT uid mAct = do
|
|
User
|
|
{ userEmail
|
|
, userDisplayName
|
|
, userMailLanguages
|
|
, userDateTimeFormat
|
|
, userDateFormat
|
|
, userTimeFormat
|
|
} <- liftHandlerT . runDB $ getJust uid
|
|
let
|
|
addr = Address (Just userDisplayName) $ CI.original userEmail
|
|
ctx = MailContext
|
|
{ mcLanguages = userMailLanguages
|
|
, mcDateTimeFormat = \case
|
|
SelFormatDateTime -> userDateTimeFormat
|
|
SelFormatDate -> userDateFormat
|
|
SelFormatTime -> userTimeFormat
|
|
}
|
|
mailT ctx $ do
|
|
_mailTo .= pure addr
|
|
mAct
|
|
|
|
addFileDB :: ( MonadMail m
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
) => FileId -> m MailObjectId
|
|
addFileDB fId = do
|
|
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
|
|
addPart $ do
|
|
_partType .= decodeUtf8 (defaultMimeLookup fileName)
|
|
_partEncoding .= Base64
|
|
_partFilename .= Just fileName
|
|
_partContent .= LBS.fromStrict fileContent
|
|
setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
|