From 39dc2089b2df0bdf753458cc4e75a8aed7d3e265 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 23 Nov 2023 18:21:41 +0200 Subject: [PATCH] S2S: Person: Accept: If topic is approving an Invite, update Permit record --- src/Data/Maybe/Local.hs | 12 +++++- src/Vervis/Actor/Person.hs | 74 ++++++++++++++++++++++++++++++++++-- src/Vervis/Persist/Collab.hs | 42 ++++++++++++++++++++ 3 files changed, 123 insertions(+), 5 deletions(-) diff --git a/src/Data/Maybe/Local.hs b/src/Data/Maybe/Local.hs index 72bdc6e..43bb250 100644 --- a/src/Data/Maybe/Local.hs +++ b/src/Data/Maybe/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -16,9 +16,12 @@ module Data.Maybe.Local ( partitionMaybes , partitionMaybePairs + , exactlyOneJust ) where +import Data.Maybe + partitionMaybes :: [(Maybe a, b)] -> ([(a, b)], [b]) partitionMaybes = foldr f ([], []) where @@ -32,3 +35,10 @@ partitionMaybePairs = foldr f ([], [], []) f (Just x, Nothing) (xs, ys, ps) = (x : xs, ys, ps) f (Nothing, Just y) (xs, ys, ps) = (xs, y : ys, ps) f (Just x, Just y) (xs, ys, ps) = (xs, ys, (x, y) : ps) + +exactlyOneJust :: Monad m => [Maybe a] -> String -> String -> m a +exactlyOneJust l none multiple = + case catMaybes l of + [] -> error none + [x] -> pure x + _ -> error multiple diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index d218eed..9daba29 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -19,6 +19,7 @@ module Vervis.Actor.Person ) where +import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -274,7 +275,13 @@ personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do -- Meaning: An actor accepted something -- Behavior: -- * Insert to my inbox --- * If it's a Follow I sent to them, add to my following list in DB +-- * If it's on a Follow I sent to them: +-- * Add to my following list in DB +-- * If it's on an Invite-for-me to collaborate on a resource: +-- * Verify I haven't yet seen the resource's accept +-- * Verify the Accept author is the resource +-- * Store it in the Permit record in DB +-- * Forward to my followers personAccept :: UTCTime -> PersonId @@ -299,13 +306,22 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do -- Find the accepted activity in our DB accepteeDB <- MaybeT $ getActivity acceptee - tryFollow (personActor personRecip) accepteeDB acceptDB + let recipActorID = personActor personRecip + Left <$> tryFollow recipActorID accepteeDB acceptDB <|> + Right <$> tryInvite recipActorID accepteeDB acceptDB case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just Nothing -> done "Not my Follow; Just inserted to my inbox" - Just (Just ()) -> + Just Nothing -> done "Not my Follow/Invite; Just inserted to my inbox" + Just (Just (Left ())) -> done "Recorded this Accept on the Follow request I sent" + Just (Just (Right (actorID, sieve))) -> do + forwardActivity + authorIdMsig body (LocalActorPerson recipPersonID) + actorID sieve + done + "Recorded this Accept on the Invite I've had & \ + \forwarded to my followers" where @@ -360,6 +376,56 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do -} tryFollow _ (Right _) _ = mzero + tryInvite recipActorID accepteeDB acceptDB = do + + -- Find a PermitFulfillsInvite + (permitID, fulfillsID) <- + case accepteeDB of + Left (actorByKey, _actorEntity, itemID) -> do + PermitTopicGestureLocal fulfillsID _ <- + MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID + PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID + return (permitID, fulfillsID) + Right remoteActivityID -> do + PermitTopicGestureRemote fulfillsID _ _ <- + MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID + PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID + return (permitID, fulfillsID) + + -- Find the local person and verify it's me + Permit p _role <- lift . lift $ getJust permitID + guard $ p == recipPersonID + + lift $ do + -- Find the topic + topic <- lift $ getPermitTopic permitID + + -- Verify I haven't seen the topic's accept yet + maybeTopicAccept <- + lift $ case bimap fst fst topic of + Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID) + Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID) + unless (isNothing maybeTopicAccept) $ + throwE "I've already seen the topic's Accept" + + -- Verify topic is the Accept sender + case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Accept sender isn't the Invite topic" + + -- Update the Permit record + lift $ case (bimap fst fst topic, bimap (view _3) (view _3) acceptDB) of + (Left localID, Left acceptID) -> insert_ $ PermitTopicAcceptLocal fulfillsID localID acceptID + (Right remoteID, Right acceptID) -> insert_ $ PermitTopicAcceptRemote fulfillsID remoteID acceptID + _ -> error "personAccept impossible" + + -- Prepare forwarding Accept to my followers + recipPersonHash <- encodeKeyHashid recipPersonID + let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash] + + return (recipActorID, sieve) + -- Meaning: An actor rejected something -- Behavior: -- * Insert to my inbox diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 9b1320e..4caaef5 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -17,6 +17,7 @@ module Vervis.Persist.Collab ( getCollabTopic , getCollabTopic' , getCollabRecip + , getPermitTopic , getStemIdent , getStemProject , getGrantRecip @@ -64,6 +65,7 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.Either.Local +import Data.Maybe.Local import Database.Persist.Local import Vervis.Actor @@ -110,6 +112,46 @@ getCollabRecip collabID = "Collab without recip" "Collab with both local and remote recip" +getPermitTopic + :: MonadIO m + => PermitId + -> ReaderT SqlBackend m + (Either + (PermitTopicLocalId, LocalActorBy Key) + (PermitTopicRemoteId, RemoteActorId) + ) +getPermitTopic permitID = do + topic <- + requireEitherAlt + (getKeyBy $ UniquePermitTopicLocal permitID) + (getBy $ UniquePermitTopicRemote permitID) + "Permit without topic" + "Permit with both local and remote topic" + bitraverse + (\ localID -> (localID,) <$> do + options <- + sequence + [ fmap (LocalActorRepo . permitTopicRepoRepo) <$> + getValBy (UniquePermitTopicRepo localID) + , fmap (LocalActorDeck . permitTopicDeckDeck) <$> + getValBy (UniquePermitTopicDeck localID) + , fmap (LocalActorLoom . permitTopicLoomLoom) <$> + getValBy (UniquePermitTopicLoom localID) + , fmap (LocalActorProject . permitTopicProjectProject) <$> + getValBy (UniquePermitTopicProject localID) + , fmap (LocalActorGroup . permitTopicGroupGroup) <$> + getValBy (UniquePermitTopicGroup localID) + ] + exactlyOneJust + options + "Found Permit without topic" + "Found Permit with multiple topics" + ) + (\ (Entity topicID (PermitTopicRemote _ actorID)) -> + return (topicID, actorID) + ) + topic + getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key) getStemIdent stemID = do maybeRepo <- getValBy $ UniqueStemIdentRepo stemID