S2S: Upgrade the Project Invite handler to handle components

src/Vervis/Actor/Common.hs

@@ -842,7 +842,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
                     return $ AudLocal [LocalActorPerson ph] []
                 Right (ObjURI h lu) -> return $ AudRemote h [lu] []
         audTopic <-
-            flip AudLocal [] . pure . grantResourceLocalActor . topicResource <$>
+            AudLocal [] . pure . localActorFollowers .
+            grantResourceLocalActor . topicResource <$>
                 encodeKeyHashid topicKey
         uInvite <- getActivityURI authorIdMsig
 

src/Vervis/Actor/Project.hs

@@ -27,6 +27,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Barbie
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
@@ -67,7 +68,7 @@ import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model hiding (projectCreate)
-import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
 import Vervis.RemoteActorStore
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
@@ -97,6 +98,93 @@ projectAccept
     -> ActE (Text, Act (), Next)
 projectAccept = topicAccept projectActor GrantResourceProject
 
+checkExistingComponents
+    :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
+checkExistingComponents projectID componentDB = do
+
+    -- Find existing Component records I have for this component
+    componentIDs <- lift $ getExistingComponents componentDB
+
+    -- 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)
+    byEnabled <-
+        lift $ for componentIDs $ \ (componentID, _) ->
+            isJust <$> runMaybeT (tryComponentEnabled componentID)
+    case length $ filter id byEnabled of
+        0 -> return ()
+        1 -> throwE "I already have a ComponentEnable for this component"
+        _ -> error "Multiple ComponentEnable for a component"
+
+    -- Verify none of the Component records are already in
+    -- Add-waiting-for-project or Invite-waiting-for-component state
+    anyStarted <-
+        lift $ runMaybeT $ asum $
+            map (\ (componentID, identID) ->
+                    tryComponentAddAccept componentID identID <|>
+                    tryComponentInviteAccept componentID
+                )
+                componentIDs
+    unless (isNothing anyStarted) $
+        throwE
+            "One of the Component records is already in Add-Accept or \
+            \Invite-Accept state"
+
+    where
+
+    getExistingComponents (Left (ComponentRepo (Entity repoID _))) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
+            E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
+            E.on $ ident E.^. ComponentLocalRepoComponent E.==. local E.^. ComponentLocalId
+            E.where_ $
+                ident E.^. ComponentLocalRepoRepo E.==. E.val repoID E.&&.
+                comp E.^. ComponentProject E.==. E.val projectID
+            return (comp E.^. ComponentId, local E.^. ComponentLocalId)
+    getExistingComponents (Left (ComponentDeck (Entity deckID _))) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
+            E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
+            E.on $ ident E.^. ComponentLocalDeckComponent E.==. local E.^. ComponentLocalId
+            E.where_ $
+                ident E.^. ComponentLocalDeckDeck E.==. E.val deckID E.&&.
+                comp E.^. ComponentProject E.==. E.val projectID
+            return (comp E.^. ComponentId, local E.^. ComponentLocalId)
+    getExistingComponents (Left (ComponentLoom (Entity loomID _))) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
+            E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
+            E.on $ ident E.^. ComponentLocalLoomComponent E.==. local E.^. ComponentLocalId
+            E.where_ $
+                ident E.^. ComponentLocalLoomLoom E.==. E.val loomID E.&&.
+                comp E.^. ComponentProject E.==. E.val projectID
+            return (comp E.^. ComponentId, local E.^. ComponentLocalId)
+    getExistingComponents (Right remoteActorID) =
+        fmap (map $ bimap E.unValue (Right . E.unValue)) $
+        E.select $ E.from $ \ (ident `E.InnerJoin` comp) -> do
+            E.on $ ident E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
+            E.where_ $
+                ident E.^. ComponentRemoteActor E.==. E.val remoteActorID E.&&.
+                comp E.^. ComponentProject E.==. E.val projectID
+            return (comp E.^. ComponentId, ident E.^. ComponentRemoteId)
+
+    tryComponentEnabled componentID =
+        const () <$> MaybeT (getBy $ UniqueComponentEnable componentID)
+
+    tryComponentAddAccept componentID identID = do
+        _ <- MaybeT $ getBy $ UniqueComponentOriginAdd componentID
+        case identID of
+            Left localID ->
+                const () <$>
+                    MaybeT (getBy $ UniqueComponentAcceptLocal localID)
+            Right remoteID ->
+                const () <$>
+                    MaybeT (getBy $ UniqueComponentAcceptRemote remoteID)
+
+    tryComponentInviteAccept componentID = do
+        originID <- MaybeT $ getKeyBy $ UniqueComponentOriginInvite componentID
+        const () <$> MaybeT (getBy $ UniqueComponentProjectAccept originID)
+
 -- Meaning: An actor is adding some object to some target
 -- Behavior:
 --     * Verify my components list is the target
@@ -166,32 +254,9 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
             (p,) <$> getJust (projectActor p)
 
         -- Find existing Component records I have for this component
-        componentIDs <- lift $ getExistingComponents componentDB
+        -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
-
+        -- mode
-        -- Grab all the enabled ones, make sure none are enabled, and even if
+        checkExistingComponents projectID componentDB
-        -- any are enabled, make sure there's at most one (otherwise it's a
-        -- bug)
-        byEnabled <-
-            lift $ for componentIDs $ \ (componentID, _) ->
-                isJust <$> runMaybeT (tryComponentEnabled componentID)
-        case length $ filter id byEnabled of
-            0 -> return ()
-            1 -> throwE "I already have a ComponentEnable for this component"
-            _ -> error "Multiple ComponentEnable for a component"
-
-        -- Verify none of the Component records are already in
-        -- Add-waiting-for-project or Invite-waiting-for-component state
-        anyStarted <-
-            lift $ runMaybeT $ asum $
-                map (\ (componentID, identID) ->
-                        tryComponentAddAccept componentID identID <|>
-                        tryComponentInviteAccept componentID
-                    )
-                    componentIDs
-        unless (isNothing anyStarted) $
-            throwE
-                "One of the Component records is already in Add-Accept or \
-                \Invite-Accept state"
 
         -- Insert the Add to my inbox
         mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
@@ -218,59 +283,6 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
 
     where
 
-    getExistingComponents (Left (ComponentRepo (Entity repoID _))) =
-        fmap (map $ bimap E.unValue (Left . E.unValue)) $
-        E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
-            E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
-            E.on $ ident E.^. ComponentLocalRepoComponent E.==. local E.^. ComponentLocalId
-            E.where_ $
-                ident E.^. ComponentLocalRepoRepo E.==. E.val repoID E.&&.
-                comp E.^. ComponentProject E.==. E.val projectID
-            return (comp E.^. ComponentId, local E.^. ComponentLocalId)
-    getExistingComponents (Left (ComponentDeck (Entity deckID _))) =
-        fmap (map $ bimap E.unValue (Left . E.unValue)) $
-        E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
-            E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
-            E.on $ ident E.^. ComponentLocalDeckComponent E.==. local E.^. ComponentLocalId
-            E.where_ $
-                ident E.^. ComponentLocalDeckDeck E.==. E.val deckID E.&&.
-                comp E.^. ComponentProject E.==. E.val projectID
-            return (comp E.^. ComponentId, local E.^. ComponentLocalId)
-    getExistingComponents (Left (ComponentLoom (Entity loomID _))) =
-        fmap (map $ bimap E.unValue (Left . E.unValue)) $
-        E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
-            E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
-            E.on $ ident E.^. ComponentLocalLoomComponent E.==. local E.^. ComponentLocalId
-            E.where_ $
-                ident E.^. ComponentLocalLoomLoom E.==. E.val loomID E.&&.
-                comp E.^. ComponentProject E.==. E.val projectID
-            return (comp E.^. ComponentId, local E.^. ComponentLocalId)
-    getExistingComponents (Right remoteActorID) =
-        fmap (map $ bimap E.unValue (Right . E.unValue)) $
-        E.select $ E.from $ \ (ident `E.InnerJoin` comp) -> do
-            E.on $ ident E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
-            E.where_ $
-                ident E.^. ComponentRemoteActor E.==. E.val remoteActorID E.&&.
-                comp E.^. ComponentProject E.==. E.val projectID
-            return (comp E.^. ComponentId, ident E.^. ComponentRemoteId)
-
-    tryComponentEnabled componentID =
-        const () <$> MaybeT (getBy $ UniqueComponentEnable componentID)
-
-    tryComponentAddAccept componentID identID = do
-        _ <- MaybeT $ getBy $ UniqueComponentOriginAdd componentID
-        case identID of
-            Left localID ->
-                const () <$>
-                    MaybeT (getBy $ UniqueComponentAcceptLocal localID)
-            Right remoteID ->
-                const () <$>
-                    MaybeT (getBy $ UniqueComponentAcceptRemote remoteID)
-
-    tryComponentInviteAccept componentID = do
-        originID <- MaybeT $ getKeyBy $ UniqueComponentOriginInvite componentID
-        const () <$> MaybeT (getBy $ UniqueComponentProjectAccept originID)
-
     insertComponent componentDB addDB = do
         componentID <- insert $ Component projectID AP.RoleAdmin
         originID <- insert $ ComponentOriginAdd componentID
@@ -359,16 +371,25 @@ projectFollow now recipProjectID verse follow = do
 
 -- Meaning: An actor A invited actor B to a resource
 -- Behavior:
---      * Verify the resource is my collabs list
+--      * Verify the resource is my collabs or components list
---      * If invitee is local, verify it's a Person and not a Component
+--      * If resource is collabs and B is local, verify it's a Person
+--      * If resource is components and B is local, verify it's a Component
 --      * Verify A isn't inviting themselves
---      * Verify A is authorized by me to invite collabs to me
+--      * Verify A is authorized by me to invite collabs/components to me
 --
+--      * In collab mode,
 --          * Verify B doesn't already have an invite/join/grant for me
+--      * In component mode,
+--          * Verify B isn't already an active component of mine
+--          * Verify B isn't already in a Add-Accept process waiting for
+--            project collab to accept too
+--          * Verify B isn't already in an Invite-Accept process waiting for
+--            component (or its collaborator) to accept too
 --
 --      * Insert the Invite to my inbox
 --
---      * Insert a Collab record to DB
+--      * In collab mode, Insert a Collab record to DB
+--      * In component mode, Create a Component record in DB
 --
 --      * Forward the Invite to my followers
 --      * Send Accept to A, B (and followers if it's a component), my-followers
@@ -400,20 +421,31 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
             _ -> throwE "Capability is remote i.e. definitely not by me"
 
     -- Check invite
-    (role, targetByKey) <- do
+    (role, invited) <- do
         let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
         (role, resourceOrComps, recipientOrComp) <- parseInvite author invite
-        unless (Left (Left $ GrantResourceProject projectID) == resourceOrComps) $
+        mode <-
-            throwE "Invite topic isn't my collabs URI"
+            case resourceOrComps of
-        recipient <-
+                Left (Left (GrantResourceProject j)) | j == projectID ->
+                    Left <$>
                         bitraverse
                             (\case
                                 Left r -> pure r
-                    Right _ -> throwE "Not accepting component actors as collabs"
+                                Right _ -> throwE "Not accepting local component actors as collabs"
                             )
                             pure
                             recipientOrComp
-        return (role, recipient)
+                Left (Right j) | j == projectID ->
+                    Right <$>
+                        bitraverse
+                            (\case
+                                Left _ -> throwE "Not accepting local Persons as components"
+                                Right r -> pure r
+                            )
+                            pure
+                            recipientOrComp
+                _ -> throwE "Invite topic isn't my collabs or components 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
@@ -424,22 +456,17 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
     -- 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.
-    targetDB <-
+    invitedDB <-
         bitraverse
+            (bitraverse
                 (withDBExcept . flip getGrantRecip "Invitee not found in DB")
-            (\ u@(ObjURI h lu) -> do
+                getRemoteActorFromURI
-                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
             )
-            targetByKey
+            (bitraverse
+                (withDBExcept . flip getComponentE "Invitee not found in DB")
+                getRemoteActorFromURI
+            )
+        invited
 
     maybeNew <- withDBExcept $ do
 
@@ -453,38 +480,29 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
         verifyCapability'
             capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin
 
+        case invitedDB of
+
             -- Verify that target doesn't already have a Collab for me
-        existingCollabIDs <-
+            Left collab -> do
-            lift $ case targetDB of
+                existingCollabIDs <- lift $ getExistingCollabs collab
-                Left (GrantRecipPerson (Entity personID _)) ->
-                    E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
-                        E.on $
-                            topic E.^. CollabTopicProjectCollab E.==.
-                            recipl E.^. CollabRecipLocalCollab
-                        E.where_ $
-                            topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
-                            recipl E.^. CollabRecipLocalPerson E.==. E.val personID
-                        return $ recipl E.^. CollabRecipLocalCollab
-                Right remoteActorID ->
-                    E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
-                        E.on $
-                            topic E.^. CollabTopicProjectCollab E.==.
-                            recipr E.^. CollabRecipRemoteCollab
-                        E.where_ $
-                            topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
-                            recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
-                        return $ recipr E.^. CollabRecipRemoteCollab
                 case existingCollabIDs of
                     [] -> pure ()
                     [_] -> throwE "I already have a Collab for the target"
                     _ -> error "Multiple collabs found for target"
 
+            -- Find existing Component records I have for this component
+            -- Make sure none are enabled / in Add-Accept mode / in
+            -- Invite-Accept mode
+            Right component -> checkExistingComponents projectID component
+
         maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
         lift $ for maybeInviteDB $ \ inviteDB -> do
 
-            -- Insert Collab record to DB
+            -- Insert Collab or Component record to DB
             acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
-            insertCollab role targetDB inviteDB acceptID
+            case invitedDB of
+                Left collab -> insertCollab role collab inviteDB acceptID
+                Right component -> insertComponent component inviteDB acceptID
 
             -- Prepare forwarding Invite to my followers
             sieve <- do
@@ -492,7 +510,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
                 return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
 
             -- Prepare an Accept activity and insert to my outbox
-            accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
+            accept@(actionAccept, _, _, _) <- prepareAccept invitedDB
             _luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
 
             return (topicActorID, sieve, acceptID, accept)
@@ -509,6 +527,37 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
 
     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 (Left (GrantRecipPerson (Entity personID _))) =
+        E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
+            E.on $
+                topic E.^. CollabTopicProjectCollab E.==.
+                recipl E.^. CollabRecipLocalCollab
+            E.where_ $
+                topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
+                recipl E.^. CollabRecipLocalPerson E.==. E.val personID
+            return $ recipl E.^. CollabRecipLocalCollab
+    getExistingCollabs (Right remoteActorID) =
+        E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
+            E.on $
+                topic E.^. CollabTopicProjectCollab E.==.
+                recipr E.^. CollabRecipRemoteCollab
+            E.where_ $
+                topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
+                recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
+            return $ recipr E.^. CollabRecipRemoteCollab
+
     insertCollab role recipient inviteDB acceptID = do
         collabID <- insert $ Collab role
         fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
@@ -525,20 +574,53 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
             Right remoteActorID ->
                 insert_ $ CollabRecipRemote collabID remoteActorID
 
-    prepareAccept invited = do
+    insertComponent componentDB inviteDB acceptID = do
+        componentID <- insert $ Component projectID AP.RoleAdmin
+        originID <- insert $ ComponentOriginInvite componentID
+        case inviteDB of
+            Left (_, _, inviteID) ->
+                insert_ $ ComponentProjectGestureLocal componentID inviteID
+            Right (author, _, inviteID) ->
+                insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) inviteID
+        case componentDB of
+            Left l -> do
+                identID <- insert $ ComponentLocal componentID
+                case l of
+                    ComponentRepo (Entity repoID _) ->
+                        insert_ $ ComponentLocalRepo identID repoID
+                    ComponentDeck (Entity deckID _) ->
+                        insert_ $ ComponentLocalDeck identID deckID
+                    ComponentLoom (Entity loomID _) ->
+                        insert_ $ ComponentLocalLoom identID loomID
+            Right remoteActorID ->
+                insert_ $ ComponentRemote componentID remoteActorID
+        insert_ $ ComponentProjectAccept originID acceptID
+
+    prepareAccept invitedDB = do
         encodeRouteHome <- getEncodeRouteHome
 
-        audInviter <- makeAudSenderOnly authorIdMsig
+        audInviter <- lift $ makeAudSenderOnly authorIdMsig
         audInvited <-
-            case invited of
+            case invitedDB of
-                Left (GrantRecipPerson p) -> do
+                Left (Left (GrantRecipPerson (Entity p _))) -> do
                     ph <- encodeKeyHashid p
                     return $ AudLocal [LocalActorPerson ph] []
-                Right (ObjURI h lu) -> return $ AudRemote h [lu] []
+                Left (Right remoteActorID) -> do
+                    ra <- getJust remoteActorID
+                    ObjURI h lu <- getRemoteActorURI ra
+                    return $ AudRemote h [lu] []
+                Right (Left componentByEnt) -> do
+                    componentByHash <- hashComponent $ bmap entityKey componentByEnt
+                    let actor = componentActor componentByHash
+                    return $ AudLocal [actor] [localActorFollowers actor]
+                Right (Right remoteActorID) -> do
+                    ra <- getJust remoteActorID
+                    ObjURI h lu <- getRemoteActorURI ra
+                    return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
         audTopic <-
-            flip AudLocal [] . pure . LocalActorProject <$>
+            AudLocal [] . pure . LocalStageProjectFollowers <$>
                 encodeKeyHashid projectID
-        uInvite <- getActivityURI authorIdMsig
+        uInvite <- lift $ getActivityURI authorIdMsig
 
         let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                 collectAudience [audInviter, audInvited, audTopic]

src/Vervis/Data/Collab.hs

@@ -47,6 +47,7 @@ module Vervis.Data.Collab
     , grantResourceLocalActor
 
     , ComponentBy (..)
+    , hashComponent
     , componentActor
     )
 where
@@ -485,6 +486,10 @@ parseComponent (DeckR d) = Just $ ComponentDeck d
 parseComponent (LoomR l) = Just $ ComponentLoom l
 parseComponent _         = Nothing
 
+hashComponent (ComponentRepo k) = ComponentRepo <$> WAP.encodeKeyHashid k
+hashComponent (ComponentDeck k) = ComponentDeck <$> WAP.encodeKeyHashid k
+hashComponent (ComponentLoom k) = ComponentLoom <$> WAP.encodeKeyHashid k
+
 unhashComponentPure ctx = f
     where
     f (ComponentRepo r) =