diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 56f2efb67..ecff641e6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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|

_{MsgPrintJobAcknowledgements} ^{userWidget recipient} diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 82ded9c15..e2e15f12c 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -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 diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index 2b4fe3e32..c7ab161ad 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -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| -

- Testheader -

- 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

  • #{nD}
  • #{nT} |] - addHtmlMarkdownAlternatives $ \(MsgRenderer mr) -> [shamlet| + addHtmlMarkdownAlternatives' "addOne" $ \(MsgRenderer mr) -> [shamlet|

    Repetition just for Testing

    #{mr MsgMailTestContent} @@ -50,3 +44,19 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail

  • #{nD}
  • #{nT} |] + addHtmlMarkdownAlternatives'' "addTwo" $ \(MsgRenderer mr) -> [shamlet| +

    Repetition just for Testing +

    + #{mr MsgMailTestContent} + +

    + #{mr MsgMailTestDateTime} +

      +
    • #{nDT} +
    • #{nD} +
    • #{nT} + |] + -- let test = $(i18nHamletFile "test") + -- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup + + \ No newline at end of file diff --git a/src/Mail.hs b/src/Mail.hs index 269803f97..df984aedc 100644 --- a/src/Mail.hs +++ b/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