diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index eb26ad2..c95797f 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -77,6 +77,526 @@ import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Ticket +import Vervis.Web.Collab + +-- Meaning: An actor is adding some object to some target +-- Behavior: +-- * If the target is my children list: +-- * Verify the object is a project, find in DB/HTTP +-- * Verify the Add is authorized +-- * Verify it's not already an active child of mine +-- * Verify it's not already an active parent 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 child's Accept +-- * Insert the Add to my inbox +-- * Create a Dest record in DB +-- * Forward the Add to my followers +-- * Publish an Accept to: +-- * The object project + followers +-- * Add sender + followers +-- * My followers +-- * Record my Accept in the Dest record +-- +-- * If the target is my parents list: +-- * Verify the object is a project, find in DB/HTTP +-- * Verify the Add is authorized +-- * Verify it's not already an active parent of mine +-- * Verify it's not already an active child 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 parent's Accept +-- * Insert the Add to my inbox +-- * Create a Source record in DB +-- * Forward the Add to my followers +-- * Publish an Accept to: +-- * The object project + followers +-- * Add sender + followers +-- * My followers +-- * Record my Accept in the Source record +-- +-- * If I'm the object, being added to someone's parents/children list: +-- * Verify the target is a project, find in DB/HTTP +-- * Verify it's not already an active parent of mine +-- * Verify it's not already an active child 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 parent/child's Accept +-- * Insert the Add to my inbox +-- * Create a Source/Dest record in DB +-- * Forward the Add to my followers +-- +-- * Otherwise, error +groupAdd + :: UTCTime + -> GroupId + -> Verse + -> AP.Add URIMode + -> ActE (Text, Act (), Next) +groupAdd now groupID (Verse authorIdMsig body) add = do + + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (object, target, role) <- parseAdd author add + unless (role == AP.RoleAdmin) $ + throwE "Add role isn't admin" + case (target, object) of + (Left (ATGroupChildren j), _) | j == groupID -> + addChildActive object + (Left (ATGroupParents j), _) | j == groupID -> + addParentActive object + (_, Left (LocalActorGroup j)) | j == groupID -> + case target of + Left (ATGroupParents j) | j /= groupID -> + addChildPassive $ Left j + Left (ATGroupChildren j) | j /= groupID -> + addParentPassive $ Left j + 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" + 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.ActorTypeTeam && Just luColl == AP.rwcSubteams rwc + then addParentPassive $ Right $ ObjURI h lu + else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcParentsOrProjects rwc + then addChildPassive $ Right $ ObjURI h lu + else throwE "Weird collection situation" + _ -> throwE "I'm being added somewhere irrelevant" + _ -> throwE "This Add isn't for me" + + where + + prepareAccept childDB = do + encodeRouteHome <- getEncodeRouteHome + + audAdder <- makeAudSenderWithFollowers authorIdMsig + audChild <- + case childDB of + Left (Entity j _) -> do + jh <- encodeKeyHashid j + return $ AudLocal [LocalActorGroup jh] [] + Right (ObjURI h lu, Entity _ ra) -> + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . LocalStageGroupFollowers <$> + encodeKeyHashid groupID + uAdd <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAdder, audChild, 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) + + addParentActive parent = do + + -- If parent is local, find it in our DB + -- If parent is remote, HTTP GET it, verify it's an actor of Group + -- 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. + parentDB <- + bitraverse + (\case + LocalActorGroup j -> withDBExcept $ getEntityE j "Parent not found in DB" + _ -> throwE "Local proposed parent 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 "Parent @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Parent isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote parent type isn't Group" + return (u, actor) + ) + parent + let parentDB' = second (entityKey . snd) parentDB + + -- 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 parent + verifyCapability'' + uCap + authorIdMsig + (LocalResourceGroup groupID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + -- Verify the object isn't a child of mine + verifyNoEnabledGroupChildren groupID parentDB' + + -- Verify the object isn't already a parent of mine, and that no + -- Source record is already in Add-Accept state + verifyNoStartedGroupParents groupID parentDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Source record in DB + acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + insertSource parentDB' addDB acceptID + + -- Prepare forwarding the Add to my followers + sieve <- do + groupHash <- encodeKeyHashid groupID + return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept parentDB + _luAccept <- updateOutboxItem' (LocalActorGroup groupID) acceptID actionAccept + + return (groupActor group, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (groupActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorGroup groupID) groupActorID sieve + lift $ sendActivity + (LocalActorGroup groupID) groupActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "Recorded a parent-group-in-progress, forwarded the Add, sent an Accept" + + where + + insertSource topicDB addDB acceptID = do + sourceID <- insert $ Source AP.RoleAdmin + holderID <- insert $ SourceHolderGroup sourceID groupID + case topicDB of + Left (Entity j _) -> do + localID <- insert $ SourceTopicLocal sourceID + insert_ $ SourceTopicGroup holderID localID j + Right a -> + insert_ $ SourceTopicRemote sourceID a + usID <- insert $ SourceOriginUs sourceID + case addDB of + Left (_, _, addID) -> + insert_ $ SourceUsGestureLocal usID addID + Right (author, _, addID) -> + insert_ $ SourceUsGestureRemote usID (remoteAuthorId author) addID + + insert_ $ SourceUsAccept usID acceptID + + addChildActive child = do + + -- If child is local, find it in our DB + -- If child is remote, HTTP GET it, verify it's an actor of Group + -- 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. + childDB <- + bitraverse + (\case + LocalActorGroup j -> withDBExcept $ getEntityE j "Child not found in DB" + _ -> throwE "Local proposed child 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 "Child @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Child isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote child type isn't Group" + return (u, actor) + ) + child + let childDB' = second (entityKey . snd) childDB + + -- 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 child + verifyCapability'' + uCap + authorIdMsig + (LocalResourceGroup groupID) + AP.RoleTriage + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + -- Verify the object isn't a parent of mine + verifyNoEnabledGroupParents groupID childDB' + + -- Verify the object isn't already a child of mine, and that no + -- Dest record is already in Add-Accept state + verifyNoStartedGroupChildren groupID childDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Dest record in DB + acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + insertDest childDB' addDB acceptID + + -- Prepare forwarding the Add to my followers + sieve <- do + groupHash <- encodeKeyHashid groupID + return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept childDB + _luAccept <- updateOutboxItem' (LocalActorGroup groupID) acceptID actionAccept + + return (groupActor group, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (groupActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorGroup groupID) groupActorID sieve + lift $ sendActivity + (LocalActorGroup groupID) groupActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "Recorded a child-group-in-progress, forwarded the Add, sent an Accept" + + where + + insertDest topicDB addDB acceptID = do + destID <- insert $ Dest AP.RoleAdmin + holderID <- insert $ DestHolderGroup destID groupID + case topicDB of + Left (Entity j _) -> do + localID <- insert $ DestTopicLocal destID + insert_ $ DestTopicGroup holderID localID j + Right a -> + insert_ $ DestTopicRemote destID a + insert_ $ DestOriginUs destID + case addDB of + Left (_, _, addID) -> + insert_ $ DestUsGestureLocal destID addID + Right (author, _, addID) -> + insert_ $ DestUsGestureRemote destID (remoteAuthorId author) addID + + insert_ $ DestUsAccept destID acceptID + + addParentPassive parent = do + + -- If parent is local, find it in our DB + -- If parent is remote, HTTP GET it, verify it's an actor of Group + -- 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. + parentDB <- + bitraverse + (\ j -> withDBExcept $ getEntityE j "Parent 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 "Parent @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Parent isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote parent type isn't Group" + return (u, actor) + ) + parent + let parentDB' = second (entityKey . snd) parentDB + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + -- Verify the target isn't a child of mine + verifyNoEnabledGroupChildren groupID parentDB' + + -- Verify the target isn't already a parent of mine, and that no + -- Source record is already in Add-Accept state + verifyNoStartedGroupParents groupID parentDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Source record in DB + insertSource parentDB' addDB + + -- Prepare forwarding the Add to my followers + sieve <- do + groupHash <- encodeKeyHashid groupID + return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash] + + return (groupActor group, sieve, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (groupActorID, sieve, inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorGroup groupID) groupActorID sieve + doneDB inboxItemID "Recorded a parent-group-in-progress, forwarded the Add" + + where + + insertSource topicDB addDB = do + sourceID <- insert $ Source AP.RoleAdmin + holderID <- insert $ SourceHolderGroup sourceID groupID + case topicDB of + Left (Entity j _) -> do + localID <- insert $ SourceTopicLocal sourceID + insert_ $ SourceTopicGroup holderID localID j + Right a -> + insert_ $ SourceTopicRemote sourceID a + themID <- insert $ SourceOriginThem sourceID + case addDB of + Left (_, _, addID) -> + insert_ $ SourceThemGestureLocal themID addID + Right (author, _, addID) -> + insert_ $ SourceThemGestureRemote themID (remoteAuthorId author) addID + + addChildPassive child = do + + -- If child is local, find it in our DB + -- If child is remote, HTTP GET it, verify it's an actor of Group + -- 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. + childDB <- + bitraverse + (\ j -> withDBExcept $ getEntityE j "Child 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 "Child @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Child isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote child type isn't Group" + return (u, actor) + ) + child + let childDB' = second (entityKey . snd) childDB + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + -- Verify the object isn't a parent of mine + verifyNoEnabledGroupParents groupID childDB' + + -- Verify the object isn't already a child of mine, and that no + -- Dest record is already in Add-Accept state + verifyNoStartedGroupChildren groupID childDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Dest record in DB + insertDest childDB' addDB + + -- Prepare forwarding the Add to my followers + sieve <- do + groupHash <- encodeKeyHashid groupID + return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash] + + return (groupActor group, sieve, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (groupActorID, sieve, inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorGroup groupID) groupActorID sieve + doneDB inboxItemID "Recorded a child-group-in-progress, forwarded the Add" + + where + + insertDest topicDB addDB = do + destID <- insert $ Dest AP.RoleAdmin + holderID <- insert $ DestHolderGroup destID groupID + case topicDB of + Left (Entity j _) -> do + localID <- insert $ DestTopicLocal destID + insert_ $ DestTopicGroup holderID localID j + Right a -> + insert_ $ DestTopicRemote destID a + themID <- insert $ DestOriginThem destID + case addDB of + Left (_, _, addID) -> + insert_ $ DestThemGestureLocal themID addID + Right (author, _, addID) -> + insert_ $ DestThemGestureRemote themID (remoteAuthorId author) addID -- Meaning: An actor accepted something -- Behavior: @@ -965,6 +1485,7 @@ groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next) groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> groupAccept now groupID verse accept + AP.AddActivity add -> groupAdd now groupID verse add AP.CreateActivity create -> groupCreate now groupID verse create AP.FollowActivity follow -> groupFollow now groupID verse follow AP.GrantActivity grant -> groupGrant now groupID verse grant