S2S: Component: Grant: Refactor, prepare for adding team-mode
This commit is contained in:
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.Data.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
|
||||||
|
import Vervis.Data.Actor
|
||||||
|
import Vervis.Data.Collab
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
|
@ -92,6 +94,11 @@ import Vervis.RemoteActorStore
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
import Vervis.Web.Collab
|
import Vervis.Web.Collab
|
||||||
|
|
||||||
|
data GrantKind
|
||||||
|
= GKDelegationStart AP.Role
|
||||||
|
| GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI)
|
||||||
|
| GKDelegator
|
||||||
|
|
||||||
actorFollow
|
actorFollow
|
||||||
:: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
|
:: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
|
||||||
=> (Route App -> ActE a)
|
=> (Route App -> ActE a)
|
||||||
|
@ -2163,6 +2170,7 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body)
|
||||||
-- as the capability
|
-- as the capability
|
||||||
-- * To: Project
|
-- * To: Project
|
||||||
-- * CC: My followers, project followers
|
-- * CC: My followers, project followers
|
||||||
|
--
|
||||||
-- * If I approved an Invite-to-project where I'm the component, and the
|
-- * If I approved an Invite-to-project where I'm the component, and the
|
||||||
-- project is now giving me the delegator-Grant:
|
-- project is now giving me the delegator-Grant:
|
||||||
-- * Record this in the Stem record in DB
|
-- * Record this in the Stem record in DB
|
||||||
|
@ -2172,8 +2180,14 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body)
|
||||||
-- as the capability
|
-- as the capability
|
||||||
-- * To: Project
|
-- * To: Project
|
||||||
-- * CC: My followers, project followers
|
-- * CC: My followers, project followers
|
||||||
|
--
|
||||||
-- * If the Grant is for an Add/Invite that hasn't had the full approval
|
-- * 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
|
-- 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
|
-- * Otherwise, if I've already seen this Grant or it's simply not related
|
||||||
-- to me, ignore it
|
-- to me, ignore it
|
||||||
componentGrant
|
componentGrant
|
||||||
|
@ -2188,47 +2202,45 @@ componentGrant
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body) grant = do
|
componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
-- Check grant
|
grant' <- checkGrant grant
|
||||||
project <- checkDelegatorGrant 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
|
where
|
||||||
fulfills <-
|
|
||||||
|
tryStem (GKDelegationStart _) = lift mzero
|
||||||
|
tryStem (GKDelegationExtend _ _) = lift mzero
|
||||||
|
tryStem GKDelegator = do
|
||||||
|
uFulfills <-
|
||||||
case AP.activityFulfills $ actbActivity body of
|
case AP.activityFulfills $ actbActivity body of
|
||||||
[u] ->
|
[] -> throwE "No fulfills"
|
||||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
[u] -> pure u
|
||||||
nameExceptT "Grant.fulfills" (parseActivityURI' u)
|
_ -> throwE "Multiple fulfills"
|
||||||
_ -> throwE "Expecting a single 'fulfills' URI"
|
fulfills <- ExceptT $ lift $ lift $ runExceptT $ first (\ (a, _, i) -> (a, i)) <$> parseActivityURI' uFulfills
|
||||||
|
fulfillsDB <- ExceptT $ MaybeT $ either (Just . Left) (fmap Right) <$> runExceptT (getActivity fulfills)
|
||||||
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"
|
|
||||||
|
|
||||||
-- See if the fulfilled activity is an Invite or Add on a local
|
-- See if the fulfilled activity is an Invite or Add on a local
|
||||||
-- component, grabbing the Stem record from our DB
|
-- component, grabbing the Stem record from our DB
|
||||||
stem <- do
|
stem <-
|
||||||
maybeStem <-
|
lift $
|
||||||
lift $ runMaybeT $
|
|
||||||
Left <$> tryInviteComp fulfillsDB <|>
|
Left <$> tryInviteComp fulfillsDB <|>
|
||||||
Right <$> tryAddComp 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
|
-- Find the local component and verify it's me
|
||||||
let stemID = either id id stem
|
let stemID = either id id stem
|
||||||
ident <- lift $ getStemIdent stemID
|
ident <- lift $ lift $ getStemIdent stemID
|
||||||
unless (topicComponent recipKey == ident) $
|
lift $ guard $ 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
|
-- Find the project, verify it's identical to the Grant sender
|
||||||
stemProject <-
|
stemProject <-
|
||||||
lift $
|
lift $ lift $
|
||||||
requireEitherAlt
|
requireEitherAlt
|
||||||
(getBy $ UniqueStemProjectLocal stemID)
|
(getBy $ UniqueStemProjectLocal stemID)
|
||||||
(getBy $ UniqueStemProjectRemote stemID)
|
(getBy $ UniqueStemProjectRemote stemID)
|
||||||
|
@ -2242,16 +2254,25 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
|
||||||
| stemProjectRemoteProject sjr == remoteAuthorId author ->
|
| stemProjectRemoteProject sjr == remoteAuthorId author ->
|
||||||
return ()
|
return ()
|
||||||
_ -> throwE "The Grant I'm waiting for is by the project"
|
_ -> throwE "The Grant I'm waiting for is by the project"
|
||||||
|
|
||||||
-- Verify I sent the Component's Accept but haven't already received
|
-- Verify I sent the Component's Accept but haven't already received
|
||||||
-- the delegator-Grant
|
-- the delegator-Grant
|
||||||
compAccept <- do
|
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"
|
fromMaybeE mk "Getting a delegator-Grant but never approved this Invite/Add"
|
||||||
gl <- lift $ getBy $ UniqueStemProjectGrantLocal compAccept
|
gl <- lift $ lift $ getBy $ UniqueStemProjectGrantLocal compAccept
|
||||||
gr <- lift $ getBy $ UniqueStemProjectGrantRemote compAccept
|
gr <- lift $ lift $ getBy $ UniqueStemProjectGrantRemote compAccept
|
||||||
unless (isNothing gl && isNothing gr) $
|
unless (isNothing gl && isNothing gr) $
|
||||||
throwE "I already received a delegator-Grant for this Invite/Add"
|
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
|
maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||||
lift $ for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
|
lift $ for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
|
||||||
|
@ -2290,41 +2311,41 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
|
||||||
fwdHostsChain chainID actionChain
|
fwdHostsChain chainID actionChain
|
||||||
doneDB inboxItemID "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant"
|
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 :: forall f. f topic -> LocalResourceBy f
|
||||||
topicResource = componentResource . topicComponent
|
topicResource = componentResource . topicComponent
|
||||||
|
|
||||||
checkDelegatorGrant g = do
|
checkGrant g = do
|
||||||
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
||||||
parseGrant' g
|
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
|
case recipient of
|
||||||
Left la | resourceToActor (topicResource recipKey) == la -> pure ()
|
Left la | la == meActor -> pure ()
|
||||||
_ -> throwE "Grant recipient isn't me"
|
_ -> throwE "Target isn't me"
|
||||||
for_ mstart $ \ start ->
|
for_ mstart $ \ start ->
|
||||||
unless (start < now) $ throwE "Start time is in the future"
|
unless (start < now) $ throwE "Start time is in the future"
|
||||||
for_ mend $ \ _ ->
|
for_ mend $ \ _ ->
|
||||||
throwE "End time is specified"
|
throwE "End time is specified"
|
||||||
unless (usage == AP.Invoke) $
|
|
||||||
throwE "Usage isn't Invoke"
|
let resourceIsAuthor =
|
||||||
for_ mdeleg $ \ _ ->
|
case (resource, authorIdMsig) of
|
||||||
throwE "'delegates' is specified"
|
(Left a, Left (a', _, _)) -> a == a'
|
||||||
return project
|
(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
|
tryInviteComp (Left (_, _, itemID)) = do
|
||||||
originInviteID <-
|
originInviteID <-
|
||||||
|
|
|
@ -625,30 +625,6 @@ deckJoin
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
deckJoin = topicJoin deckResource LocalResourceDeck
|
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
|
deckGrant
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> DeckId
|
-> DeckId
|
||||||
|
|
Loading…
Reference in a new issue