S2S: Component: Implement Revoke handler

src/Vervis/Actor/Common.hs

@@ -27,6 +27,7 @@ module Vervis.Actor.Common
     , topicCreateMe
     , componentGrant
     , componentAdd
+    , componentRevoke
     )
 where
 
@@ -2482,3 +2483,324 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
                     insert_ $ StemProjectGestureLocal originID addID
                 Right (author, _, addID) ->
                     insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) addID
+
+-- Meaning: An actor is revoking Grant activities
+-- Behavior:
+--  * For each revoked activity:
+--      * If it's a project revoking a delegator-Grant it gave me:
+--          * Delete the whole Stem record
+--          * Forward the Revoke to my followers
+--          * Send Revoke-start-Grant to project+followers & my followers
+--      * If it's a team revoking a delegator-Grant it gave me:
+--          * Delete the whole Squad record
+--          * Forward the Revoke to my followers
+--          * Send Accept to team+followers & my followers
+componentRevoke
+    :: forall comp.
+       (PersistRecordBackend comp SqlBackend, ToBackendKey SqlBackend comp)
+    => (comp -> KomponentId)
+    -> (forall f. f comp -> ComponentBy f)
+    -> UTCTime
+    -> Key comp
+    -> Verse
+    -> AP.Revoke URIMode
+    -> ActE (Text, Act (), Next)
+componentRevoke grabKomponent toComponent now compKey (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest)) = do
+
+    ObjURI h _ <- lift $ getActorURI authorIdMsig
+    parseRevoked <- do
+        hl <- hostIsLocal h
+        return $
+            \ lu ->
+                if hl
+                    then
+                        Left . (\ (a, _, i) -> (a, i)) <$>
+                            parseLocalActivityURI' lu
+                    else pure $ Right lu
+    revokedFirst <- parseRevoked luFirst
+    revokedRest <- traverse parseRevoked lusRest
+
+    mode <- withDBExcept $ do
+
+        revokedFirstDB <- do
+            a <- getActivity $ second (ObjURI h) revokedFirst
+            fromMaybeE a "Can't find revoked in DB"
+
+        meKomponentID <- lift $ grabKomponent <$> getJust compKey
+        Komponent meResourceID <- lift $ getJust meKomponentID
+
+        let adapt = maybe (Right Nothing) (either Left (Right . Just))
+        maybeMode <-
+            ExceptT $ fmap adapt $ runMaybeT $
+                runExceptT (Left <$> tryProject meKomponentID revokedFirstDB) <|>
+                runExceptT (Right <$> tryTeam meResourceID revokedFirstDB)
+        fromMaybeE
+            maybeMode
+            "Revoked activity isn't a relevant Grant I'm aware of"
+
+    case mode of
+        Left j -> revokeProject revokedRest j
+        Right t -> revokeTeam revokedRest t
+
+    where
+
+    verifyStemHolder :: KomponentId -> StemId -> MaybeT ActDB ()
+    verifyStemHolder meKomponentID stemID = do
+        Stem _ k <- lift $ getJust stemID
+        guard $ k == meKomponentID
+
+    tryProject' meKomponentID usAcceptID send = do
+        StemComponentAccept stemID _ <- lift $ lift $ getJust usAcceptID
+        lift $ verifyStemHolder meKomponentID stemID
+        send' <-
+            lift $ lift $
+            bitraverse
+                (traverseOf _1 $ \ localID -> do
+                    StemProjectLocal _ projectID <- getJust localID
+                    return (localID, projectID)
+                )
+                (traverseOf _1 $ \ remoteID -> do
+                    StemProjectRemote _ actorID <- getJust remoteID
+                    return (remoteID, actorID)
+                )
+                send
+        maybeStart <- lift $ lift $ getBy $ UniqueStemDelegateLocal usAcceptID
+        return (stemID, usAcceptID, send', maybeStart)
+
+    tryProject k (Left (_actorByKey, _actorEntity, itemID)) = do
+        Entity sendID (StemProjectGrantLocal usAcceptID localID _) <-
+            lift $ MaybeT $ getBy $ UniqueStemProjectGrantLocalGrant itemID
+        tryProject' k usAcceptID $ Left (localID, sendID)
+    tryProject k (Right remoteActivityID) = do
+        Entity sendID (StemProjectGrantRemote usAcceptID remoteID _) <-
+            lift $ MaybeT $ getBy $ UniqueStemProjectGrantRemoteGrant remoteActivityID
+        tryProject' k usAcceptID $ Right (remoteID, sendID)
+
+    verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB ()
+    verifySquadHolder meResourceID squadID = do
+        Squad _ resourceID <- lift $ getJust squadID
+        guard $ resourceID == meResourceID
+
+    tryTeam' meResourceID usAcceptID send = do
+        SquadUsAccept squadID _ <- lift $ lift $ getJust usAcceptID
+        lift $ verifySquadHolder meResourceID squadID
+        topic <- lift . lift $ getSquadTeam squadID
+        return (squadID, usAcceptID, topic, send)
+
+    tryTeam r (Left (_actorByKey, _actorEntity, itemID)) = do
+        Entity sendID (SquadThemSendDelegatorLocal usAcceptID _localID _) <-
+            lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorLocalGrant itemID
+        tryTeam' r usAcceptID (Left sendID) --(Left localID)
+    tryTeam r (Right remoteActivityID) = do
+        Entity sendID (SquadThemSendDelegatorRemote usAcceptID _remoteID _) <-
+            lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorRemoteGrant remoteActivityID
+        tryTeam' r usAcceptID (Right sendID) --(Right remoteID)
+
+    revokeProject revokedRest (stemID, usAcceptID, project, maybeStart) = do
+
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (LocalActorProject . snd . fst) (snd . fst) project) $
+            throwE "Sender isn't the Project the revoked Grant came from"
+
+        unless (null revokedRest) $
+            throwE "Project revoking the delegator-Grant and something more"
+
+        Entity startID (StemDelegateLocal _ grantID) <- fromMaybeE maybeStart "No recorded start-Grant"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            komponentID <- lift $ grabKomponent <$> getJust compKey
+            Komponent resourceID <- lift $ getJust komponentID
+            Resource topicActorID <- lift $ getJust resourceID
+            topicActor <- lift $ getJust topicActorID
+
+            maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+            lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do
+
+                -- Delete the whole Stem record
+                delete startID
+                case project of
+                    Left (_, sendID) -> delete sendID
+                    Right (_, sendID) -> delete sendID
+                origin <-
+                    requireEitherAlt
+                        (getKeyBy $ UniqueStemOriginAdd stemID)
+                        (getKeyBy $ UniqueStemOriginInvite stemID)
+                        "Neither us nor them"
+                        "Both us and them"
+                case origin of
+                    Left usID -> delete usID
+                    Right themID -> do
+                        deleteBy $ UniqueStemProjectAcceptLocal themID
+                        deleteBy $ UniqueStemProjectAcceptRemote themID
+                        deleteBy $ UniqueStemProjectGestureLocal themID
+                        deleteBy $ UniqueStemProjectGestureRemote themID
+                        delete themID
+                delete usAcceptID
+                deleteBy $ UniqueStemComponentGestureLocal stemID
+                deleteBy $ UniqueStemComponentGestureRemote stemID
+                case project of
+                    Left ((localID, _), _) -> delete localID
+                    Right ((remoteID, _), _) -> delete remoteID
+                delete stemID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid compKey
+                    let topicByHash = resourceToActor $ componentResource $ toComponent topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                -- Prepare Accept activity
+                revoke@(actionRevoke, _, _, _) <- prepareRevoke grantID
+                let recipByKey = resourceToActor $ componentResource $ toComponent compKey
+                revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+                _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
+
+                return (topicActorID, sieve, revokeID, revoke, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
+                let topicByID = resourceToActor $ componentResource $ toComponent compKey
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                lift $
+                    sendActivity
+                        topicByID topicActorID localRecipsRevoke
+                        remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+                doneDB inboxItemID "Deleted the Project/Stem, forwarded Revoke, sent Revoke-start-Grant"
+
+        where
+
+        prepareRevoke grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            recipHash <- encodeKeyHashid compKey
+            let topicByHash = resourceToActor $ componentResource $ toComponent recipHash
+
+            audProject <- makeAudSenderWithFollowers authorIdMsig
+            let audMe = AudLocal [] [localActorFollowers topicByHash]
+            uRevoke <- lift $ getActivityURI authorIdMsig
+            luGrant <- do
+                grantHash <- encodeKeyHashid grantID
+                return $ encodeRouteLocal $ activityRoute topicByHash grantHash
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audProject, audMe]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Nothing
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uRevoke]
+                    , AP.actionSpecific   = AP.RevokeActivity AP.Revoke
+                        { AP.revokeObject = luGrant :| []
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+    revokeTeam revokedRest (squadID, usAcceptID, team, send) = do
+
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (LocalActorGroup . snd) snd team) $
+            throwE "Sender isn't the Team the revoked Grant came from"
+
+        unless (null revokedRest) $
+            throwE "Team revoking the delegator-Grant and something more"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            komponentID <- lift $ grabKomponent <$> getJust compKey
+            Komponent resourceID <- lift $ getJust komponentID
+            Resource topicActorID <- lift $ getJust resourceID
+            topicActor <- lift $ getJust topicActorID
+
+            maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+            lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do
+
+                maybeStartID <- getKeyBy $ UniqueSquadUsStart usAcceptID
+
+                -- Delete the whole Squad record
+                for_ maybeStartID delete
+                case send of
+                    Left sendID -> delete sendID
+                    Right sendID -> delete sendID
+                origin <-
+                    requireEitherAlt
+                        (getKeyBy $ UniqueSquadOriginUs squadID)
+                        (getKeyBy $ UniqueSquadOriginThem squadID)
+                        "Neither us nor them"
+                        "Both us and them"
+                deleteBy $ UniqueSquadUsGestureLocal squadID
+                deleteBy $ UniqueSquadUsGestureRemote squadID
+                case origin of
+                    Left usID -> delete usID
+                    Right themID -> do
+                        deleteBy $ UniqueSquadThemAcceptLocal themID
+                        deleteBy $ UniqueSquadThemAcceptRemote themID
+                        deleteBy $ UniqueSquadThemGestureLocal themID
+                        deleteBy $ UniqueSquadThemGestureRemote themID
+                        delete themID
+                delete usAcceptID
+                case team of
+                    Left (l, _) -> delete l
+                    Right (r, _) -> delete r
+                delete squadID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid compKey
+                    let topicByHash = resourceToActor $ componentResource $ toComponent topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                -- Prepare Accept activity
+                accept@(actionAccept, _, _, _) <- prepareAccept
+                let recipByKey = resourceToActor $ componentResource $ toComponent compKey
+                acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+                _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
+
+                return (topicActorID, sieve, acceptID, accept, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
+                let topicByID = resourceToActor $ componentResource $ toComponent compKey
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                lift $
+                    sendActivity
+                        topicByID topicActorID localRecipsAccept
+                        remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                doneDB inboxItemID "Deleted the Team/Squad, forwarded Revoke, sent Accept"
+
+        where
+
+        prepareAccept = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            recipHash <- encodeKeyHashid compKey
+            let topicByHash = resourceToActor $ componentResource $ toComponent recipHash
+
+            audTeam <- makeAudSenderWithFollowers authorIdMsig
+            let audMe = AudLocal [] [localActorFollowers topicByHash]
+            uRevoke <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audTeam, audMe]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Nothing
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uRevoke]
+                    , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                        { AP.acceptObject   = uRevoke
+                        , AP.acceptResult   = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)

src/Vervis/Actor/Deck.hs

@@ -489,6 +489,14 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
+deckRevoke
+    :: UTCTime
+    -> DeckId
+    -> Verse
+    -> AP.Revoke URIMode
+    -> ActE (Text, Act (), Next)
+deckRevoke = componentRevoke deckKomponent ComponentDeck
+
 ------------------------------------------------------------------------------
 -- Following
 ------------------------------------------------------------------------------
@@ -904,6 +912,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
         AP.RejectActivity reject -> deckReject now deckID verse reject
         AP.RemoveActivity remove -> deckRemove now deckID verse remove
         AP.ResolveActivity resolve -> deckResolve now deckID verse resolve
+        AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke
         AP.UndoActivity undo     -> deckUndo now deckID verse undo
         _ -> throwE "Unsupported activity type for Deck"
 deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck"