From 9ce745c72586e4888936087aedf558e6b1e91262 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Sat, 6 Jul 2024 12:53:31 +0300
Subject: [PATCH] UI, DB: Store debug reports in DB and link to them from
 navbar

---
 migrations/648_2024-07-06_report.model |  5 +++++
 src/Vervis/Application.hs              |  7 +------
 src/Vervis/Foundation.hs               |  2 --
 src/Vervis/Handler/Client.hs           | 11 +++++------
 src/Vervis/Migration.hs                |  2 ++
 src/Vervis/Migration/Entities.hs       |  6 ++++++
 src/Vervis/Web/Actor.hs                | 23 ++++++++---------------
 templates/default-layout.hamlet        |  7 +++++++
 th/models                              |  6 ++++++
 th/routes                              |  2 +-
 10 files changed, 41 insertions(+), 30 deletions(-)
 create mode 100644 migrations/648_2024-07-06_report.model

diff --git a/migrations/648_2024-07-06_report.model b/migrations/648_2024-07-06_report.model
new file mode 100644
index 0000000..3d66e7f
--- /dev/null
+++ b/migrations/648_2024-07-06_report.model
@@ -0,0 +1,5 @@
+Report
+    time    UTCTime
+    message Text
+    types   ListOfByteStrings
+    body    ByteString
diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs
index 1ae4bbc..1430e02 100644
--- a/src/Vervis/Application.hs
+++ b/src/Vervis/Application.hs
@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022, 2023
+ - Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -202,11 +202,6 @@ makeFoundation appSettings = do
 
     appActorFetchShare <- newResultShare actorFetchShareAction
 
-    appActivities <-
-        case appInboxDebugReportLength appSettings of
-            Nothing -> return Nothing
-            Just n -> Just . (n,) <$> newTVarIO mempty
-
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
     -- logging function. To get out of this loop, we initially create a
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 0efeb6a..6aabb23 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -137,8 +137,6 @@ data App = App
     , appTheater :: Theater
     , appEnv     :: Env
     , appPersonLauncher :: MVar (PersonId, MVar Bool)
-
-    , appActivities  :: Maybe (Int, TVar (Vector ActivityReport))
     }
 
 -- Aliases for the routes file, because it doesn't like spaces in path piece
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index 4f743b8..6a06880 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@@ -94,7 +94,7 @@ import Yesod.Persist.Core
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.HashMap.Strict as M
 import qualified Data.Text as T
-import qualified Data.Text.Lazy.Encoding as TLE
+import qualified Data.Text.Encoding as TE
 import qualified Database.Esqueleto as E
 
 import Database.Persist.JSON
@@ -792,8 +792,7 @@ postPublishR = do
 
 getInboxDebugR :: Handler Html
 getInboxDebugR = do
-    acts <-
-        liftIO . readTVarIO . snd =<< maybe notFound return =<< getsYesod appActivities
+    acts <- runDB $ selectList [] [Desc ReportId, LimitTo 30]
     defaultLayout
         [whamlet|
             <p>
@@ -805,14 +804,14 @@ getInboxDebugR = do
               result. Activities that aren't understood or their processing
               fails get listed here too, with a report of what exactly
               happened.
-            <p>Last 10 activities posted:
+            <p>Last 30 activities posted:
             <ul>
-              $forall ActivityReport time msg ctypes body <- acts
+              $forall Entity _ (Report time msg ctypes body) <- acts
                 <li>
                   <div>#{show time}
                   <div>#{msg}
                   <div><code>#{intercalate " | " $ map BC.unpack ctypes}
-                  <div><pre>#{TLE.decodeUtf8 body}
+                  <div><pre>#{TE.decodeUtf8 body}
         |]
 
 {-
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index b1045be..ed4c4c7 100644
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@@ -3829,6 +3829,8 @@ changes hLocal ctx =
     , addFieldRefRequiredEmpty "EffortTopicLocal" "topic" "Resource"
       -- 647
     , removeField "Effort" "topic"
+      -- 648
+    , addEntities model_648_report
     ]
 
 migrateDB
diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs
index f88f68c..422b84d 100644
--- a/src/Vervis/Migration/Entities.hs
+++ b/src/Vervis/Migration/Entities.hs
@@ -78,6 +78,7 @@ module Vervis.Migration.Entities
     , model_626_komponent
     , model_638_effort_squad
     , model_639_component_convey
+    , model_648_report
     )
 where
 
@@ -305,3 +306,8 @@ model_638_effort_squad = $(schema "638_2024-05-14_effort_squad")
 
 model_639_component_convey :: [Entity SqlBackend]
 model_639_component_convey = $(schema "639_2024-05-14_component_convey")
+
+type ListOfByteStrings = [ByteString]
+
+model_648_report :: [Entity SqlBackend]
+model_648_report = $(schema "648_2024-07-06_report")
diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs
index 2560b59..a5e8ed1 100644
--- a/src/Vervis/Web/Actor.hs
+++ b/src/Vervis/Web/Actor.hs
@@ -68,6 +68,7 @@ import Yesod.Form.Types
 import Yesod.Persist.Core
 
 import qualified Data.ByteString.Char8 as BC (unpack)
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as M
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
@@ -277,22 +278,14 @@ postInbox recipByKey = do
             sendResponseStatus badRequest400 err
         Right _ -> return ()
     where
-    recordActivity
-        :: (MonadSite m, SiteEnv m ~ App)
-        => UTCTime -> Either Text (Object, Text) -> [ContentType] -> m ()
+    recordActivity :: UTCTime -> Either Text (Object, Text) -> [ContentType] -> Handler ()
     recordActivity now result contentTypes = do
-        macts <- asksSite appActivities
-        for_ macts $ \ (size, acts) ->
-            liftIO $ atomically $ modifyTVar' acts $ \ vec ->
-                let (msg, body) =
-                        case result of
-                            Left t -> (t, "{?}")
-                            Right (o, t) -> (t, encodePretty o)
-                    item = ActivityReport now msg contentTypes body
-                    vec' = item `V.cons` vec
-                in  if V.length vec' > size
-                        then V.init vec'
-                        else vec'
+        let (msg, body) =
+                case result of
+                    Left t -> (t, "{?}")
+                    Right (o, t) -> (t, BL.toStrict $ encodePretty o)
+            item = Report now msg contentTypes body
+        runDB $ insert_ item
     parseAuthenticatedLocalActivityURI
         :: (MonadSite m, YesodHashids (SiteEnv m))
         => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
index 9e824ef..dc46178 100644
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@@ -44,6 +44,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
         <span>
           <a href=@{RemoteActorsR}>
             [🌁 Browse remote actors]
+        <span>
+          <a href=@{InboxDebugR}>
+            [💥 Inbox Debug Reports]
         <span>
           <a href=@{HomeR}>
             [📣 Publish an activity]
@@ -66,6 +69,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <a href=@{AuthR LoginR}>Log in.
       Or
       <a href=@{AuthR newAccountR}>Sign up.
+      <span> -|-
+      <span>
+        <a href=@{InboxDebugR}>
+          [💥 Inbox Debug Reports]
 
   $if federationDisabled
     <p>
diff --git a/th/models b/th/models
index a5cb2df..531a92a 100644
--- a/th/models
+++ b/th/models
@@ -13,6 +13,12 @@
 -- with this software. If not, see
 -- <http://creativecommons.org/publicdomain/zero/1.0/>.
 
+Report
+    time    UTCTime
+    message Text
+    types   [ByteString]
+    body    ByteString
+
 -- ========================================================================= --
 -- Remote Object
 -- ========================================================================= --
diff --git a/th/routes b/th/routes
index 1c697c5..91c9421 100644
--- a/th/routes
+++ b/th/routes
@@ -128,7 +128,7 @@
 /browse        BrowseR        GET
 /notifications NotificationsR GET POST
 -- /publish       PublishR       GET POST
-/inbox         InboxDebugR    GET
+/inbox-debug      InboxDebugR    GET
 
 /ssh-keys                         KeysR      GET POST
 /ssh-keys/#SshKeyKeyHashid/delete KeyDeleteR POST