diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index a02a28c..3d24e9c 100644 --- a/src/Vervis/Actor/Common.hs +++ b/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) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 0283ecc..9a5a90d 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/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"