diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index fa71ade..59219c0 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -137,6 +137,10 @@ 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 @@ -311,8 +315,8 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do throwE "This Join already has an Accept" _ -> error "projectAccept impossible" grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now - lift $ insert_ $ CollabEnable collabID grantID - return (collabID, inviterOrJoiner, collab, grantID) + enableID <- lift $ insert $ CollabEnable collabID grantID + return (collabID, inviterOrJoiner, collab, grantID, enableID) -- In Invite-component mode, only if the Accept author is the -- component, record the Accept and enable the Component @@ -361,15 +365,90 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do maybeGrant <- case idsForGrant of - -- In collab mode, prepare a regular Grant - Left (collabID, inviterOrJoiner, collab, grantID) -> lift $ do + -- In collab mode, prepare a regular Grant and extension + -- Grants + Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID) -> lift $ do let isInvite = isLeft collab grant@(actionGrant, _, _, _) <- do Collab role <- getJust collabID prepareCollabGrant isInvite inviterOrJoiner role let recipByKey = LocalActorProject projectID _luGrant <- updateOutboxItem' recipByKey grantID actionGrant - return $ Just (grantID, grant) + + 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) -- In Invite-component mode, only if the Accept author is -- the component, prepare a delegator-Grant @@ -381,7 +460,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) @@ -390,10 +469,14 @@ 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)) -> + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), exts) -> do 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 @@ -606,6 +689,49 @@ 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