From b0972bb154f453edd545fb4f658d9f5ff79966eb Mon Sep 17 00:00:00 2001
From: Steffen <s.jost@fraport.de>
Date: Tue, 20 Aug 2024 12:35:16 +0200
Subject: [PATCH] fix(mail): display html emails no longer distorts page

html is filtered once through pandoc, as proposed in #2
---
 src/Handler/MailCenter.hs | 17 ++++++++++-------
 src/Model/Types/Markup.hs | 10 +++++-----
 src/Utils/Pandoc.hs       | 11 ++++++++---
 3 files changed, 23 insertions(+), 15 deletions(-)

diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs
index c6abfa015..021860b76 100644
--- a/src/Handler/MailCenter.hs
+++ b/src/Handler/MailCenter.hs
@@ -96,7 +96,7 @@ mkMCTable = do
       , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
           let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
               linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
-          in anchorCellM (MailPlainR <$> encrypt k) linkWgt
+          in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
       -- , sortable Nothing (i18nCell MsgCommContent)    $ \(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
       ]
@@ -219,10 +219,13 @@ handleMailShow hdr prefTypes cusm = do
             <p>
               ^{part2widget pt}
     |]
-    -- Include for Debugging:
-    -- ^{jsonWidget (sm ^. _sentMailHeaders)}
-    -- ^{jsonWidget (sentMailContentContent cn)}
-
+      -- Include for Debugging:
+      -- <section>
+      --   <h2>Debugging
+      --   <p>
+      --     ^{jsonWidget (sm ^. _sentMailHeaders)}
+      --   <p>
+      --     ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here
 
 selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
 selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
@@ -255,8 +258,8 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD
     |]
   where
     showBody
-      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
-      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
+      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
+      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
       | pt == decodeUtf8 typeJson  =
           let jw :: Aeson.Value -> Widget = jsonWidget
           in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs
index a250927c4..836530d75 100644
--- a/src/Model/Types/Markup.hs
+++ b/src/Model/Types/Markup.hs
@@ -9,7 +9,7 @@ module Model.Types.Markup
   , markdownToStoredMarkup
   , esqueletoMarkupOutput
   , I18nStoredMarkup
-  , markupIsSmallish  
+  , markupIsSmallish
   , html2textlines
   , isSimilarMarkup
   ) where
@@ -53,7 +53,7 @@ data StoredMarkup = StoredMarkup
   deriving anyclass (Binary, Hashable, NFData)
 
 isSimilarMarkup :: StoredMarkup -> StoredMarkup -> Bool
-isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai} 
+isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai}
                 StoredMarkup{markupInputFormat=bf, markupInput=bi}
               = af==bf && ai == bi
 
@@ -74,7 +74,7 @@ plaintextToStoredMarkup :: Textual t => t -> StoredMarkup
 plaintextToStoredMarkup (repack -> t) = StoredMarkup
   { markupInputFormat = MarkupPlaintext
   , markupInput = t
-  , markupOutput = plaintextToHtml $ LT.toStrict t
+  , markupOutput = plainTextToHtml $ LT.toStrict t
   }
 preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup
 preEscapedToStoredMarkup (repack -> t) = StoredMarkup
@@ -86,8 +86,8 @@ markdownToStoredMarkup :: Textual t => t -> StoredMarkup
 markdownToStoredMarkup (repack -> t) = StoredMarkup
   { markupInputFormat = MarkupMarkdown
   , markupInput = t
-  , markupOutput = plaintextToHtml $ LT.toStrict t
-  }  
+  , markupOutput = plainTextToHtml $ LT.toStrict t
+  }
 
 
 esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html)
diff --git a/src/Utils/Pandoc.hs b/src/Utils/Pandoc.hs
index ad7582377..d2030d2a3 100644
--- a/src/Utils/Pandoc.hs
+++ b/src/Utils/Pandoc.hs
@@ -19,11 +19,16 @@ import qualified Text.Pandoc as P
 markdownToHtml :: Html  -> Either P.PandocError Html
 markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
 
-plaintextToHtml :: Text -> Html
-plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $
+plainTextToHtml :: Text -> Html
+plainTextToHtml text = fromRight (toMarkup text) $ P.runPure $
   P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
   -- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code
-  -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]] 
+  -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
+
+plainHtmlToHtml :: Text -> Html
+plainHtmlToHtml text = fromRight (toMarkup text) $ P.runPure $
+  P.writeHtml5 htmlWriterOptions =<< P.readHtml markdownReaderOptions text
+
 
 
 htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions