chore(mail): reworked testmail to test named attachments

src/Handler/LMS.hs

@@ -313,7 +313,7 @@ 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 (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
@@ -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)
 
 

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

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