From a428bd74abf7c85a7150b1adedbc45c05bb5a742 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sun, 28 Apr 2024 00:31:48 +0300 Subject: [PATCH] UI, S2S: Store errors in Errbox + display in notifications --- src/Vervis/Actor/Common.hs | 2 +- src/Vervis/Actor/Deck.hs | 9 ++- src/Vervis/Actor/Group.hs | 9 ++- src/Vervis/Actor/Loom.hs | 11 +++- src/Vervis/Actor/Person.hs | 8 ++- src/Vervis/Actor/Project.hs | 9 ++- src/Vervis/Actor/Repo.hs | 12 +++- src/Vervis/Federation/Discussion.hs | 2 +- src/Vervis/Federation/Offer.hs | 2 +- src/Vervis/Federation/Ticket.hs | 2 +- src/Vervis/Federation/Util.hs | 80 --------------------------- src/Vervis/Handler/Client.hs | 28 ++++++---- src/Vervis/Persist/Actor.hs | 67 +++++++++++++++++++++- templates/person/notifications.hamlet | 12 +++- vervis.cabal | 1 - 15 files changed, 141 insertions(+), 113 deletions(-) delete mode 100644 src/Vervis/Federation/Util.hs diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 522a7c3..c568051 100644 --- a/src/Vervis/Actor/Common.hs +++ b/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 diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 969e23c..4de7496 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/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 diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 166dffe..eb26ad2 100644 --- a/src/Vervis/Actor/Group.hs +++ b/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 diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index 045a098..1878dd2 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2023 by fr33domlover . + - Written in 2023, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 4f23def..66df3ef 100644 --- a/src/Vervis/Actor/Person.hs +++ b/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 diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 51aaa72..7bf7ab4 100644 --- a/src/Vervis/Actor/Project.hs +++ b/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 diff --git a/src/Vervis/Actor/Repo.hs b/src/Vervis/Actor/Repo.hs index 3dd7eb9..f5de7ae 100644 --- a/src/Vervis/Actor/Repo.hs +++ b/src/Vervis/Actor/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2023 by fr33domlover . + - Written in 2023, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index bc4551c..dd7b4ac 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/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 diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index dc1979f..14d960f 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/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 diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index f473fbe..8965cb2 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/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 diff --git a/src/Vervis/Federation/Util.hs b/src/Vervis/Federation/Util.hs deleted file mode 100644 index 8394ca6..0000000 --- a/src/Vervis/Federation/Util.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2019, 2020, 2023, 2024 by fr33domlover . - - - - ♡ 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 - - . - -} - -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)) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index bd0fa62..6c2c539 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -532,13 +532,16 @@ getNotificationsR = do Entity _ viewer <- requireVerifiedAuth items <- runDB $ do - inboxID <- actorInbox <$> getJust (personActor viewer) - map adaptItem <$> getItems inboxID + actor <- getJust $ personActor viewer + 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] diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index a9b0a67..6debea3 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2022, 2023, 2024 by fr33domlover . + - Written in 2019, 2020, 2022, 2023, 2024 + - by fr33domlover . - - ♡ 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 diff --git a/templates/person/notifications.hamlet b/templates/person/notifications.hamlet index 73bc3d0..2a5e9db 100644 --- a/templates/person/notifications.hamlet +++ b/templates/person/notifications.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2019, 2022 by fr33domlover . +$# Written in 2019, 2022, 2024 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -22,7 +22,7 @@ $else