diff --git a/migrations/554_2023-11-21_further_local_deleg.model b/migrations/554_2023-11-21_further_local_deleg.model new file mode 100644 index 0000000..b4710e1 --- /dev/null +++ b/migrations/554_2023-11-21_further_local_deleg.model @@ -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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index f30193f..895c169 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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 () diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index a803485..04c4921 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -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 diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 864c146..145727a 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -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] diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index ecb1ab4..cd90ee9 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -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 diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 3813361..931d35e 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -92,7 +92,7 @@ groupCreateMe -> ActE (Text, Act (), Next) groupCreateMe = topicCreateMe - groupActor GrantResourceGroup + groupActor LocalActorGroup CollabTopicGroupGroup CollabTopicGroup groupCreate diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index 5f65c57..ace96f4 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -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 diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index a4c2dda..c427a72 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -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 diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 59219c0..8248c3f 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -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,115 +952,13 @@ 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 - maybeNew <- withDBExcept $ do - - -- Grab me from DB - (recipActorID, recipActor) <- lift $ do - recip <- getJust projectID - let actorID = projectActor recip - (actorID,) <$> getJust actorID - - -- Find the Component record from the capability - Entity enableID (ComponentEnable componentID _) <- do - unless (fst capability == LocalActorProject projectID) $ - throwE "Capability isn't mine" - m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability - fromMaybeE m "I don't have a Component with this capability" - Component j role' <- lift $ getJust componentID - unless (j == projectID) $ - throwE "Found a Component for this delegator-Grant but it's not mine" - unless (role' == role) $ - throwE "Grant role isn't the same as in the Invite/Add" - ident <- lift $ getComponentIdent componentID - identForCheck <- - lift $ - bitraverse - (pure . snd) - (\ (_, raID) -> getRemoteActorURI =<< getJust raID) - ident - unless (identForCheck == component) $ - throwE "Capability's component and Grant author aren't the same actor" - - -- Verify I don't yet have a delegation from the component - maybeDeleg <- - lift $ case bimap fst fst ident of - Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID) - Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID) - verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component" - - maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False - for maybeGrantDB $ \ grantDB -> do - - -- Record the delegation in DB - lift $ case (grantDB, bimap fst fst ident) of - (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID - (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID - _ -> error "projectGrant impossible" - - -- Prepare forwarding of Accept to my followers - projectHash <- encodeKeyHashid projectID - let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash] - - -- 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.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 - ) - localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value recipID, E.Value personID, E.Value enableID') -> do - extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ ComponentFurtherLocal enableID recipID extID - ext@(actionExt, _, _, _) <- - prepareExtensionGrant identForCheck (Left personID) (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.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 - ) - remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value recipID, E.Value raID, E.Value enableID') -> do - extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ ComponentFurtherRemote enableID recipID extID - ext@(actionExt, _, _, _) <- - prepareExtensionGrant identForCheck (Right raID) (min role role') enableID' - let recipByKey = LocalActorProject projectID - _luExt <- updateOutboxItem' recipByKey extID actionExt - return (extID, ext) - - return (recipActorID, sieve, localExtensions, remoteExtensions) - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, sieve, localExts, remoteExts) -> do - let recipByID = LocalActorProject projectID - forwardActivity authorIdMsig body recipByID recipActorID sieve - lift $ for_ (localExts ++ remoteExts) $ - \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> - sendActivity - recipByID recipActorID localRecipsExt - remoteRecipsExt fwdHostsExt extID actionExt - done "Forwarded the Grant and published delegation extensions" + case grant' of + Left (role, component) -> handleComp capability role component + Right collab -> handleCollab capability collab where @@ -1176,7 +971,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do AP.RXDelegator -> throwE "Role is delegator" component <- fromMaybeE - (bitraverse resourceToComponent Just resource) + (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 () @@ -1195,64 +990,401 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do throwE "'delegates' is specified" return (role', component) - prepareExtensionGrant component collab role enableID = do - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal + 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 - projectHash <- encodeKeyHashid projectID - uStart <- lift $ getActivityURI authorIdMsig + handleComp capability role component = do - (uCollab, audCollab) <- - case collab of - Left personID -> do - personHash <- encodeKeyHashid personID - return - ( encodeRouteHome $ PersonR personHash - , AudLocal [LocalActorPerson personHash] [] - ) - Right raID -> do - ra <- getJust raID - u@(ObjURI h lu) <- getRemoteActorURI ra - return (u, AudRemote h [lu] []) + maybeNew <- withDBExcept $ do - uComponent <- - case component of - Left c -> do - a <- componentActor <$> hashComponent c - return $ encodeRouteHome $ renderLocalActor a - Right u -> pure u + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID - enableHash <- encodeKeyHashid enableID + -- Find the Component record from the capability + Entity enableID (ComponentEnable componentID _) <- do + unless (fst capability == LocalActorProject projectID) $ + throwE "Capability isn't mine" + m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability + fromMaybeE m "I don't have a Component with this capability" + Component j role' <- lift $ getJust componentID + unless (j == projectID) $ + throwE "Found a Component for this delegator-Grant but it's not mine" + unless (role' == role) $ + throwE "Grant role isn't the same as in the Invite/Add" + ident <- lift $ getComponentIdent componentID + identForCheck <- + lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + ident + unless (identForCheck == component) $ + throwE "Capability's component and Grant author aren't the same actor" - let audience = [audCollab] + -- Verify I don't yet have a delegation from the component + maybeDeleg <- + lift $ case bimap fst fst ident of + Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID) + verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component" - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience audience + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ grantDB -> do - 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 + -- Record the delegation in DB + lift $ case (grantDB, bimap fst fst ident) of + (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID + (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID + _ -> error "projectGrant impossible" + + -- Prepare forwarding of Accept to my followers + projectHash <- encodeKeyHashid projectID + let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash] + + -- 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 `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.^. CollabRecipLocalPerson + , deleg ) - , AP.grantStart = Just now - , AP.grantEnd = Nothing - , AP.grantAllows = AP.Invoke - , AP.grantDelegates = Just uStart - } - } + 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 delegID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant identForCheck (Left (personID, grantID)) (min role role') enableID' + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) - return (action, recipientSet, remoteActors, fwdHosts) + remoteCollabs <- + lift $ + 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.^. CollabRecipRemoteActor + , deleg + ) + 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 delegID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant identForCheck (Right (raID, grantID)) (min role role') enableID' + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return (recipActorID, sieve, localExtensions, remoteExtensions) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, localExts, remoteExts) -> do + let recipByID = LocalActorProject projectID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ (localExts ++ remoteExts) $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Forwarded the start-Grant and published delegation extensions" + + where + + prepareExtensionGrant component collab role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + uStart <- lift $ getActivityURI authorIdMsig + + (uCollab, audCollab, uDeleg) <- + case collab of + Left (personID, itemID) -> do + personHash <- encodeKeyHashid personID + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ PersonR personHash + , AudLocal [LocalActorPerson personHash] [] + , encodeRouteHome $ + PersonOutboxItemR personHash itemHash + ) + Right (raID, ractID) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + uAct <- do + ract <- getJust ractID + getRemoteActivityURI ract + return (u, AudRemote h [lu] [], uAct) + + uComponent <- + case component of + Left c -> do + a <- componentActor <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + enableHash <- encodeKeyHashid enableID + + let audience = [audCollab] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { 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] + , 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) -- Meaning: An actor A invited actor B to a resource -- Behavior: @@ -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 diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index c4ae8a1..d1afb26 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -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] diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 89d076b..ed315b6 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -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) diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index 99eca6d..7fd82bb 100644 --- a/src/Vervis/Data/Ticket.hs +++ b/src/Vervis/Data/Ticket.hs @@ -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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index a5a2d02..4331fb4 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 1763406..e713717 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -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") diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 4f51d96..6cb052d 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -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 diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 84147ff..01f481a 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -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 diff --git a/src/Vervis/Persist/Ticket.hs b/src/Vervis/Persist/Ticket.hs index d912faf..f8615a7 100644 --- a/src/Vervis/Persist/Ticket.hs +++ b/src/Vervis/Persist/Ticket.hs @@ -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 diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index e779417..fa88bc5 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -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)] diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs index 8ccf3b1..f83db53 100644 --- a/src/Vervis/Web/Collab.hs +++ b/src/Vervis/Web/Collab.hs @@ -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" diff --git a/th/models b/th/models index 7d69a8d..2b5e02f 100644 --- a/th/models +++ b/th/models @@ -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