UI, DB: Store debug reports in DB and link to them from navbar

migrations/648_2024-07-06_report.model

@@ -0,0 +1,5 @@
+Report
+    time    UTCTime
+    message Text
+    types   ListOfByteStrings
+    body    ByteString

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

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

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}
         |]
 
 {-

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

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")

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'
+                    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

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>

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
 -- ========================================================================= --

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