From 072039f5d8c3bac0238d024d39df107ef3c8c8e4 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Tue, 23 Jul 2019 18:17:15 +0000
Subject: [PATCH] On "See JSON" pages, display a link back to "regular HTML"
 version of the page

---
 src/Yesod/ActivityPub.hs | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs
index 9cb12a6..10ebc12 100644
--- a/src/Yesod/ActivityPub.hs
+++ b/src/Yesod/ActivityPub.hs
@@ -32,6 +32,8 @@ import Data.Aeson
 import Data.Aeson.Encode.Pretty
 import Data.ByteString (ByteString)
 import Data.Foldable
+import Data.Function
+import Data.List
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Network.HTTP.Client
@@ -210,6 +212,17 @@ provideHtmlAndAP' host object widget = selectRep $ do
                     if sky
                         then renderPrettyJSONSkylighting doc
                         else renderPrettyJSON doc
+                    mroute <- getCurrentRoute
+                    for_ mroute $ \ route -> do
+                        params <- reqGetParams <$> getRequest
+                        let params' =
+                                delete' "prettyjson" $
+                                    delete' "highlight" params
+                        [whamlet|
+                            <div>
+                              <a href=@?{(route, params')}>
+                                [See HTML]
+                        |]
                 _ -> do
                     widget
                     mroute <- getCurrentRoute
@@ -223,6 +236,8 @@ provideHtmlAndAP' host object widget = selectRep $ do
                               <a href=@?{(route, params')}>
                                 [See JSON]
                         |]
+    where
+    delete' t = deleteBy ((==) `on` fst) (t, "")
 
 provideHtmlAndAP''
     :: Yesod site