S2S: Component: Grant: Refactor, prepare for adding team-mode
This commit is contained in:
Pere Lev
parent
40ab419946
commit
10a1f74847
2 changed files with 113 additions and 116 deletions
|
|
@ -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 <-
|
||||
where
|
||||
|
||||
tryStem (GKDelegationStart _) = lift mzero
|
||||
tryStem (GKDelegationExtend _ _) = lift mzero
|
||||
tryStem GKDelegator = do
|
||||
uFulfills <-
|
||||
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"
|
||||
|
||||
[] -> 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 $
|
||||
stem <-
|
||||
lift $
|
||||
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"
|
||||
|
||||
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,16 +2254,25 @@ 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)
|
||||
|
||||
handleStem (stemID, stemProject, compAccept) = do
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
resourceID <- lift $ grabResource <$> getJust recipKey
|
||||
Resource recipActorID <- lift $ getJust resourceID
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
lift $ for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
|
||||
|
|
@ -2290,41 +2311,41 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
|
|||
fwdHostsChain chainID actionChain
|
||||
doneDB inboxItemID "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant"
|
||||
|
||||
where
|
||||
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 <-
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue