78 lines
2.5 KiB
Haskell
78 lines
2.5 KiB
Haskell
module Handler.Utils.Mail
|
|
( addRecipientsDB
|
|
, userAddress, userAddressFrom
|
|
, userMailT
|
|
, addFileDB
|
|
) where
|
|
|
|
import Import
|
|
|
|
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 Control.Monad.Trans.State (StateT)
|
|
|
|
|
|
addRecipientsDB :: ( MonadMail 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 (liftHandler . 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
|
|
|
|
userAddressFrom :: User -> Address
|
|
-- ^ Format an e-mail address suitable for usage in a @From@-header
|
|
--
|
|
-- Uses `userDisplayEmail`
|
|
userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
|
|
|
|
userAddress :: User -> Address
|
|
-- ^ Format an e-mail address suitable for usage as a recipient
|
|
--
|
|
-- Uses `userEmail`
|
|
userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
|
|
|
|
userMailT :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadThrow m
|
|
, MonadUnliftIO m
|
|
) => UserId -> MailT m a -> m a
|
|
userMailT uid mAct = do
|
|
user@User
|
|
{ userLanguages
|
|
, userDateTimeFormat
|
|
, userDateFormat
|
|
, userTimeFormat
|
|
} <- liftHandler . runDB $ getJust uid
|
|
let
|
|
ctx = MailContext
|
|
{ mcLanguages = fromMaybe def userLanguages
|
|
, mcDateTimeFormat = \case
|
|
SelFormatDateTime -> userDateTimeFormat
|
|
SelFormatDate -> userDateFormat
|
|
SelFormatTime -> userTimeFormat
|
|
}
|
|
mailT ctx $ do
|
|
_mailTo .= pure (userAddress user)
|
|
mAct
|
|
|
|
addFileDB :: ( MonadMail m
|
|
, HandlerSite m ~ UniWorX
|
|
) => FileId -> m (Maybe MailObjectId)
|
|
addFileDB fId = runMaybeT $ do
|
|
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId
|
|
lift . addPart $ do
|
|
_partType .= decodeUtf8 (mimeLookup fileName)
|
|
_partEncoding .= Base64
|
|
_partFilename .= Just fileName
|
|
_partContent .= LBS.fromStrict fileContent
|
|
setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId
|