chore(mail): reworked testmail to test named attachments

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 (Maybe (Entity LmsUser))
-                                                               , E.SqlExpr (E.Value (Maybe [Maybe UTCTime]))
+                                                               , 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 
+    -- 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; 
+    --   - 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       
+                                       | Just d <- lastLetterDate -> dateTimeCell d
-                                       | otherwise -> i18nCell MsgPrintJobUnacknowledged  
+                                       | otherwise -> i18nCell MsgPrintJobUnacknowledged
-                  cAckDates = case letterDates of 
+                  cAckDates = case letterDates of
                     Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
                           <h1>
                             _{MsgPrintJobAcknowledgements} ^{userWidget recipient}

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
       }
 
-{-
+-- | provide a name for the part 
-addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
+addHtmlMarkdownAlternatives' :: ( MonadMail m
-                                , MonadMail m
+                                , ToMailPart (HandlerSite m) (NamedMailPart Html)
-                                , ToMailPart (HandlerSite m) Html
                                 , ToMailHtml (HandlerSite m) a
-                                ) => a -> m ()
+                                ) => Text -> a -> m ()
-addHtmlMarkdownAlternatives' = addHtmlMarkdownAlternatives
+addHtmlMarkdownAlternatives' fn html' = do  
--}
+  html <- toMailHtml html'
-
--- For now failed attempt to use with i18nHaletFile or widgets:
-addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
-                                , MonadMail m
-                                , YesodMail (HandlerSite m)
-                                ) => Html -> m ()
-addHtmlMarkdownAlternatives' html = do  
   markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
 
   addAlternatives $ do
-    providePreferredAlternative html
+    providePreferredAlternative $ NamedMailPart { namedPart = html, disposition = AttachmentDisposition fn } 
-    whenIsJust markdown provideAlternative
+    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

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|
-      <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
+
+  

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