S2S: Deck Invite handler: Implement component mode

src/Vervis/Actor/Common.hs

@@ -667,21 +667,79 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
+-- Meaning: An actor A invited actor B to a resource
+-- Behavior:
+--      * If resource is my collaborators collection:
+--          * Verify A isn't inviting themselves
+--          * Verify A is authorized by me to invite actors to me
+--          * Verify B doesn't already have an invite/join/grant for me
+--          * Remember the invite in DB
+--          * Forward the Invite to my followers
+--          * Send Accept to A, B, my-followers
+--      * If I'm B, i.e. I'm the one being invited:
+--          * Verify the resource is some project's components collection URI
+--          * For each Stem record I have for this project:
+--              * Verify it's not enabled yet, i.e. I'm not already a component
+--                of this project
+--              * Verify it's not in Invite-Accept state, already got the
+--                project's Accept and waiting for my approval
+--              * Verify it's not in Add-Accept state, has my approval and
+--                waiting for the project's side
+--          * Create a Stem record in DB
+--          * Insert the Invite to my inbox
+--          * Forward the Invite to my followers
 topicInvite
     :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
        , PersistRecordBackend ct SqlBackend
+       , PersistRecordBackend si SqlBackend
        )
     => (topic -> ActorId)
     -> (forall f. f topic -> GrantResourceBy f)
+    -> (forall f. f topic -> ComponentBy f)
     -> EntityField ct (Key topic)
     -> EntityField ct CollabId
     -> (CollabId -> Key topic -> ct)
+    -> (StemId -> Key topic -> si)
     -> UTCTime
     -> Key topic
     -> Verse
     -> AP.Invite URIMode
     -> ActE (Text, Act (), Next)
-topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) invite = do
+topicInvite grabActor topicResource topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
+
+    -- Check invite
+    recipOrProject <- do
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        (role, resourceOrComps, recipientOrComp) <- parseInvite author invite
+        let collabMode =
+                Left (Left $ topicResource topicKey) == resourceOrComps
+            compMode =
+                Left (Right $ topicComponent topicKey) == recipientOrComp
+        case (collabMode, compMode) of
+            (False, False) -> throwE "Invite is unrelated to me"
+            (True, True) -> throwE "I'm being invited as a collaborator in myself"
+            (True, False) -> Left . (role,) <$>
+                bitraverse
+                    (\case
+                        Left r -> pure r
+                        Right _ -> throwE "Not accepting component actors as collabs"
+                    )
+                    pure
+                    recipientOrComp
+            (False, True) -> Right <$> do
+                unless (role == AP.RoleAdmin) $
+                    throwE "Invite-component role isn't admin"
+                bitraverse
+                    (\case
+                        Left _ -> throwE "Inviting me to be a collaborator doesn't make sense to me"
+                        Right j -> pure j
+                    )
+                    pure
+                    resourceOrComps
+
+    recipOrProjectDB <-
+        bitraverse
+            (\ (role, targetByKey) -> do
 
                 -- Check capability
                 capability <- do
@@ -702,22 +760,6 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
                             return (actorByKey, outboxItemID)
                         _ -> throwE "Capability is remote i.e. definitely not by me"
 
-    -- Check invite
-    (role, targetByKey) <- do
-        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (role, resourceOrComps, recipientOrComp) <- parseInvite author invite
-        unless (Left (Left $ topicResource topicKey) == resourceOrComps) $
-            throwE "Invite topic isn't my collabs URI"
-        recipient <-
-            bitraverse
-                (\case
-                    Left r -> pure r
-                    Right _ -> throwE "Not accepting component actors as collabs"
-                )
-                pure
-                recipientOrComp
-        return (role, recipient)
-
                 -- 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)
@@ -744,6 +786,53 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
                         )
                         targetByKey
 
+                return (role, capability, targetByKey, targetDB)
+            )
+
+            -- If project is local, find it in our DB
+            -- If project is remote, HTTP GET it 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.
+            (bitraverse
+                (withDBExcept . flip getEntityE "Project not found in DB")
+                (\ u@(ObjURI h luComps) -> do
+                    manager <- asksEnv envHttpManager
+                    collection <-
+                        ExceptT $ first T.pack <$>
+                            AP.fetchAPID
+                                manager
+                                (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
+                                h
+                                luComps
+                    luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
+                    project <-
+                        ExceptT $ first T.pack <$>
+                            AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
+                    unless (AP.projectComponents project == luComps) $
+                        throwE "The collection isn't the project's components collection"
+
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h luProject
+                    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) -> do
+                            unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
+                                throwE "Remote project type isn't Project"
+                            return $ entityKey actor
+                )
+            )
+
+            recipOrProject
+
     maybeNew <- withDBExcept $ do
 
         -- Grab me from DB
@@ -752,6 +841,9 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
             let actorID = grabActor recip
             (actorID,) <$> getJust actorID
 
+        case recipOrProjectDB of
+            Left (role, capability, _targetByKey, targetDB) -> do
+
                 -- Verify the specified capability gives relevant access
                 verifyCapability'
                     capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
@@ -782,13 +874,16 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
                     [_] -> throwE "I already have a Collab for the target"
                     _ -> error "Multiple collabs found for target"
 
+            Right projectDB ->
+
+                -- Find existing Stem records I have for this project
+                -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
+                -- mode
+                checkExistingStems (topicComponent topicKey) projectDB
+
         maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
         lift $ for maybeInviteDB $ \ inviteDB -> do
 
-            -- Insert Collab record to DB
-            acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
-            insertCollab role targetDB inviteDB acceptID
-
             -- Prepare forwarding Invite to my followers
             sieve <- do
                 topicHash <- encodeKeyHashid topicKey
@@ -796,22 +891,33 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
                         grantResourceLocalActor $ topicResource topicHash
                 return $ makeRecipientSet [] [localActorFollowers topicByHash]
 
-            -- Prepare an Accept activity and inser to my outbox
+            -- Insert Collab or Stem record to DB
+            -- In Collab mode: Prepare an Accept activity and insert to my
+            -- outbox
+            maybeAccept <- case recipOrProjectDB of
+                Left (role, _capability, targetByKey, targetDB) -> Just <$> do
+                    acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+                    insertCollab role targetDB inviteDB acceptID
                     accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
                     let topicByKey = grantResourceLocalActor $ topicResource topicKey
                     _luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
+                    return (acceptID, accept)
+                Right projectDB -> do
+                    insertStem projectDB inviteDB
+                    return Nothing
 
-            return (topicActorID, sieve, acceptID, accept)
+            return (topicActorID, sieve, maybeAccept)
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+        Just (topicActorID, sieve, maybeAccept) -> do
             let topicByID = grantResourceLocalActor $ topicResource topicKey
             forwardActivity authorIdMsig body topicByID topicActorID sieve
-            lift $ sendActivity
+            lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) ->
+                sendActivity
                     topicByID topicActorID localRecipsAccept remoteRecipsAccept
                     fwdHostsAccept acceptID actionAccept
-            done "Recorded and forwarded the Invite, sent an Accept"
+            done "Recorded and forwarded the Invite, sent an Accept if collab"
 
     where
 
@@ -831,6 +937,21 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
             Right remoteActorID ->
                 insert_ $ CollabRecipRemote collabID remoteActorID
 
+    insertStem projectDB inviteDB = do
+        stemID <- insert $ Stem AP.RoleAdmin
+        insert_ $ stemIdentCtor stemID topicKey
+        case projectDB of
+            Left (Entity projectID _) ->
+                insert_ $ StemProjectLocal stemID projectID
+            Right remoteActorID ->
+                insert_ $ StemProjectRemote stemID remoteActorID
+        originID <- insert $ StemOriginInvite stemID
+        case inviteDB of
+            Left (_, _, inviteID) ->
+                insert_ $ StemProjectGestureLocal originID inviteID
+            Right (author, _, inviteID) ->
+                insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) inviteID
+
     prepareAccept invited = do
         encodeRouteHome <- getEncodeRouteHome
 

src/Vervis/Actor/Deck.hs

@@ -74,81 +74,6 @@ import Vervis.Persist.Discussion
 import Vervis.RemoteActorStore
 import Vervis.Ticket
 
-checkExistingStems
-    :: DeckId -> Either (Entity Project) RemoteActorId -> ActDBE ()
-checkExistingStems deckID projectDB = do
-
-    -- Find existing Stem records I have for this project
-    stemIDs <- lift $ getExistingStems projectDB
-
-    -- 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 stemIDs $ \ (_, stem) ->
-            isJust <$> runMaybeT (tryStemEnabled stem)
-    case length $ filter id byEnabled of
-        0 -> return ()
-        1 -> throwE "I already have a StemProjectGrant* for this project"
-        _ -> error "Multiple StemProjectGrant* for a project"
-
-    -- Verify none of the Stem records are already in
-    -- Add-waiting-for-project or Invite-waiting-for-my-collaborator state
-    anyStarted <-
-        lift $ runMaybeT $ asum $
-            map (\ (stemID, project) ->
-                    tryStemAddAccept stemID <|>
-                    tryStemInviteAccept stemID project
-                )
-                stemIDs
-    unless (isNothing anyStarted) $
-        throwE
-            "One of the Stem records is already in Add-Accept or \
-            \Invite-Accept state"
-
-    where
-
-    getExistingStems (Left (Entity projectID _)) =
-        fmap (map $ bimap E.unValue (Left . E.unValue)) $
-        E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
-            E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. StemIdentDeckStem
-            E.where_ $
-                project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
-                ident E.^. StemIdentDeckDeck E.==. E.val deckID
-            return
-                ( project E.^. StemProjectLocalStem
-                , project E.^. StemProjectLocalId
-                )
-    getExistingStems (Right remoteActorID) =
-        fmap (map $ bimap E.unValue (Right . E.unValue)) $
-        E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
-            E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. StemIdentDeckStem
-            E.where_ $
-                project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
-                ident E.^. StemIdentDeckDeck E.==. E.val deckID
-            return
-                ( project E.^. StemProjectRemoteStem
-                , project E.^. StemProjectRemoteId
-                )
-
-    tryStemEnabled (Left localID) =
-        const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)
-    tryStemEnabled (Right remoteID) =
-        const () <$> MaybeT (getBy $ UniqueStemProjectGrantRemoteProject remoteID)
-
-    tryStemAddAccept stemID = do
-        _ <- MaybeT $ getBy $ UniqueStemOriginAdd stemID
-        _ <- MaybeT $ getBy $ UniqueStemComponentAccept stemID
-        pure ()
-
-    tryStemInviteAccept stemID project = do
-        originID <- MaybeT $ getKeyBy $ UniqueStemOriginInvite stemID
-        case project of
-            Left localID ->
-                const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
-            Right remoteID ->
-                const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
-
 -- Meaning: An actor is adding some object to some target
 -- Behavior:
 --     * Verify that the object is me
@@ -260,7 +185,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
         -- Find existing Stem records I have for this project
         -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
         -- mode
-        checkExistingStems deckID projectDB
+        checkExistingStems (ComponentDeck deckID) projectDB
 
         -- Verify the specified capability gives relevant access
         verifyCapability'
@@ -483,13 +408,25 @@ deckReject = topicReject deckActor GrantResourceDeck
 
 -- Meaning: An actor A invited actor B to a resource
 -- Behavior:
---      * Verify the resource is me
+--      * If resource is my collaborators collection:
 --          * Verify A isn't inviting themselves
 --          * Verify A is authorized by me to invite actors to me
 --          * Verify B doesn't already have an invite/join/grant for me
 --          * Remember the invite in DB
 --          * Forward the Invite to my followers
 --          * Send Accept to A, B, my-followers
+--      * If I'm B, i.e. I'm the one being invited:
+--          * Verify the resource is some project's components collection URI
+--          * For each Stem record I have for this project:
+--              * Verify it's not enabled yet, i.e. I'm not already a component
+--                of this project
+--              * Verify it's not in Invite-Accept state, already got the
+--                project's Accept and waiting for my approval
+--              * Verify it's not in Add-Accept state, has my approval and
+--                waiting for the project's side
+--          * Create a Stem record in DB
+--          * Insert the Invite to my inbox
+--          * Forward the Invite to my followers
 deckInvite
     :: UTCTime
     -> DeckId
@@ -498,8 +435,9 @@ deckInvite
     -> ActE (Text, Act (), Next)
 deckInvite =
     topicInvite
-        deckActor GrantResourceDeck
+        deckActor GrantResourceDeck ComponentDeck
-        CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
+        CollabTopicDeckDeck CollabTopicDeckCollab
+        CollabTopicDeck StemIdentDeck
 
 -- Meaning: An actor A is removing actor B from a resource
 -- Behavior:

src/Vervis/Persist/Collab.hs

@@ -28,20 +28,27 @@ module Vervis.Persist.Collab
     , getGrant
 
     , getComponentIdent
+
+    , checkExistingStems
     )
 where
 
+import Control.Applicative
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
+import Data.Foldable
 import Data.List (sortOn)
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist.Sql
 import Optics.Core
 
@@ -393,3 +400,85 @@ getComponentIdent componentID = do
         )
         (\ (Entity k v) -> pure (k, componentRemoteActor v))
         ident
+
+checkExistingStems
+    :: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
+checkExistingStems componentByID projectDB = do
+
+    -- Find existing Stem records I have for this project
+    stemIDs <- lift $ getExistingStems componentByID
+
+    -- 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 stemIDs $ \ (_, stem) ->
+            isJust <$> runMaybeT (tryStemEnabled stem)
+    case length $ filter id byEnabled of
+        0 -> return ()
+        1 -> throwE "I already have a StemProjectGrant* for this project"
+        _ -> error "Multiple StemProjectGrant* for a project"
+
+    -- Verify none of the Stem records are already in
+    -- Add-waiting-for-project or Invite-waiting-for-my-collaborator state
+    anyStarted <-
+        lift $ runMaybeT $ asum $
+            map (\ (stemID, project) ->
+                    tryStemAddAccept stemID <|>
+                    tryStemInviteAccept stemID project
+                )
+                stemIDs
+    unless (isNothing anyStarted) $
+        throwE
+            "One of the Stem records is already in Add-Accept or \
+            \Invite-Accept state"
+
+    where
+
+    getExistingStems' compID stemField compField (Left (Entity projectID _)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
+            E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. stemField
+            E.where_ $
+                project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
+                ident E.^. compField E.==. E.val compID
+            return
+                ( project E.^. StemProjectLocalStem
+                , project E.^. StemProjectLocalId
+                )
+    getExistingStems' compID stemField compField (Right remoteActorID) =
+        fmap (map $ bimap E.unValue (Right . E.unValue)) $
+        E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
+            E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. stemField
+            E.where_ $
+                project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
+                ident E.^. compField E.==. E.val compID
+            return
+                ( project E.^. StemProjectRemoteStem
+                , project E.^. StemProjectRemoteId
+                )
+
+    getExistingStems (ComponentRepo repoID) =
+        getExistingStems' repoID StemIdentRepoStem StemIdentRepoRepo projectDB
+    getExistingStems (ComponentDeck deckID) =
+        getExistingStems' deckID StemIdentDeckStem StemIdentDeckDeck projectDB
+    getExistingStems (ComponentLoom loomID) =
+        getExistingStems' loomID StemIdentLoomStem StemIdentLoomLoom projectDB
+
+    tryStemEnabled (Left localID) =
+        const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)
+    tryStemEnabled (Right remoteID) =
+        const () <$> MaybeT (getBy $ UniqueStemProjectGrantRemoteProject remoteID)
+
+    tryStemAddAccept stemID = do
+        _ <- MaybeT $ getBy $ UniqueStemOriginAdd stemID
+        _ <- MaybeT $ getBy $ UniqueStemComponentAccept stemID
+        pure ()
+
+    tryStemInviteAccept stemID project = do
+        originID <- MaybeT $ getKeyBy $ UniqueStemOriginInvite stemID
+        case project of
+            Left localID ->
+                const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
+            Right remoteID ->
+                const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)