diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 8a5ddf3..96621e4 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -82,6 +82,8 @@ import Vervis.Data.Collab import Vervis.Data.Discussion import Vervis.FedURI +import Vervis.Data.Actor +import Vervis.Data.Collab import Vervis.Foundation import Vervis.Model import Vervis.Persist.Actor @@ -92,6 +94,11 @@ import Vervis.RemoteActorStore import Vervis.Ticket import Vervis.Web.Collab +data GrantKind + = GKDelegationStart AP.Role + | GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI) + | GKDelegator + actorFollow :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r) => (Route App -> ActE a) @@ -2163,6 +2170,7 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body) -- 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 @@ -2172,8 +2180,14 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body) -- 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 +-- +-- * Almost-Team sending me the delegator-Grant +-- * Update the Squad record, enabling the team +-- * Send a start-Grant giving access-to-me +-- -- * Otherwise, if I've already seen this Grant or it's simply not related -- to me, ignore it componentGrant @@ -2188,47 +2202,45 @@ componentGrant -> ActE (Text, Act (), Next) componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body) grant = do - -- Check grant - project <- checkDelegatorGrant grant + grant' <- checkGrant grant + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeMode <- + withDBExcept $ do + meResourceID <- lift $ grabResource <$> getJust recipKey + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (id <$> tryStem grant') + mode <- + fromMaybeE + maybeMode + "Not a relevant Grant that I'm aware of" + case mode of + stem -> handleStem stem - -- 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 - resourceID <- lift $ grabResource <$> getJust recipKey - Resource recipActorID <- lift $ getJust resourceID - recipActor <- lift $ getJust recipActorID - - -- Find the fulfilled activity in our DB - fulfillsDB <- do - a <- getActivity fulfills - fromMaybeE a "Can't find fulfilled in DB" + where + tryStem (GKDelegationStart _) = lift mzero + tryStem (GKDelegationExtend _ _) = lift mzero + tryStem GKDelegator = do + uFulfills <- + case AP.activityFulfills $ actbActivity body of + [] -> throwE "No fulfills" + [u] -> pure u + _ -> throwE "Multiple fulfills" + fulfills <- ExceptT $ lift $ lift $ runExceptT $ first (\ (a, _, i) -> (a, i)) <$> parseActivityURI' uFulfills + fulfillsDB <- ExceptT $ MaybeT $ either (Just . Left) (fmap Right) <$> runExceptT (getActivity fulfills) -- 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" - + stem <- + lift $ + Left <$> tryInviteComp fulfillsDB <|> + Right <$> tryAddComp fulfillsDB -- 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" - + ident <- lift $ lift $ getStemIdent stemID + lift $ guard $ topicComponent recipKey == ident -- Find the project, verify it's identical to the Grant sender stemProject <- - lift $ + lift $ lift $ requireEitherAlt (getBy $ UniqueStemProjectLocal stemID) (getBy $ UniqueStemProjectRemote stemID) @@ -2242,89 +2254,98 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body | 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 + mk <- lift $ 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 + gl <- lift $ lift $ getBy $ UniqueStemProjectGrantLocal compAccept + gr <- lift $ lift $ getBy $ UniqueStemProjectGrantRemote compAccept unless (isNothing gl && isNothing gr) $ throwE "I already received a delegator-Grant for this Invite/Add" + return (stemID, stemProject, compAccept) - maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False - lift $ for maybeGrantDB $ \ (inboxItemID, grantDB) -> do + handleStem (stemID, stemProject, compAccept) = do - -- Prepare forwarding to my followers - sieve <- do - recipHash <- encodeKeyHashid recipKey - let recipByHash = resourceToActor $ topicResource recipHash - return $ makeRecipientSet [] [localActorFollowers recipByHash] + maybeNew <- withDBExcept $ do - -- 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 + -- Grab me from DB + resourceID <- lift $ grabResource <$> getJust recipKey + Resource recipActorID <- lift $ getJust resourceID + recipActor <- lift $ getJust recipActorID - -- Prepare a Grant activity and insert to my outbox - chain <- do - Stem role _ <- getJust stemID - chain@(actionChain, _, _, _) <- prepareChain role - let recipByKey = resourceToActor $ topicResource recipKey - _luChain <- updateOutboxItem' recipByKey chainID actionChain - return chain + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + lift $ for maybeGrantDB $ \ (inboxItemID, grantDB) -> do - return (recipActorID, sieve, chainID, chain, inboxItemID) + -- Prepare forwarding to my followers + sieve <- do + recipHash <- encodeKeyHashid recipKey + let recipByHash = resourceToActor $ topicResource recipHash + return $ makeRecipientSet [] [localActorFollowers recipByHash] - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain), inboxItemID) -> do - let recipByID = resourceToActor $ topicResource recipKey - forwardActivity authorIdMsig body recipByID recipActorID sieve - lift $ sendActivity - recipByID recipActorID localRecipsChain remoteRecipsChain - fwdHostsChain chainID actionChain - doneDB inboxItemID "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant" + -- 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 - where + -- Prepare a Grant activity and insert to my outbox + chain <- do + Stem role _ <- getJust stemID + chain@(actionChain, _, _, _) <- prepareChain role + let recipByKey = resourceToActor $ topicResource recipKey + _luChain <- updateOutboxItem' recipByKey chainID actionChain + return chain + + return (recipActorID, sieve, chainID, chain, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain), inboxItemID) -> do + let recipByID = resourceToActor $ topicResource recipKey + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ sendActivity + recipByID recipActorID localRecipsChain remoteRecipsChain + fwdHostsChain chainID actionChain + doneDB inboxItemID "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant" + + meID = recipKey + toComponent = topicComponent + + meComponent = toComponent recipKey + meResource = componentResource meComponent + meActor = resourceToActor meResource topicResource :: forall f. f topic -> LocalResourceBy f topicResource = componentResource . topicComponent - checkDelegatorGrant g = do + checkGrant 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 - LocalActorProject 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 la | resourceToActor (topicResource recipKey) == la -> pure () - _ -> throwE "Grant recipient isn't me" + Left la | la == meActor -> pure () + _ -> throwE "Target 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 + + let resourceIsAuthor = + case (resource, authorIdMsig) of + (Left a, Left (a', _, _)) -> a == a' + (Right u, Right (ra, _, _)) -> remoteAuthorURI ra == u + _ -> False + + case (role, resourceIsAuthor, usage, mdeleg) of + (AP.RXRole r, True, AP.GatherAndConvey, Nothing) -> + pure $ GKDelegationStart r + (AP.RXRole r, False, AP.GatherAndConvey, Just _) -> + pure $ GKDelegationExtend r resource + (AP.RXDelegator, True, AP.Invoke, Nothing) -> + pure GKDelegator + _ -> throwE "A kind of Grant that I don't use" tryInviteComp (Left (_, _, itemID)) = do originInviteID <- diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index bd131ea..2462130 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -625,30 +625,6 @@ deckJoin -> ActE (Text, Act (), Next) deckJoin = topicJoin deckResource LocalResourceDeck --- 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