S2S: Component: Implement Revoke handler
This commit is contained in:
Pere Lev
parent
ae659dbba2
commit
1bdd1e9e9b
2 changed files with 331 additions and 0 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue