From 6dceaa1cffd6c1bc68d60b251f0cc948c085f3fa Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 7 Dec 2023 17:03:26 +0200 Subject: [PATCH] S2S: Person: Revoke: Delete Permit records --- src/Vervis/Actor/Person.hs | 150 +++++++++++++++++++++++++++++++++++-- 1 file changed, 143 insertions(+), 7 deletions(-) diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index db8c47e..5f4f1b5 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -28,6 +28,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Barbie +import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -1105,27 +1106,162 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) -- Meaning: An actor has revoked some previously published Grants --- Behavior: Insert to my inbox +-- Behavior: +-- * Insert to my inbox +-- * For each revoked activity: +-- * If it's a direct-Grant given to me: +-- * Verify the sender is the Permit topic +-- * Delete the Permit record +-- * If it's an extension-Grant given to me: +-- * Verify the sender is the Permit topic +-- * Delete the PermitTopicExtend* record personRevoke :: UTCTime -> PersonId -> Verse -> AP.Revoke URIMode -> ActE (Text, Act (), Next) -personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke _lus) = do +personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do - maybeRevoke <- lift $ withDB $ do + -- Check input + grants <- nameExceptT "Revoke.object" $ do + ObjURI h _ <- lift $ getActorURI authorIdMsig + hl <- hostIsLocal h + if hl + then + for lus $ \ lu -> + (\ (actor, _, item) -> Left (actor, item)) <$> + parseLocalActivityURI' lu + else + pure $ Right . ObjURI h <$> lus + + maybeNew <- withDBExcept $ do -- Grab me from DB - (_personRecip, actorRecip) <- do + (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - insertToInbox now authorIdMsig body (actorInbox actorRecip) True + -- Look for the revoked Grants in my Permit records + grantsDB <- for grants $ \ grant -> runMaybeT $ do + grantDB <- MaybeT $ getActivity grant + found <- + Left <$> tryDirect grantDB <|> + Right <$> tryExtension grantDB + bitraverse + (\ (gestureID, topicAndEnable) -> do - case maybeRevoke of + -- Verify the Permit is mine + PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID + Permit p _ <- lift . lift $ getJust permitID + guard $ p == recipPersonID + + -- Verify the Revoke sender is the Permit topic + lift $ do + topic <- lift $ getPermitTopic permitID + case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Revoke sender isn't the Permit topic" + + -- Return data for Permit deletion + return (permitID, gestureID, topicAndEnable) + ) + (\ extend -> do + + -- Verify the Permit is mine + sendID <- + lift . lift $ case extend of + Left k -> permitTopicExtendLocalPermit <$> getJust k + Right k -> permitTopicExtendRemotePermit <$> getJust k + PermitPersonSendDelegator gestureID _ <- lift . lift $ getJust sendID + PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID + Permit p _ <- lift . lift $ getJust permitID + guard $ p == recipPersonID + + -- Verify the Revoke sender is the Permit topic + lift $ do + topic <- lift $ getPermitTopic permitID + case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Revoke sender isn't the Permit topic" + + -- Return data for PermitTopicExtend* deletion + return extend + ) + found + + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True + lift $ for mractid $ \ _revokeDB -> + -- Delete revoked records from DB + for grantsDB $ traverse_ $ + bitraverse_ + (\ (permitID, gestureID, topicAndEnable) -> do + case topicAndEnable of + Left (_, enableID) -> + deleteWhere [PermitTopicExtendLocalTopic ==. enableID] + Right (_, enableID) -> + deleteWhere [PermitTopicExtendRemoteTopic ==. enableID] + deleteBy $ UniquePermitPersonSendDelegator gestureID + case topicAndEnable of + Left (topicID, enableID) -> do + delete enableID + deleteBy $ UniquePermitTopicAcceptLocalTopic topicID + Right (topicID, enableID) -> do + delete enableID + deleteBy $ UniquePermitTopicAcceptRemoteTopic topicID + maybeInvite <- getKeyBy $ UniquePermitFulfillsInvite permitID + for_ maybeInvite $ \ inviteID -> do + deleteBy $ UniquePermitTopicGestureLocal inviteID + deleteBy $ UniquePermitTopicGestureRemote inviteID + delete gestureID + deleteBy $ UniquePermitFulfillsTopicCreation permitID + deleteBy $ UniquePermitFulfillsInvite permitID + deleteBy $ UniquePermitFulfillsJoin permitID + case topicAndEnable of + Left (topicID, _) -> do + deleteBy $ UniquePermitTopicRepo topicID + deleteBy $ UniquePermitTopicDeck topicID + deleteBy $ UniquePermitTopicLoom topicID + deleteBy $ UniquePermitTopicProject topicID + deleteBy $ UniquePermitTopicGroup topicID + delete topicID + Right (topicID, _) -> delete topicID + delete permitID + ) + (\case + Left k -> delete k + Right k -> delete k + ) + + case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just _revokeDB -> done "Inserted to my inbox" + Just _ -> done "Deleted any relevant Permit/Extend records" + + where + + tryDirect objectDB = + case objectDB of + Left (_actorByKey, _actorEntity, itemID) -> do + Entity enableID (PermitTopicEnableLocal gestureID topicID _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicEnableLocalGrant itemID + return (gestureID, Left (topicID, enableID)) + Right remoteActivityID -> do + Entity enableID (PermitTopicEnableRemote gestureID topicID _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicEnableRemoteGrant remoteActivityID + return (gestureID, Right (topicID, enableID)) + + tryExtension objectDB = + case objectDB of + Left (_actorByKey, _actorEntity, itemID) -> do + Entity extendID (PermitTopicExtendLocal _ _ _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicExtendLocalGrant itemID + return $ Left extendID + Right remoteActivityID -> do + Entity extendID (PermitTopicExtendRemote _ _ _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicExtendRemoteGrant remoteActivityID + return $ Right extendID ------------------------------------------------------------------------------ -- Main behavior function