From 46fb4d15125b793e9090e04c6084f3a0821f7f74 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Thu, 25 Apr 2019 22:46:27 +0000
Subject: [PATCH] Add settings switch for activity debug reports

---
 config/settings-default.yaml |  5 +++++
 src/Vervis/Application.hs    |  5 ++++-
 src/Vervis/Foundation.hs     |  2 +-
 src/Vervis/Handler/Inbox.hs  | 26 ++++++++++++++------------
 src/Vervis/Settings.hs       |  5 +++++
 5 files changed, 29 insertions(+), 14 deletions(-)

diff --git a/config/settings-default.yaml b/config/settings-default.yaml
index 1d8ef43..84433ed 100644
--- a/config/settings-default.yaml
+++ b/config/settings-default.yaml
@@ -160,3 +160,8 @@ drop-delivery-after:
 retry-delivery-every:
   amount:               1
   unit:                 hours
+
+# How many activities to remember in the debug report list, showing latest
+# activities received in local inboxes and the result of their processing.
+# 'null' means disable the report page entirely.
+#activity-debug-reports: 10
diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs
index fe792d5..2044439 100644
--- a/src/Vervis/Application.hs
+++ b/src/Vervis/Application.hs
@@ -130,7 +130,10 @@ makeFoundation appSettings = do
 
     appActorFetchShare <- newResultShare actorFetchShareAction
 
-    appActivities <- newTVarIO mempty
+    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
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 5b7c58b..7c1bfe8 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -113,7 +113,7 @@ data App = App
     , appHashidsContext :: HashidsContext
     , appActorFetchShare :: ActorFetchShare App
 
-    , appActivities  :: TVar (Vector ActivityReport)
+    , 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/Inbox.hs b/src/Vervis/Handler/Inbox.hs
index 7f46edd..a08ada0 100644
--- a/src/Vervis/Handler/Inbox.hs
+++ b/src/Vervis/Handler/Inbox.hs
@@ -105,7 +105,8 @@ import Vervis.Settings
 
 getInboxR :: Handler Html
 getInboxR = do
-    acts <- liftIO . readTVarIO =<< getsYesod appActivities
+    acts <-
+        liftIO . readTVarIO . snd =<< maybe notFound return =<< getsYesod appActivities
     defaultLayout
         [whamlet|
             <p>
@@ -187,17 +188,18 @@ postSharerInboxR shrRecip = do
                 "application/ld+json; \
                 \profile=\"https://www.w3.org/ns/activitystreams\""
     recordActivity now result contentTypes = do
-        acts <- getsYesod appActivities
-        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' > 10
-                    then V.init vec'
-                    else vec'
+        macts <- getsYesod 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'
 
 postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
 postProjectInboxR _ _ = error "TODO implement postProjectInboxR"
diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs
index 38e6911..1620104 100644
--- a/src/Vervis/Settings.hs
+++ b/src/Vervis/Settings.hs
@@ -148,6 +148,10 @@ data AppSettings = AppSettings
     , appDropDeliveryAfter        :: NominalDiffTime
       -- | How much time to wait between retries of failed deliveries.
     , appDeliveryRetryFreq        :: TimeInterval
+      -- | How many activities to remember in the debug report list, showing
+      -- latest activities received in local inboxes and the result of their
+      -- processing. 'Nothing' means disable the report page entirely.
+    , appInboxDebugReportLength   :: Maybe Int
     }
 
 instance FromJSON AppSettings where
@@ -196,6 +200,7 @@ instance FromJSON AppSettings where
         appRejectOnMaxKeys          <- o .: "reject-on-max-keys"
         appDropDeliveryAfter        <- ndt <$> o .: "drop-delivery-after"
         appDeliveryRetryFreq        <- interval <$> o .: "retry-delivery-every"
+        appInboxDebugReportLength   <- o .:? "activity-debug-reports"
 
         return AppSettings {..}
         where