S2S: Implement component delegator-Grant handler
This commit is contained in:
parent
9a78c83233
commit
4ac73a9515
3 changed files with 274 additions and 1 deletions
|
@ -23,6 +23,7 @@ module Vervis.Actor.Common
|
||||||
, topicRemove
|
, topicRemove
|
||||||
, topicJoin
|
, topicJoin
|
||||||
, topicCreateMe
|
, topicCreateMe
|
||||||
|
, componentGrant
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -1680,3 +1681,237 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
||||||
}
|
}
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
-- Meaning: An actor is granting access-to-some-resource to another actor
|
||||||
|
-- Behavior:
|
||||||
|
-- * If I approved an Add-to-project where I'm the component, and the
|
||||||
|
-- project is now giving me the delegator-Grant:
|
||||||
|
-- * Record this in the Stem record in DB
|
||||||
|
-- * Forward to my followers
|
||||||
|
-- * Start a delegation chain giving access-to-me, send this new Grant
|
||||||
|
-- to the project to distribute further, and use the delegator-Grant
|
||||||
|
-- as the capability
|
||||||
|
-- * To: Project
|
||||||
|
-- * CC: My followers, project followers
|
||||||
|
-- * If I approved an Invite-to-project where I'm the component, and the
|
||||||
|
-- project is now giving me the delegator-Grant:
|
||||||
|
-- * Record this in the Stem record in DB
|
||||||
|
-- * Forward to my followers
|
||||||
|
-- * Start a delegation chain giving access-to-me, send this new Grant
|
||||||
|
-- to the project to distribute further, and use the delegator-Grant
|
||||||
|
-- as the capability
|
||||||
|
-- * To: Project
|
||||||
|
-- * CC: My followers, project followers
|
||||||
|
-- * If the Grant is for an Add/Invite that hasn't had the full approval
|
||||||
|
-- chain, or I already got the delegator-Grant, raise an error
|
||||||
|
-- * Otherwise, if I've already seen this Grant or it's simply not related
|
||||||
|
-- to me, ignore it
|
||||||
|
componentGrant
|
||||||
|
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||||
|
=> (topic -> ActorId)
|
||||||
|
-> (forall f. f topic -> GrantResourceBy f)
|
||||||
|
-> (forall f. f topic -> ComponentBy f)
|
||||||
|
-> UTCTime
|
||||||
|
-> Key topic
|
||||||
|
-> Verse
|
||||||
|
-> AP.Grant URIMode
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
componentGrant grabActor topicResource topicComponent now recipKey (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
|
-- Check grant
|
||||||
|
project <- checkDelegatorGrant grant
|
||||||
|
|
||||||
|
-- Check the Add/Invite that it's related to
|
||||||
|
fulfills <-
|
||||||
|
case AP.activityFulfills $ actbActivity body of
|
||||||
|
[u] ->
|
||||||
|
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||||
|
nameExceptT "Grant.fulfills" (parseActivityURI' u)
|
||||||
|
_ -> throwE "Expecting a single 'fulfills' URI"
|
||||||
|
|
||||||
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
-- Grab me from DB
|
||||||
|
(recipActorID, recipActor) <- lift $ do
|
||||||
|
recip <- getJust recipKey
|
||||||
|
let actorID = grabActor recip
|
||||||
|
(actorID,) <$> getJust actorID
|
||||||
|
|
||||||
|
-- Find the fulfilled activity in our DB
|
||||||
|
fulfillsDB <- do
|
||||||
|
a <- getActivity fulfills
|
||||||
|
fromMaybeE a "Can't find fulfilled in DB"
|
||||||
|
|
||||||
|
-- See if the fulfilled activity is an Invite or Add on a local
|
||||||
|
-- component, grabbing the Stem record from our DB
|
||||||
|
stem <- do
|
||||||
|
maybeStem <-
|
||||||
|
lift $ runMaybeT $
|
||||||
|
Left <$> tryInviteComp fulfillsDB <|>
|
||||||
|
Right <$> tryAddComp fulfillsDB
|
||||||
|
fromMaybeE maybeStem "Fulfilled activity isn't an Invite/Add I'm aware of"
|
||||||
|
|
||||||
|
-- Find the local component and verify it's me
|
||||||
|
let stemID = either id id stem
|
||||||
|
ident <- lift $ getStemIdent stemID
|
||||||
|
unless (topicComponent recipKey == ident) $
|
||||||
|
throwE "Fulfilled object is an Invite/Add for some other component"
|
||||||
|
|
||||||
|
-- Find the project, verify it's identical to the Grant sender
|
||||||
|
stemProject <-
|
||||||
|
lift $
|
||||||
|
requireEitherAlt
|
||||||
|
(getBy $ UniqueStemProjectLocal stemID)
|
||||||
|
(getBy $ UniqueStemProjectRemote stemID)
|
||||||
|
"Found Stem with no project"
|
||||||
|
"Found Stem with multiple projects"
|
||||||
|
case (stemProject, authorIdMsig) of
|
||||||
|
(Left (Entity _ sjl), Left (LocalActorProject projectID, _, _))
|
||||||
|
| stemProjectLocalProject sjl == projectID ->
|
||||||
|
return ()
|
||||||
|
(Right (Entity _ sjr), Right (author, _, _))
|
||||||
|
| stemProjectRemoteProject sjr == remoteAuthorId author ->
|
||||||
|
return ()
|
||||||
|
_ -> throwE "The Grant I'm waiting for is by the project"
|
||||||
|
|
||||||
|
-- Verify I sent the Component's Accept but haven't already received
|
||||||
|
-- the delegator-Grant
|
||||||
|
compAccept <- do
|
||||||
|
mk <- lift $ getKeyBy $ UniqueStemComponentAccept stemID
|
||||||
|
fromMaybeE mk "Getting a delegator-Grant but never approved this Invite/Add"
|
||||||
|
gl <- lift $ getBy $ UniqueStemProjectGrantLocal compAccept
|
||||||
|
gr <- lift $ getBy $ UniqueStemProjectGrantRemote compAccept
|
||||||
|
unless (isNothing gl && isNothing gr) $
|
||||||
|
throwE "I already received a delegator-Grant for this Invite/Add"
|
||||||
|
|
||||||
|
maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||||
|
lift $ for maybeGrantDB $ \ grantDB -> do
|
||||||
|
|
||||||
|
-- Prepare forwarding to my followers
|
||||||
|
sieve <- do
|
||||||
|
recipHash <- encodeKeyHashid recipKey
|
||||||
|
let recipByHash =
|
||||||
|
grantResourceLocalActor $ topicResource recipHash
|
||||||
|
return $ makeRecipientSet [] [localActorFollowers recipByHash]
|
||||||
|
|
||||||
|
-- Update the Stem record in DB
|
||||||
|
case (stemProject, grantDB) of
|
||||||
|
(Left (Entity j _), Left (_, _, g)) -> insert_ $ StemProjectGrantLocal compAccept j g
|
||||||
|
(Right (Entity j _), Right (_, _, g)) -> insert_ $ StemProjectGrantRemote compAccept j g
|
||||||
|
_ -> error "componentGrant impossible"
|
||||||
|
chainID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
|
insert_ $ StemDelegateLocal compAccept chainID
|
||||||
|
|
||||||
|
-- Prepare a Grant activity and insert to my outbox
|
||||||
|
chain <- do
|
||||||
|
Stem role <- getJust stemID
|
||||||
|
chain@(actionChain, _, _, _) <- prepareChain role
|
||||||
|
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||||
|
_luChain <- updateOutboxItem' recipByKey chainID actionChain
|
||||||
|
return chain
|
||||||
|
|
||||||
|
return (recipActorID, sieve, chainID, chain)
|
||||||
|
|
||||||
|
case maybeNew of
|
||||||
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
|
Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do
|
||||||
|
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||||
|
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||||
|
lift $ sendActivity
|
||||||
|
recipByID recipActorID localRecipsChain remoteRecipsChain
|
||||||
|
fwdHostsChain chainID actionChain
|
||||||
|
done "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant"
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
checkDelegatorGrant g = do
|
||||||
|
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
||||||
|
parseGrant' g
|
||||||
|
case role of
|
||||||
|
AP.RXRole _ -> throwE "Not a delegator Grant"
|
||||||
|
AP.RXDelegator -> pure ()
|
||||||
|
project <-
|
||||||
|
bitraverse
|
||||||
|
(\case
|
||||||
|
GrantResourceProject j -> return j
|
||||||
|
_ -> throwE "Resource isn't a project"
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
resource
|
||||||
|
case (project, authorIdMsig) of
|
||||||
|
(Left j, Left (a, _, _)) | LocalActorProject j == a -> pure ()
|
||||||
|
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
|
||||||
|
_ -> throwE "Author and resource aren't the same project actor"
|
||||||
|
case recipient of
|
||||||
|
Left (GrantRecipComponent' c)
|
||||||
|
| topicComponent recipKey == c -> pure ()
|
||||||
|
_ -> throwE "Grant recipient isn't me"
|
||||||
|
for_ mstart $ \ start ->
|
||||||
|
unless (start < now) $ throwE "Start time is in the future"
|
||||||
|
for_ mend $ \ _ ->
|
||||||
|
throwE "End time is specified"
|
||||||
|
unless (usage == AP.Invoke) $
|
||||||
|
throwE "Usage isn't Invoke"
|
||||||
|
for_ mdeleg $ \ _ ->
|
||||||
|
throwE "'delegates' is specified"
|
||||||
|
return project
|
||||||
|
|
||||||
|
tryInviteComp (Left (_, _, itemID)) = do
|
||||||
|
originInviteID <-
|
||||||
|
stemProjectGestureLocalOrigin <$>
|
||||||
|
MaybeT (getValBy $ UniqueStemProjectGestureLocalInvite itemID)
|
||||||
|
lift $ stemOriginInviteStem <$> getJust originInviteID
|
||||||
|
tryInviteComp (Right remoteActivityID) = do
|
||||||
|
StemProjectGestureRemote originInviteID _ _ <-
|
||||||
|
MaybeT $ getValBy $
|
||||||
|
UniqueStemProjectGestureRemoteInvite remoteActivityID
|
||||||
|
lift $ stemOriginInviteStem <$> getJust originInviteID
|
||||||
|
|
||||||
|
tryAddComp (Left (_, __, itemID)) = do
|
||||||
|
StemComponentGestureLocal stemID _ <-
|
||||||
|
MaybeT $ getValBy $ UniqueStemComponentGestureLocalActivity itemID
|
||||||
|
_originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID
|
||||||
|
return stemID
|
||||||
|
tryAddComp (Right remoteActivityID) = do
|
||||||
|
StemComponentGestureRemote stemID _ _ <-
|
||||||
|
MaybeT $ getValBy $
|
||||||
|
UniqueStemComponentGestureRemoteActivity remoteActivityID
|
||||||
|
_originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID
|
||||||
|
return stemID
|
||||||
|
|
||||||
|
prepareChain role = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
|
||||||
|
audProject <- makeAudSenderWithFollowers authorIdMsig
|
||||||
|
audMe <-
|
||||||
|
AudLocal [] . pure . localActorFollowers .
|
||||||
|
grantResourceLocalActor . topicResource <$>
|
||||||
|
encodeKeyHashid recipKey
|
||||||
|
uProject <- lift $ getActorURI authorIdMsig
|
||||||
|
uGrant <- lift $ getActivityURI authorIdMsig
|
||||||
|
recipHash <- encodeKeyHashid recipKey
|
||||||
|
let topicByHash = grantResourceLocalActor $ topicResource recipHash
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience [audProject, audMe]
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Just uGrant
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [uGrant]
|
||||||
|
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||||
|
{ AP.grantObject = AP.RXRole role
|
||||||
|
, AP.grantContext =
|
||||||
|
encodeRouteHome $ renderLocalActor topicByHash
|
||||||
|
, AP.grantTarget = uProject
|
||||||
|
, AP.grantResult = Nothing
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.GatherAndConvey
|
||||||
|
, AP.grantDelegates = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
|
@ -495,6 +495,38 @@ deckJoin =
|
||||||
deckActor GrantResourceDeck
|
deckActor GrantResourceDeck
|
||||||
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
|
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
|
||||||
|
|
||||||
|
-- Meaning: An actor is granting access-to-some-resource to another actor
|
||||||
|
-- Behavior:
|
||||||
|
-- * If I approved an Add-to-project where I'm the component, and the
|
||||||
|
-- project is now giving me the delegator-Grant:
|
||||||
|
-- * Record this in the Stem record in DB
|
||||||
|
-- * Forward to my followers
|
||||||
|
-- * Start a delegation chain giving access-to-me, send this new Grant
|
||||||
|
-- to the project to distribute further, and use the delegator-Grant
|
||||||
|
-- as the capability
|
||||||
|
-- * To: Project
|
||||||
|
-- * CC: My followers, project followers
|
||||||
|
-- * If I approved an Invite-to-project where I'm the component, and the
|
||||||
|
-- project is now giving me the delegator-Grant:
|
||||||
|
-- * Record this in the Stem record in DB
|
||||||
|
-- * Forward to my followers
|
||||||
|
-- * Start a delegation chain giving access-to-me, send this new Grant
|
||||||
|
-- to the project to distribute further, and use the delegator-Grant
|
||||||
|
-- as the capability
|
||||||
|
-- * To: Project
|
||||||
|
-- * CC: My followers, project followers
|
||||||
|
-- * If the Grant is for an Add/Invite that hasn't had the full approval
|
||||||
|
-- chain, or I already got the delegator-Grant, raise an error
|
||||||
|
-- * Otherwise, if I've already seen this Grant or it's simply not related
|
||||||
|
-- to me, ignore it
|
||||||
|
deckGrant
|
||||||
|
:: UTCTime
|
||||||
|
-> DeckId
|
||||||
|
-> Verse
|
||||||
|
-> AP.Grant URIMode
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
deckGrant = componentGrant deckActor GrantResourceDeck ComponentDeck
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- Ambiguous: Following/Resolving
|
-- Ambiguous: Following/Resolving
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
@ -711,6 +743,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
|
||||||
AP.AddActivity add -> deckAdd now deckID verse add
|
AP.AddActivity add -> deckAdd now deckID verse add
|
||||||
AP.CreateActivity create -> deckCreate now deckID verse create
|
AP.CreateActivity create -> deckCreate now deckID verse create
|
||||||
AP.FollowActivity follow -> deckFollow now deckID verse follow
|
AP.FollowActivity follow -> deckFollow now deckID verse follow
|
||||||
|
AP.GrantActivity grant -> deckGrant now deckID verse grant
|
||||||
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
||||||
AP.JoinActivity join -> deckJoin now deckID verse join
|
AP.JoinActivity join -> deckJoin now deckID verse join
|
||||||
AP.RejectActivity reject -> deckReject now deckID verse reject
|
AP.RejectActivity reject -> deckReject now deckID verse reject
|
||||||
|
|
|
@ -580,18 +580,21 @@ resourceToComponent = \case
|
||||||
data GrantRecipBy' f
|
data GrantRecipBy' f
|
||||||
= GrantRecipPerson' (f Person)
|
= GrantRecipPerson' (f Person)
|
||||||
| GrantRecipProject' (f Project)
|
| GrantRecipProject' (f Project)
|
||||||
|
| GrantRecipComponent' (ComponentBy f)
|
||||||
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
|
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
|
||||||
|
|
||||||
deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f)
|
deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f)
|
||||||
|
|
||||||
parseGrantRecip' (PersonR p) = Just $ GrantRecipPerson' p
|
parseGrantRecip' (PersonR p) = Just $ GrantRecipPerson' p
|
||||||
parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j
|
parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j
|
||||||
parseGrantRecip' _ = Nothing
|
parseGrantRecip' r = GrantRecipComponent' <$> parseComponent r
|
||||||
|
|
||||||
hashGrantRecip' (GrantRecipPerson' k) =
|
hashGrantRecip' (GrantRecipPerson' k) =
|
||||||
GrantRecipPerson' <$> WAP.encodeKeyHashid k
|
GrantRecipPerson' <$> WAP.encodeKeyHashid k
|
||||||
hashGrantRecip' (GrantRecipProject' k) =
|
hashGrantRecip' (GrantRecipProject' k) =
|
||||||
GrantRecipProject' <$> WAP.encodeKeyHashid k
|
GrantRecipProject' <$> WAP.encodeKeyHashid k
|
||||||
|
hashGrantRecip' (GrantRecipComponent' byk) =
|
||||||
|
GrantRecipComponent' <$> hashComponent byk
|
||||||
|
|
||||||
unhashGrantRecipPure' ctx = f
|
unhashGrantRecipPure' ctx = f
|
||||||
where
|
where
|
||||||
|
@ -599,6 +602,8 @@ unhashGrantRecipPure' ctx = f
|
||||||
GrantRecipPerson' <$> decodeKeyHashidPure ctx p
|
GrantRecipPerson' <$> decodeKeyHashidPure ctx p
|
||||||
f (GrantRecipProject' p) =
|
f (GrantRecipProject' p) =
|
||||||
GrantRecipProject' <$> decodeKeyHashidPure ctx p
|
GrantRecipProject' <$> decodeKeyHashidPure ctx p
|
||||||
|
f (GrantRecipComponent' c) =
|
||||||
|
GrantRecipComponent' <$> unhashComponentPure ctx c
|
||||||
|
|
||||||
unhashGrantRecip' resource = do
|
unhashGrantRecip' resource = do
|
||||||
ctx <- asksEnv WAP.stageHashidsContext
|
ctx <- asksEnv WAP.stageHashidsContext
|
||||||
|
|
Loading…
Reference in a new issue