S2S: Person: Revoke: Delete Permit records

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