diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 4dd777c..7f28270 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -2175,6 +2175,12 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo Just inboxItemID -> doneDB inboxItemID "[Team-passive] Saw the removal attempt, just waiting for the Revoke" +-- Meaning: An actor A asked to join a resource +-- Behavior: +-- * Verify the resource is me +-- * Verify A doesn't already have an invite/join/grant for me +-- * Remember the join in DB +-- * Forward the Join to my followers topicJoin :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ResourceId) diff --git a/src/Vervis/Actor/Factory.hs b/src/Vervis/Actor/Factory.hs index feab317..dda494f 100644 --- a/src/Vervis/Actor/Factory.hs +++ b/src/Vervis/Actor/Factory.hs @@ -85,6 +85,842 @@ import Vervis.Web.Collab data NewActor = NADeck | NAProject | NATeam +-- Meaning: An actor accepted something +-- Behavior: +-- * == Collab mode == +-- * Is it an Invite to be a collaborator in me? +-- * Verify the Accept is by the Invite target +-- * Is it a Join to be a collaborator in me? +-- * Verify the Accept is authorized +-- +-- * In collab mode, verify the Collab isn't enabled yet +-- +-- * Insert the Accept to my inbox +-- +-- * In collab mode, record the Accept and enable the Collab in DB +-- +-- * Forward the Accept to my followers +-- +-- * Possibly send a Grant/Accept: +-- * For Invite-collab mode: +-- * Regular collaborator-Grant +-- * To: Accepter (i.e. Invite target) +-- * CC: Invite sender, Accepter's followers, my followers +-- * For Join-as-collab mode: +-- * Regular collaborator-Grant +-- * To: Join sender +-- * CC: Accept sender, Join sender's followers, my followers +-- +-- * Add-a-Team mode +-- * Give me a new team active SquadOriginUs +-- * Respond with error, we aren't supposed to get any Accept +-- * Give me a new team passive SquadOriginThem +-- * Option 1: I haven't yet seen parent's Accept +-- * Verify sender is the parent +-- * Option 2: I saw it, but not my collaborator's Accept +-- * Verify the accept is authorized +-- * Otherwise respond with error, no Accept is needed +-- +-- * Insert the Accept to my inbox +-- +-- * In team-passive mode, +-- * Option 1: Record team's Accept in the Dest record +-- * Option 2: Record my collaborator's Accept in the Squad record +-- * Prepare to send my own Accept +-- +-- * Forward the Accept to my followers +-- +-- * Possibly send a Grant/Accept: +-- * Team-passive +-- * In option 2 +-- * Accept +-- * Object: The Add +-- * Fulfills: My collaborator's Accept +-- * To: Team +-- * CC: +-- - Team's followers +-- - My followers +-- - The Accept sender (my collaborator) +factoryAccept + :: UTCTime + -> FactoryId + -> Verse + -> AP.Accept URIMode + -> ActE (Text, Act (), Next) +factoryAccept now factoryID (Verse authorIdMsig body) accept = do + + -- Check input + acceptee <- parseAccept accept + + collabOrComp_or_child <- withDBExcept $ do + + (myInboxID, meResourceID) <- lift $ do + factory <- getJust factoryID + resource <- getJust $ factoryResource factory + actor <- getJust $ resourceActor resource + return (actorInbox actor, factoryResource factory) + + -- Find the accepted activity in our DB + accepteeDB <- do + a <- getActivity acceptee + fromMaybeE a "Can't find acceptee in DB" + + -- See if the accepted activity is an Invite or Join where my collabs + -- URI is the resource, grabbing the Collab record from our DB, + -- Or if the accepted activity is an Invite or Add where my components + -- URI is the resource, grabbing the Component record from our DB + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeCollab <- + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left <$> tryInviteCollab accepteeDB) <|> + runExceptT (Left <$> tryJoinCollab accepteeDB) <|> + runExceptT (Right <$> tryAddTeamActive meResourceID accepteeDB) <|> + runExceptT (Right <$> tryAddTeamPassive meResourceID accepteeDB) + fromMaybeE + maybeCollab + "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of" + + case collabOrComp_or_child of + Left collab -> addCollab collab + Right team -> addTeam team + + where + + verifyCollabTopic collabID = do + topic <- lift $ getCollabTopic collabID + unless (LocalResourceFactory factoryID == topic) $ + throwE "Accept object is an Invite/Join for some other resource" + + verifyInviteCollabTopic fulfillsID = do + collabID <- lift $ collabFulfillsInviteCollab <$> getJust fulfillsID + verifyCollabTopic collabID + return collabID + + verifyJoinCollabTopic fulfillsID = do + collabID <- lift $ collabFulfillsJoinCollab <$> getJust fulfillsID + verifyCollabTopic collabID + return collabID + + tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) = do + fulfillsID <- + lift $ collabInviterLocalCollab <$> + MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID) + collabID <- + ExceptT $ lift $ runExceptT $ verifyInviteCollabTopic fulfillsID + return (collabID, Left fulfillsID, Left actorByKey) + tryInviteCollab (Right remoteActivityID) = do + CollabInviterRemote fulfillsID actorID _ <- + lift $ MaybeT $ getValBy $ + UniqueCollabInviterRemoteInvite remoteActivityID + collabID <- + ExceptT $ lift $ runExceptT $ verifyInviteCollabTopic fulfillsID + sender <- lift $ lift $ do + actor <- getJust actorID + (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collabID, Left fulfillsID, Right sender) + + tryJoinCollab (Left (actorByKey, _actorEntity, itemID)) = do + fulfillsID <- + lift $ collabRecipLocalJoinFulfills <$> + MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID) + collabID <- + ExceptT $ lift $ runExceptT $ verifyJoinCollabTopic fulfillsID + return (collabID, Right fulfillsID, Left actorByKey) + tryJoinCollab (Right remoteActivityID) = do + CollabRecipRemoteJoin recipID fulfillsID _ <- + lift $ MaybeT $ getValBy $ + UniqueCollabRecipRemoteJoinJoin remoteActivityID + collabID <- + ExceptT $ lift $ runExceptT $ verifyJoinCollabTopic fulfillsID + joiner <- lift $ lift $ do + remoteActorID <- collabRecipRemoteActor <$> getJust recipID + actor <- getJust remoteActorID + (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collabID, Right fulfillsID, Right joiner) + + verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB () + verifySquadHolder meResourceID squadID = do + Squad _ r <- lift $ getJust squadID + guard $ r == meResourceID + + tryAddTeamActive' r squadID = do + usID <- lift $ MaybeT $ getKeyBy $ UniqueSquadOriginUs squadID + lift $ verifySquadHolder r squadID + topic <- lift . lift $ getSquadTeam squadID + return (squadID, topic, Left ()) + + tryAddTeamActive r (Left (_actorByKey, _actorEntity, itemID)) = do + SquadUsGestureLocal squadID _ <- + lift $ MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity itemID + tryAddTeamActive' r squadID + tryAddTeamActive r (Right remoteActivityID) = do + SquadUsGestureRemote squadID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity remoteActivityID + tryAddTeamActive' r squadID + + tryAddTeamPassive' r themID = do + SquadOriginThem squadID <- lift . lift $ getJust themID + lift $ verifySquadHolder r squadID + topic <- lift . lift $ getSquadTeam squadID + return (squadID, topic, Right themID) + + tryAddTeamPassive r (Left (_actorByKey, _actorEntity, itemID)) = do + SquadThemGestureLocal themID _ <- + lift $ MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd itemID + tryAddTeamPassive' r themID + tryAddTeamPassive r (Right remoteActivityID) = do + SquadThemGestureRemote themID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd remoteActivityID + tryAddTeamPassive' r themID + + theyIsAuthor :: Either (a, FactoryId) (b, RemoteActorId) -> Bool + theyIsAuthor ident = + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + in author == bimap (LocalActorFactory . snd) snd ident + + theyIsAuthor' :: Either (a, GroupId) (b, RemoteActorId) -> Bool + theyIsAuthor' ident = + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + in author == bimap (LocalActorGroup . snd) snd ident + + addCollab (collabID, fulfills, inviterOrJoiner) = do + + collab <- + bitraverse + + -- If accepting an Invite, find the Collab recipient and verify + -- it's the sender of the Accept + (\ fulfillsID -> withDBExcept $ do + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + case (recip, authorIdMsig) of + (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _)) + | collabRecipLocalPerson crl == personID -> + return (fulfillsID, Left crlid) + (Right (Entity crrid crr), Right (author, _, _)) + | collabRecipRemoteActor crr == remoteAuthorId author -> + return (fulfillsID, Right crrid) + _ -> throwE "Accepting an Invite whose recipient is someone else" + ) + + -- If accepting a Join, verify accepter has permission + (\ fulfillsID -> do + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceFactory factoryID) + AP.RoleAdmin + return fulfillsID + ) + + fulfills + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (actorMeID, actorMe) <- lift $ do + factory <- getJust factoryID + resource <- getJust $ factoryResource factory + let actorID = resourceActor resource + (actorID,) <$> getJust actorID + + -- In collab mode, verify the Collab isn't already validated + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do + + -- Record the Accept and enable the Collab + (grantID, enableID) <- do + case (collab, acceptDB) of + (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Right fulfillsID, Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + (Right fulfillsID, Right (author, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + _ -> error "factoryAccept impossible" + grantID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now + enableID <- lift $ insert $ CollabEnable collabID grantID + return (grantID, enableID) + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorFactory factoryID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + -- Prepare a regular Grant + let isInvite = isLeft collab + grant@(actionGrant, _, _, _) <- lift $ do + Collab role _ <- getJust collabID + prepareCollabGrant isInvite inviterOrJoiner role + let recipByKey = LocalActorFactory factoryID + _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant + + return (actorMeID, sieve, grantID, grant, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorMeID, sieve, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), inboxItemID) -> do + let recipByID = LocalActorFactory factoryID + forwardActivity authorIdMsig body recipByID actorMeID sieve + lift $ + sendActivity + recipByID actorMeID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + doneDB inboxItemID "[Collab mode] Forwarded the Accept and published a Grant" + + prepareCollabGrant isInvite sender role = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + audAccepter <- makeAudSenderWithFollowers authorIdMsig + audApprover <- lift $ makeAudSenderOnly authorIdMsig + recipHash <- encodeKeyHashid factoryID + let topicByHash = LocalActorFactory recipHash + + senderHash <- bitraverse hashLocalActor pure sender + + uAccepter <- lift $ getActorURI authorIdMsig + + let audience = + if isInvite + then + let audInviter = + case senderHash of + Left actor -> AudLocal [actor] [] + Right (ObjURI h lu, _followers) -> + AudRemote h [lu] [] + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audInviter, audAccepter, audTopic] + else + let audJoiner = + case senderHash of + Left actor -> AudLocal [actor] [localActorFollowers actor] + Right (ObjURI h lu, followers) -> + AudRemote h [lu] (maybeToList followers) + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audJoiner, audApprover, audTopic] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [AP.acceptObject accept] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = + encodeRouteHome $ renderLocalActor topicByHash + , AP.grantTarget = + if isInvite + then uAccepter + else case senderHash of + Left actor -> + encodeRouteHome $ renderLocalActor actor + Right (ObjURI h lu, _) -> ObjURI h lu + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + addTeam (squadID, topic, mode) = do + + (themID, mode') <- + case mode of + + -- Team-active mode + -- Respond with error, we aren't supposed to get any Accept + Left () -> throwE "Team-active (SquadOriginUs) mode, I'm not expecting any Accept" + + -- Team-passive mode + -- Option 1: I haven't yet seen team's Accept + -- * Verify sender is the team + -- Option 2: I saw it, but not my collaborator's Accept + -- * Verify the accept is authorized + -- Otherwise respond with error, no Accept is needed + Right themID -> (themID,) <$> do + (maybeTeamAccept, maybeUsGesture) <- + lift $ withDB $ liftA2 (,) + (case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueSquadThemAcceptLocalTopic localID) + Right remoteID -> (() <$) <$> getBy (UniqueSquadThemAcceptRemoteTopic remoteID) + ) + (do l <- getBy $ UniqueSquadUsGestureLocal squadID + r <- getBy $ UniqueSquadUsGestureRemote squadID + case (isJust l, isJust r) of + (False, False) -> pure Nothing + (False, True) -> pure $ Just () + (True, False) -> pure $ Just () + (True, True) -> error "Both SquadUsGestureLocal and SquadUsGestureRemote" + ) + case (isJust maybeTeamAccept, isJust maybeUsGesture) of + (False, True) -> error "Impossible/bug, didn't see team's Accept but recorded my collaborator's Accept" + (False, False) -> do + unless (theyIsAuthor' topic) $ + throwE "The Accept I'm waiting for is from my new team" + return $ Left () + (True, False) -> do + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceFactory factoryID) + AP.RoleAdmin + return $ Right () + (True, True) -> throwE "Just waiting for Grant from team, or already have it, anyway not needing any further Accept" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (actorMeID, actorMe) <- lift $ do + factory <- getJust factoryID + resource <- getJust $ factoryResource factory + let actorID = resourceActor resource + (actorID,) <$> getJust actorID + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do + + idsForGrant <- + lift $ case mode' of + + -- Getting an Accept from the team + -- Record team's Accept in the Squad record + Left () -> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ SquadThemAcceptLocal themID localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ SquadThemAcceptRemote themID remoteID acceptID + _ -> error "factoryAccept impossible v" + return Nothing + + -- Getting an Accept from my collaborator + -- Record my collaborator's Accept in the Squad record + -- Prepare to send my own Accept + Right () -> Just <$> do + case acceptDB of + Left (_, _, acceptID) -> + insert_ $ SquadUsGestureLocal squadID acceptID + Right (author, _, acceptID) -> + insert_ $ SquadUsGestureRemote squadID (remoteAuthorId author) acceptID + acceptID <- insertEmptyOutboxItem' (actorOutbox actorMe) now + insert_ $ SquadUsAccept squadID acceptID + return acceptID + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorFactory factoryID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + maybeAct <- + for idsForGrant $ \ acceptID -> lift $ do + accept@(actionAccept, _, _, _) <- + prepareSquadAccept (bimap snd snd topic) + let recipByKey = LocalActorFactory factoryID + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + return (acceptID, accept) + + return (actorMeID, sieve, maybeAct, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorMeID, sieve, maybeGrant, inboxItemID) -> do + let recipByID = LocalActorFactory factoryID + forwardActivity authorIdMsig body recipByID actorMeID sieve + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + recipByID actorMeID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + doneDB inboxItemID "[Team] Forwarded the Accept and maybe published a Grant/Accept" + + where + + prepareSquadAccept topic = do + encodeRouteHome <- getEncodeRouteHome + + audMyCollab <- lift $ makeAudSenderOnly authorIdMsig + audSquad <- + case topic of + Left j -> do + h <- encodeKeyHashid j + return $ + AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h] + Right raID -> do + ra <- getJust raID + ObjURI h lu <- getRemoteActorURI ra + return $ + AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . LocalStageFactoryFollowers <$> + encodeKeyHashid factoryID + uCollabAccept <- lift $ getActivityURI authorIdMsig + let uAdd = AP.acceptObject accept + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audMyCollab, audSquad, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uCollabAccept] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uAdd + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +-- Meaning: An actor is adding some object to some target +-- Behavior: +-- * 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 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 +-- +-- * Otherwise, error +factoryAdd + :: UTCTime + -> FactoryId + -> Verse + -> AP.Add URIMode + -> ActE (Text, Act (), Next) +factoryAdd now factoryID (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 (ATFactoryTeams j), _) | j == factoryID -> + addTeamActive object + (_, Left (LocalActorFactory j)) | j == factoryID -> + case target of + 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" + 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.rwcTeamResources rwc + then addTeamPassive $ 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 [LocalActorFactory jh] [] + Right (ObjURI h lu, Entity _ ra) -> + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . LocalStageFactoryFollowers <$> + encodeKeyHashid factoryID + 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) + + 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 Factory + -- 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 + (LocalResourceFactory factoryID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + factory <- lift $ getJust factoryID + resource <- lift $ getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- lift $ getJust actorMeID + + -- Verify the object isn't already a team of mine, and that no + -- Squad record is already in Add-Accept state + verifyNoStartedResourceTeams (factoryResource factory) teamDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Squad record in DB + acceptID <- insertEmptyOutboxItem' (actorOutbox actorMe) now + insertSquad (factoryResource factory) teamDB' addDB acceptID + + -- Prepare forwarding the Add to my followers + sieve <- do + factoryHash <- encodeKeyHashid factoryID + return $ makeRecipientSet [] [LocalStageFactoryFollowers factoryHash] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept teamDB + _luAccept <- updateOutboxItem' (LocalActorFactory factoryID) acceptID actionAccept + + return (actorMeID, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorMeID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorFactory factoryID) actorMeID sieve + lift $ sendActivity + (LocalActorFactory factoryID) actorMeID 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 . LocalStageFactoryFollowers <$> + encodeKeyHashid factoryID + 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 Factory + -- 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 + factory <- lift $ getJust factoryID + resource <- lift $ getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- lift $ getJust actorMeID + + -- Verify the object isn't already a team of mine, and that no + -- Squad record is already in Add-Accept state + verifyNoStartedResourceTeams (factoryResource factory) teamDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Squad record in DB + insertSquad (factoryResource factory) teamDB' addDB + + -- Prepare forwarding the Add to my followers + sieve <- do + factoryHash <- encodeKeyHashid factoryID + return $ makeRecipientSet [] [LocalStageFactoryFollowers factoryHash] + + return (actorMeID, sieve, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorMeID, sieve, inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorFactory factoryID) actorMeID 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 + factoryCreateMe :: UTCTime -> FactoryId @@ -462,11 +1298,1252 @@ factoryFollow now recipFactoryID verse follow = do (\ _ -> pure []) now recipFactoryID verse follow +data GrantKind + = GKDelegationStart AP.Role + | GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI) + | GKDelegator + +-- Meaning: An actor is granting access-to-some-resource to another actor +-- Behavior: +-- * Option 1 - 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 +-- +-- * Option 2 - Almost-Team sending me the delegator-Grant +-- * Update the Squad record, enabling the team +-- * Send a start-Grant giving access-to-me +-- +-- * If neither of those, raise an error +factoryGrant + :: UTCTime + -> FactoryId + -> Verse + -> AP.Grant URIMode + -> ActE (Text, Act (), Next) +factoryGrant now factoryID (Verse authorIdMsig body) grant = do + + grant' <- checkGrant grant + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeMode <- + withDBExcept $ do + (_myInboxID, meResourceID) <- lift $ do + factory <- getJust factoryID + resource <- getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- getJust actorMeID + return (actorInbox actorMe, factoryResource factory) + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left <$> tryCollab grant') <|> + runExceptT (Right <$> tryTeam meResourceID grant') + mode <- + fromMaybeE + maybeMode + "Not a relevant Grant that I'm aware of" + case mode of + Left (enableID, role, recip) -> + handleCollab enableID role recip + Right (role, topic, acceptID) -> + handleTeam role topic acceptID + + where + + checkCapability = do + -- Verify that a capability is provided + uCap <- lift $ hoistMaybe $ AP.activityCapability $ actbActivity body + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + cap <- + ExceptT . lift . lift . runExceptT $ + nameExceptT "Grant capability" $ parseActivityURI' uCap + + -- Verify the capability is local + case cap of + Left (actorByKey, _, outboxItemID) -> + return (actorByKey, outboxItemID) + _ -> lift mzero + + checkGrant g = do + (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- + parseGrant' g + case recipient of + Left (LocalActorFactory j) | j == factoryID -> 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" + + let resourceIsAuthor = + case (resource, authorIdMsig) of + (Left a, Left (a', _, _)) -> a == a' + (Right u, Right (ra, _, _)) -> remoteAuthorURI ra == u + _ -> False + + case (role, resourceIsAuthor, usage, mdeleg) of + (AP.RXRole r, True, AP.GatherAndConvey, Nothing) -> + pure $ GKDelegationStart r + (AP.RXRole r, False, AP.GatherAndConvey, Just _) -> + pure $ GKDelegationExtend r resource + (AP.RXDelegator, True, AP.Invoke, Nothing) -> + pure GKDelegator + _ -> throwE "A kind of Grant that I don't use" + + tryCollab (GKDelegationStart _) = lift mzero + tryCollab (GKDelegationExtend _ _) = lift mzero + tryCollab GKDelegator = do + capability <- checkCapability + -- Find the Collab record from the capability + Entity enableID (CollabEnable collabID _) <- lift $ do + -- Capability isn't mine + guard $ fst capability == LocalActorFactory factoryID + -- I don't have a Collab with this capability + MaybeT $ getBy $ UniqueCollabEnableGrant $ snd capability + Collab role _ <- lift $ lift $ getJust collabID + topic <- lift $ lift $ getCollabTopic collabID + -- Found a Collab for this direct-Grant but it's not mine + lift $ guard $ topic == LocalResourceFactory factoryID + recip <- lift $ lift $ getCollabRecip collabID + recipForCheck <- + lift $ lift $ + bitraverse + (pure . collabRecipLocalPerson . entityVal) + (getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal) + recip + unless (first LocalActorPerson recipForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Capability's collaborator and Grant author aren't the same actor" + return (enableID, role, recip) + + handleCollab enableID role recip = do + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + factory <- lift $ getJust factoryID + resource <- lift $ getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- lift $ getJust actorMeID + + -- 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 actorMe) False + for maybeGrantDB $ \ (inboxItemID, grantDB) -> do + + -- Record the delegator-Grant in the Collab record + 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 $ encodeRouteHome delegR + (Right (_, _, grantID), Right remoteID) -> do + delegID <- insert $ CollabDelegRemote enableID remoteID grantID + u <- getRemoteActivityURI =<< getJust grantID + return u + _ -> error "factoryGrant impossible 2" + + -- Prepare forwarding of Accept to my followers + factoryHash <- encodeKeyHashid factoryID + let sieve = makeRecipientSet [] [LocalStageFactoryFollowers factoryHash] + + return (actorMeID, sieve, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorMeID, sieve, inboxItemID) -> do + let recipByID = LocalActorFactory factoryID + forwardActivity authorIdMsig body recipByID actorMeID sieve + doneDB inboxItemID "[Collab] Forwarded the delegator-Grant, updated DB" + + tryTeam _ (GKDelegationStart _) = lift mzero + tryTeam _ (GKDelegationExtend _ _) = lift mzero + tryTeam meResourceID GKDelegator = do + uFulfills <- + case AP.activityFulfills $ actbActivity body of + [] -> throwE "No fulfills" + [u] -> pure u + _ -> throwE "Multiple fulfills" + fulfills <- ExceptT $ lift $ lift $ runExceptT $ first (\ (a, _, i) -> (a, i)) <$> parseActivityURI' uFulfills + fulfillsDB <- ExceptT $ MaybeT $ either (Just . Left) (fmap Right) <$> runExceptT (getActivity fulfills) + -- Find the Squad record from the fulfills + squadID <- + lift $ + case fulfillsDB of + Left (_, _, addID) -> + (do SquadUsGestureLocal squadID _ <- MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity addID + _ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID + return squadID + ) + <|> + (do SquadThemGestureLocal themID _ <- MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd addID + SquadOriginThem squadID <- lift $ getJust themID + return squadID + ) + Right addID -> + (do SquadUsGestureRemote squadID _ _ <- MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity addID + _ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID + return squadID + ) + <|> + (do SquadThemGestureRemote themID _ _ <- MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd addID + SquadOriginThem squadID <- lift $ getJust themID + return squadID + ) + -- Verify this Squad record is mine + Squad role r <- lift $ lift $ getJust squadID + lift $ guard $ r == meResourceID + -- Verify the Grant sender is the Squad topic + topic <- lift $ lift $ getSquadTeam squadID + topicForCheck <- + lift $ lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + topic + unless (first LocalActorGroup topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Squad topic and Grant author aren't the same actor" + -- Verify I sent my Accept + maybeMe <- lift $ lift $ getKeyBy $ UniqueSquadUsAccept squadID + meAcceptID <- fromMaybeE maybeMe "I haven't sent my Accept" + -- Verify I haven't yet seen a delegator-Grant from the team + case bimap fst fst topic of + Left localID -> do + m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorLocalTopic localID + verifyNothingE m "Already have a SquadThemSendDelegatorLocal" + Right remoteID -> do + m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorRemoteTopic remoteID + verifyNothingE m "Already have a SquadThemSendDelegatorRemote" + return (role, topic, meAcceptID) + + handleTeam role topic acceptID = do + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + factory <- lift $ getJust factoryID + resource <- lift $ getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- lift $ getJust actorMeID + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + for maybeGrantDB $ \ (inboxItemID, grantDB) -> do + + -- Record the delegator-Grant in DB + to <- case (grantDB, bimap fst fst topic) of + (Left (_, _, grantID), Left localID) -> Left <$> do + mk <- lift $ insertUnique $ SquadThemSendDelegatorLocal acceptID localID grantID + fromMaybeE mk "I already have such a SquadThemSendDelegatorLocal" + (Right (_, _, grantID), Right remoteID) -> Right <$> do + mk <- lift $ insertUnique $ SquadThemSendDelegatorRemote acceptID remoteID grantID + fromMaybeE mk "I already have such a SquadThemSendDelegatorRemote" + _ -> error "factoryGrant.team impossible" + + startID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now + squadStartID <- lift $ insert $ SquadUsStart acceptID startID + + -- Prepare a start-Grant + start@(actionStart, _, _, _) <- lift $ prepareStartGrant role squadStartID + let recipByKey = LocalActorFactory factoryID + _luStart <- lift $ updateOutboxItem' recipByKey startID actionStart + + return + ( actorMeID + , startID + , start + , inboxItemID + ) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorMeID, extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt), inboxItemID) -> do + let recipByID = LocalActorFactory factoryID + lift $ + sendActivity + recipByID actorMeID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "[Team] Sent start-Grant" + + where + + prepareStartGrant role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + factoryHash <- encodeKeyHashid factoryID + + uDeleg <- lift $ getActivityURI authorIdMsig + + audTeam <- lift $ makeAudSenderOnly authorIdMsig + uTeam <- lift $ getActorURI authorIdMsig + + resultR <- do + startHash <- encodeKeyHashid startID + return $ FactoryTeamLiveR factoryHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTeam] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uDeleg] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = encodeRouteHome $ FactoryR factoryHash + , AP.grantTarget = uTeam + , AP.grantResult = + Just + ( encodeRouteLocal resultR + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +-- Meaning: An actor A invited actor B to a resource +-- Behavior: +-- * Verify the resource is my collabs list +-- * If resource is collabs and B is local, verify it's a Person +-- * Verify A isn't inviting themselves +-- * Verify A is authorized by me to invite collabs to me +-- +-- * Verify B doesn't already have an invite/join/grant for me +-- +-- * Insert the Invite to my inbox +-- +-- * Insert a Collab record to DB +-- +-- * Forward the Invite to my followers +-- * Send Accept to A, B, my-followers +factoryInvite + :: UTCTime + -> FactoryId + -> Verse + -> AP.Invite URIMode + -> ActE (Text, Act (), Next) +factoryInvite now factoryID (Verse authorIdMsig body) invite = do + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Check invite + (role, invited) <- do + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (role, resourceOrComps, recipientOrComp) <- parseInvite author invite + mode <- + case resourceOrComps of + Left (Left (LocalResourceFactory j)) | j == factoryID -> + bitraverse + (\case + Left r -> pure r + Right _ -> throwE "Not accepting local component actors as collabs" + ) + pure + recipientOrComp + _ -> throwE "Invite topic isn't my collabs URI" + return (role, mode) + + -- If target is local, find it in our DB + -- If target is remote, HTTP GET it, verify it's an actor, 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 Invite handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result (approve/disapprove the Invite) would be sent later in a + -- separate (e.g. Accept) activity. But for the PoC level, the current + -- situation will hopefully do. + invitedDB <- + bitraverse + (withDBExcept . flip getGrantRecip "Invitee not found in DB") + getRemoteActorFromURI + invited + + -- Verify the specified capability gives relevant access + verifyCapability'' + uCap authorIdMsig (LocalResourceFactory factoryID) AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + resourceID <- lift $ factoryResource <$> getJust factoryID + Resource topicActorID <- lift $ getJust resourceID + topicActor <- lift $ getJust topicActorID + + -- Verify that target doesn't already have a Collab for me + existingCollabIDs <- lift $ getExistingCollabs resourceID invitedDB + case existingCollabIDs of + [] -> pure () + [_] -> throwE "I already have a Collab for the target" + _ -> error "Multiple collabs found for target" + + maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False + lift $ for maybeInviteDB $ \ (inboxItemID, inviteDB) -> do + + -- Insert Collab or Component record to DB + acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now + insertCollab resourceID role invitedDB inviteDB acceptID + + -- Prepare forwarding Invite to my followers + sieve <- do + factoryHash <- encodeKeyHashid factoryID + return $ makeRecipientSet [] [LocalStageFactoryFollowers factoryHash] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept invitedDB + _luAccept <- updateOutboxItem' (LocalActorFactory factoryID) acceptID actionAccept + + return (topicActorID, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorMeID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorFactory factoryID) actorMeID sieve + lift $ sendActivity + (LocalActorFactory factoryID) actorMeID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "Recorded and forwarded the Invite, sent an Accept" + + where + + getRemoteActorFromURI (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 "Target @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Target isn't an actor" + Right (Just actor) -> return $ entityKey actor + + getExistingCollabs resourceID (Left (GrantRecipPerson (Entity personID _))) = + E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do + E.on $ + collab E.^. CollabId E.==. + recipl E.^. CollabRecipLocalCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + recipl E.^. CollabRecipLocalPerson E.==. E.val personID + return $ recipl E.^. CollabRecipLocalCollab + getExistingCollabs resourceID (Right remoteActorID) = + E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do + E.on $ + collab E.^. CollabId E.==. + recipr E.^. CollabRecipRemoteCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID + return $ recipr E.^. CollabRecipRemoteCollab + + insertCollab resourceID role recipient inviteDB acceptID = do + collabID <- insert $ Collab role resourceID + fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID + case inviteDB of + Left (_, _, inviteID) -> + insert_ $ CollabInviterLocal fulfillsID inviteID + Right (author, _, inviteID) -> do + let authorID = remoteAuthorId author + insert_ $ CollabInviterRemote fulfillsID authorID inviteID + case recipient of + Left (GrantRecipPerson (Entity personID _)) -> + insert_ $ CollabRecipLocal collabID personID + Right remoteActorID -> + insert_ $ CollabRecipRemote collabID remoteActorID + + prepareAccept invitedDB = do + encodeRouteHome <- getEncodeRouteHome + + audInviter <- lift $ makeAudSenderOnly authorIdMsig + audInvited <- + case invitedDB of + Left (GrantRecipPerson (Entity p _)) -> do + ph <- encodeKeyHashid p + return $ AudLocal [LocalActorPerson ph] [] + Right remoteActorID -> do + ra <- getJust remoteActorID + ObjURI h lu <- getRemoteActorURI ra + return $ AudRemote h [lu] [] + audTopic <- + AudLocal [] . pure . LocalStageFactoryFollowers <$> + encodeKeyHashid factoryID + uInvite <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audInviter, audInvited, audTopic] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uInvite] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uInvite + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +factoryJoin + :: UTCTime + -> FactoryId + -> Verse + -> AP.Join URIMode + -> ActE (Text, Act (), Next) +factoryJoin = topicJoin factoryResource LocalResourceFactory + +-- Meaning: An actor A is removing actor B from collection C +-- Behavior: +-- * If C is my collaborators collection: +-- * Verify A isn't removing themselves +-- * Verify A is authorized by me to remove actors from me +-- * Verify B already has a Grant for me +-- * Remove the whole Collab record from DB +-- * Forward the Remove to my followers +-- * Send a Revoke: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- +-- * If C is my teams collection: +-- * Verify A is authorized by me to remove teams from me +-- * Verify B is an active team of mine +-- * Remove the whole Squad record from DB +-- * Forward the Remove to my followers +-- * Send an Accept on the Remove: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- +-- * If I'm B, being removed from the resources of a team of mine: +-- * Do nothing, just waiting for team to send a Revoke on the +-- delegator-Grant +factoryRemove + :: UTCTime + -> FactoryId + -> Verse + -> AP.Remove URIMode + -> ActE (Text, Act (), Next) +factoryRemove now factoryID (Verse authorIdMsig body) remove = do + + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (collection, item) <- parseRemove author remove + case (collection, item) of + (Left (Left (LocalResourceFactory j)), _) | j == factoryID -> + removeCollab item + (Left (Right (ATFactoryTeams j)), _) | j == factoryID -> + removeTeamActive item + (_, Left (LocalActorFactory j)) | j == factoryID -> + case collection of + Left (Right (ATGroupEfforts g)) -> + removeTeamPassive $ 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" + rwc <- AP.fetchRWC_T manager h lu + AP.Actor l d <- + case AP.rwcResource rwc of + AP.ResourceActor a -> pure a + AP.ResourceChild _ _ -> throwE "Remove.origin remote ResourceChild" + let typ = AP.actorType d + if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc + then removeTeamPassive $ Right $ ObjURI h lu + else throwE "Weird collection situation" + _ -> throwE "I'm being removed from somewhere irrelevant" + _ -> throwE "This Remove isn't for me" + + where + + removeCollab member = do + + -- Check remove + memberByKey <- + bitraverse + (\case + LocalActorPerson p -> pure p + _ -> throwE "Not accepting non-person actors as collabs" + ) + pure + member + + -- Verify the specified capability gives relevant access + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceFactory factoryID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Find member in our DB + memberDB <- + bitraverse + (flip getEntityE "Member not found in DB") + (\ u@(ObjURI h lu) -> (,u) <$> do + maybeActor <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance h + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu + MaybeT $ getBy $ UniqueRemoteActor roid + fromMaybeE maybeActor "Remote removee not found in DB" + ) + memberByKey + + -- Grab me from DB + resourceID <- lift $ factoryResource <$> getJust factoryID + Resource topicActorID <- lift $ getJust resourceID + topicActor <- lift $ getJust topicActorID + + -- Find the collab that the member already has for me + existingCollabIDs <- + lift $ case memberDB of + Left (Entity personID _) -> + fmap (map $ over _1 Left) $ + E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do + E.on $ + collab E.^. CollabId E.==. + recipl E.^. CollabRecipLocalCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + recipl E.^. CollabRecipLocalPerson E.==. E.val personID + return + ( recipl E.^. persistIdField + , recipl E.^. CollabRecipLocalCollab + ) + Right (Entity remoteActorID _, _) -> + fmap (map $ over _1 Right) $ + E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do + E.on $ + collab E.^. CollabId E.==. + recipr E.^. CollabRecipRemoteCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID + return + ( recipr E.^. persistIdField + , recipr E.^. CollabRecipRemoteCollab + ) + (recipID, E.Value collabID) <- + case existingCollabIDs of + [] -> throwE "Remove object isn't a member of me" + [collab] -> return collab + _ -> error "Multiple collabs found for removee" + + -- Verify the Collab is enabled + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + Entity enableID (CollabEnable _ grantID) <- + fromMaybeE maybeEnabled "Remove object isn't a member of me yet" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do + + -- Grab grants that I'm about to revoke + maybeDeleg <- + case recipID of + Left (E.Value localID) -> fmap Left <$> getKeyBy (UniqueCollabDelegLocalRecip localID) + Right (E.Value remoteID) -> fmap Right <$> getKeyBy (UniqueCollabDelegRemoteRecip remoteID) + + -- Delete the whole Collab record + deleteBy $ UniqueCollabDelegLocal enableID + deleteBy $ UniqueCollabDelegRemote enableID + delete enableID + case recipID of + Left (E.Value l) -> do + deleteBy $ UniqueCollabRecipLocalJoinCollab l + deleteBy $ UniqueCollabRecipLocalAcceptCollab l + delete l + Right (E.Value r) -> do + deleteBy $ UniqueCollabRecipRemoteJoinCollab r + deleteBy $ UniqueCollabRecipRemoteAcceptCollab r + delete r + fulfills <- do + mf <- runMaybeT $ asum + [ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID) + , Right . Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsInvite collabID) + , Right . Right <$> MaybeT (getKeyBy $ UniqueCollabFulfillsJoin collabID) + ] + maybe (error $ "No fulfills for collabID#" ++ show collabID) pure mf + case fulfills of + Left fc -> delete fc + Right (Left fi) -> do + deleteBy $ UniqueCollabInviterLocal fi + deleteBy $ UniqueCollabInviterRemote fi + delete fi + Right (Right fj) -> do + deleteBy $ UniqueCollabApproverLocal fj + deleteBy $ UniqueCollabApproverRemote fj + delete fj + delete collabID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid factoryID + let topicByHash = + LocalActorFactory topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare a Revoke activity and insert to my outbox + revoke@(actionRevoke, _, _, _) <- + lift $ prepareMainRevoke memberDB grantID + let recipByKey = LocalActorFactory factoryID + revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now + _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke + + return (topicActorID, sieve, revokeID, revoke, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do + let topicByID = LocalActorFactory factoryID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ + sendActivity + topicByID topicActorID localRecipsRevoke + remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke + doneDB inboxItemID "[Collab] Deleted the Grant/Collab, forwarded Remove, sent Revoke" + + where + + prepareMainRevoke member grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + recipHash <- encodeKeyHashid factoryID + let topicByHash = LocalActorFactory recipHash + + memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member + + audRemover <- makeAudSenderOnly authorIdMsig + let audience = + let audMember = + case memberHash of + Left p -> + AudLocal [LocalActorPerson p] [LocalStagePersonFollowers p] + Right (Entity _ actor, ObjURI h lu) -> + AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audRemover, audMember, audTopic] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + uRemove <- getActivityURI authorIdMsig + luGrant <- do + grantHash <- encodeKeyHashid grantID + return $ encodeRouteLocal $ activityRoute topicByHash grantHash + let action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + removeTeamActive team = do + + -- If team is local, find it in our DB + -- If team is remote, HTTP GET it, verify it's an actor of Factory + -- 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 + + -- 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 remove a team + verifyCapability'' + uCap + authorIdMsig + (LocalResourceFactory factoryID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + factory <- lift $ getJust factoryID + resource <- lift $ getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- lift $ getJust actorMeID + + -- Verify it's an active team of mine + squads <- lift $ case teamDB of + Left (Entity g _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (factoryResource factory) E.&&. + topic E.^. SquadTopicLocalGroup E.==. E.val g + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorLocalSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicLocalId + , send E.^. SquadThemSendDelegatorLocalId + ) + Right (_, Entity a _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (factoryResource factory) E.&&. + topic E.^. SquadTopicRemoteTopic E.==. E.val a + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorRemoteSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicRemoteId + , send E.^. SquadThemSendDelegatorRemoteId + ) + + (E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <- + verifySingleE squads "No squad" "Multiple squads" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do + + -- Delete uses of this Squad from my Component records + deleteWhere [ComponentConveyTeam ==. squadStartID] + + -- Delete uses of this Squad from my Source records + conveyIDs <- selectKeysList [SourceUsConveyTeam ==. squadStartID] [] + deleteWhere [SourceUsConveyFromLocalConvey <-. conveyIDs] + deleteWhere [SourceUsConveyFromRemoteConvey <-. conveyIDs] + deleteWhere [SourceUsConveyId <-. conveyIDs] + + -- Delete the whole Squad record + delete squadStartID + case topic of + Left (_, sendID) -> delete sendID + Right (_, sendID) -> delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueSquadOriginUs squadID) + (getKeyBy $ UniqueSquadOriginThem squadID) + "Neither us nor them" + "Both us and them" + deleteBy $ UniqueSquadUsGestureLocal squadID + deleteBy $ UniqueSquadUsGestureRemote squadID + case origin of + Left usID -> delete usID + Right themID -> do + deleteBy $ UniqueSquadThemAcceptLocal themID + deleteBy $ UniqueSquadThemAcceptRemote themID + deleteBy $ UniqueSquadThemGestureLocal themID + deleteBy $ UniqueSquadThemGestureRemote themID + delete themID + delete usAcceptID + case topic of + Left (l, _) -> delete l + Right (r, _) -> delete r + delete squadID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid factoryID + let topicByHash = + LocalActorFactory topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare Accept activity + accept@(actionAccept, _, _, _) <- prepareAccept teamDB + let recipByKey = LocalActorFactory factoryID + acceptID <- insertEmptyOutboxItem' (actorOutbox actorMe) now + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + + return (actorMeID, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + let topicByID = LocalActorFactory factoryID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ + sendActivity + topicByID topicActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "[Team-active] Deleted the Team/Squad, forwarded Remove, sent Accept" + + where + + prepareAccept teamDB = do + encodeRouteHome <- getEncodeRouteHome + + audRemover <- lift $ makeAudSenderOnly authorIdMsig + audTeam <- + case teamDB of + Left (Entity g _) -> do + h <- encodeKeyHashid g + return $ AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h] + Right (ObjURI h lu, Entity _ ra) -> + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . LocalStageFactoryFollowers <$> + encodeKeyHashid factoryID + uRemove <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRemover, audTeam, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uRemove + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + removeTeamPassive team = do + + -- If team is local, find it in our DB + -- If team is remote, HTTP GET it, verify it's an actor of Factory + -- 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 + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + factory <- lift $ getJust factoryID + resource <- lift $ getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- lift $ getJust actorMeID + + -- Verify it's an active team of mine + squads <- lift $ case teamDB of + Left (Entity g _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (factoryResource factory) E.&&. + topic E.^. SquadTopicLocalGroup E.==. E.val g + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorLocalSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicLocalId + , send E.^. SquadThemSendDelegatorLocalId + ) + Right (_, Entity a _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (factoryResource factory) E.&&. + topic E.^. SquadTopicRemoteTopic E.==. E.val a + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorRemoteSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicRemoteId + , send E.^. SquadThemSendDelegatorRemoteId + ) + + (E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <- + verifySingleE squads "No squad" "Multiple squads" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do + + return inboxItemID + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just inboxItemID -> + doneDB inboxItemID "[Team-passive] Saw the removal attempt, just waiting for the Revoke" + +-- Meaning: An actor is revoking Grant activities +-- Behavior: +-- * For each revoked activity: +-- * If it's a team revoking a delegator-Grant it gave me: +-- * Delete the whole Squad record +-- * Forward the Revoke to my followers +-- * Send Accept to team+followers & my followers +factoryRevoke + :: UTCTime + -> FactoryId + -> Verse + -> AP.Revoke URIMode + -> ActE (Text, Act (), Next) +factoryRevoke now factoryID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest)) = do + + ObjURI h _ <- lift $ getActorURI authorIdMsig + parseRevoked <- do + hl <- hostIsLocal h + return $ + \ lu -> + if hl + then + Left . (\ (a, _, i) -> (a, i)) <$> + parseLocalActivityURI' lu + else pure $ Right lu + revokedFirst <- parseRevoked luFirst + revokedRest <- traverse parseRevoked lusRest + + mode <- withDBExcept $ do + + revokedFirstDB <- do + a <- getActivity $ second (ObjURI h) revokedFirst + fromMaybeE a "Can't find revoked in DB" + + meResourceID <- lift $ factoryResource <$> getJust factoryID + + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeMode <- + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (tryTeam meResourceID revokedFirstDB) + fromMaybeE + maybeMode + "Revoked activity isn't a relevant Grant I'm aware of" + + case mode of + t -> revokeTeam revokedRest t + + where + + verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB () + verifySquadHolder meResourceID squadID = do + Squad _ resourceID <- lift $ getJust squadID + guard $ resourceID == meResourceID + + tryTeam' meResourceID usAcceptID send = do + SquadUsAccept squadID _ <- lift $ lift $ getJust usAcceptID + lift $ verifySquadHolder meResourceID squadID + topic <- lift . lift $ getSquadTeam squadID + return (squadID, usAcceptID, topic, send) + + tryTeam r (Left (_actorByKey, _actorEntity, itemID)) = do + Entity sendID (SquadThemSendDelegatorLocal usAcceptID _localID _) <- + lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorLocalGrant itemID + tryTeam' r usAcceptID (Left sendID) --(Left localID) + tryTeam r (Right remoteActivityID) = do + Entity sendID (SquadThemSendDelegatorRemote usAcceptID _remoteID _) <- + lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorRemoteGrant remoteActivityID + tryTeam' r usAcceptID (Right sendID) --(Right remoteID) + + revokeTeam revokedRest (squadID, usAcceptID, team, send) = do + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (LocalActorGroup . snd) snd team) $ + throwE "Sender isn't the Team the revoked Grant came from" + + unless (null revokedRest) $ + throwE "Team revoking the delegator-Grant and something more" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + factory <- lift $ getJust factoryID + resource <- lift $ getJust $ factoryResource factory + let actorMeID = resourceActor resource + actorMe <- lift $ getJust actorMeID + + maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False + lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do + + maybeStartID <- getKeyBy $ UniqueSquadUsStart usAcceptID + + -- Delete the whole Squad record + for_ maybeStartID delete + case send of + Left sendID -> delete sendID + Right sendID -> delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueSquadOriginUs squadID) + (getKeyBy $ UniqueSquadOriginThem squadID) + "Neither us nor them" + "Both us and them" + deleteBy $ UniqueSquadUsGestureLocal squadID + deleteBy $ UniqueSquadUsGestureRemote squadID + case origin of + Left usID -> delete usID + Right themID -> do + deleteBy $ UniqueSquadThemAcceptLocal themID + deleteBy $ UniqueSquadThemAcceptRemote themID + deleteBy $ UniqueSquadThemGestureLocal themID + deleteBy $ UniqueSquadThemGestureRemote themID + delete themID + delete usAcceptID + case team of + Left (l, _) -> delete l + Right (r, _) -> delete r + delete squadID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid factoryID + let topicByHash = + LocalActorFactory topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare Accept activity + accept@(actionAccept, _, _, _) <- prepareAccept + let recipByKey = LocalActorFactory factoryID + acceptID <- insertEmptyOutboxItem' (actorOutbox actorMe) now + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + + return (actorMeID, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + let topicByID = LocalActorFactory factoryID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ + sendActivity + topicByID topicActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "Deleted the Team/Squad, forwarded Revoke, sent Accept" + + where + + prepareAccept = do + encodeRouteHome <- getEncodeRouteHome + + audTeam <- makeAudSenderWithFollowers authorIdMsig + audMe <- + AudLocal [] . pure . LocalStageFactoryFollowers <$> + encodeKeyHashid factoryID + uRevoke <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTeam, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRevoke] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uRevoke + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + factoryBehavior :: UTCTime -> FactoryId -> ActorMessage Factory -> ActE (Text, Act (), Next) factoryBehavior now factoryID (FactoryMsgVerse verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of + AP.AcceptActivity accept -> factoryAccept now factoryID verse accept + AP.AddActivity add -> factoryAdd now factoryID verse add AP.CreateActivity create -> factoryCreate now factoryID verse create AP.FollowActivity follow -> factoryFollow now factoryID verse follow + AP.GrantActivity grant -> factoryGrant now factoryID verse grant + AP.InviteActivity invite -> factoryInvite now factoryID verse invite + AP.JoinActivity join -> factoryJoin now factoryID verse join + AP.RemoveActivity remove -> factoryRemove now factoryID verse remove + AP.RevokeActivity revoke -> factoryRevoke now factoryID verse revoke _ -> throwE "Unsupported activity type for Factory" factoryBehavior now factoryID (FactoryMsgVerified personID) = factoryCheckPerson now factoryID personID