forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Project: Send ext-Grants to new collab upon getting their delegator-Grant

Browse source 
Until now, adding a direct collaborator to a Project worked exactly like
with components: Invite or Join, then Accept, finally the direct-Grant.
I missed the fact that much like with project-component relationships,
projects (and teams) need to be able to send extension-Grants to their
direct collaborators.

So in Project's Grant handler it now:

- Recognizes the delegator-Grant coming from a new collaborator
- Sends extension-Grants, using the delegator-Grant as the capability
- When getting a new component and sending extension-Grants for it to
  direct collaborators, Project uses their delegator-Grants as
  capability

And in Project's Accept handler, it no longer sends extension-Grants
(because it doesn't yet have the collaborator's delegator-Grant at this
point).

NOTE, THIS TEMPORARILY BREAKS grant chains: If you create a Project and
add a Deck to it, you won't get an extension-Grant-for-the-Deck from the
Project, because the Project doesn't yet have your delegator-Grant.

The next commits will implement the Person-side of Collab records, and
will cause Person actors to automatically send the delegator-Grant,
fixing the break.
This commit is contained in:
Pere Lev 2023-11-22 14:16:08 +02:00
parent 5d0f707c55
commit 88e6818edc
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
20 changed files with 751 additions and 642 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
migrations/554_2023-11-21_further_local_deleg.model Normal file
View file

@ -0,0 +1,61 @@
ComponentEnable
Actor
Outbox
OutboxItem
outbox OutboxId
activity PersistJSONObject
published UTCTime
Collab
role Role
CollabRecipLocal
collab CollabId
person PersonId
UniqueCollabRecipLocal collab
CollabEnable
collab CollabId
grant OutboxItemId
UniqueCollabEnable collab
UniqueCollabEnableGrant grant
CollabDelegLocal
enable CollabEnableId
recip CollabRecipLocalId
grant OutboxItemId
UniqueCollabDelegLocal enable
UniqueCollabDelegLocalRecip recip
UniqueCollabDelegLocalGrant grant
ComponentFurtherLocal
component ComponentEnableId
collab CollabRecipLocalId
collabNew CollabDelegLocalId
grant OutboxItemId
UniqueComponentFurtherLocal component collab
UniqueComponentFurtherLocalGrant grant
Person
username Username
login Text
passphraseHash ByteString
email EmailAddress
verified Bool
verifiedKey Text
verifiedKeyCreated UTCTime
resetPassKey Text
resetPassKeyCreated UTCTime
actor ActorId
-- reviewFollow Bool
UniquePersonUsername username
UniquePersonLogin login
UniquePersonEmail email
UniquePersonActor actor

23
src/Vervis/API.hs
View file

@ -34,6 +34,7 @@ import Control.Applicative
import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
@ -158,26 +159,8 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
verifyResourceAddressed
:: (MonadSite m, YesodHashids (SiteEnv m))
=> RecipientRoutes -> GrantResourceBy Key -> ExceptT Text m ()
verifyResourceAddressed localRecips resource = do
resourceHash <- hashGrantResource resource
fromMaybeE (verify resourceHash) "Local resource not addressed"
where
verify (GrantResourceRepo r) = do
routes <- lookup r $ recipRepos localRecips
guard $ routeRepo routes
verify (GrantResourceDeck d) = do
routes <- lookup d $ recipDecks localRecips
guard $ routeDeck $ familyDeck routes
verify (GrantResourceLoom l) = do
routes <- lookup l $ recipLooms localRecips
guard $ routeLoom $ familyLoom routes
verify (GrantResourceProject r) = do
routes <- lookup r $ recipProjects localRecips
guard $ routeProject routes
verify (GrantResourceGroup r) = do
routes <- lookup r $ recipGroups localRecips
guard $ routeGroup routes
=> RecipientRoutes -> LocalActorBy Key -> ExceptT Text m ()
verifyResourceAddressed localRecips resource = logWarn "Vervis.API verifyResourceAddressed"
verifyRemoteAddressed
:: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()

25
src/Vervis/Actor.hs
View file

@ -78,10 +78,13 @@ module Vervis.Actor
, RemoteRecipient (..)
, sendToLocalActors
, actorIsAddressed
)
where
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
@ -689,3 +692,25 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
E.on $ f E.^. FollowActor E.==. p E.^. actorField
E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
return $ p E.^. persistIdField
actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
actorIsAddressed recips = isJust . verify
where
verify (LocalActorPerson p) = do
routes <- lookup p $ recipPeople recips
guard $ routePerson routes
verify (LocalActorGroup g) = do
routes <- lookup g $ recipGroups recips
guard $ routeGroup routes
verify (LocalActorRepo r) = do
routes <- lookup r $ recipRepos recips
guard $ routeRepo routes
verify (LocalActorDeck d) = do
routes <- lookup d $ recipDecks recips
guard $ routeDeck $ familyDeck routes
verify (LocalActorLoom l) = do
routes <- lookup l $ recipLooms recips
guard $ routeLoom $ familyLoom routes
verify (LocalActorProject j) = do
routes <- lookup j $ recipProjects recips
guard $ routeProject routes

98
src/Vervis/Actor/Common.hs
View file

@ -14,6 +14,7 @@
-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Vervis.Actor.Common
( actorFollow
@ -227,16 +228,16 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
-- * Otherwise, just ignore the Accept
-- * Otherwise respond with error
topicAccept
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
:: forall topic.
(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.Accept URIMode
-> ActE (Text, Act (), Next)
topicAccept topicActor topicResource topicComponent now recipKey (Verse authorIdMsig body) accept = do
topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) accept = do
-- Check input
acceptee <- parseAccept accept
@ -282,6 +283,9 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
where
topicResource :: forall f. f topic -> LocalActorBy f
topicResource = componentActor . topicComponent
tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) =
(,Left actorByKey) . collabInviterLocalCollab <$>
MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
@ -341,7 +345,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
audAccepter <- makeAudSenderWithFollowers authorIdMsig
audApprover <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash
let topicByHash = topicResource recipHash
senderHash <- bitraverse hashLocalActor pure sender
@ -475,7 +479,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
_ -> error "topicAccept impossible"
-- Prepare forwarding of Accept to my followers
let recipByID = grantResourceLocalActor $ topicResource recipKey
let recipByID = topicResource recipKey
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
@ -491,7 +495,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
grant@(actionGrant, _, _, _) <- do
Collab role <- lift $ getJust collabID
lift $ prepareGrant isInvite inviterOrJoiner role
let recipByKey = grantResourceLocalActor $ topicResource recipKey
let recipByKey = topicResource recipKey
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
return (grantID, grant)
@ -500,7 +504,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
let recipByID = grantResourceLocalActor $ topicResource recipKey
let recipByID = topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity
recipByID recipActorID localRecipsGrant
@ -539,7 +543,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
audAccepter <- lift $ makeAudSenderOnly authorIdMsig
audMe <-
AudLocal [] . pure . localActorFollowers .
grantResourceLocalActor . topicResource <$>
topicResource <$>
encodeKeyHashid recipKey
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
@ -655,7 +659,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) acceptID
-- Prepare forwarding of Accept to my followers
let recipByID = grantResourceLocalActor $ topicResource recipKey
let recipByID = topicResource recipKey
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
@ -667,7 +671,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
-- Prepare an Accept activity and insert to my outbox
react@(actionReact, _, _, _) <- lift $ prepareReact project inviter
let recipByKey = grantResourceLocalActor $ topicResource recipKey
let recipByKey = topicResource recipKey
_luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact
return (reactID, react)
@ -679,7 +683,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
Nothing -> done "I already have this activity in my inbox"
Just Nothing -> done "Done"
Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do
let recipByID = grantResourceLocalActor $ topicResource recipKey
let recipByID = topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity
recipByID recipActorID localRecipsReact
@ -689,7 +693,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
topicReject
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ActorId)
-> (forall f. f topic -> GrantResourceBy f)
-> (forall f. f topic -> LocalActorBy f)
-> UTCTime
-> Key topic
-> Verse
@ -815,7 +819,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
lift $ delete collabID
-- Prepare forwarding of Reject to my followers
let recipByID = grantResourceLocalActor $ topicResource recipKey
let recipByID = topicResource recipKey
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
@ -827,7 +831,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
isInvite = isLeft collab
newReject@(actionReject, _, _, _) <-
lift $ prepareReject isInvite inviterOrJoiner
let recipByKey = grantResourceLocalActor $ topicResource recipKey
let recipByKey = topicResource recipKey
_luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject
return (newRejectID, newReject)
@ -836,7 +840,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
let recipByID = grantResourceLocalActor $ topicResource recipKey
let recipByID = topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity
recipByID recipActorID localRecips
@ -879,7 +883,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
audRejecter <- makeAudSenderWithFollowers authorIdMsig
audForbidder <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash
let topicByHash = topicResource recipHash
senderHash <- bitraverse hashLocalActor pure sender
@ -942,12 +946,12 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
-- * Insert the Invite to my inbox
-- * Forward the Invite to my followers
topicInvite
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
:: forall topic ct si.
( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
, PersistRecordBackend ct SqlBackend
, PersistRecordBackend si SqlBackend
)
=> (topic -> ActorId)
-> (forall f. f topic -> GrantResourceBy f)
-> (forall f. f topic -> ComponentBy f)
-> EntityField ct (Key topic)
-> EntityField ct CollabId
@ -958,7 +962,7 @@ topicInvite
-> Verse
-> AP.Invite URIMode
-> ActE (Text, Act (), Next)
topicInvite grabActor topicResource topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
-- Check invite
recipOrProject <- do
@ -1141,7 +1145,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
sieve <- do
topicHash <- encodeKeyHashid topicKey
let topicByHash =
grantResourceLocalActor $ topicResource topicHash
topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Insert Collab or Stem record to DB
@ -1152,7 +1156,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
insertCollab role targetDB inviteDB acceptID
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
let topicByKey = grantResourceLocalActor $ topicResource topicKey
let topicByKey = topicResource topicKey
_luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
return (acceptID, accept)
Right projectDB -> do
@ -1164,7 +1168,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, maybeAccept) -> do
let topicByID = grantResourceLocalActor $ topicResource topicKey
let topicByID = topicResource topicKey
forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) ->
sendActivity
@ -1174,6 +1178,9 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
where
topicResource :: forall f. f topic -> LocalActorBy f
topicResource = componentActor . topicComponent
insertCollab role recipient inviteDB acceptID = do
collabID <- insert $ Collab role
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
@ -1217,7 +1224,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
Right (ObjURI h lu) -> return $ AudRemote h [lu] []
audTopic <-
AudLocal [] . pure . localActorFollowers .
grantResourceLocalActor . topicResource <$>
topicResource <$>
encodeKeyHashid topicKey
uInvite <- getActivityURI authorIdMsig
@ -1243,7 +1250,7 @@ topicRemove
, PersistRecordBackend ct SqlBackend
)
=> (topic -> ActorId)
-> (forall f. f topic -> GrantResourceBy f)
-> (forall f. f topic -> LocalActorBy f)
-> EntityField ct (Key topic)
-> EntityField ct CollabId
-> UTCTime
@ -1406,13 +1413,13 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
sieve <- lift $ do
topicHash <- encodeKeyHashid topicKey
let topicByHash =
grantResourceLocalActor $ topicResource topicHash
topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Prepare a Revoke activity and insert to my outbox
revoke@(actionRevoke, _, _, _) <-
lift $ prepareRevoke memberDB grantID
let recipByKey = grantResourceLocalActor $ topicResource topicKey
let recipByKey = topicResource topicKey
revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
@ -1421,7 +1428,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do
let topicByID = grantResourceLocalActor $ topicResource topicKey
let topicByID = topicResource topicKey
forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $ sendActivity
topicByID topicActorID localRecipsRevoke
@ -1435,7 +1442,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
encodeRouteLocal <- getEncodeRouteLocal
recipHash <- encodeKeyHashid topicKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash
let topicByHash = topicResource recipHash
memberHash <- bitraverse (hashGrantRecip . bmap entityKey) pure member
@ -1475,7 +1482,7 @@ topicJoin
, PersistRecordBackend ct SqlBackend
)
=> (topic -> ActorId)
-> (forall f. f topic -> GrantResourceBy f)
-> (forall f. f topic -> LocalActorBy f)
-> EntityField ct (Key topic)
-> EntityField ct CollabId
-> (CollabId -> Key topic -> ct)
@ -1546,14 +1553,14 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
sieve <- lift $ do
topicHash <- encodeKeyHashid topicKey
let topicByHash =
grantResourceLocalActor $ topicResource topicHash
topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
return (topicActorID, sieve)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve) -> do
let topicByID = grantResourceLocalActor $ topicResource topicKey
let topicByID = topicResource topicKey
forwardActivity authorIdMsig body topicByID topicActorID sieve
done "Recorded and forwarded the Join"
@ -1577,7 +1584,7 @@ topicCreateMe
, PersistRecordBackend ct SqlBackend
)
=> (topic -> ActorId)
-> (forall f. f topic -> GrantResourceBy f)
-> (forall f. f topic -> LocalActorBy f)
-> EntityField ct (Key topic)
-> (CollabId -> Key topic -> ct)
-> UTCTime
@ -1622,7 +1629,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
-- Prepare a Grant activity and insert to my outbox
grant@(actionGrant, _, _, _) <- lift prepareGrant
let recipByKey = grantResourceLocalActor $ topicResource recipKey
let recipByKey = topicResource recipKey
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
return (recipActorID, grantID, grant)
@ -1630,7 +1637,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
let recipByID = grantResourceLocalActor $ topicResource recipKey
let recipByID = topicResource recipKey
lift $ sendActivity
recipByID recipActorID localRecipsGrant
remoteRecipsGrant fwdHostsGrant grantID actionGrant
@ -1653,7 +1660,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
recipHash <- encodeKeyHashid recipKey
uCreator <- getActorURI authorIdMsig
uCreate <- getActivityURI authorIdMsig
let topicByHash = grantResourceLocalActor $ topicResource recipHash
let topicByHash = topicResource recipHash
audience =
let audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audCreator, audTopic]
@ -1707,16 +1714,16 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
-- * 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)
:: forall topic.
(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
componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) grant = do
-- Check grant
project <- checkDelegatorGrant grant
@ -1791,7 +1798,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
sieve <- do
recipHash <- encodeKeyHashid recipKey
let recipByHash =
grantResourceLocalActor $ topicResource recipHash
topicResource recipHash
return $ makeRecipientSet [] [localActorFollowers recipByHash]
-- Update the Stem record in DB
@ -1806,7 +1813,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
chain <- do
Stem role <- getJust stemID
chain@(actionChain, _, _, _) <- prepareChain role
let recipByKey = grantResourceLocalActor $ topicResource recipKey
let recipByKey = topicResource recipKey
_luChain <- updateOutboxItem' recipByKey chainID actionChain
return chain
@ -1815,7 +1822,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
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
let recipByID = topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity
recipByID recipActorID localRecipsChain remoteRecipsChain
@ -1824,6 +1831,9 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
where
topicResource :: forall f. f topic -> LocalActorBy f
topicResource = componentActor . topicComponent
checkDelegatorGrant g = do
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
parseGrant' g
@ -1833,7 +1843,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
project <-
bitraverse
(\case
GrantResourceProject j -> return j
LocalActorProject j -> return j
_ -> throwE "Resource isn't a project"
)
pure
@ -1885,12 +1895,12 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
audProject <- makeAudSenderWithFollowers authorIdMsig
audMe <-
AudLocal [] . pure . localActorFollowers .
grantResourceLocalActor . topicResource <$>
topicResource <$>
encodeKeyHashid recipKey
uProject <- lift $ getActorURI authorIdMsig
uGrant <- lift $ getActivityURI authorIdMsig
recipHash <- encodeKeyHashid recipKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash
let topicByHash = topicResource recipHash
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audProject, audMe]

24
src/Vervis/Actor/Deck.hs
View file

@ -191,7 +191,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
-- Verify the specified capability gives relevant access
verifyCapability'
capability authorIdMsig (GrantResourceDeck deckID) AP.RoleAdmin
capability authorIdMsig (LocalActorDeck deckID) AP.RoleAdmin
-- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
@ -292,7 +292,7 @@ deckCreateMe
-> ActE (Text, Act (), Next)
deckCreateMe =
topicCreateMe
deckActor GrantResourceDeck CollabTopicDeckDeck CollabTopicDeck
deckActor LocalActorDeck CollabTopicDeckDeck CollabTopicDeck
deckCreate
:: UTCTime
@ -391,11 +391,11 @@ deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
verifyCapability'
lcap
authorIdMsig
(GrantResourceDeck deckID)
(LocalActorDeck deckID)
AP.RoleReport
-- Prepare forwarding the Offer to my followers
let recipByID = grantResourceLocalActor $ GrantResourceDeck deckID
let recipByID = LocalActorDeck deckID
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
@ -528,7 +528,7 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do
verifyCapability''
uCap
authorIdMsig
(GrantResourceDeck deckID)
(LocalActorDeck deckID)
AP.RoleTriage
{-
@ -744,7 +744,7 @@ deckAccept
-> Verse
-> AP.Accept URIMode
-> ActE (Text, Act (), Next)
deckAccept = topicAccept deckActor GrantResourceDeck ComponentDeck
deckAccept = topicAccept deckActor ComponentDeck
-- Meaning: An actor rejected something
-- Behavior:
@ -769,7 +769,7 @@ deckReject
-> Verse
-> AP.Reject URIMode
-> ActE (Text, Act (), Next)
deckReject = topicReject deckActor GrantResourceDeck
deckReject = topicReject deckActor LocalActorDeck
-- Meaning: An actor A invited actor B to a resource
-- Behavior:
@ -800,7 +800,7 @@ deckInvite
-> ActE (Text, Act (), Next)
deckInvite =
topicInvite
deckActor GrantResourceDeck ComponentDeck
deckActor ComponentDeck
CollabTopicDeckDeck CollabTopicDeckCollab
CollabTopicDeck StemIdentDeck
@ -823,7 +823,7 @@ deckRemove
-> ActE (Text, Act (), Next)
deckRemove =
topicRemove
deckActor GrantResourceDeck
deckActor LocalActorDeck
CollabTopicDeckDeck CollabTopicDeckCollab
-- Meaning: An actor A asked to join a resource
@ -840,7 +840,7 @@ deckJoin
-> ActE (Text, Act (), Next)
deckJoin =
topicJoin
deckActor GrantResourceDeck
deckActor LocalActorDeck
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
-- Meaning: An actor is granting access-to-some-resource to another actor
@ -873,7 +873,7 @@ deckGrant
-> Verse
-> AP.Grant URIMode
-> ActE (Text, Act (), Next)
deckGrant = componentGrant deckActor GrantResourceDeck ComponentDeck
deckGrant = componentGrant deckActor ComponentDeck
------------------------------------------------------------------------------
-- Ambiguous: Following/Resolving
@ -1014,7 +1014,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
verifyCapability'
capability
authorIdMsig
(GrantResourceDeck recipDeckID)
(LocalActorDeck recipDeckID)
AP.RoleTriage
lift $ lift deleteFromDB

2
src/Vervis/Actor/Group.hs
View file

@ -92,7 +92,7 @@ groupCreateMe
-> ActE (Text, Act (), Next)
groupCreateMe =
topicCreateMe
groupActor GrantResourceGroup
groupActor LocalActorGroup
CollabTopicGroupGroup CollabTopicGroup
groupCreate

6
src/Vervis/Actor/Loom.hs
View file

@ -279,11 +279,11 @@ loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
verifyCapability'
lcap
authorIdMsig
(GrantResourceLoom loomID)
(LocalActorLoom loomID)
AP.RoleReport
-- Prepare forwarding the Offer to my followers
let recipByID = grantResourceLocalActor $ GrantResourceLoom loomID
let recipByID = LocalActorLoom loomID
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
@ -485,7 +485,7 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do
verifyCapability'
capability
authorIdMsig
(GrantResourceLoom loomID)
(LocalActorLoom loomID)
AP.RoleTriage
-- Prepare forwarding the Resolve to my followers & ticket

53
src/Vervis/Actor/Person/Client.hs
View file

@ -81,26 +81,11 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
import Vervis.RemoteActorStore
import Vervis.Ticket
verifyResourceAddressed :: RecipientRoutes -> GrantResourceBy Key -> ActE ()
verifyResourceAddressed localRecips resource = do
resourceHash <- hashGrantResource' resource
fromMaybeE (verify resourceHash) "Local resource not addressed"
where
verify (GrantResourceRepo r) = do
routes <- lookup r $ recipRepos localRecips
guard $ routeRepo routes
verify (GrantResourceDeck d) = do
routes <- lookup d $ recipDecks localRecips
guard $ routeDeck $ familyDeck routes
verify (GrantResourceLoom l) = do
routes <- lookup l $ recipLooms localRecips
guard $ routeLoom $ familyLoom routes
verify (GrantResourceProject r) = do
routes <- lookup r $ recipProjects localRecips
guard $ routeProject routes
verify (GrantResourceGroup r) = do
routes <- lookup r $ recipGroups localRecips
guard $ routeGroup routes
verifyActorAddressed :: RecipientRoutes -> LocalActorBy Key -> ActE ()
verifyActorAddressed localRecips resource = do
resourceHash <- hashLocalActor resource
unless (actorIsAddressed localRecips resourceHash) $
throwE "Local resource not addressed"
verifyProjectAddressed localRecips projectID = do
projectHash <- encodeKeyHashid projectID
@ -838,7 +823,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
resourceDB <-
bitraverse
(bitraverse
(withDBExcept . flip getGrantResource "Grant resource not found in DB")
(withDBExcept . flip getLocalActorEntityE "Grant resource not found in DB")
(withDBExcept . flip getEntityE "Grant context project not found in DB")
)
(\ u@(ObjURI h luColl) -> do
@ -887,7 +872,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Verify that resource and recipient are addressed by the Invite
bitraverse_
(bitraverse_
(verifyResourceAddressed localRecips . bmap entityKey)
(verifyActorAddressed localRecips . bmap entityKey)
(verifyProjectAddressed localRecips . entityKey)
)
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
@ -913,12 +898,12 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Prepare local recipients for Invite delivery
sieve <- lift $ do
resourceHash <- bitraverse (bitraverse hashGrantResource' encodeKeyHashid) pure resource
resourceHash <- bitraverse (bitraverse hashLocalActor encodeKeyHashid) pure resource
recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient
senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes
[ case resourceHash of
Left (Left r) -> Just $ grantResourceLocalActor r
Left (Left a) -> Just a
Left (Right j) -> Just $ LocalActorProject j
Right _ -> Nothing
, case recipientHash of
@ -929,7 +914,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
sieveStages = catMaybes
[ Just $ LocalStagePersonFollowers senderHash
, case resourceHash of
Left (Left r) -> Just $ localActorFollowers $ grantResourceLocalActor r
Left (Left a) -> Just $ localActorFollowers a
Left (Right j) -> Just $ LocalStageProjectFollowers j
Right _ -> Nothing
, case recipientHash of
@ -1088,7 +1073,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Verify that resource is addressed by the Remove
bitraverse_
(verifyResourceAddressed localRecips)
(verifyActorAddressed localRecips)
(verifyRemoteAddressed remoteRecips)
resource'
@ -1103,7 +1088,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- If resource is local, find it in our DB
_resourceDB <-
bitraverse
(flip getGrantResource "Resource not found in DB")
(flip getLocalActorEntityE "Resource not found in DB")
pure
resource'
@ -1125,16 +1110,12 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Prepare local recipients for Remove delivery
sieve <- lift $ do
resourceHash <- bitraverse hashGrantResource' pure resource'
resourceHash <- bitraverse hashLocalActor pure resource'
recipientHash <- bitraverse hashGrantRecip pure member
senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes
[ case resourceHash of
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
Left (GrantResourceProject l) -> Just $ LocalActorProject l
Left (GrantResourceGroup l) -> Just $ LocalActorGroup l
Left a -> Just a
Right _ -> Nothing
, case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@ -1143,11 +1124,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
sieveStages = catMaybes
[ Just $ LocalStagePersonFollowers senderHash
, case resourceHash of
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
Left (GrantResourceGroup l) -> Just $ LocalStageGroupFollowers l
Left a -> Just $ localActorFollowers a
Right _ -> Nothing
, case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p

514
src/Vervis/Actor/Project.hs
View file

@ -137,10 +137,6 @@ import Vervis.Ticket
-- - Component's followers
-- - My followers
-- - The Accept's sender
--
-- * In collab mode, if we just sent the collaborator-Grant, also send to
-- my new collaborator a delegation-extension Grant for each component I
-- have
projectAccept
:: UTCTime
-> ProjectId
@ -223,7 +219,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
verifyCapability'
capability
authorIdMsig
(GrantResourceProject projectID)
(LocalActorProject projectID)
AP.RoleAdmin
return fulfillsID
)
@ -267,7 +263,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
verifyCapability'
capability
authorIdMsig
(GrantResourceProject projectID)
(LocalActorProject projectID)
AP.RoleAdmin
)
@ -358,15 +354,14 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
return (componentID, ident, grantID, enableID, True)
-- Prepare forwarding of Accept to my followers
let recipByID = grantResourceLocalActor $ GrantResourceProject projectID
let recipByID = LocalActorProject projectID
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
maybeGrant <-
case idsForGrant of
-- In collab mode, prepare a regular Grant and extension
-- Grants
-- In collab mode, prepare a regular Grant
Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID) -> lift $ do
let isInvite = isLeft collab
grant@(actionGrant, _, _, _) <- do
@ -374,81 +369,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
prepareCollabGrant isInvite inviterOrJoiner role
let recipByKey = LocalActorProject projectID
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
recip <-
requireEitherAlt
(getBy $ UniqueCollabRecipLocal collabID)
(getBy $ UniqueCollabRecipRemote collabID)
"Found Collab with no recip"
"Found Collab with multiple recips"
let insertExt =
case bimap entityKey entityKey recip of
Left localID ->
\ enableID furtherID -> insert_ $ ComponentFurtherLocal enableID localID furtherID
Right remoteID ->
\ enableID furtherID -> insert_ $ ComponentFurtherRemote enableID remoteID furtherID
locals <-
fmap (map $ over _1 Left) $
E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
return (deleg E.^. ComponentDelegateLocalGrant, comp, enable)
remotes <-
fmap (map $ over _1 Right) $
E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
return (deleg E.^. ComponentDelegateRemoteGrant, comp, enable)
(uCollab, audCollab) <-
case recip of
Left (Entity _ (CollabRecipLocal _ personID)) -> do
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
return
( encodeRouteHome $ PersonR personHash
, AudLocal [LocalActorPerson personHash] []
)
Right (Entity _ (CollabRecipRemote _ raID)) -> do
ra <- getJust raID
u@(ObjURI h lu) <- getRemoteActorURI ra
return (u, AudRemote h [lu] [])
Collab role <- getJust collabID
exts <- for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID _) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
insertExt enableID extID
componentIdent <- do
i <- getComponentIdent componentID
bitraverse
(pure . snd)
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
i
uStart <-
case start of
Left (E.Value startID) -> do
encodeRouteHome <- getEncodeRouteHome
c <-
case componentIdent of
Left ci -> hashComponent ci
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
s <- encodeKeyHashid startID
return $ encodeRouteHome $ activityRoute (componentActor c) s
Right (E.Value remoteActivityID) -> do
objectID <- remoteActivityIdent <$> getJust remoteActivityID
o <- getJust objectID
let luAct = remoteObjectIdent o
h <- instanceHost <$> getJust (remoteObjectInstance o)
return $ ObjURI h luAct
ext@(actionExt, _, _, _) <-
prepareExtensionGrant uCollab audCollab componentIdent uStart (min role (componentRole component)) collabEnableID
let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext)
return $ Just (grantID, grant, exts)
return $ Just (grantID, grant)
-- In Invite-component mode, only if the Accept author is
-- the component, prepare a delegator-Grant
@ -460,7 +381,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
let recipByKey = LocalActorProject projectID
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
return (grantID, grant, [])
return (grantID, grant)
return (recipActorID, sieve, maybeGrant)
@ -469,21 +390,17 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
Just (recipActorID, sieve, maybeGrant) -> do
let recipByID = LocalActorProject projectID
forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), exts) -> do
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
sendActivity
recipByID recipActorID localRecipsGrant
remoteRecipsGrant fwdHostsGrant grantID actionGrant
for_ exts $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
sendActivity
recipByID recipActorID localRecipsExt
remoteRecipsExt fwdHostsExt extID actionExt
done "Forwarded the Accept and maybe published a Grant"
where
verifyCollabTopic collabID = do
topic <- lift $ getCollabTopic collabID
unless (GrantResourceProject projectID == topic) $
unless (LocalActorProject projectID == topic) $
throwE "Accept object is an Invite/Join for some other resource"
verifyInviteCollabTopic fulfillsID = do
@ -583,7 +500,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
audAccepter <- makeAudSenderWithFollowers authorIdMsig
audApprover <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid projectID
let topicByHash = grantResourceLocalActor $ GrantResourceProject recipHash
let topicByHash = LocalActorProject recipHash
senderHash <- bitraverse hashLocalActor pure sender
@ -689,49 +606,6 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
return (action, recipientSet, remoteActors, fwdHosts)
prepareExtensionGrant uCollab audCollab component uStart role enableID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
projectHash <- encodeKeyHashid projectID
uComponent <-
case component of
Left c -> do
a <- componentActor <$> hashComponent c
return $ encodeRouteHome $ renderLocalActor a
Right u -> pure u
enableHash <- encodeKeyHashid enableID
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audCollab]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uStart]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RXRole role
, AP.grantContext = uComponent
, AP.grantTarget = uCollab
, AP.grantResult =
Just
(encodeRouteLocal $
ProjectCollabLiveR projectHash enableHash
, Nothing
)
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Just uStart
}
}
return (action, recipientSet, remoteActors, fwdHosts)
checkExistingComponents
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
checkExistingComponents projectID componentDB = do
@ -952,7 +826,7 @@ projectCreateMe
-> ActE (Text, Act (), Next)
projectCreateMe =
topicCreateMe
projectActor GrantResourceProject
projectActor LocalActorProject
CollabTopicProjectProject CollabTopicProject
projectCreate
@ -1005,7 +879,7 @@ projectFollow now recipProjectID verse follow = do
-- Meaning: An actor is granting access-to-some-resource to another actor
-- Behavior:
-- * Verify that:
-- * Option 1 - Component sending me a delegation-start - Verify that:
-- * The sender is a component of mine, C
-- * The Grant's context is C
-- * The Grant's target is me
@ -1019,14 +893,37 @@ projectFollow now recipProjectID verse follow = do
-- * Insert the Grant to my inbox
-- * Record the delegation in the Component record in DB
-- * Forward the Grant to my followers
-- * For each person (non-team) collaborator of mine, prepare and send a
-- Grant, and store it in the Componet record in DB:
-- * For each person (non-team) collaborator of mine, prepare and send an
-- extension-Grant, and store it in the Componet record in DB:
-- * Role: The lower among (1) admin (2) the collaborator's role in me
-- * Resource: C
-- * Target: The collaborator
-- * Delegates: The Grant I just got from C
-- * Result: ProjectCollabLiveR for this collaborator
-- * Usage: invoke
--
-- * Option 2 - Collaborator sending me a delegator-Grant - Verify that:
-- * The sender is a collaborator of mine, A
-- * The Grant's context is A
-- * The Grant's target is me
-- * The Grant's usage is invoke & role is delegate
-- * The Grant doesn't specify 'delegates'
-- * The activity is authorized via a valid direct-Grant I had sent
-- to A
-- * Verify I don't yet have a delegator-Grant from A
-- * Insert the Grant to my inbox
-- * Record the delegator-Grant in the Collab record in DB
-- * Forward the Grant to my followers
-- * For each component of mine C, prepare and send an
-- extension-Grant to A, and store it in the Componet record in DB:
-- * Role: The lower among (1) admin (2) the collaborator's role in me
-- * Resource: C
-- * Target: A
-- * Delegates: The start-Grant I have from C
-- * Result: ProjectCollabLiveR for this collaborator, A
-- * Usage: invoke
--
-- * If neither 1 nor 2, raise an error
projectGrant
:: UTCTime
-> ProjectId
@ -1055,7 +952,76 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
_ -> throwE "Capability is remote i.e. definitely not by me"
-- Check grant
(role, component) <- checkDelegationStart grant
grant' <-
Left <$> checkDelegationStart grant <|>
Right <$> checkDelegator grant
case grant' of
Left (role, component) -> handleComp capability role component
Right collab -> handleCollab capability collab
where
checkDelegationStart g = do
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
parseGrant' g
role' <-
case role of
AP.RXRole r -> pure r
AP.RXDelegator -> throwE "Role is delegator"
component <-
fromMaybeE
(bitraverse actorToComponent Just resource)
"Resource is a local project, therefore not a component of mine"
case (component, authorIdMsig) of
(Left c, Left (a, _, _)) | componentActor c == a -> pure ()
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
_ -> throwE "Author and context aren't the same actor"
case recipient of
Left (GrantRecipProject' j) | j == projectID -> 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.GatherAndConvey) $
throwE "Usage isn't GatherAndConvey"
for_ mdeleg $ \ _ ->
throwE "'delegates' is specified"
return (role', component)
checkDelegator g = do
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
parseGrant' g
case role of
AP.RXRole _ -> throwE "Role isn't delegator"
AP.RXDelegator -> pure ()
collab <-
bitraverse
(\case
LocalActorPerson p -> pure p
_ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine"
)
pure
resource
case (collab, authorIdMsig) of
(Left c, Left (a, _, _)) | LocalActorPerson c == a -> pure ()
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
_ -> throwE "Author and context aren't the same actor"
case recipient of
Left (GrantRecipProject' j) | j == projectID -> 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 collab
handleComp capability role component = do
maybeNew <- withDBExcept $ do
@ -1109,44 +1075,44 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
-- For each Collab in me, prepare a delegation-extension Grant
localCollabs <-
lift $
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL) -> do
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do
E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable
E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
return
( collab E.^. CollabRole
, recipL E.^. CollabRecipLocalId
, recipL E.^. CollabRecipLocalPerson
, enable E.^. CollabEnableId
, deleg
)
localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value recipID, E.Value personID, E.Value enableID') -> do
localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value personID, Entity delegID (CollabDelegLocal enableID' recipID grantID)) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
insert_ $ ComponentFurtherLocal enableID recipID extID
insert_ $ ComponentFurtherLocal enableID delegID extID
ext@(actionExt, _, _, _) <-
prepareExtensionGrant identForCheck (Left personID) (min role role') enableID'
prepareExtensionGrant identForCheck (Left (personID, grantID)) (min role role') enableID'
let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext)
remoteCollabs <-
lift $
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR) -> do
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do
E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable
E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
return
( collab E.^. CollabRole
, recipR E.^. CollabRecipRemoteId
, recipR E.^. CollabRecipRemoteActor
, enable E.^. CollabEnableId
, deleg
)
remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value recipID, E.Value raID, E.Value enableID') -> do
remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value raID, Entity delegID (CollabDelegRemote enableID' recipID grantID)) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
insert_ $ ComponentFurtherRemote enableID recipID extID
insert_ $ ComponentFurtherRemote enableID delegID extID
ext@(actionExt, _, _, _) <-
prepareExtensionGrant identForCheck (Right raID) (min role role') enableID'
prepareExtensionGrant identForCheck (Right (raID, grantID)) (min role role') enableID'
let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext)
@ -1163,38 +1129,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
sendActivity
recipByID recipActorID localRecipsExt
remoteRecipsExt fwdHostsExt extID actionExt
done "Forwarded the Grant and published delegation extensions"
done "Forwarded the start-Grant and published delegation extensions"
where
checkDelegationStart g = do
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
parseGrant' g
role' <-
case role of
AP.RXRole r -> pure r
AP.RXDelegator -> throwE "Role is delegator"
component <-
fromMaybeE
(bitraverse resourceToComponent Just resource)
"Resource is a local project, therefore not a component of mine"
case (component, authorIdMsig) of
(Left c, Left (a, _, _)) | componentActor c == a -> pure ()
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
_ -> throwE "Author and context aren't the same actor"
case recipient of
Left (GrantRecipProject' j) | j == projectID -> 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.GatherAndConvey) $
throwE "Usage isn't GatherAndConvey"
for_ mdeleg $ \ _ ->
throwE "'delegates' is specified"
return (role', component)
prepareExtensionGrant component collab role enableID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
@ -1202,18 +1140,24 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
projectHash <- encodeKeyHashid projectID
uStart <- lift $ getActivityURI authorIdMsig
(uCollab, audCollab) <-
(uCollab, audCollab, uDeleg) <-
case collab of
Left personID -> do
Left (personID, itemID) -> do
personHash <- encodeKeyHashid personID
itemHash <- encodeKeyHashid itemID
return
( encodeRouteHome $ PersonR personHash
, AudLocal [LocalActorPerson personHash] []
, encodeRouteHome $
PersonOutboxItemR personHash itemHash
)
Right raID -> do
Right (raID, ractID) -> do
ra <- getJust raID
u@(ObjURI h lu) <- getRemoteActorURI ra
return (u, AudRemote h [lu] [])
uAct <- do
ract <- getJust ractID
getRemoteActivityURI ract
return (u, AudRemote h [lu] [], uAct)
uComponent <-
case component of
@ -1231,7 +1175,195 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
{ AP.actionCapability = Just uDeleg
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uStart]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RXRole role
, AP.grantContext = uComponent
, AP.grantTarget = uCollab
, AP.grantResult =
Just
(encodeRouteLocal $
ProjectCollabLiveR projectHash enableHash
, Nothing
)
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Just uStart
}
}
return (action, recipientSet, remoteActors, fwdHosts)
handleCollab capability collab = do
maybeNew <- withDBExcept $ do
-- Grab me from DB
(recipActorID, recipActor) <- lift $ do
recip <- getJust projectID
let actorID = projectActor recip
(actorID,) <$> getJust actorID
-- Find the Collab record from the capability
Entity enableID (CollabEnable collabID _) <- do
unless (fst capability == LocalActorProject projectID) $
throwE "Capability isn't mine"
m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability
fromMaybeE m "I don't have a Collab with this capability"
Collab role <- lift $ getJust collabID
topic <- lift $ getCollabTopic collabID
unless (topic == LocalActorProject projectID) $
throwE "Found a Collab for this direct-Grant but it's not mine"
recip <- lift $ getCollabRecip collabID
recipForCheck <-
lift $
bitraverse
(pure . collabRecipLocalPerson . entityVal)
(getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal)
recip
unless (recipForCheck == collab) $
throwE "Capability's collaborator and Grant author aren't the same actor"
-- Verify I don't yet have a delegator-Grant from the collaborator
maybeDeleg <-
lift $ case bimap entityKey entityKey recip of
Left localID -> (() <$) <$> getBy (UniqueCollabDelegLocalRecip localID)
Right remoteID -> (() <$) <$> getBy (UniqueCollabDelegRemoteRecip remoteID)
verifyNothingE maybeDeleg "I already have a delegator-Grant from this collaborator"
maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
for maybeGrantDB $ \ grantDB -> do
-- Record the delegator-Grant in the Collab record
(insertExt, uDeleg) <-
lift $ case (grantDB, bimap entityKey entityKey recip) of
(Left (grantActor, _, grantID), Left localID) -> do
delegID <- insert $ CollabDelegLocal enableID localID grantID
encodeRouteHome <- getEncodeRouteHome
delegR <-
activityRoute
<$> hashLocalActor grantActor
<*> encodeKeyHashid grantID
return
(\ enableID furtherID ->
insert_ $ ComponentFurtherLocal enableID delegID furtherID
, encodeRouteHome delegR
)
(Right (_, _, grantID), Right remoteID) -> do
delegID <- insert $ CollabDelegRemote enableID remoteID grantID
u <- getRemoteActivityURI =<< getJust grantID
return
(\ enableID furtherID ->
insert_ $ ComponentFurtherRemote enableID delegID furtherID
, u
)
_ -> error "projectGrant impossible 2"
-- Prepare forwarding of Accept to my followers
projectHash <- encodeKeyHashid projectID
let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
-- For each Component of mine, prepare a delegation-extension
-- Grant
extensions <- lift $ do
locals <-
fmap (map $ over _1 Left) $
E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
return (deleg E.^. ComponentDelegateLocalGrant, comp, enable)
remotes <-
fmap (map $ over _1 Right) $
E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
return (deleg E.^. ComponentDelegateRemoteGrant, comp, enable)
(uCollab, audCollab) <-
case recip of
Left (Entity _ (CollabRecipLocal _ personID)) -> do
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
return
( encodeRouteHome $ PersonR personHash
, AudLocal [LocalActorPerson personHash] []
)
Right (Entity _ (CollabRecipRemote _ raID)) -> do
ra <- getJust raID
u@(ObjURI h lu) <- getRemoteActorURI ra
return (u, AudRemote h [lu] [])
for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID' _) -> do
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
insertExt enableID' extID
componentIdent <- do
i <- getComponentIdent componentID
bitraverse
(pure . snd)
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
i
uStart <-
case start of
Left (E.Value startID) -> do
encodeRouteHome <- getEncodeRouteHome
c <-
case componentIdent of
Left ci -> hashComponent ci
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
s <- encodeKeyHashid startID
return $ encodeRouteHome $ activityRoute (componentActor c) s
Right (E.Value remoteActivityID) -> do
ra <- getJust remoteActivityID
getRemoteActivityURI ra
ext@(actionExt, _, _, _) <-
prepareExtensionGrant uCollab audCollab uDeleg componentIdent uStart (min role (componentRole component)) enableID
let recipByKey = LocalActorProject projectID
_luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext)
return (recipActorID, sieve, extensions)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, sieve, extensions) -> do
let recipByID = LocalActorProject projectID
forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ for_ extensions $
\ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
sendActivity
recipByID recipActorID localRecipsExt
remoteRecipsExt fwdHostsExt extID actionExt
done "Forwarded the delegator-Grant, updated DB and published delegation extensions"
where
prepareExtensionGrant uCollab audCollab uDeleg component uStart role enableID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
projectHash <- encodeKeyHashid projectID
uComponent <-
case component of
Left c -> do
a <- componentActor <$> hashComponent c
return $ encodeRouteHome $ renderLocalActor a
Right u -> pure u
enableHash <- encodeKeyHashid enableID
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audCollab]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Just uDeleg
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uStart]
@ -1311,7 +1443,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
mode <-
case resourceOrComps of
Left (Left (GrantResourceProject j)) | j == projectID ->
Left (Left (LocalActorProject j)) | j == projectID ->
Left <$>
bitraverse
(\case
@ -1363,7 +1495,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
-- Verify the specified capability gives relevant access
verifyCapability'
capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin
capability authorIdMsig (LocalActorProject projectID) AP.RoleAdmin
case invitedDB of
@ -1538,7 +1670,7 @@ projectJoin
-> ActE (Text, Act (), Next)
projectJoin =
topicJoin
projectActor GrantResourceProject
projectActor LocalActorProject
CollabTopicProjectProject CollabTopicProjectCollab CollabTopicProject
-- Meaning: An actor rejected something
@ -1564,7 +1696,7 @@ projectReject
-> Verse
-> AP.Reject URIMode
-> ActE (Text, Act (), Next)
projectReject = topicReject projectActor GrantResourceProject
projectReject = topicReject projectActor LocalActorProject
-- Meaning: An actor A is removing actor B from a resource
-- Behavior:
@ -1585,7 +1717,7 @@ projectRemove
-> ActE (Text, Act (), Next)
projectRemove =
topicRemove
projectActor GrantResourceProject
projectActor LocalActorProject
CollabTopicProjectProject CollabTopicProjectCollab
-- Meaning: An actor is undoing some previous action

26
src/Vervis/Client.hs
View file

@ -1120,7 +1120,7 @@ invite personID uRecipient uResourceCollabs role = do
resource
resourceDB <-
bitraverse
hashGrantResource
VR.hashLocalActor
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@ -1158,16 +1158,7 @@ invite personID uRecipient uResourceCollabs role = do
let audResource =
case resourceDB of
Left (GrantResourceRepo r) ->
AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
Left (GrantResourceDeck d) ->
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
Left (GrantResourceLoom l) ->
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
Left (GrantResourceProject l) ->
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
Left (GrantResourceGroup l) ->
AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
Left la -> AudLocal [la] [localActorFollowers la]
Right (remoteActor, ObjURI h lu) ->
AudRemote h
[lu]
@ -1237,7 +1228,7 @@ remove personID uRecipient uResourceCollabs = do
-- managing actor & followers collection
resourceDB <-
bitraverse
hashGrantResource
VR.hashLocalActor
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@ -1275,16 +1266,7 @@ remove personID uRecipient uResourceCollabs = do
let audResource =
case resourceDB of
Left (GrantResourceRepo r) ->
AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
Left (GrantResourceDeck d) ->
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
Left (GrantResourceLoom l) ->
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
Left (GrantResourceProject l) ->
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
Left (GrantResourceGroup l) ->
AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
Left la -> AudLocal [la] [localActorFollowers la]
Right (remoteActor, ObjURI h lu) ->
AudRemote h
[lu]

183
src/Vervis/Data/Collab.hs
View file

@ -33,26 +33,12 @@ module Vervis.Data.Collab
, grantResourceActorID
, GrantResourceBy (..)
, unhashGrantResourcePure
, unhashGrantResource
, unhashGrantResourceE
, unhashGrantResource'
, unhashGrantResourceE'
, unhashGrantResource404
, hashGrantResource
, hashGrantResource'
, getGrantResource
, getGrantResource404
, grantResourceLocalActor
, ComponentBy (..)
, parseComponent
, hashComponent
, unhashComponentE
, componentActor
, resourceToComponent
, actorToComponent
, GrantRecipBy' (..)
, hashGrantRecip'
@ -96,18 +82,11 @@ import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
parseGrantResource (GroupR l) = Just $ GrantResourceGroup l
parseGrantResource _ = Nothing
parseGrantResourceCollabs (RepoCollabsR r) = Just $ GrantResourceRepo r
parseGrantResourceCollabs (DeckCollabsR d) = Just $ GrantResourceDeck d
parseGrantResourceCollabs (LoomCollabsR l) = Just $ GrantResourceLoom l
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ GrantResourceProject l
parseGrantResourceCollabs (GroupMembersR l) = Just $ GrantResourceGroup l
parseGrantResourceCollabs (RepoCollabsR r) = Just $ LocalActorRepo r
parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalActorDeck d
parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalActorLoom l
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalActorProject l
parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalActorGroup l
parseGrantResourceCollabs _ = Nothing
data GrantRecipBy f = GrantRecipPerson (f Person)
@ -144,7 +123,7 @@ verifyRole = pure
parseTopic
:: StageRoute Env ~ Route App
=> FedURI -> ActE (Either (GrantResourceBy Key) FedURI)
=> FedURI -> ActE (Either (LocalActorBy Key) FedURI)
parseTopic u = do
t <- parseTopic' u
bitraverse
@ -158,7 +137,7 @@ parseTopic u = do
parseTopic'
:: StageRoute Env ~ Route App
=> FedURI
-> ActE (Either (Either (GrantResourceBy Key) ProjectId) FedURI)
-> ActE (Either (Either (LocalActorBy Key) ProjectId) FedURI)
parseTopic' u = do
routeOrRemote <- parseFedURI u
bitraverse
@ -170,7 +149,7 @@ parseTopic' u = do
fromMaybeE
(parseGrantResourceCollabs route)
"Not a shared resource collabs route"
unhashGrantResourceE'
unhashLocalActorE
resourceHash
"Contains invalid hashid"
)
@ -242,7 +221,7 @@ parseInvite
-> AP.Invite URIMode
-> ActE
( AP.Role
, Either (Either (GrantResourceBy Key) ProjectId) FedURI
, Either (Either (LocalActorBy Key) ProjectId) FedURI
, Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI
)
parseInvite sender (AP.Invite instrument object target) =
@ -254,7 +233,7 @@ parseInvite sender (AP.Invite instrument object target) =
parseJoin
:: StageRoute Env ~ Route App
=> AP.Join URIMode
-> ActE (AP.Role, Either (GrantResourceBy Key) FedURI)
-> ActE (AP.Role, Either (LocalActorBy Key) FedURI)
parseJoin (AP.Join instrument object) =
(,) <$> verifyRole instrument
<*> nameExceptT "Join object" (parseTopic object)
@ -264,7 +243,7 @@ parseGrant
-> AP.Grant URIMode
-> ActE
( AP.RoleExt
, Either (GrantResourceBy Key) LocalURI
, Either (LocalActorBy Key) LocalURI
, Either (GrantRecipBy Key) FedURI
, Maybe (LocalURI, Maybe Int)
, Maybe UTCTime
@ -298,13 +277,7 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
fromMaybeE
(decodeRouteLocal lu)
"Grant context isn't a valid route"
resourceHash <-
fromMaybeE
(parseGrantResource route)
"Grant context isn't a shared resource route"
unhashGrantResourceE'
resourceHash
"Grant resource contains invalid hashid"
parseLocalActorE' route
else pure $ Right lu
parseTarget u@(ObjURI h lu) = do
hl <- hostIsLocal h
@ -327,7 +300,7 @@ parseGrant'
:: AP.Grant URIMode
-> ActE
( AP.RoleExt
, Either (GrantResourceBy Key) FedURI
, Either (LocalActorBy Key) FedURI
, Either (GrantRecipBy' Key) FedURI
, Maybe (LocalURI, Maybe Int)
, Maybe UTCTime
@ -358,13 +331,7 @@ parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) =
fromMaybeE
(decodeRouteLocal lu)
"Grant context isn't a valid route"
resourceHash <-
fromMaybeE
(parseGrantResource route)
"Grant context isn't a shared resource route"
unhashGrantResourceE'
resourceHash
"Grant resource contains invalid hashid"
parseLocalActorE' route
else pure $ Right u
parseTarget u@(ObjURI h lu) = do
hl <- hostIsLocal h
@ -397,7 +364,7 @@ parseRemove
=> Either (LocalActorBy Key) FedURI
-> AP.Remove URIMode
-> ActE
( Either (Either (GrantResourceBy Key) ProjectId) FedURI
( Either (Either (LocalActorBy Key) ProjectId) FedURI
, Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI
)
parseRemove sender (AP.Remove object origin) =
@ -453,104 +420,13 @@ parseAdd sender (AP.Add object target role) = do
pure
routeOrRemote
grantResourceActorID :: GrantResourceBy Identity -> ActorId
grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
grantResourceActorID (GrantResourceProject (Identity j)) = projectActor j
grantResourceActorID (GrantResourceGroup (Identity g)) = groupActor g
data GrantResourceBy f
= GrantResourceRepo (f Repo)
| GrantResourceDeck (f Deck)
| GrantResourceLoom (f Loom)
| GrantResourceProject (f Project)
| GrantResourceGroup (f Group)
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
unhashGrantResourcePure ctx = f
where
f (GrantResourceRepo r) =
GrantResourceRepo <$> decodeKeyHashidPure ctx r
f (GrantResourceDeck d) =
GrantResourceDeck <$> decodeKeyHashidPure ctx d
f (GrantResourceLoom l) =
GrantResourceLoom <$> decodeKeyHashidPure ctx l
f (GrantResourceProject l) =
GrantResourceProject <$> decodeKeyHashidPure ctx l
f (GrantResourceGroup l) =
GrantResourceGroup <$> decodeKeyHashidPure ctx l
unhashGrantResource resource = do
ctx <- asksSite siteHashidsContext
return $ unhashGrantResourcePure ctx resource
unhashGrantResourceE resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
unhashGrantResource' resource = do
ctx <- asksEnv WAP.stageHashidsContext
return $ unhashGrantResourcePure ctx resource
unhashGrantResourceE' resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource
unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
hashGrantResource (GrantResourceRepo k) =
GrantResourceRepo <$> encodeKeyHashid k
hashGrantResource (GrantResourceDeck k) =
GrantResourceDeck <$> encodeKeyHashid k
hashGrantResource (GrantResourceLoom k) =
GrantResourceLoom <$> encodeKeyHashid k
hashGrantResource (GrantResourceProject k) =
GrantResourceProject <$> encodeKeyHashid k
hashGrantResource (GrantResourceGroup k) =
GrantResourceGroup <$> encodeKeyHashid k
hashGrantResource' (GrantResourceRepo k) =
GrantResourceRepo <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceDeck k) =
GrantResourceDeck <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceLoom k) =
GrantResourceLoom <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceProject k) =
GrantResourceProject <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceGroup k) =
GrantResourceGroup <$> WAP.encodeKeyHashid k
getGrantResource (GrantResourceRepo k) e =
GrantResourceRepo <$> getEntityE k e
getGrantResource (GrantResourceDeck k) e =
GrantResourceDeck <$> getEntityE k e
getGrantResource (GrantResourceLoom k) e =
GrantResourceLoom <$> getEntityE k e
getGrantResource (GrantResourceProject k) e =
GrantResourceProject <$> getEntityE k e
getGrantResource (GrantResourceGroup k) e =
GrantResourceGroup <$> getEntityE k e
getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
where
getGrantResourceEntity (GrantResourceRepo k) =
fmap GrantResourceRepo <$> getEntity k
getGrantResourceEntity (GrantResourceDeck k) =
fmap GrantResourceDeck <$> getEntity k
getGrantResourceEntity (GrantResourceLoom k) =
fmap GrantResourceLoom <$> getEntity k
getGrantResourceEntity (GrantResourceProject k) =
fmap GrantResourceProject <$> getEntity k
getGrantResourceEntity (GrantResourceGroup k) =
fmap GrantResourceGroup <$> getEntity k
grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l
grantResourceLocalActor (GrantResourceGroup l) = LocalActorGroup l
grantResourceActorID :: LocalActorBy Identity -> ActorId
grantResourceActorID (LocalActorPerson (Identity p)) = personActor p
grantResourceActorID (LocalActorRepo (Identity r)) = repoActor r
grantResourceActorID (LocalActorDeck (Identity d)) = deckActor d
grantResourceActorID (LocalActorLoom (Identity l)) = loomActor l
grantResourceActorID (LocalActorProject (Identity j)) = projectActor j
grantResourceActorID (LocalActorGroup (Identity g)) = groupActor g
data ComponentBy f
= ComponentRepo (f Repo)
@ -588,12 +464,13 @@ componentActor (ComponentRepo r) = LocalActorRepo r
componentActor (ComponentDeck d) = LocalActorDeck d
componentActor (ComponentLoom l) = LocalActorLoom l
resourceToComponent = \case
GrantResourceRepo k -> Just $ ComponentRepo k
GrantResourceDeck k -> Just $ ComponentDeck k
GrantResourceLoom k -> Just $ ComponentLoom k
GrantResourceProject _ -> Nothing
GrantResourceGroup _ -> Nothing
actorToComponent = \case
LocalActorPerson _ -> Nothing
LocalActorRepo k -> Just $ ComponentRepo k
LocalActorDeck k -> Just $ ComponentDeck k
LocalActorLoom k -> Just $ ComponentLoom k
LocalActorProject _ -> Nothing
LocalActorGroup _ -> Nothing
data GrantRecipBy' f
= GrantRecipPerson' (f Person)

4
src/Vervis/Data/Ticket.hs
View file

@ -37,7 +37,6 @@ module Vervis.Data.Ticket
, unhashWorkItemE
, unhashWorkItem404
, workItemResource
, workItemActor
, workItemFollowers
, workItemRoute
@ -351,9 +350,6 @@ unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor
ctx <- asksSite siteHashidsContext
return $ unhashWorkItemPure ctx byHash
workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck
workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom
workItemActor (WorkItemTicket deck _) = LocalActorDeck deck
workItemActor (WorkItemCloth loom _) = LocalActorLoom loom

53
src/Vervis/Migration.hs
View file

@ -3066,6 +3066,59 @@ changes hLocal ctx =
outboxID <- actor553Outbox <$> getJust actorID
itemID <- insert $ OutboxItem553 outboxID doc defaultTime
insert_ $ CollabDelegLocal553 enableID recipID itemID
-- 554
, addFieldRefRequired''
"ComponentFurtherLocal"
(do collabID <- insert $ Collab554 RoleVisit
outboxID <- insert Outbox554
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
itemID <- insert $ OutboxItem554 outboxID doc defaultTime
enableID <- insert $ CollabEnable554 collabID itemID
personID <- do
mp <- selectFirst [] [Asc Person554Id]
entityKey <$> maybe (error "No people") return mp
recipID <- insert $ CollabRecipLocal554 collabID personID
insertEntity $ CollabDelegLocal554 enableID recipID itemID
)
(Just $ \ (Entity cdlidTemp cdlTemp) -> do
l <- selectList [] []
for_ l $ \ (Entity cflid (ComponentFurtherLocal554 _ recipID _ _)) -> do
mk <- getKeyBy $ UniqueCollabDelegLocalRecip554 recipID
case mk of
Nothing -> error "Found ComponentFurtherLocal whose CollabRecipLocal doesn't have a CollabDelegLocal, previous migration should have created it"
Just k -> update cflid [ComponentFurtherLocal554CollabNew =. k]
delete cdlidTemp
let CollabDelegLocal554 enableID recipID itemID = cdlTemp
delete recipID
collabID <- collabEnable554Collab <$> getJust enableID
delete enableID
outboxID <- outboxItem554Outbox <$> getJust itemID
delete itemID
delete outboxID
delete collabID
)
"collabNew"
"CollabDelegLocal"
-- 555
, addFieldRefRequiredEmpty
"ComponentFurtherRemote" "collabNew" "CollabDelegRemote"
-- 556
, removeUnique' "ComponentFurtherLocal" ""
-- 557
, removeField "ComponentFurtherLocal" "collab"
-- 558
, renameField "ComponentFurtherLocal" "collabNew" "collab"
-- 559
, addUnique' "ComponentFurtherLocal" "" ["component", "collab"]
-- 560
, removeUnique' "ComponentFurtherRemote" ""
-- 561
, removeField "ComponentFurtherRemote" "collab"
-- 562
, renameField "ComponentFurtherRemote" "collabNew" "collab"
-- 563
, addUnique' "ComponentFurtherRemote" "" ["component", "collab"]
]
migrateDB

3
src/Vervis/Migration/Model.hs
View file

@ -534,3 +534,6 @@ makeEntitiesMigration "549"
makeEntitiesMigration "553"
$(modelFile "migrations/553_2023-11-21_collab_deleg.model")
makeEntitiesMigration "554"
$(modelFile "migrations/554_2023-11-21_further_local_deleg.model")

24
src/Vervis/Persist/Actor.hs
View file

@ -17,8 +17,12 @@ module Vervis.Persist.Actor
( getLocalActor
, getLocalActorEnt
, getLocalActorEntity
, getLocalActorEntityE
, getLocalActorEntity404
, verifyLocalActivityExistsInDB
, getRemoteObjectURI
, getRemoteActorURI
, getRemoteActivityURI
, insertActor
, updateOutboxItem
, updateOutboxItem'
@ -39,6 +43,7 @@ import Data.Text (Text)
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Yesod.Core.Handler
import qualified Data.Text as T
import qualified Database.Esqueleto as E
@ -110,6 +115,14 @@ getLocalActorEntity (LocalActorLoom l) =
getLocalActorEntity (LocalActorProject r) =
fmap (LocalActorProject . Entity r) <$> get r
getLocalActorEntityE a e = do
m <- lift $ getLocalActorEntity a
case m of
Nothing -> throwE e
Just a' -> return a'
getLocalActorEntity404 = maybe notFound return <=< getLocalActorEntity
verifyLocalActivityExistsInDB
:: MonadIO m
=> LocalActorBy Key
@ -125,14 +138,21 @@ verifyLocalActivityExistsInDB actorByKey outboxItemID = do
unless (itemActorByKey == actorByKey) $
throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch"
getRemoteActorURI actor = do
object <- getJust $ remoteActorIdent actor
getRemoteObjectURI object = do
inztance <- getJust $ remoteObjectInstance object
return $
ObjURI
(instanceHost inztance)
(remoteObjectIdent object)
getRemoteActorURI actor = do
object <- getJust $ remoteActorIdent actor
getRemoteObjectURI object
getRemoteActivityURI act = do
object <- getJust $ remoteActivityIdent act
getRemoteObjectURI object
insertActor now name desc mby = do
ibid <- insert Inbox
obid <- insert Outbox

33
src/Vervis/Persist/Collab.hs
View file

@ -16,6 +16,7 @@
module Vervis.Persist.Collab
( getCollabTopic
, getCollabTopic'
, getCollabRecip
, getStemIdent
, getStemProject
, getGrantRecip
@ -70,11 +71,11 @@ import Vervis.Model
import Vervis.Persist.Actor
getCollabTopic
:: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
:: MonadIO m => CollabId -> ReaderT SqlBackend m (LocalActorBy Key)
getCollabTopic = fmap snd . getCollabTopic'
getCollabTopic'
:: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key)
:: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), LocalActorBy Key)
getCollabTopic' collabID = do
maybeRepo <- getBy $ UniqueCollabTopicRepo collabID
maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
@ -85,17 +86,29 @@ getCollabTopic' collabID = do
case (maybeRepo, maybeDeck, maybeLoom, maybeProject, maybeGroup) of
(Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
(Just (Entity k r), Nothing, Nothing, Nothing, Nothing) ->
(delete k, GrantResourceRepo $ collabTopicRepoRepo r)
(delete k, LocalActorRepo $ collabTopicRepoRepo r)
(Nothing, Just (Entity k d), Nothing, Nothing, Nothing) ->
(delete k, GrantResourceDeck $ collabTopicDeckDeck d)
(delete k, LocalActorDeck $ collabTopicDeckDeck d)
(Nothing, Nothing, Just (Entity k l), Nothing, Nothing) ->
(delete k, GrantResourceLoom $ collabTopicLoomLoom l)
(delete k, LocalActorLoom $ collabTopicLoomLoom l)
(Nothing, Nothing, Nothing, Just (Entity k l), Nothing) ->
(delete k, GrantResourceProject $ collabTopicProjectProject l)
(delete k, LocalActorProject $ collabTopicProjectProject l)
(Nothing, Nothing, Nothing, Nothing, Just (Entity k l)) ->
(delete k, GrantResourceGroup $ collabTopicGroupGroup l)
(delete k, LocalActorGroup $ collabTopicGroupGroup l)
_ -> error "Found Collab with multiple topics"
getCollabRecip
:: MonadIO m
=> CollabId
-> ReaderT SqlBackend m
(Either (Entity CollabRecipLocal) (Entity CollabRecipRemote))
getCollabRecip collabID =
requireEitherAlt
(getBy $ UniqueCollabRecipLocal collabID)
(getBy $ UniqueCollabRecipRemote collabID)
"Collab without recip"
"Collab with both local and remote recip"
getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)
getStemIdent stemID = do
maybeRepo <- getValBy $ UniqueStemIdentRepo stemID
@ -288,7 +301,7 @@ verifyCapability
:: MonadIO m
=> (LocalActorBy Key, OutboxItemId)
-> Either PersonId RemoteActorId
-> GrantResourceBy Key
-> LocalActorBy Key
-> AP.Role
-> ExceptT Text (ReaderT SqlBackend m) ()
verifyCapability (capActor, capItem) actor resource requiredRole = do
@ -320,7 +333,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
topic <- lift $ getCollabTopic collabID
-- Verify that topic is indeed the sender of the Grant
unless (grantResourceLocalActor topic == capActor) $
unless (topic == capActor) $
error "Grant sender isn't the topic"
-- Verify the topic matches the resource specified
@ -338,7 +351,7 @@ verifyCapability'
-> Either
(LocalActorBy Key, ActorId, OutboxItemId)
(RemoteAuthor, LocalURI, Maybe ByteString)
-> GrantResourceBy Key
-> LocalActorBy Key
-> AP.Role
-> ExceptT Text (ReaderT SqlBackend m) ()
verifyCapability' cap actor resource role = do

2
src/Vervis/Persist/Ticket.hs
View file

@ -179,7 +179,7 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
case capID of
Left (capActor, _, capItem) -> return (capActor, capItem)
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
verifyCapability capability actor (GrantResourceLoom loomID) AP.RoleWrite
verifyCapability capability actor (LocalActorLoom loomID) AP.RoleWrite
-- Get the patches from DB, verify VCS match just in case
diffs <- do

22
src/Vervis/Recipient.hs
View file

@ -770,28 +770,6 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
then Nothing
else Just (rkhid, merged)
actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
actorIsAddressed recips = isJust . verify
where
verify (LocalActorPerson p) = do
routes <- lookup p $ recipPeople recips
guard $ routePerson routes
verify (LocalActorGroup g) = do
routes <- lookup g $ recipGroups recips
guard $ routeGroup routes
verify (LocalActorRepo r) = do
routes <- lookup r $ recipRepos recips
guard $ routeRepo routes
verify (LocalActorDeck d) = do
routes <- lookup d $ recipDecks recips
guard $ routeDeck $ familyDeck routes
verify (LocalActorLoom l) = do
routes <- lookup l $ recipLooms recips
guard $ routeLoom $ familyLoom routes
verify (LocalActorProject j) = do
routes <- lookup j $ recipProjects recips
guard $ routeProject routes
data ParsedAudience u = ParsedAudience
{ paudLocalRecips :: RecipientRoutes
, paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]

11
src/Vervis/Web/Collab.hs
View file

@ -91,15 +91,14 @@ verifyCapability''
-> Either
(LocalActorBy Key, ActorId, OutboxItemId)
(RemoteAuthor, LocalURI, Maybe ByteString)
-> GrantResourceBy Key
-> LocalActorBy Key
-> AP.Role
-> ActE ()
verifyCapability'' uCap recipientActor resource requiredRole = do
manager <- asksEnv envHttpManager
encodeRouteHome <- getEncodeRouteHome
uResource <-
encodeRouteHome . VR.renderLocalActor <$>
hashLocalActor (grantResourceLocalActor resource)
encodeRouteHome . VR.renderLocalActor <$> hashLocalActor resource
now <- liftIO getCurrentTime
grants <- traverseGrants manager uResource now
unless (checkRole grants) $
@ -220,7 +219,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
-- Find the local topic, on which this Collab gives access
topic <- lift $ getCollabTopic collabID
-- Verify that topic is indeed the sender of the Grant
unless (grantResourceLocalActor topic == capActor) $
unless (topic == capActor) $
error "Grant sender isn't the topic"
-- Verify the topic matches the resource specified
unless (topic == resource) $
@ -242,7 +241,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
unless (componentActor topic == capActor) $
error "Grant sender isn't the Stem ident"
-- Verify the topic matches the resource specified
unless (componentActor topic == grantResourceLocalActor resource) $
unless (componentActor topic == resource) $
throwE "Capability topic is some other local resource"
return $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l
@ -250,7 +249,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
Just uParent -> nameExceptT "Extension-Grant" $ do
case cap of
Left (actor, _, _)
| grantResourceLocalActor resource == actor ->
| resource == actor ->
throwE "Grant.delegates specified but Grant's actor is me"
_ -> return ()
(luResult, _) <- fromMaybeE (AP.grantResult grant) "Grant.result not specified"

4
th/models
View file

@ -903,7 +903,7 @@ ComponentDelegateRemote
-- direct collaborator
ComponentFurtherLocal
component ComponentEnableId
collab CollabRecipLocalId
collab CollabDelegLocalId
grant OutboxItemId
UniqueComponentFurtherLocal component collab
@ -913,7 +913,7 @@ ComponentFurtherLocal
-- direct collaborator
ComponentFurtherRemote
component ComponentEnableId
collab CollabRecipRemoteId
collab CollabDelegRemoteId
grant OutboxItemId
UniqueComponentFurtherRemote component collab