chore(mail): reworked testmail to test named attachments
This commit is contained in:
Steffen Jost
parent
fea058cffc
commit
e185015b75
@ -252,7 +252,7 @@ instance CsvColumnsExplained LmsTableCsv where
|
||||
|
||||
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
|
||||
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
|
||||
|
||||
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
|
||||
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
|
||||
@ -312,12 +312,12 @@ isRenewPinAct LmsActRenewPinData = True
|
||||
|
||||
lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
||||
, E.SqlExpr (Entity User)
|
||||
, E.SqlExpr (Maybe (Entity LmsUser))
|
||||
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime]))
|
||||
, E.SqlExpr (Maybe (Entity LmsUser))
|
||||
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
|
||||
)
|
||||
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
|
||||
-- RECALL: another outer join on PrintJob did not work out well, since
|
||||
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
|
||||
-- RECALL: another outer join on PrintJob did not work out well, since
|
||||
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
|
||||
-- - using noExsists on printJob join condition works, but only deliver single value;
|
||||
-- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
|
||||
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
||||
@ -327,7 +327,9 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
|
||||
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
|
||||
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
||||
E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser))
|
||||
pure $ E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) [E.desc $ pj E.^. PrintJobCreated] -- latest comes first! This is assumed to be the case later on!
|
||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
return (qualUser, user, lmsUser, printAcknowledged)
|
||||
|
||||
|
||||
@ -368,7 +370,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
|
||||
, single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin))
|
||||
, single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
|
||||
, single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
|
||||
, single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
|
||||
, single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
@ -382,7 +384,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||
| otherwise -> E.true
|
||||
)
|
||||
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
|
||||
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||
@ -487,15 +489,15 @@ postLmsR sid qsh = do
|
||||
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
|
||||
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified
|
||||
recipient = row ^. hasUser
|
||||
letterDates = row ^? resultPrintAck
|
||||
letterDates = row ^? resultPrintAck
|
||||
lastLetterDate = headDef Nothing =<< letterDates
|
||||
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
|
||||
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
|
||||
notNotified = isNothing notifyDate
|
||||
cIcon = iconFixedCell $ iconLetterOrEmail letterSent
|
||||
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
|
||||
| Just d <- lastLetterDate -> dateTimeCell d
|
||||
| otherwise -> i18nCell MsgPrintJobUnacknowledged
|
||||
cAckDates = case letterDates of
|
||||
| Just d <- lastLetterDate -> dateTimeCell d
|
||||
| otherwise -> i18nCell MsgPrintJobUnacknowledged
|
||||
cAckDates = case letterDates of
|
||||
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
|
||||
<h1>
|
||||
_{MsgPrintJobAcknowledgements} ^{userWidget recipient}
|
||||
|
||||
@ -9,6 +9,7 @@ module Handler.Utils.Mail
|
||||
, addFileDB
|
||||
, addHtmlMarkdownAlternatives
|
||||
, addHtmlMarkdownAlternatives'
|
||||
, addHtmlMarkdownAlternatives''
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -126,26 +127,36 @@ addHtmlMarkdownAlternatives html' = do
|
||||
{ P.writerReferenceLinks = True
|
||||
}
|
||||
|
||||
{-
|
||||
addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
|
||||
, MonadMail m
|
||||
, ToMailPart (HandlerSite m) Html
|
||||
-- | provide a name for the part
|
||||
addHtmlMarkdownAlternatives' :: ( MonadMail m
|
||||
, ToMailPart (HandlerSite m) (NamedMailPart Html)
|
||||
, ToMailHtml (HandlerSite m) a
|
||||
) => a -> m ()
|
||||
addHtmlMarkdownAlternatives' = addHtmlMarkdownAlternatives
|
||||
-}
|
||||
|
||||
-- For now failed attempt to use with i18nHaletFile or widgets:
|
||||
addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
|
||||
, MonadMail m
|
||||
, YesodMail (HandlerSite m)
|
||||
) => Html -> m ()
|
||||
addHtmlMarkdownAlternatives' html = do
|
||||
) => Text -> a -> m ()
|
||||
addHtmlMarkdownAlternatives' fn html' = do
|
||||
html <- toMailHtml html'
|
||||
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
|
||||
|
||||
addAlternatives $ do
|
||||
providePreferredAlternative html
|
||||
whenIsJust markdown provideAlternative
|
||||
providePreferredAlternative $ NamedMailPart { namedPart = html, disposition = AttachmentDisposition fn }
|
||||
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
|
||||
where
|
||||
writerOptions = markdownWriterOptions
|
||||
{ P.writerReferenceLinks = True
|
||||
}
|
||||
|
||||
|
||||
-- | provide a name for the part
|
||||
addHtmlMarkdownAlternatives'' :: ( MonadMail m
|
||||
, ToMailPart (HandlerSite m) (NamedMailPart Html)
|
||||
, ToMailHtml (HandlerSite m) a
|
||||
) => Text -> a -> m ()
|
||||
addHtmlMarkdownAlternatives'' fn html' = do
|
||||
html <- toMailHtml html'
|
||||
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
|
||||
|
||||
addAlternatives $ do
|
||||
providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition fn, namedPart = html }
|
||||
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
|
||||
where
|
||||
writerOptions = markdownWriterOptions
|
||||
{ P.writerReferenceLinks = True
|
||||
|
||||
@ -10,17 +10,11 @@ import Import
|
||||
|
||||
import Handler.Utils.Mail
|
||||
import Handler.Utils.DateTime
|
||||
-- import Handler.Utils.I18n
|
||||
|
||||
dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX
|
||||
dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do
|
||||
_mailTo .= [Address Nothing jEmail]
|
||||
-- TODO: remove me after the test!
|
||||
addHtmlMarkdownAlternatives $ \(MsgRenderer _mr) -> [shamlet|
|
||||
<h1>
|
||||
Testheader
|
||||
<p>
|
||||
Dieser Abschnitt ist ein Test, ob mehrfache Mailparts ankommen.
|
||||
|]
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI MsgMailTestSubject
|
||||
now <- liftIO getCurrentTime
|
||||
@ -38,7 +32,7 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
|
||||
<li>#{nD}
|
||||
<li>#{nT}
|
||||
|]
|
||||
addHtmlMarkdownAlternatives $ \(MsgRenderer mr) -> [shamlet|
|
||||
addHtmlMarkdownAlternatives' "addOne" $ \(MsgRenderer mr) -> [shamlet|
|
||||
<h2>Repetition just for Testing
|
||||
<p>
|
||||
#{mr MsgMailTestContent}
|
||||
@ -50,3 +44,19 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
|
||||
<li>#{nD}
|
||||
<li>#{nT}
|
||||
|]
|
||||
addHtmlMarkdownAlternatives'' "addTwo" $ \(MsgRenderer mr) -> [shamlet|
|
||||
<h2>Repetition just for Testing
|
||||
<p>
|
||||
#{mr MsgMailTestContent}
|
||||
|
||||
<p>
|
||||
#{mr MsgMailTestDateTime}
|
||||
<ul>
|
||||
<li>#{nDT}
|
||||
<li>#{nD}
|
||||
<li>#{nT}
|
||||
|]
|
||||
-- let test = $(i18nHamletFile "test")
|
||||
-- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup
|
||||
|
||||
|
||||
13
src/Mail.hs
13
src/Mail.hs
@ -23,6 +23,7 @@ module Mail
|
||||
-- * Monadically constructing Mail
|
||||
, PrioritisedAlternatives
|
||||
, ToMailPart(..)
|
||||
, NamedMailPart(..)
|
||||
, addAlternatives, provideAlternative, providePreferredAlternative
|
||||
, addPart, addPart', modifyPart, partIsAttachment
|
||||
, MonadHeader(..)
|
||||
@ -435,6 +436,16 @@ instance YesodMail site => ToMailPart site YamlValue where
|
||||
_partContent .= PartContent (fromStrict $ Yaml.encode val)
|
||||
|
||||
|
||||
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
|
||||
_partDisposition .= disposition nmp
|
||||
return r
|
||||
|
||||
|
||||
addAlternatives :: (MonadMail m)
|
||||
=> Writer (PrioritisedAlternatives m) ()
|
||||
-> m ()
|
||||
@ -447,7 +458,7 @@ provideAlternative, providePreferredAlternative
|
||||
:: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
|
||||
=> a
|
||||
-> Writer (PrioritisedAlternatives m) ()
|
||||
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
|
||||
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
|
||||
providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
|
||||
|
||||
addPart :: ( MonadMail m
|
||||
|
||||
Loading…
Reference in New Issue
Block a user