From 1216bc0f2f1c8abd9e8680b4d30a865e54f62991 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Mon, 12 Dec 2022 16:46:22 +0100
Subject: [PATCH] chore(avs): avs testpage shows JSON pandoc formatted

---
 src/Handler/Admin/Avs.hs    | 15 +++++++++++----
 src/Handler/Utils/Pandoc.hs | 15 +++++++++++++++
 templates/avs.hamlet        |  4 ++--
 3 files changed, 28 insertions(+), 6 deletions(-)

diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index d455788ae..572d221ec 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -90,6 +90,13 @@ avsLicenceOptions = mkOptionList
   | l <- universeF
   ]
 
+
+jsonToWidget :: ToJSON a => a -> Widget
+jsonToWidget x = 
+  case jsonToHtml jsonReaderOptions htmlWriterOptions $ tshow $ toJSON x of
+    Left  err  -> msg2widget err 
+    Right html -> toWgt html
+
 getAdminAvsR,  postAdminAvsR :: Handler Html
 getAdminAvsR = postAdminAvsR
 postAdminAvsR = do
@@ -103,8 +110,8 @@ postAdminAvsR = do
             addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
             res <- avsQueryPerson fr
             case res of
-              Left  err -> return . Just $ tshow err
-              Right jsn -> return . Just $ tshow jsn
+              Left  err -> return . Just $ text2widget $ tshow err
+              Right jsn -> return . Just $ jsonToWidget jsn
       mbPerson <- formResultMaybe presult procFormPerson
 
       ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
@@ -112,8 +119,8 @@ postAdminAvsR = do
             addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
             res <- avsQueryStatus fr
             case res of
-              Left err -> return . Just $ tshow err
-              Right jsn -> return . Just $ tshow jsn
+              Left err  -> return . Just $ text2widget $ tshow err
+              Right jsn -> return . Just $ jsonToWidget jsn
       mbStatus <- formResultMaybe sresult procFormStatus
 
       ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs
index 5643dd30e..e49ce6019 100644
--- a/src/Handler/Utils/Pandoc.hs
+++ b/src/Handler/Utils/Pandoc.hs
@@ -7,6 +7,8 @@ module Handler.Utils.Pandoc
   , renderMarkdownWith, parseMarkdownWith
   , htmlReaderOptions, markdownReaderOptions
   , markdownWriterOptions, htmlWriterOptions
+  , jsonToHtml
+  , jsonReaderOptions
   ) where
 
 import Import.NoFoundation
@@ -103,3 +105,16 @@ markdownWriterOptions = def
   , P.writerTabStop = P.readerTabStop markdownReaderOptions
   }
 htmlWriterOptions = markdownWriterOptions
+
+jsonToHtml :: P.ReaderOptions -> P.WriterOptions -> Text -> Either (SomeMessage site) Html
+jsonToHtml readerOptions writerOptions text =
+  bimap pandocError (preEscapedText . sanitizeBalance) . P.runPure $
+    P.writeHtml5String writerOptions =<< P.readJSON readerOptions text
+  where
+    pandocError = SomeMessage . tshow
+
+jsonReaderOptions :: P.ReaderOptions
+jsonReaderOptions = def 
+  { P.readerExtensions = P.pandocExtensions
+  , P.readerTabStop = 2
+  }
diff --git a/templates/avs.hamlet b/templates/avs.hamlet
index cd6cfa8e5..a755e172f 100644
--- a/templates/avs.hamlet
+++ b/templates/avs.hamlet
@@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   $maybe answer <- mbPerson
     <p>
       Unverarbeitete Antwort: #
-      #{answer}
+      ^{answer}
 
 <section>
   <p> 
@@ -52,4 +52,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   $maybe answer <- mbStatus
     <p>
       Unverarbeitete Antwort: #
-      #{answer}
\ No newline at end of file
+      ^{answer}
\ No newline at end of file