S2S: Group: Add: Implement resource-active mode

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

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:

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

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