diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 3d24e9c..beba856 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -2170,8 +2170,24 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body -- * Project's followers -- * My followers -- --- * If the object is me: --- * Verify the target is some project's components collection URI +-- * If the target is my teams list: +-- * Verify the object is a team, find in DB/HTTP +-- * Verify the Add is authorized +-- * Verify it's not already an active team of mine +-- * Verify it's not already in an Origin-Us process where I saw the Add +-- and sent my Accept +-- * Verify it's not already in an Origin-Them process, where I saw the +-- Add and the potential team's Accept +-- * Insert the Add to my inbox +-- * Create a Squad record in DB +-- * Forward the Add to my followers +-- * Publish an Accept to: +-- * The object team + followers +-- * Add sender + followers +-- * My followers +-- * Record my Accept in the Squad record +-- +-- * If the object is me & target is some project's components collection URI -- * For each Stem record I have for this project: -- * Verify it's not enabled yet, i.e. I'm not already a component -- of this project @@ -2182,6 +2198,17 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body -- * Create a Stem record in DB -- * Insert the Add to my inbox -- * Forward the Add to my followers +-- +-- * If I'm the object, being added to some teams' resource list: +-- * Verify the target is a team, find in DB/HTTP +-- * Verify it's not already an active team of mine +-- * Verify it's not already in an Origin-Us process where I saw the Add +-- and sent my Accept +-- * Verify it's not already in an Origin-Them process, where I saw the +-- Add and the potential team's Accept +-- * Insert the Add to my inbox +-- * Create a Squad record in DB +-- * Forward the Add to my followers componentAdd :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> KomponentId) @@ -2199,7 +2226,7 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = throwE "Add role isn't admin" case (target, object) of (Left at, _) - | addTargetComponentProjects at == Just (toComponent meID) -> do + | addTargetComponentProjects at == Just meComponent -> do project <- bitraverse (\case @@ -2209,31 +2236,42 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = pure object addProjectActive role project + | (resourceFromNG <$> addTargetResourceTeams at) == Just meResource -> + addTeamActive object (_, Left la) | resourceToActor (componentResource $ toComponent meID) == la -> do case target of Left (ATProjectComponents j) -> addProjectPassive role $ Left j + Left (ATGroupEfforts g) -> + addTeamPassive $ Left g Right (ObjURI h luColl) -> do -- NOTE this is HTTP GET done synchronously in the activity -- handler manager <- asksEnv envHttpManager c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl lu <- fromMaybeE (AP.collectionContext c) "No context" - j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu - if luColl == AP.projectComponents j + rwc <- AP.fetchRWC_T manager h lu + AP.Actor l d <- + case AP.rwcResource rwc of + AP.ResourceActor a -> pure a + AP.ResourceChild _ _ -> throwE "Add.target remote ResourceChild" + let typ = AP.actorType d + if typ == AP.ActorTypeProject && Just luColl == AP.rwcComponents rwc then addProjectPassive role $ Right $ ObjURI h lu - else throwE "Non-components collection" + else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc + then addTeamPassive $ Right $ ObjURI h lu + else throwE "Non-components collection" _ -> throwE "I'm being added somewhere irrelevant" _ -> throwE "This Add isn't for me" where - addProjectActive role project = do + meComponent = toComponent meID + meResource = componentResource meComponent + meActor = resourceToActor meResource - let meComponent = toComponent meID - meResource = componentResource meComponent - meActor = resourceToActor meResource + addProjectActive role project = do -- Check capability capability <- do @@ -2484,6 +2522,220 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = Right (author, _, addID) -> insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) addID + addTeamActive team = do + + -- If team is local, find it in our DB + -- If team is remote, HTTP GET it, verify it's an actor of Project + -- type, and store in our DB (if it's already there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + teamDB <- + bitraverse + (\case + LocalActorGroup g -> withDBExcept $ getEntityE g "Team not found in DB" + _ -> throwE "Local proposed team of non-Group type" + ) + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h lu + case result of + Left Nothing -> throwE "Team @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Team isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote team type isn't Team" + return (u, actor) + ) + team + let teamDB' = second (entityKey . snd) teamDB + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the sender is authorized by me to add a team + verifyCapability'' + uCap + authorIdMsig + meResource + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + meKomponentID <- lift $ grabKomponent <$> getJust meID + Komponent meResourceID <- lift $ getJust meKomponentID + Resource meActorID <- lift $ getJust meResourceID + meActorDB <- lift $ getJust meActorID + + -- Verify the object isn't already a team of mine, and that no + -- Squad record is already in Add-Accept state + verifyNoStartedResourceTeams meResourceID teamDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Squad record in DB + acceptID <- insertEmptyOutboxItem' (actorOutbox meActorDB) now + insertSquad meResourceID teamDB' addDB acceptID + + -- Prepare forwarding the Add to my followers + sieve <- do + h <- hashLocalActor meActor + return $ makeRecipientSet [] [localActorFollowers h] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept teamDB + _luAccept <- updateOutboxItem' meActor acceptID actionAccept + + return (meActorID, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (meActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + forwardActivity authorIdMsig body meActor meActorID sieve + lift $ sendActivity + meActor meActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "[Team-active] Recorded a team-in-progress, forwarded the Add, sent an Accept" + + where + + insertSquad resourceID topicDB addDB acceptID = do + squadID <- insert $ Squad AP.RoleAdmin resourceID + case topicDB of + Left (Entity g _) -> insert_ $ SquadTopicLocal squadID g + Right a -> insert_ $ SquadTopicRemote squadID a + insert_ $ SquadOriginUs squadID + case addDB of + Left (_, _, addID) -> + insert_ $ SquadUsGestureLocal squadID addID + Right (author, _, addID) -> + insert_ $ SquadUsGestureRemote squadID (remoteAuthorId author) addID + + insert_ $ SquadUsAccept squadID acceptID + + prepareAccept teamDB = do + encodeRouteHome <- getEncodeRouteHome + + audAdder <- makeAudSenderWithFollowers authorIdMsig + audTeam <- + case teamDB of + Left (Entity g _) -> do + gh <- encodeKeyHashid g + return $ AudLocal [LocalActorGroup gh] [LocalStageGroupFollowers gh] + Right (ObjURI h lu, Entity _ ra) -> + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . localActorFollowers <$> + hashLocalActor meActor + uAdd <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAdder, audTeam, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uAdd] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uAdd + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + addTeamPassive team = do + + -- If team is local, find it in our DB + -- If team is remote, HTTP GET it, verify it's an actor of Project + -- type, and store in our DB (if it's already there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + teamDB <- + bitraverse + (\ g -> withDBExcept $ getEntityE g "Team not found in DB") + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h lu + case result of + Left Nothing -> throwE "Team @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Team isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote team type isn't Team" + return (u, actor) + ) + team + let teamDB' = second (entityKey . snd) teamDB + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + meKomponentID <- lift $ grabKomponent <$> getJust meID + Komponent meResourceID <- lift $ getJust meKomponentID + Resource meActorID <- lift $ getJust meResourceID + meActorDB <- lift $ getJust meActorID + + -- Verify the object isn't already a team of mine, and that no + -- Squad record is already in Add-Accept state + verifyNoStartedResourceTeams meResourceID teamDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Squad record in DB + insertSquad meResourceID teamDB' addDB + + -- Prepare forwarding the Add to my followers + sieve <- do + h <- hashLocalActor meActor + return $ makeRecipientSet [] [localActorFollowers h] + + return (meActorID, sieve, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (meActorID, sieve, inboxItemID) -> do + forwardActivity authorIdMsig body meActor meActorID sieve + doneDB inboxItemID "[Team-passive] Recorded a team-in-progress, forwarded the Add" + + where + + insertSquad resourceID topicDB addDB = do + squadID <- insert $ Squad AP.RoleAdmin resourceID + case topicDB of + Left (Entity g _) -> insert_ $ SquadTopicLocal squadID g + Right a -> insert_ $ SquadTopicRemote squadID a + themID <- insert $ SquadOriginThem squadID + case addDB of + Left (_, _, addID) -> + insert_ $ SquadThemGestureLocal themID addID + Right (author, _, addID) -> + insert_ $ SquadThemGestureRemote themID (remoteAuthorId author) addID + -- Meaning: An actor is revoking Grant activities -- Behavior: -- * For each revoked activity: