S2S: Person: Implement response to direct-Grant and extension-Grant
This commit is contained in:
Pere Lev
parent
39dc2089b2
commit
11a79b00fb
1 changed files with 271 additions and 16 deletions
|
|
@ -805,6 +805,21 @@ personJoin now recipPersonID (Verse authorIdMsig body) join = do
|
|||
-- Meaning: An actor published a Grant
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
--
|
||||
-- * If it's a direct-Grant that fulfills a Permit I have:
|
||||
-- * Verify the Permit isn't already enabled
|
||||
-- * Verify the sender is the Permit topic
|
||||
-- * Verify the role is identical to what was requested
|
||||
-- * Update the Permit record, storing the direct-Grant
|
||||
-- * Forward the direct-Grant to my followers
|
||||
-- * If topic is a Project or a Team:
|
||||
-- * Send a delegator-Grant to the topic
|
||||
-- * Update the Permit record, storing the delegator-Grant
|
||||
--
|
||||
-- * If it's a extension-Grant whose capability is a delegator-Grant from
|
||||
-- a Permit I have:
|
||||
-- * Verify the sender is the Permit topic
|
||||
-- * Update the Permit record, storing the extension-Grant
|
||||
personGrant
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
|
|
@ -814,9 +829,18 @@ personGrant
|
|||
personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||
|
||||
-- Check input
|
||||
target <- do
|
||||
--h <- lift $ objUriAuthority <$> getActorURI authorIdMsig
|
||||
(_role, resource, recip, _mresult, _mstart, _mend, _usage, _mdeleg) <-
|
||||
maybeMine <- do
|
||||
-- Verify the capability URI, if provided, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCapability <-
|
||||
for (AP.activityCapability $ actbActivity body) $ \ uCap ->
|
||||
nameExceptT "Grant.capability" $
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI' uCap
|
||||
|
||||
-- Basic sanity checks
|
||||
(role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <-
|
||||
parseGrant' grant
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (GrantRecipPerson' p), Left (LocalActorPerson p', _, _))
|
||||
|
|
@ -826,28 +850,259 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
| uRecip == remoteAuthorURI author ->
|
||||
throwE "Grant sender and target are the same remote actor"
|
||||
_ -> pure ()
|
||||
return recip
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
case mdeleg of
|
||||
Nothing ->
|
||||
unless (author == resource) $
|
||||
throwE "Not an extension but resource and actor differ"
|
||||
Just _ ->
|
||||
when (author == resource) $
|
||||
throwE "Extension but resource and actor are identical"
|
||||
|
||||
maybeGrant <- withDBExcept $ do
|
||||
-- For a direct-Grant, use 'fulfills' to identify the Permit
|
||||
-- For an extension-Grant, use 'capability' for that
|
||||
runMaybeT $ do
|
||||
guard $ usage == AP.Invoke
|
||||
guard $ recip == Left (GrantRecipPerson' recipPersonID)
|
||||
lift $ do
|
||||
for_ mstart $ \ start ->
|
||||
unless (start <= now) $
|
||||
throwE "Got a Grant that hasn't started"
|
||||
for_ mend $ \ _ -> throwE "Got a Grant with expiration"
|
||||
if isNothing mdeleg
|
||||
then do
|
||||
uFulfills <-
|
||||
case AP.activityFulfills $ actbActivity body of
|
||||
[] -> mzero
|
||||
[u] -> pure u
|
||||
_ -> lift $ throwE "Multiple fulfills"
|
||||
fulfills <-
|
||||
lift $
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI' uFulfills
|
||||
return $ Left (role, fulfills)
|
||||
else do
|
||||
cap <- lift $ fromMaybeE maybeCapability "Extension-Grant doesn't specify a delegator-Grant capability"
|
||||
delegatorID <-
|
||||
case cap of
|
||||
Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID
|
||||
_ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine"
|
||||
return $ Right delegatorID
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
for mractid $ \ _grantDB -> return $ personActor personRecip
|
||||
maybePermit <-
|
||||
for maybeMine $
|
||||
bitraverse
|
||||
(\ (role, fulfills) -> do
|
||||
|
||||
case maybeGrant of
|
||||
-- Find my Permit record, verify the roles match
|
||||
fulfillsDB <- do
|
||||
a <- getActivity fulfills
|
||||
fromMaybeE a "Can't find fulfills in DB"
|
||||
(permitID, maybeGestureID) <- do
|
||||
mp <- runMaybeT $ do
|
||||
x@(pt, mg) <-
|
||||
tryInvite fulfillsDB <|>
|
||||
tryJoin fulfillsDB <|>
|
||||
tryCreate fulfillsDB
|
||||
Permit p role' <- lift . lift $ getJust pt
|
||||
guard $ p == recipPersonID
|
||||
lift $ unless (role == AP.RXRole role') $
|
||||
throwE "Requested and granted roles differ"
|
||||
return x
|
||||
fromMaybeE mp "Can't find a PermitFulfills*"
|
||||
|
||||
-- If Permit fulfills an Invite, verify I've approved
|
||||
-- it
|
||||
gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"
|
||||
|
||||
-- Verify the Permit isn't already enabled
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
maybeTopicEnable <-
|
||||
lift $ case bimap fst fst topic of
|
||||
Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
|
||||
Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
|
||||
unless (isNothing maybeTopicEnable) $
|
||||
throwE "I've already received the direct-Grant"
|
||||
|
||||
-- Verify the Grant sender is the Permit topic
|
||||
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 "Grant sender isn't the Permit topic"
|
||||
|
||||
return (gestureID, bimap fst fst topic)
|
||||
)
|
||||
(\ delegatorID -> do
|
||||
Entity sendID (PermitPersonSendDelegator gestureID _) <- do
|
||||
mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID
|
||||
fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record"
|
||||
PermitPersonGesture permitID _ <- lift $ getJust gestureID
|
||||
|
||||
-- Verify the Grant sender is the Permit topic
|
||||
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 "Grant sender isn't the Permit topic"
|
||||
|
||||
return (sendID, bimap fst fst topic)
|
||||
)
|
||||
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
for mractid $ \ grantDB -> do
|
||||
|
||||
for maybePermit $
|
||||
bitraverse
|
||||
(\ (gestureID, topic) -> lift $ do
|
||||
|
||||
-- Update the Permit record, storing the direct-Grant
|
||||
case (topic, grantDB) of
|
||||
(Left localID, Left (_, _, grantID)) ->
|
||||
insert_ $ PermitTopicEnableLocal gestureID localID grantID
|
||||
(Right remoteID, Right (_, _, grantID)) ->
|
||||
insert_ $ PermitTopicEnableRemote gestureID remoteID grantID
|
||||
_ -> error "personGrant impossible"
|
||||
|
||||
-- Prepare forwarding direct-Grant to my followers
|
||||
recipPersonHash <- encodeKeyHashid recipPersonID
|
||||
let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
|
||||
|
||||
-- Prepapre delegator-Grant and update Permit
|
||||
needDeleg <-
|
||||
case grantDB of
|
||||
Left (la, _, _) ->
|
||||
pure $ case la of
|
||||
LocalActorProject _ -> True
|
||||
LocalActorGroup _ -> True
|
||||
_ -> False
|
||||
Right (author, _, _) -> do
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
pure $ case remoteActorType ra of
|
||||
AP.ActorTypeProject -> True
|
||||
AP.ActorTypeTeam -> True
|
||||
_ -> False
|
||||
maybeDeleg <-
|
||||
if needDeleg
|
||||
then Just <$> do
|
||||
delegID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
deleg@(actionDeleg, _, _, _) <- prepareDelegGrant
|
||||
let recipByKey = LocalActorPerson recipPersonID
|
||||
_luDeleg <- updateOutboxItem' recipByKey delegID actionDeleg
|
||||
|
||||
insert_ $ PermitPersonSendDelegator gestureID delegID
|
||||
|
||||
return (delegID, deleg)
|
||||
else
|
||||
pure Nothing
|
||||
|
||||
return (personActor personRecip, sieve, maybeDeleg)
|
||||
)
|
||||
(\ (sendID, topic) ->
|
||||
case (topic, grantDB) of
|
||||
(Left localID, Left (_, _, extID)) -> lift $ do
|
||||
enableID <- do
|
||||
me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID
|
||||
case me of
|
||||
Just e -> pure e
|
||||
Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable"
|
||||
insert_ $ PermitTopicExtendLocal sendID enableID extID
|
||||
(Right remoteID, Right (_, _, extID)) -> lift $ do
|
||||
enableID <- do
|
||||
me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID
|
||||
case me of
|
||||
Just e -> pure e
|
||||
Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable"
|
||||
insert_ $ PermitTopicExtendRemote sendID enableID extID
|
||||
_ -> error "personGrant impossible 2"
|
||||
)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just _actorID -> do
|
||||
let targetIsRecip =
|
||||
case target of
|
||||
Left (GrantRecipPerson' p) -> p == recipPersonID
|
||||
_ -> False
|
||||
if not targetIsRecip
|
||||
then done "I'm not the target; Inserted to inbox"
|
||||
else done "I'm the target; Inserted to inbox"
|
||||
Just Nothing -> done "Inserted Grant to my inbox"
|
||||
Just (Just (Left (recipActorID, sieve, maybeDeleg))) -> do
|
||||
let recipByID = LocalActorPerson recipPersonID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeDeleg $ \ (delegID, (actionDeleg, localRecipsDeleg, remoteRecipsDeleg, fwdHostsDeleg)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsDeleg
|
||||
remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
|
||||
done "Forwarded the direct-Grant, updated Permit, maybe published delegator-Grant"
|
||||
Just (Just (Right ())) ->
|
||||
done "Got an extension-Grant, updated Permit"
|
||||
|
||||
where
|
||||
|
||||
tryInvite fulfillsDB = do
|
||||
fulfillsID <-
|
||||
case fulfillsDB of
|
||||
Left (_actorByKey, _actorEntity, itemID) -> do
|
||||
PermitTopicGestureLocal fulfillsID _ <-
|
||||
MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
|
||||
return fulfillsID
|
||||
Right remoteActivityID -> do
|
||||
PermitTopicGestureRemote fulfillsID _ _ <-
|
||||
MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
|
||||
return fulfillsID
|
||||
PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
|
||||
maybeGestureID <- lift . lift $ getKeyBy $ UniquePermitPersonGesture permitID
|
||||
return (permitID, maybeGestureID)
|
||||
|
||||
tryJoin fulfillsDB = do
|
||||
Entity gestureID (PermitPersonGesture permitID _) <-
|
||||
case fulfillsDB of
|
||||
Left (_actorByKey, _actorEntity, itemID) ->
|
||||
MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
|
||||
Right _remoteActivityID -> mzero
|
||||
_ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsJoin permitID
|
||||
return (permitID, Just gestureID)
|
||||
|
||||
tryCreate fulfillsDB = do
|
||||
Entity gestureID (PermitPersonGesture permitID _) <-
|
||||
case fulfillsDB of
|
||||
Left (_actorByKey, _actorEntity, itemID) ->
|
||||
MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
|
||||
Right _remoteActivityID -> mzero
|
||||
_ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
|
||||
return (permitID, Just gestureID)
|
||||
|
||||
prepareDelegGrant = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
personHash <- encodeKeyHashid recipPersonID
|
||||
audTopic <- lift $ makeAudSenderOnly authorIdMsig
|
||||
uTopic <- lift $ getActorURI authorIdMsig
|
||||
uDirectGrant <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audTopic]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Just uDirectGrant
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uDirectGrant]
|
||||
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||
{ AP.grantObject = AP.RXDelegator
|
||||
, AP.grantContext = encodeRouteHome $ PersonR personHash
|
||||
, AP.grantTarget = uTopic
|
||||
, AP.grantResult = Nothing
|
||||
, AP.grantStart = Just now
|
||||
, AP.grantEnd = Nothing
|
||||
, AP.grantAllows = AP.Invoke
|
||||
, AP.grantDelegates = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor has revoked some previously published Grants
|
||||
-- Behavior: Insert to my inbox
|
||||
|
|
|
|||
Loading…
Reference in a new issue