diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index d6d6894..f3dee60 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -26,9 +26,12 @@ module Vervis.Actor ( -- * Local actors LocalActorBy (..) , LocalResourceBy (..) + , LocalResourceNonGroupBy (..) , LocalActor , actorToResource , resourceToActor + , resourceToNG + , resourceFromNG -- * Converting between KeyHashid, Key, Identity and Entity -- @@ -177,6 +180,15 @@ data LocalResourceBy f deriving instance AllBF Eq f LocalResourceBy => Eq (LocalResourceBy f) +data LocalResourceNonGroupBy f + = LocalResourceRepo' (f Repo) + | LocalResourceDeck' (f Deck) + | LocalResourceLoom' (f Loom) + | LocalResourceProject' (f Project) + deriving (Generic, FunctorB, ConstraintsB) + +deriving instance AllBF Eq f LocalResourceNonGroupBy => Eq (LocalResourceNonGroupBy f) + type LocalActor = LocalActorBy KeyHashid actorToResource = \case @@ -194,6 +206,19 @@ resourceToActor = \case LocalResourceLoom l -> LocalActorLoom l LocalResourceProject j -> LocalActorProject j +resourceToNG = \case + LocalResourceGroup _ -> Nothing + LocalResourceRepo r -> Just $ LocalResourceRepo' r + LocalResourceDeck d -> Just $ LocalResourceDeck' d + LocalResourceLoom l -> Just $ LocalResourceLoom' l + LocalResourceProject j -> Just $ LocalResourceProject' j + +resourceFromNG = \case + LocalResourceRepo' r -> LocalResourceRepo r + LocalResourceDeck' d -> LocalResourceDeck d + LocalResourceLoom' l -> LocalResourceLoom l + LocalResourceProject' j -> LocalResourceProject j + hashLocalActorPure :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid hashLocalActorPure ctx = f diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 3a12789..0a03d9c 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -118,6 +118,23 @@ import Vervis.Web.Collab -- * My followers -- * Record my Accept in the Source record -- +-- * If the target is my resources list: +-- * Verify the object is a resource (i.e. project or component), find in DB/HTTP +-- * Verify the Add is authorized +-- * Verify it's not already an active resource 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 resource's Accept +-- * Insert the Add to my inbox +-- * Create a Effort record in DB +-- * Forward the Add to my followers +-- * Publish an Accept to: +-- * The object resource + followers +-- * Add sender + followers +-- * My followers +-- * Record my Accept in the Effort 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 @@ -148,6 +165,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do addChildActive object (Left (ATGroupParents j), _) | j == groupID -> addParentActive object + (Left (ATGroupEfforts j), _) | j == groupID -> + addResourceActive object (_, Left (LocalActorGroup j)) | j == groupID -> case target of Left (ATGroupParents j) | j /= groupID -> @@ -599,6 +618,143 @@ groupAdd now groupID (Verse authorIdMsig body) add = do Right (author, _, addID) -> insert_ $ DestThemGestureRemote themID (remoteAuthorId author) addID + addResourceActive resource = do + + -- If resource is local, find it in our DB + -- If resource 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. + resourceDB <- + bitraverse + (\ la -> + case resourceToNG =<< actorToResource la of + Just ng -> withDBExcept $ getLocalResourceEntityE (resourceFromNG ng) "Resource not found in DB" + Nothing -> throwE "Local proposed resource of non-resource 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 "Resource @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Resource isn't an actor" + Right (Just actor) -> do + if AP.actorTypeIsResourceNT $ remoteActorType $ entityVal actor + then pure () + else throwE "Remote resource type isn't a resource" + return (u, actor) + ) + resource + let resourceDB' = bimap localResourceID (entityKey . snd) resourceDB + + -- 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 resource + 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 already a resource of mine, and that no + -- Effort record is already in Add-Accept state + verifyNoStartedGroupResources groupID resourceDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create an Effort record in DB + acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + insertEffort resourceDB' 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 resourceDB + _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 "[Resource-active] Recorded a resource-in-progress, forwarded the Add, sent an Accept" + + where + + insertEffort topicDB addDB acceptID = do + effortID <- insert $ Effort AP.RoleAdmin groupID + case topicDB of + Left r -> insert_ $ EffortTopicLocal effortID r + Right a -> insert_ $ EffortTopicRemote effortID a + usID <- insert $ EffortOriginUs effortID + case addDB of + Left (_, _, addID) -> + insert_ $ EffortUsGestureLocal usID addID + Right (author, _, addID) -> + insert_ $ EffortUsGestureRemote usID (remoteAuthorId author) addID + + insert_ $ EffortUsAccept usID acceptID + + prepareAccept resourceDB = do + encodeRouteHome <- getEncodeRouteHome + + audAdder <- makeAudSenderWithFollowers authorIdMsig + audResource <- + case resourceDB of + Left r -> do + a <- hashLocalActor $ resourceToActor $ bmap entityKey r + return $ AudLocal [a] [localActorFollowers a] + 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, audResource, 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) + -- Meaning: An actor accepted something -- Behavior: -- * Check if I know the activity that's being Accepted: diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 943a058..6093865 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -72,6 +72,8 @@ module Vervis.Persist.Collab , getEffortAdd , getEffortTopic + + , verifyNoStartedGroupResources ) where @@ -1882,3 +1884,79 @@ getEffortTopic effortID = (getBy $ UniqueEffortTopicRemote effortID) "Found Effort without topic" "Found Effort with both local and remote topic" + +getExistingGroupEfforts groupID (Left resourceID) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (effort `E.InnerJoin` topic) -> do + E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort + E.where_ $ + effort E.^. EffortHolder E.==. E.val groupID E.&&. + topic E.^. EffortTopicLocalTopic E.==. E.val resourceID + return + ( effort E.^. EffortId + , topic E.^. EffortTopicLocalId + ) +getExistingGroupEfforts groupID (Right actorID) = + fmap (map $ bimap E.unValue (Right . E.unValue)) $ + E.select $ E.from $ \ (effort `E.InnerJoin` topic) -> do + E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort + E.where_ $ + effort E.^. EffortHolder E.==. E.val groupID E.&&. + topic E.^. EffortTopicRemoteTopic E.==. E.val actorID + return + ( effort E.^. EffortId + , topic E.^. EffortTopicRemoteId + ) + +verifyEffortsNotEnabled effortIDs = do + byEnabled <- + lift $ for effortIDs $ \ (effortID, _) -> + isJust <$> runMaybeT (tryEffortEnabled effortID) + case length $ filter id byEnabled of + 0 -> return () + 1 -> throwE "I already have a EffortUsSendDelegator for this effort" + _ -> error "Multiple EffortUsSendDelegator for a effort" + where + tryEffortEnabled effortID = + const () <$> MaybeT (getBy $ UniqueEffortUsSendDelegator effortID) + +verifyEffortsNotStarted effortIDs = do + anyStarted <- + lift $ runMaybeT $ asum $ + map (\ (effortID, topic) -> + tryEffortUs effortID <|> + tryEffortThem effortID topic + ) + effortIDs + unless (isNothing anyStarted) $ + throwE "One of the Effort records is already in Add-Accept state" + where + tryEffortUs effortID = do + usID <- MaybeT $ getKeyBy $ UniqueEffortOriginUs effortID + const () <$> MaybeT (getBy $ UniqueEffortUsAccept usID) + + tryEffortThem effortID topic = do + _ <- MaybeT $ getBy $ UniqueEffortOriginThem effortID + case topic of + Left localID -> + const () <$> + MaybeT (getBy $ UniqueEffortThemAcceptLocal localID) + Right remoteID -> + const () <$> + MaybeT (getBy $ UniqueEffortThemAcceptRemote remoteID) + +verifyNoStartedGroupResources + :: GroupId -> Either ResourceId RemoteActorId -> ActDBE () +verifyNoStartedGroupResources groupID resource = do + + -- Find existing Effort records I have for this resource + effortIDs <- lift $ getExistingGroupEfforts groupID resource + + -- Grab all the enabled ones, make sure none are enabled, and even if + -- any are enabled, make sure there's at most one (otherwise it's a + -- bug) + verifyEffortsNotEnabled effortIDs + + -- Verify none of the Effort records are already in + -- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state + verifyEffortsNotStarted effortIDs diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index f391e5c..fb54938 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -31,6 +31,8 @@ module Web.ActivityPub -- instance for fetching and a 'ToJSON' instance for publishing. , ActorType (..) , actorTypeIsComponent + , actorTypeIsResource + , actorTypeIsResourceNT , parseActorType , renderActorType --, Algorithm (..) @@ -398,6 +400,16 @@ actorTypeIsComponent = \case ActorTypePatchTracker -> True _ -> False +actorTypeIsResource = \case + ActorTypeRepo -> True + ActorTypeTicketTracker -> True + ActorTypePatchTracker -> True + ActorTypeProject -> True + ActorTypeTeam -> True + _ -> False + +actorTypeIsResourceNT t = actorTypeIsResource t && t /= ActorTypeTeam + parseActorType :: Text -> ActorType parseActorType t | t == "Person" = ActorTypePerson