S2S: Person: Revoke: Delete Permit records

This commit is contained in:
Pere Lev 2023-12-07 17:03:26 +02:00
parent 11a79b00fb
commit 6dceaa1cff
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D

View file

@ -28,6 +28,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Barbie import Data.Barbie
import Data.Bifoldable
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -1105,27 +1106,162 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: An actor has revoked some previously published Grants -- 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 personRevoke
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> Verse -> Verse
-> AP.Revoke URIMode -> AP.Revoke URIMode
-> ActE (Text, Act (), Next) -> 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 -- Grab me from DB
(_personRecip, actorRecip) <- do (personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (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" 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 -- Main behavior function