UI, S2S: Store errors in Errbox + display in notifications

src/Vervis/Actor/Common.hs

@@ -79,7 +79,7 @@ import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Persist.Actor

src/Vervis/Actor/Deck.hs

@@ -66,7 +66,7 @@ import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.Data.Ticket
 import Vervis.FedURI
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model hiding (deckCreate)
 import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
@@ -1095,4 +1095,9 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
 deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck"
 
 instance VervisActor Deck where
-    actorBehavior = deckBehavior
+    actorBehavior now deckID ve = do
+        errboxID <- lift $ withDB $ do
+            resourceID <- deckResource <$> getJust deckID
+            Resource actorID <- getJust resourceID
+            actorErrbox <$> getJust actorID
+        adaptErrbox errboxID False deckBehavior now deckID ve

src/Vervis/Actor/Group.hs

@@ -68,7 +68,7 @@ import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model hiding (groupCreate)
 import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
@@ -977,4 +977,9 @@ groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
 groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"
 
 instance VervisActor Group where
-    actorBehavior = groupBehavior
+    actorBehavior now groupID ve = do
+        errboxID <- lift $ withDB $ do
+            resourceID <- groupResource <$> getJust groupID
+            Resource actorID <- getJust resourceID
+            actorErrbox <$> getJust actorID
+        adaptErrbox errboxID False groupBehavior now groupID ve

src/Vervis/Actor/Loom.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -70,7 +70,7 @@ import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.Data.Ticket
 import Vervis.FedURI
-import Vervis.Federation.Util
+
 import Vervis.Fetch
 import Vervis.Foundation
 import Vervis.Model hiding (deckCreate)
@@ -578,4 +578,9 @@ loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) =
 loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom"
 
 instance VervisActor Loom where
-    actorBehavior = loomBehavior
+    actorBehavior now loomID ve = do
+        errboxID <- lift $ withDB $ do
+            resourceID <- loomResource <$> getJust loomID
+            Resource actorID <- getJust resourceID
+            actorErrbox <$> getJust actorID
+        adaptErrbox errboxID False loomBehavior now loomID ve

src/Vervis/Actor/Person.hs

@@ -69,7 +69,7 @@ import Vervis.Data.Discussion
 import Vervis.Data.Follow
 import Vervis.Data.Ticket
 import Vervis.FedURI
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Persist.Actor
@@ -1340,4 +1340,8 @@ personBehavior now personID (Left verse@(Verse _authorIdMsig body)) =
 personBehavior now personID (Right msg) = clientBehavior now personID msg
 
 instance VervisActor Person where
-    actorBehavior = personBehavior
+    actorBehavior now personID ve = do
+        errboxID <- lift $ withDB $ do
+            actorID <- personActor <$> getJust personID
+            actorErrbox <$> getJust actorID
+        adaptErrbox errboxID True personBehavior now personID ve

src/Vervis/Actor/Project.hs

@@ -69,7 +69,7 @@ import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model hiding (projectCreate)
 import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
@@ -5351,4 +5351,9 @@ projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) =
 projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"
 
 instance VervisActor Project where
-    actorBehavior = projectBehavior
+    actorBehavior now projectID ve = do
+        errboxID <- lift $ withDB $ do
+            resourceID <- projectResource <$> getJust projectID
+            Resource actorID <- getJust resourceID
+            actorErrbox <$> getJust actorID
+        adaptErrbox errboxID False projectBehavior now projectID ve

src/Vervis/Actor/Repo.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -46,9 +46,10 @@ import Vervis.Actor
 import Vervis.Cloth
 import Vervis.Data.Discussion
 import Vervis.FedURI
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Persist.Actor
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
@@ -59,4 +60,9 @@ repoBehavior now repoID (Left _verse@(Verse _authorIdMsig body)) =
 repoBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Repo"
 
 instance VervisActor Repo where
-    actorBehavior = repoBehavior
+    actorBehavior now repoID ve = do
+        errboxID <- lift $ withDB $ do
+            resourceID <- repoResource <$> getJust repoID
+            Resource actorID <- getJust resourceID
+            actorErrbox <$> getJust actorID
+        adaptErrbox errboxID False repoBehavior now repoID ve

src/Vervis/Federation/Discussion.hs

@@ -72,7 +72,7 @@ import Vervis.Cloth
 import Vervis.Data.Discussion
 import Vervis.FedURI
 import Vervis.Federation.Auth
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident

src/Vervis/Federation/Offer.hs

@@ -86,7 +86,7 @@ import Vervis.Cloth
 import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Federation.Auth
-import Vervis.Federation.Util
+
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident

src/Vervis/Federation/Ticket.hs

@@ -98,7 +98,7 @@ import Vervis.Data.Ticket
 import Vervis.Darcs
 import Vervis.Web.Delivery
 import Vervis.Federation.Auth
-import Vervis.Federation.Util
+
 import Vervis.FedURI
 import Vervis.Fetch
 import Vervis.Foundation

src/Vervis/Federation/Util.hs

@@ -1,80 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2019, 2020, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ Copying is an act of love. Please copy, reuse and share.
- -
- - The author(s) have dedicated all copyright and related and neighboring
- - rights to this software to the public domain worldwide. This software is
- - distributed without any warranty.
- -
- - You should have received a copy of the CC0 Public Domain Dedication along
- - with this software. If not, see
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
-module Vervis.Federation.Util
-    ( insertToInbox
-    )
-where
-
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader
-import Data.ByteString (ByteString)
-import Data.Either
-import Data.Time.Clock
-import Database.Persist
-import Database.Persist.Sql
-
-import Database.Persist.JSON
-import Network.FedURI
-
-import Database.Persist.Local
-
-import Vervis.Actor
-import Vervis.Federation.Auth
-import Vervis.Foundation
-import Vervis.Model
-
--- | Insert an activity delivered to us into our inbox. Return its
--- database ID if the activity wasn't already in our inbox.
-insertToInbox
-    :: UTCTime
-    -> Either
-        (LocalActorBy Key, ActorId, OutboxItemId)
-        (RemoteAuthor, LocalURI, Maybe ByteString)
-    -> ActivityBody
-    -> InboxId
-    -> Bool
-    -> ActDB
-        (Maybe
-            ( InboxItemId
-            , Either
-                (LocalActorBy Key, ActorId, OutboxItemId)
-                (RemoteAuthor, LocalURI, RemoteActivityId)
-            )
-        )
-insertToInbox now (Left a@(_, _, outboxItemID)) _body inboxID unread = do
-    inboxItemID <- insert $ InboxItem unread now "No result yet"
-    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-    case maybeItem of
-        Nothing -> do
-            delete inboxItemID
-            return Nothing
-        Just _ -> return $ Just (inboxItemID, Left a)
-insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
-    let iidAuthor = remoteAuthorInstance author
-    roid <-
-        either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
-    ractid <- either entityKey id <$> insertBy' RemoteActivity
-        { remoteActivityIdent    = roid
-        , remoteActivityContent  = persistJSONFromBL $ actbBL body
-        , remoteActivityReceived = now
-        }
-    ibiid <- insert $ InboxItem unread now "No result yet"
-    mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
-    case mibrid of
-        Nothing -> do
-            delete ibiid
-            return Nothing
-        Just _ -> return $ Just (ibiid, Right (author, luAct, ractid))

src/Vervis/Handler/Client.hs

@@ -532,13 +532,16 @@ getNotificationsR = do
     Entity _ viewer <- requireVerifiedAuth
 
     items <- runDB $ do
-        inboxID <- actorInbox <$> getJust (personActor viewer)
+        actor <- getJust $ personActor viewer
-        map adaptItem <$> getItems inboxID
+        map adaptItem <$>
+            liftA2 (++)
+                (getItems $ actorErrbox actor)
+                (getItems $ actorInbox actor)
 
-    notifications <- for items $ \ (ibiid, activity) -> do
+    notifications <- for items $ \ (ibiid, activity, result) -> do
         ((_result, widget), enctype) <-
             runFormPost $ notificationForm $ Just $ Just (ibiid, False)
-        return (activity, widget, enctype)
+        return (activity, result, widget, enctype)
 
     ((_result, widgetAll), enctypeAll) <-
         runFormPost $ notificationForm $ Just Nothing
@@ -570,18 +573,19 @@ getNotificationsR = do
                     , ob E.?. OutboxItemPublished
                     , ract E.?. RemoteActivityContent
                     , ract E.?. RemoteActivityReceived
+                    , ib E.^. InboxItemResult
                     )
     adaptItem
-        (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) =
+        (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec, E.Value result) =
             case (mact, mpub, mobj, mrec) of
                 (Nothing, Nothing, Nothing, Nothing) ->
                     error $ ibiidString ++ " neither local nor remote"
                 (Just _, Just _, Just _, Just _) ->
                     error $ ibiidString ++ " both local and remote"
                 (Just act, Just pub, Nothing, Nothing) ->
-                    (ibid, (persistJSONObject act, (pub, False)))
+                    (ibid, (persistJSONObject act, (pub, False)), result)
                 (Nothing, Nothing, Just obj, Just rec) ->
-                    (ibid, (persistJSONObject obj, (rec, True)))
+                    (ibid, (persistJSONObject obj, (rec, True)), result)
                 _ -> error $ "Unexpected query result for " ++ ibiidString
         where
         ibiidString = "InboxItem #" ++ show (E.fromSqlKey ibid)
@@ -598,10 +602,12 @@ postNotificationsR = do
             setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l)
         FormSuccess mitem -> do
             (multi, markedUnread) <- runDB $ do
-                inboxID <- actorInbox <$> getJust (personActor poster)
+                actor <- getJust $ personActor poster
+                let inboxID = actorInbox actor
+                    errboxID = actorErrbox actor
                 case mitem of
                     Nothing -> do
-                        ibiids <- map E.unValue <$> getItems inboxID
+                        ibiids <- map E.unValue <$> liftA2 (++) (getItems errboxID) (getItems inboxID)
                         updateWhere
                             [InboxItemId <-. ibiids]
                             [InboxItemUnread =. False]
@@ -616,9 +622,9 @@ postNotificationsR = do
                         let samePid =
                                 case mib of
                                     Left ibl ->
-                                        inboxItemLocalInbox ibl == inboxID
+                                        inboxItemLocalInbox ibl == inboxID || inboxItemLocalInbox ibl == errboxID
                                     Right ibr ->
-                                        inboxItemRemoteInbox ibr == inboxID
+                                        inboxItemRemoteInbox ibr == inboxID || inboxItemRemoteInbox ibr == errboxID
                         if samePid
                             then do
                                 update ibiid [InboxItemUnread =. unread]

src/Vervis/Persist/Actor.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -38,6 +39,8 @@ module Vervis.Persist.Actor
     , getRemoteActorM
     , getRemoteActorE
     , doneDB
+    , insertToInbox
+    , adaptErrbox
     )
 where
 
@@ -50,8 +53,10 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Data.Aeson
 import Data.Barbie
+import Data.ByteString (ByteString)
 import Data.Bitraversable
 import Data.Text (Text)
+import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql
@@ -323,3 +328,63 @@ doneDB :: InboxItemId -> Text -> VA.ActE (Text, VA.Act (), Next)
 doneDB itemID msg = do
     lift $ VA.withDB $ update itemID [InboxItemResult =. msg]
     done msg
+
+-- | Insert an activity delivered to us into our inbox. Return its
+-- database ID if the activity wasn't already in our inbox.
+insertToInbox
+    :: UTCTime
+    -> Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (VA.RemoteAuthor, LocalURI, Maybe ByteString)
+    -> VA.ActivityBody
+    -> InboxId
+    -> Bool
+    -> VA.ActDB
+        (Maybe
+            ( InboxItemId
+            , Either
+                (LocalActorBy Key, ActorId, OutboxItemId)
+                (VA.RemoteAuthor, LocalURI, RemoteActivityId)
+            )
+        )
+insertToInbox now (Left a@(_, _, outboxItemID)) _body inboxID unread = do
+    inboxItemID <- insert $ InboxItem unread now "No result yet"
+    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
+    case maybeItem of
+        Nothing -> do
+            delete inboxItemID
+            return Nothing
+        Just _ -> return $ Just (inboxItemID, Left a)
+insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
+    let iidAuthor = VA.remoteAuthorInstance author
+    roid <-
+        either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
+    ractid <- either entityKey id <$> insertBy' RemoteActivity
+        { remoteActivityIdent    = roid
+        , remoteActivityContent  = persistJSONFromBL $ VA.actbBL body
+        , remoteActivityReceived = now
+        }
+    ibiid <- insert $ InboxItem unread now "No result yet"
+    mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
+    case mibrid of
+        Nothing -> do
+            delete ibiid
+            return Nothing
+        Just _ -> return $ Just (ibiid, Right (author, luAct, ractid))
+
+adaptErrbox
+    :: InboxId
+    -> Bool
+    -> (UTCTime -> Key a -> VA.VerseExt -> VA.ActE (Text, VA.Act (), Next))
+    -> UTCTime -> Key a -> VA.VerseExt -> VA.ActE (Text, VA.Act (), Next)
+adaptErrbox _ _ behavior now key ve@(Right _) = behavior now key ve
+adaptErrbox inboxID unread behavior now key ve@(Left (VA.Verse authorIdMsig body)) = do
+    result <- lift $ runExceptT $ behavior now key ve
+    case result of
+        Right success -> return success
+        Left err -> do
+            _ <- lift $ VA.withDB $ runMaybeT $ do
+                _ <- MaybeT $ get inboxID
+                (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread
+                lift $ update itemID [InboxItemResult =. err]
+            throwE err

templates/person/notifications.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2019, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -22,7 +22,7 @@ $else
       <input type="submit" value="Mark all as read">
 
 <div>
-  $forall ((obj, (time, isRemote)), widget, enctype) <- notifications
+  $forall ((obj, (time, isRemote)), result, widget, enctype) <- notifications
     <div>
       $if isRemote
         Received #
@@ -31,6 +31,14 @@ $else
       <a href="#{objectId obj}">
         #{showTime time}
 
+    <div>
+      Result:
+      <i>
+        $if T.null result
+          [None]
+        $else
+          #{result}
+
     $maybe summary <- objectSummary obj
       <div>
         ^{preEscapedToHtml summary}

vervis.cabal

@@ -175,7 +175,6 @@ library
                        Vervis.Federation.Offer
                        --Vervis.Federation.Push
                        Vervis.Federation.Ticket
-                       Vervis.Federation.Util
                        Vervis.FedURI
                        Vervis.Fetch
                        Vervis.Field.Key