S2S: Implement component delegator-Grant handler
This commit is contained in:
Pere Lev
parent
9a78c83233
commit
4ac73a9515
3 changed files with 274 additions and 1 deletions
|
|
@ -23,6 +23,7 @@ module Vervis.Actor.Common
|
|||
, topicRemove
|
||||
, topicJoin
|
||||
, topicCreateMe
|
||||
, componentGrant
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1680,3 +1681,237 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
|||
}
|
||||
|
||||
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
|
||||
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
|
||||
------------------------------------------------------------------------------
|
||||
|
|
@ -711,6 +743,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
|
|||
AP.AddActivity add -> deckAdd now deckID verse add
|
||||
AP.CreateActivity create -> deckCreate now deckID verse create
|
||||
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.JoinActivity join -> deckJoin now deckID verse join
|
||||
AP.RejectActivity reject -> deckReject now deckID verse reject
|
||||
|
|
|
|||
|
|
@ -580,18 +580,21 @@ resourceToComponent = \case
|
|||
data GrantRecipBy' f
|
||||
= GrantRecipPerson' (f Person)
|
||||
| GrantRecipProject' (f Project)
|
||||
| GrantRecipComponent' (ComponentBy f)
|
||||
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f)
|
||||
|
||||
parseGrantRecip' (PersonR p) = Just $ GrantRecipPerson' p
|
||||
parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j
|
||||
parseGrantRecip' _ = Nothing
|
||||
parseGrantRecip' r = GrantRecipComponent' <$> parseComponent r
|
||||
|
||||
hashGrantRecip' (GrantRecipPerson' k) =
|
||||
GrantRecipPerson' <$> WAP.encodeKeyHashid k
|
||||
hashGrantRecip' (GrantRecipProject' k) =
|
||||
GrantRecipProject' <$> WAP.encodeKeyHashid k
|
||||
hashGrantRecip' (GrantRecipComponent' byk) =
|
||||
GrantRecipComponent' <$> hashComponent byk
|
||||
|
||||
unhashGrantRecipPure' ctx = f
|
||||
where
|
||||
|
|
@ -599,6 +602,8 @@ unhashGrantRecipPure' ctx = f
|
|||
GrantRecipPerson' <$> decodeKeyHashidPure ctx p
|
||||
f (GrantRecipProject' p) =
|
||||
GrantRecipProject' <$> decodeKeyHashidPure ctx p
|
||||
f (GrantRecipComponent' c) =
|
||||
GrantRecipComponent' <$> unhashComponentPure ctx c
|
||||
|
||||
unhashGrantRecip' resource = do
|
||||
ctx <- asksEnv WAP.stageHashidsContext
|
||||
|
|
|
|||
Loading…
Reference in a new issue