chore(mail): mail display towards #171
This commit is contained in:
parent
4df8bd2fa5
commit
21d32fd4cf
@ -150,7 +150,8 @@ MenuPrintLog: LPR Schnittstelle
|
||||
MenuPrintAck: Druckbestätigung
|
||||
|
||||
MenuMailCenter: E‑Mails
|
||||
MenuMailShow: Anzeige
|
||||
MenuMailHtml !ident-ok: Html
|
||||
MenuMailPlain !ident-ok: Text
|
||||
|
||||
MenuApiDocs: API-Dokumentation (Englisch)
|
||||
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
|
||||
|
||||
@ -150,7 +150,8 @@ MenuPrintLog: LPR Interface
|
||||
MenuPrintAck: Acknowledge Printing
|
||||
|
||||
MenuMailCenter: Email
|
||||
MenuMailShow: Display
|
||||
MenuMailHtml: Html
|
||||
MenuMailPlain: Text
|
||||
|
||||
MenuApiDocs: API documentation
|
||||
MenuSwagger: OpenAPI 2.0 (Swagger)
|
||||
|
||||
3
routes
3
routes
@ -85,7 +85,8 @@
|
||||
/print/log PrintLogR GET !system-printer
|
||||
|
||||
/mail MailCenterR GET POST
|
||||
/mail/show/#CryptoUUIDSentMail MailShowR GET
|
||||
/mail/html/#CryptoUUIDSentMail MailHtmlR GET
|
||||
/mail/plain/#CryptoUUIDSentMail MailPlainR GET
|
||||
|
||||
/health HealthR GET !free
|
||||
/health/interface/+Texts HealthInterfaceR GET !free
|
||||
|
||||
@ -48,6 +48,7 @@ module Database.Esqueleto.Utils
|
||||
, subSelectCountDistinct
|
||||
, selectCountRows, selectCountDistinct
|
||||
, selectMaybe
|
||||
, str2text
|
||||
, num2text --, text2num
|
||||
, day, day', dayMaybe, interval, diffDays, diffTimes
|
||||
, exprLift
|
||||
@ -328,7 +329,7 @@ mkExactFilterLastWith :: (PersistField b)
|
||||
-> Last a -- ^ needle
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
mkExactFilterLastWith cast lenslike row criterias
|
||||
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
|
||||
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
|
||||
| otherwise = true
|
||||
|
||||
-- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
|
||||
@ -409,7 +410,7 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
|
||||
| Set.null compulsories = cond_optional
|
||||
| Set.null alternatives = cond_compulsory
|
||||
| otherwise = cond_compulsory E.&&. cond_optional
|
||||
where
|
||||
where
|
||||
(Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
|
||||
cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
|
||||
cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives
|
||||
@ -516,7 +517,7 @@ selectExists query = do
|
||||
_other -> error "SELECT EXISTS ... returned zero or more than one rows"
|
||||
selectNotExists = fmap not . selectExists
|
||||
|
||||
filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
|
||||
filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
|
||||
=> EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
|
||||
filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
|
||||
ent <- Ex.from Ex.table
|
||||
@ -655,7 +656,7 @@ infixl 8 ->.
|
||||
|
||||
infixl 8 ->>.
|
||||
|
||||
(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
|
||||
(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
|
||||
(->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
|
||||
|
||||
infixl 8 ->>>.
|
||||
@ -682,7 +683,7 @@ unKey = E.veryUnsafeCoerceSqlExprValue
|
||||
-- | distinct version of `Database.Esqueleto.subSelectCount`
|
||||
subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
|
||||
subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
|
||||
|
||||
|
||||
-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
|
||||
-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
|
||||
|
||||
@ -707,6 +708,10 @@ selectCountDistinct q = do
|
||||
selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
|
||||
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
|
||||
|
||||
-- | convert something that is like a text to text
|
||||
str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text)
|
||||
str2text = E.unsafeSqlCastAs "text"
|
||||
|
||||
-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
|
||||
num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
|
||||
num2text = E.unsafeSqlCastAs "text"
|
||||
@ -726,9 +731,9 @@ dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day
|
||||
dayMaybe = E.unsafeSqlCastAs "date"
|
||||
|
||||
interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day
|
||||
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
|
||||
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
|
||||
interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
|
||||
where
|
||||
where
|
||||
singleQuote = Text.Builder.singleton '\''
|
||||
wrapSqlString b = singleQuote <> b <> singleQuote
|
||||
|
||||
@ -775,12 +780,12 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
|
||||
|
||||
|
||||
-- Suspected to cause trouble. Needs more testing!
|
||||
-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
|
||||
-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
|
||||
-- => record -> ReaderT backend m ()
|
||||
-- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> " RESTART IDENTITY") []
|
||||
|
||||
truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code
|
||||
=> proxy record -> ReaderT backend m ()
|
||||
truncateTable tbl =
|
||||
truncateTable tbl =
|
||||
let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
|
||||
in E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []
|
||||
@ -137,7 +137,8 @@ breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenter
|
||||
breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR
|
||||
|
||||
breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter Nothing
|
||||
breadcrumb MailShowR{} = i18nCrumb MsgMenuMailShow $ Just MailCenterR
|
||||
breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR
|
||||
breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR
|
||||
|
||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||
@ -2477,8 +2478,25 @@ pageActions PrintCenterR = do
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
emailCenter = NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuMailCenter $ MailCenterR
|
||||
, navChildren = []
|
||||
}
|
||||
dayLinks <- mapM toDayAck $ Map.toAscList dayMap
|
||||
return $ manualSend : printLog : printAck : take 9 dayLinks
|
||||
return $ emailCenter : manualSend : printLog : printAck : take 9 dayLinks
|
||||
|
||||
pageActions (MailHtmlR smid) = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions (MailPlainR smid) = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
|
||||
pageActions AdminCrontabR = return
|
||||
[ NavPageActionPrimary
|
||||
|
||||
@ -6,7 +6,8 @@
|
||||
|
||||
module Handler.MailCenter
|
||||
( getMailCenterR, postMailCenterR
|
||||
, getMailShowR
|
||||
, getMailHtmlR
|
||||
, getMailPlainR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -31,6 +32,18 @@ import Handler.Utils
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
-- import Jobs.Queue
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
|
||||
-- import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
-- import Data.Text (Text)
|
||||
|
||||
|
||||
-- import qualified Data.Text.Lazy as LT
|
||||
-- import qualified Data.Text.Lazy.Encoding as LT
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
|
||||
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
@ -58,20 +71,19 @@ type MCTableExpr =
|
||||
queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
|
||||
queryMail = $(sqlLOJproj 2 1)
|
||||
|
||||
{-
|
||||
|
||||
queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryRecipient = $(sqlLOJproj 2 2)
|
||||
-}
|
||||
|
||||
|
||||
type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))
|
||||
|
||||
resultMail :: Lens' MCTableData (Entity SentMail)
|
||||
resultMail = _dbrOutput . _1
|
||||
|
||||
{-
|
||||
resultRecipient :: Traversal' MCTableData (Entity User)
|
||||
resultRecipient = _dbrOutput . _2 . _Just
|
||||
-}
|
||||
|
||||
|
||||
mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
|
||||
mkMCTable = do
|
||||
@ -85,15 +97,27 @@ mkMCTable = do
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (resultMail . _entityKey))
|
||||
, sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t -- TODO: msg
|
||||
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
|
||||
let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
|
||||
linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
|
||||
in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
|
||||
, sortable Nothing (i18nCell MsgMenuMailHtml) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
|
||||
, sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
|
||||
, single ("recipient" , sortUserNameBareM queryRecipient)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("sent" , FilterColumn . E.mkDayFilter $ views (to queryMail) (E.^. SentMailSentAt))
|
||||
[ single ("sent" , FilterColumn . E.mkDayFilter $ views (to queryMail) (E.^. SentMailSentAt))
|
||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, single ("subject" , FilterColumn . E.mkContainsFilter $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- TODO: msg
|
||||
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
dbtIdent :: Text
|
||||
@ -140,5 +164,104 @@ postMailCenterR = do
|
||||
$(widgetFile "mail-center")
|
||||
|
||||
|
||||
getMailShowR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailShowR _ = error "TODO: STUB"
|
||||
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailHtmlR = handleMailShow [typeHtml,typePlain]
|
||||
|
||||
getMailPlainR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailPlainR = handleMailShow [typePlain,typeHtml]
|
||||
|
||||
handleMailShow :: [ContentType] -> CryptoUUIDSentMail -> Handler Html
|
||||
handleMailShow prefTypes cusm = do
|
||||
smid <- decrypt cusm
|
||||
(sm,cn) <- runDB $ do
|
||||
sm <- get404 smid
|
||||
cn <- get404 $ sm ^. _sentMailContentRef
|
||||
return (sm,cn)
|
||||
siteLayoutMsg MsgMenuMailCenter $ do
|
||||
setTitleI MsgMenuMailCenter
|
||||
let mcontent = getMailContent (sentMailContentContent cn)
|
||||
getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
|
||||
[whamlet|
|
||||
<section>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
_{MsgPrintJobCreated}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
|
||||
$maybe r <- getHeader "From"
|
||||
<dt .deflist__dt>
|
||||
_{MsgPrintSender}
|
||||
<dd .deflist__dd>
|
||||
#{r}
|
||||
$maybe r <- getHeader "To"
|
||||
<dt .deflist__dt>
|
||||
_{MsgPrintRecipient}
|
||||
<dd .deflist__dd>
|
||||
#{r}
|
||||
$maybe r <- getHeader "Subject"
|
||||
<dt .deflist__dt>
|
||||
_{MsgCommSubject}
|
||||
<dd .deflist__dd>
|
||||
#{r}
|
||||
|
||||
<section>
|
||||
$forall mc <- mcontent
|
||||
$maybe pt <- selectAlternative prefTypes mc
|
||||
<p>
|
||||
^{part2widget pt}
|
||||
|]
|
||||
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
|
||||
-- ^{jsonWidget (sentMailContentContent cn)}
|
||||
|
||||
|
||||
{-
|
||||
alternative2widget :: Alternatives -> Widget
|
||||
alternative2widget alt = -- show all parts for now TODO: select only best representation for each
|
||||
[whamlet|
|
||||
<section>
|
||||
$forall p <- alt
|
||||
^{part2widget p}
|
||||
<hr>
|
||||
|]
|
||||
-}
|
||||
|
||||
selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
|
||||
selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
|
||||
where
|
||||
aux ts@(ct:_) (pt:ps)
|
||||
| ct == partType pt = Just pt
|
||||
| otherwise = aux ts ps
|
||||
aux (_:ts) [] = aux ts allAlts
|
||||
aux [] (pt:_) = Just pt
|
||||
aux _ [] = Nothing
|
||||
|
||||
disposition2widget :: Disposition -> Widget
|
||||
disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
|
||||
disposition2widget (InlineDisposition n) = [whamlet|<h3>#{n}|]
|
||||
disposition2widget DefaultDisposition = mempty
|
||||
|
||||
|
||||
part2widget :: Part -> Widget
|
||||
part2widget Part{partContent=NestedParts ps} =
|
||||
[whamlet|
|
||||
<section>
|
||||
$forall p <- ps
|
||||
^{part2widget p}
|
||||
<hr>
|
||||
<hr>
|
||||
|]
|
||||
part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
|
||||
[whamlet|
|
||||
<section>
|
||||
^{disposition2widget dispo}
|
||||
^{showBody}
|
||||
<hr>
|
||||
|]
|
||||
where
|
||||
showBody
|
||||
| pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
|
||||
| pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
|
||||
| pt == decodeUtf8 typeJson =
|
||||
let jw :: Aeson.Value -> Widget = jsonWidget
|
||||
in either str2widget jw $ Aeson.eitherDecodeStrict' pc
|
||||
| otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
|
||||
|
||||
45
src/Mail.hs
45
src/Mail.hs
@ -38,7 +38,7 @@ module Mail
|
||||
, setDate, setDateCurrent
|
||||
, getMailSmtpData
|
||||
, _addressName, _addressEmail
|
||||
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
|
||||
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts
|
||||
, _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
|
||||
) where
|
||||
|
||||
@ -140,9 +140,9 @@ import Web.HttpApiData (ToHttpApiData(toHeader))
|
||||
|
||||
newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
|
||||
deriving (Show, Generic)
|
||||
instance Eq AddressEqIgnoreName where
|
||||
instance Eq AddressEqIgnoreName where
|
||||
(==) = (==) `on` (addressEmail . getAddress)
|
||||
instance Ord AddressEqIgnoreName where
|
||||
instance Ord AddressEqIgnoreName where
|
||||
compare = compare `on` (addressEmail . getAddress)
|
||||
|
||||
|
||||
@ -159,16 +159,19 @@ _partFilename = _partDisposition . dispositionFilename
|
||||
dispositionFilename _ DefaultDisposition = pure DefaultDisposition
|
||||
|
||||
_mailHeader :: CI ByteString -> Traversal' Mail Text
|
||||
_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
|
||||
_mailHeader = (_mailHeaders .) . _mailHeader'
|
||||
|
||||
_mailReplyTo' :: Lens' Mail Text
|
||||
_mailHeader' :: CI ByteString -> Traversal' Headers Text
|
||||
_mailHeader' hdrName = traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
|
||||
|
||||
_mailReplyTo' :: Lens' Mail Text
|
||||
_mailReplyTo' = _mailHeaders . _headerReplyTo'
|
||||
|
||||
_headerReplyTo' :: Lens' Headers Text
|
||||
_headerReplyTo' :: Lens' Headers Text
|
||||
-- Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
|
||||
_headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
|
||||
_mailReplyTo :: Lens' Mail Address
|
||||
_mailReplyTo = _mailHeaders . _headerReplyTo
|
||||
@ -176,8 +179,8 @@ _mailReplyTo = _mailHeaders . _headerReplyTo
|
||||
_headerReplyTo :: Lens' Headers Address
|
||||
-- Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
|
||||
_headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
-- _addressEmail :: Lens' Address Text might help to simplify this code?
|
||||
|
||||
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
|
||||
@ -270,7 +273,7 @@ instance Exception MailException
|
||||
class Yesod site => YesodMail site where
|
||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||
defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
|
||||
|
||||
|
||||
envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||
envelopeFromAddress = addressEmail <$> defaultFromAddress
|
||||
|
||||
@ -336,12 +339,12 @@ defMailT :: ( MonadHandler m
|
||||
-> MailT m a
|
||||
-> m a
|
||||
defMailT ls (MailT mailC) = do
|
||||
fromAddress <- defaultFromAddress
|
||||
(ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
|
||||
fromAddress <- defaultFromAddress
|
||||
(ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
|
||||
mail1 <- maybeT (return mail0) $ do
|
||||
guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
|
||||
domain <- mailObjectIdDomain
|
||||
let sender = mail0 ^. _mailFrom
|
||||
let sender = mail0 ^. _mailFrom
|
||||
isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
|
||||
$logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
|
||||
guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
|
||||
@ -378,7 +381,7 @@ instance Semigroup (PrioritisedAlternatives m) where
|
||||
(<>) = mappenddefault
|
||||
|
||||
instance Monoid (PrioritisedAlternatives m) where
|
||||
mempty = memptydefault
|
||||
mempty = memptydefault
|
||||
|
||||
class YesodMail site => ToMailPart site a where
|
||||
type MailPartReturn site a :: Type
|
||||
@ -452,14 +455,14 @@ instance YesodMail site => ToMailPart site YamlValue where
|
||||
_partContent .= PartContent (fromStrict $ Yaml.encode val)
|
||||
|
||||
|
||||
data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
|
||||
data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
|
||||
|
||||
instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
|
||||
type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
|
||||
toMailPart nmp = do
|
||||
r <- toMailPart $ namedPart nmp
|
||||
toMailPart nmp = do
|
||||
r <- toMailPart $ namedPart nmp
|
||||
_partDisposition .= disposition nmp
|
||||
return r
|
||||
return r
|
||||
|
||||
|
||||
addAlternatives :: (MonadMail m)
|
||||
@ -546,7 +549,7 @@ lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
|
||||
lookupMailHeader = fmap listToMaybe . getMailHeaders
|
||||
|
||||
mapMailHeader :: MonadHeader m => MailHeader -> (Text -> Text) -> m ()
|
||||
mapMailHeader header f = modifyHeaders $ adjustAssoc f header
|
||||
mapMailHeader header f = modifyHeaders $ adjustAssoc f header
|
||||
|
||||
replaceMailHeaderI :: ( RenderMessage site msg
|
||||
, MonadMail m
|
||||
@ -642,5 +645,5 @@ getMailSmtpData = execWriterT $ do
|
||||
|
||||
tell $ mempty
|
||||
{ smtpRecipients = recps
|
||||
, smtpEnvelopeFrom = Last $ Just from
|
||||
, smtpEnvelopeFrom = Last $ Just from
|
||||
}
|
||||
|
||||
@ -34,6 +34,7 @@ import Data.ByteString.Base32
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
|
||||
-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
|
||||
--
|
||||
@ -121,7 +122,7 @@ instance PathPiece BounceSecret where
|
||||
toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
|
||||
fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
|
||||
|
||||
newtype MailContent = MailContent [Alternatives]
|
||||
newtype MailContent = MailContent {getMailContent :: [Alternatives]}
|
||||
deriving (Eq, Show, Generic)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
deriving anyclass (Binary, NFData)
|
||||
@ -140,3 +141,5 @@ instance PersistFieldSql MailContentReference where
|
||||
sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
|
||||
|
||||
derivePersistFieldJSON ''MailHeaders
|
||||
|
||||
instance E.SqlString MailHeaders
|
||||
@ -56,8 +56,7 @@ instance Csv.ToNamedRecord Address where
|
||||
instance Csv.DefaultOrdered Address where
|
||||
headerOrder _ = Csv.header [ "name", "email" ]
|
||||
|
||||
|
||||
newtype MailHeaders = MailHeaders Headers
|
||||
newtype MailHeaders = MailHeaders {toHeaders:: Headers}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
@ -79,7 +78,7 @@ deriving anyclass instance NFData PartContent
|
||||
deriving anyclass instance NFData Part
|
||||
deriving anyclass instance NFData Address
|
||||
deriving anyclass instance NFData Mail
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
} ''Encoding
|
||||
|
||||
@ -186,8 +186,8 @@ class HasEntity c record where
|
||||
hasEntity :: Lens' c (Entity record)
|
||||
|
||||
--Trivial instance, usefull for lifting to maybes
|
||||
instance HasEntity (Entity r) r where
|
||||
hasEntity = id
|
||||
instance HasEntity (Entity r) r where
|
||||
hasEntity = id
|
||||
|
||||
-- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want.
|
||||
hasEntityUser :: (HasEntity a User) => Lens' a (Entity User)
|
||||
@ -299,6 +299,9 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
makeWrapped ''Textarea
|
||||
makeLenses_ ''SentMail
|
||||
|
||||
_mailHeaders' :: Iso' MailHeaders Headers
|
||||
_mailHeaders' = coerced
|
||||
|
||||
makePrisms ''RoomReference
|
||||
makeLenses_ ''RoomReference
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user