S2S: Group: Accept: Implement resource mode
This commit is contained in:
Pere Lev
parent
47736bb0a8
commit
cd18217f08
1 changed files with 287 additions and 3 deletions
|
|
@ -944,6 +944,41 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
|
|||
-- delegation Grant I got from B
|
||||
-- * To: The parent/collaborator/team to whom I'd sent the Grant
|
||||
-- * CC: -
|
||||
--
|
||||
-- * Give me a new resource active EffortOriginUs
|
||||
-- * Verify we haven't yet seen resource's Accept
|
||||
-- * Insert the Accept to my inbox
|
||||
-- * If sender is the resource, record the Accept into the Effort record
|
||||
-- * Prepare to send degelator-Grant
|
||||
-- * Otherwise nothing to do
|
||||
-- * Forward the Accept to my followers
|
||||
-- * Possibly send a Grant:
|
||||
-- * If sender is the resource
|
||||
-- * delegator-Grant
|
||||
-- * To: Resource
|
||||
-- * CC:
|
||||
-- - Resource's followers
|
||||
-- - My followers
|
||||
--
|
||||
-- * Give me a new resource passive EffortOriginThem
|
||||
-- * Option 1: We haven't seen resource's Accept yet
|
||||
-- * Verify sender is the resource
|
||||
-- * Option 2: We saw it, but not my collaborator's Accept
|
||||
-- * Verify the Accept is authorized
|
||||
-- * Otherwise respond with error, no Accept is needed
|
||||
-- * Insert the Accept to my inbox
|
||||
-- * Option 1: Record resource's Accept in Effort record
|
||||
-- * Option 2: Record my collaborator's Accept
|
||||
-- * Prepare to send delegator-Grant
|
||||
-- * Forward the Accept to my followers
|
||||
-- * Possibly send a Grant:
|
||||
-- * In option 2
|
||||
-- * delegator-Grant
|
||||
-- * To: Resource
|
||||
-- * CC:
|
||||
-- - Resource's followers
|
||||
-- - My followers
|
||||
-- - The Accept sender (my collaborator)
|
||||
groupAccept
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
|
|
@ -972,8 +1007,10 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
||||
maybeCollab <-
|
||||
ExceptT $ fmap adapt $ runMaybeT $
|
||||
runExceptT (Left <$> tryInviteCollab accepteeDB) <|>
|
||||
runExceptT (Left <$> tryJoinCollab accepteeDB) <|>
|
||||
runExceptT (Left . Left <$> tryInviteCollab accepteeDB) <|>
|
||||
runExceptT (Left . Left <$> tryJoinCollab accepteeDB) <|>
|
||||
runExceptT (Left . Right <$> tryAddResourceActive accepteeDB) <|>
|
||||
runExceptT (Left . Right <$> tryAddResourcePassive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddChildActive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
|
||||
|
|
@ -984,7 +1021,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
"Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
|
||||
|
||||
case collabOrComp_or_child of
|
||||
Left collab -> addCollab collab
|
||||
Left (Left collab) -> addCollab collab
|
||||
Left (Right resource) -> addResource resource
|
||||
Right (Left cp) -> addChildParent cp
|
||||
Right (Right parent) -> removeParent parent
|
||||
|
||||
|
|
@ -1174,6 +1212,41 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
|
||||
tryRemoveParent' i
|
||||
|
||||
verifyEffortHolder :: EffortId -> MaybeT ActDB ()
|
||||
verifyEffortHolder effortID = do
|
||||
Effort _ g <- lift $ getJust effortID
|
||||
guard $ g == groupID
|
||||
|
||||
tryAddResourceActive' usID = do
|
||||
EffortOriginUs effortID <- lift . lift $ getJust usID
|
||||
lift $ verifyEffortHolder effortID
|
||||
topic <- lift . lift $ getEffortTopic effortID
|
||||
return (effortID, topic, Left ())
|
||||
|
||||
tryAddResourceActive (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
EffortUsGestureLocal usID _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueEffortUsGestureLocalAdd itemID
|
||||
tryAddResourceActive' usID
|
||||
tryAddResourceActive (Right remoteActivityID) = do
|
||||
EffortUsGestureRemote usID _ _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueEffortUsGestureRemoteAdd remoteActivityID
|
||||
tryAddResourceActive' usID
|
||||
|
||||
tryAddResourcePassive' themID = do
|
||||
EffortOriginThem effortID <- lift . lift $ getJust themID
|
||||
lift $ verifyEffortHolder effortID
|
||||
topic <- lift . lift $ getEffortTopic effortID
|
||||
return (effortID, topic, Right ())
|
||||
|
||||
tryAddResourcePassive (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
EffortThemGestureLocal themID _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueEffortThemGestureLocalAdd itemID
|
||||
tryAddResourcePassive' themID
|
||||
tryAddResourcePassive (Right remoteActivityID) = do
|
||||
EffortThemGestureRemote themID _ _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueEffortThemGestureRemoteAdd remoteActivityID
|
||||
tryAddResourcePassive' themID
|
||||
|
||||
componentIsAuthor ident =
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (resourceToActor . componentResource . snd) snd ident
|
||||
|
|
@ -1183,6 +1256,11 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (LocalActorGroup . snd) snd ident
|
||||
|
||||
theyIsAuthor' :: Either (a, LocalResourceBy Key) (b, RemoteActorId) -> Bool
|
||||
theyIsAuthor' ident =
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (resourceToActor . snd) snd ident
|
||||
|
||||
addCollab (collabID, fulfills, inviterOrJoiner) = do
|
||||
|
||||
collab <-
|
||||
|
|
@ -1915,6 +1993,212 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
addResource (effortID, topic', mode) = do
|
||||
|
||||
topic <-
|
||||
lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) topic'
|
||||
mode' <-
|
||||
bitraverse
|
||||
|
||||
-- Resource-active mode
|
||||
-- Verify we haven't yet seen resource's Accept
|
||||
(\ () -> do
|
||||
maybeResourceAccept <-
|
||||
lift $ withDB $
|
||||
case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueEffortThemAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueEffortThemAcceptRemote remoteID)
|
||||
verifyNothingE maybeResourceAccept "I already saw resource's Accept"
|
||||
)
|
||||
|
||||
-- Resource-passive mode
|
||||
-- Option 1: We haven't seen resource's Accept yet
|
||||
-- * Verify sender is the resource
|
||||
-- Option 2: We saw it, but not my collaborator's Accept
|
||||
-- * Verify the Accept is authorized
|
||||
-- Otherwise respond with error, no Accept is needed
|
||||
(\ () -> do
|
||||
(maybeResourceAccept, maybeGrant) <-
|
||||
lift $ withDB $ liftA2 (,)
|
||||
(case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueEffortThemAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueEffortThemAcceptRemote remoteID)
|
||||
)
|
||||
(getBy $ UniqueEffortUsSendDelegator effortID)
|
||||
case (isJust maybeResourceAccept, isJust maybeGrant) of
|
||||
(False, True) -> error "Impossible/bug, didn't see resource's Accept but sent a Grant"
|
||||
(False, False) -> do
|
||||
unless (theyIsAuthor' topic) $
|
||||
throwE "The Accept I'm waiting for is from my new resource"
|
||||
return $ Left ()
|
||||
(True, False) -> do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalResourceGroup groupID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Resource already enabled, not needing any further Accept"
|
||||
)
|
||||
|
||||
mode
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust groupID
|
||||
let actorID = groupActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do
|
||||
|
||||
idsForGrant <-
|
||||
lift $
|
||||
bitraverse
|
||||
|
||||
-- Resource-active mode
|
||||
-- If sender is resource, record the Accept into the
|
||||
-- Effort record & prepare to send degelator-Grant
|
||||
-- Othrerwise do nothing
|
||||
(\ () ->
|
||||
if theyIsAuthor' topic
|
||||
then Just <$> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ EffortThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ EffortThemAcceptRemote remoteID acceptID
|
||||
_ -> error "groupAccept impossible iv"
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ EffortUsSendDelegator effortID grantID
|
||||
return grantID
|
||||
else pure Nothing
|
||||
)
|
||||
|
||||
-- Resource-passive mode
|
||||
(\case
|
||||
|
||||
-- Getting an Accept from the resource
|
||||
-- Record resource's Accept in Effort record
|
||||
Left () -> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ EffortThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ EffortThemAcceptRemote remoteID acceptID
|
||||
_ -> error "groupAccept impossible v"
|
||||
return Nothing
|
||||
|
||||
-- Getting an Accept from my collaborator
|
||||
-- Record my collaborator's Accept
|
||||
-- Prepare to send delegator-Grant
|
||||
Right () -> Just <$> do
|
||||
{-
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ ? localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ ? remoteID acceptID
|
||||
_ -> error "groupAccept impossible iv"
|
||||
-}
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ EffortUsSendDelegator effortID grantID
|
||||
return grantID
|
||||
)
|
||||
|
||||
mode'
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = LocalActorGroup groupID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
maybeAct <-
|
||||
case idsForGrant of
|
||||
Left mg -> for mg $ \ grantID -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareEffortDelegGrant (bimap snd snd topic) False
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
Right mg -> for mg $ \ grantID -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareEffortDelegGrant (bimap snd snd topic) True
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
return (recipActorID, sieve, maybeAct, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do
|
||||
let recipByID = LocalActorGroup groupID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
doneDB inboxItemID "[Resource] Forwarded the Accept and maybe published a Grant/Accept"
|
||||
|
||||
where
|
||||
|
||||
prepareEffortDelegGrant ident includeAuthor = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
(uResource, audResource) <-
|
||||
case ident of
|
||||
Left lr -> do
|
||||
la <- resourceToActor <$> hashLocalResource lr
|
||||
return
|
||||
( encodeRouteHome $ renderLocalActor la
|
||||
, AudLocal [la] [localActorFollowers la]
|
||||
)
|
||||
Right raID -> do
|
||||
ra <- getJust raID
|
||||
u@(ObjURI h lu) <- getRemoteActorURI ra
|
||||
return
|
||||
( u
|
||||
, AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||
)
|
||||
audAuthor <- lift $ makeAudSenderOnly authorIdMsig
|
||||
groupHash <- encodeKeyHashid groupID
|
||||
let audGroup = AudLocal [] [LocalStageGroupFollowers groupHash]
|
||||
|
||||
audience =
|
||||
if includeAuthor
|
||||
then [audResource, audGroup, audAuthor]
|
||||
else [audResource, audGroup]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience audience
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [AP.acceptObject accept]
|
||||
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||
{ AP.grantObject = AP.RXDelegator
|
||||
, AP.grantContext = encodeRouteHome $ GroupR groupHash
|
||||
, AP.grantTarget = uResource
|
||||
, AP.grantResult = Nothing
|
||||
, AP.grantStart = Just now
|
||||
, AP.grantEnd = Nothing
|
||||
, AP.grantAllows = AP.Invoke
|
||||
, AP.grantDelegates = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: Someone has created a group with my ID URI
|
||||
-- Behavior:
|
||||
-- * Verify I'm in a just-been-created state
|
||||
|
|
|
|||
Loading…
Reference in a new issue