S2S: Person: Update Invite handler to create a Permit record

src/Vervis/Actor/Person.hs

@@ -26,6 +26,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)
@@ -535,7 +536,17 @@ personAdd now recipPersonID (Verse authorIdMsig body) add = do
 -- Meaning: Someone invited someone to a resource
 -- Behavior:
 --      * Insert to my inbox
---      * If I'm the target, forward the Invite to my followers
+--      * If I'm being invited to the resource's collaborators/members
+--        collection:
+--          * For each Permit record I have for this resource:
+--              * Verify it's not enabled yet, i.e. I'm not already a
+--                collaborator, haven't received a direct-Grant
+--              * Verify it's not in Invite-Accept state, already got the
+--                resource's Accept and waiting for my approval or for the
+--                topic's Grant
+--              * Verify it's not a Join
+--          * Create a Permit record in DB
+--          * Forward the Invite to my followers
 personInvite
     :: UTCTime
     -> PersonId
@@ -545,10 +556,42 @@ personInvite
 personInvite now recipPersonID (Verse authorIdMsig body) invite = do
 
     -- Check input
-    recipientOrComp <- do
+    maybeRoleAndResourceDB <- do
         let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (_role, _resource, target) <- parseInvite author invite
+        (role, resource, recip) <- parseInvite author invite
-        return target
+        let recipIsMe =
+                case recip of
+                    Left (Left (GrantRecipPerson p)) | p == recipPersonID -> True
+                    _ -> False
+        if not recipIsMe
+            then pure Nothing
+            else
+                -- If resource collabs URI is remote, HTTP GET it and its resource and its
+                -- managing actor, and insert to our DB. If resource is local, find it in
+                -- our DB.
+                case resource of
+                    Left r ->
+                        case r of
+                            Left la -> withDBExcept $ Just . (role,) . Left <$> getLocalActorEntityE la "Invite resource not found in DB"
+                            Right _j -> pure Nothing
+                    Right u@(ObjURI h luColl) -> do
+                        manager <- asksEnv envHttpManager
+                        coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
+                        lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
+                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                        if mluCollabs == Just luColl || mluMembers == Just luColl
+                            then Just . (role,) . Right <$> do
+                                instanceID <-
+                                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                                result <-
+                                    ExceptT $ first (T.pack . show) <$>
+                                        fetchRemoteResource instanceID h lu
+                                case result of
+                                    Left (Entity actorID actor) ->
+                                        return (remoteActorIdent actor, actorID, u)
+                                    Right (objectID, luManager, (Entity actorID _)) ->
+                                        return (objectID, actorID, ObjURI h luManager)
+                            else pure Nothing
 
     maybeNew <- withDBExcept $ do
 
@@ -558,31 +601,64 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
             (p,) <$> getJust (personActor p)
 
         maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
-        for maybeInviteDB $ \ _inviteDB ->
+        for maybeInviteDB $ \ inviteDB -> do
-            return $ personActor personRecip
+
+            maybePermit <- for maybeRoleAndResourceDB $ \ (role, resourceDB) -> do
+
+                -- Find existing Permit records I have for this topic
+                -- Make sure none are enabled / in Join mode / in Invite-Accept
+                -- mode
+                checkExistingPermits
+                    recipPersonID
+                    (bimap (bmap entityKey) (view _2) resourceDB)
+
+                -- Prepare forwarding Invite to my followers
+                recipPersonHash <- encodeKeyHashid recipPersonID
+                let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
+
+                -- Insert Collab or Stem record to DB
+                insertPermit resourceDB inviteDB role
+
+                return sieve
+
+            return (personActor personRecip, maybePermit)
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just actorID -> do
+        Just (actorID, maybePermit) ->
-            let targetIsRecip =
+            case maybePermit of
-                    case recipientOrComp of
+                Nothing -> done "I'm not the target; Inserted to inbox"
-                        Left (Left (GrantRecipPerson p)) -> p == recipPersonID
+                Just sieve -> do
-                        _ -> False
-            if not targetIsRecip
-                then done "I'm not the target; Inserted to inbox"
-                else do
-                    recipHash <- encodeKeyHashid recipPersonID
-                    let sieve =
-                            makeRecipientSet
-                                []
-                                [LocalStagePersonFollowers recipHash]
                     forwardActivity
                         authorIdMsig body (LocalActorPerson recipPersonID)
                         actorID sieve
                     done
-                        "I'm the target; Inserted to inbox; \
+                        "I'm the target; Inserted to inbox; Inserted Permit; \
                         \Forwarded to followers if addressed"
 
+    where
+
+    insertPermit resourceDB inviteDB role = do
+        permitID <- lift $ insert $ Permit recipPersonID role
+        case resourceDB of
+            Left la -> do
+                localID <- lift $ insert $ PermitTopicLocal permitID
+                case bmap entityKey la of
+                    LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\""
+                    LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r
+                    LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d
+                    LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l
+                    LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j
+                    LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g
+            Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
+        lift $ do
+            fulfillsID <- insert $ PermitFulfillsInvite permitID
+            case inviteDB of
+                Left (_, _, inviteID) ->
+                    insert_ $ PermitTopicGestureLocal fulfillsID inviteID
+                Right (author, _, inviteID) ->
+                    insert_ $ PermitTopicGestureRemote fulfillsID (remoteAuthorId author) inviteID
+
 -- Meaning: Someone removed someone from a resource
 -- Behavior:
 --      * Insert to my inbox

src/Vervis/Persist/Collab.hs

@@ -33,6 +33,7 @@ module Vervis.Persist.Collab
     , getComponentIdent
 
     , checkExistingStems
+    , checkExistingPermits
     )
 where
 
@@ -508,3 +509,127 @@ checkExistingStems componentByID projectDB = do
                 const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
             Right remoteID ->
                 const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
+
+checkExistingPermits
+    :: PersonId -> Either (LocalActorBy Key) RemoteActorId -> ActDBE ()
+checkExistingPermits personID topicDB = do
+
+    -- Find existing Permit records I have for this topic
+    permitIDs <- lift $ getExistingPermits topicDB
+
+    -- 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 permitIDs $ \ (_, permit) ->
+            isJust <$> runMaybeT (tryPermitEnabled permit)
+    case length $ filter id byEnabled of
+        0 -> return ()
+        1 -> throwE "I already have a PermitTopicEnable* for this topic"
+        _ -> error "Multiple PermitTopicEnable* for a topic"
+
+    -- Verify none of the Permit records are already in Join or
+    -- Invite-and-Accept state
+    anyStarted <-
+        lift $ runMaybeT $ asum $
+            map (\ (permitID, topic) ->
+                    tryPermitJoin permitID <|>
+                    tryPermitInviteAccept permitID topic
+                )
+                permitIDs
+    unless (isNothing anyStarted) $
+        throwE
+            "One of the Permit records is already in Join or Invite-Accept \
+            \state"
+
+    where
+
+    getExistingPermits (Left (LocalActorPerson _)) = pure []
+    getExistingPermits (Left (LocalActorRepo repoID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicRepoPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicRepoRepo E.==. E.val repoID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorDeck deckID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicDeckPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicDeckDeck E.==. E.val deckID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorLoom loomID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicLoomPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicLoomLoom E.==. E.val loomID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorProject projectID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicProjectPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicProjectProject E.==. E.val projectID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorGroup groupID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicGroupPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicGroupGroup E.==. E.val groupID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Right remoteActorID) =
+        fmap (map $ bimap E.unValue (Right . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` remote) -> do
+            E.on $ permit E.^. PermitId E.==. remote E.^. PermitTopicRemotePermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                remote E.^. PermitTopicRemoteActor E.==. E.val remoteActorID
+            return
+                ( permit E.^. PermitId
+                , remote E.^. PermitTopicRemoteId
+                )
+
+    tryPermitEnabled (Left localID) =
+        const () <$> MaybeT (getBy $ UniquePermitTopicEnableLocalTopic localID)
+    tryPermitEnabled (Right remoteID) =
+        const () <$> MaybeT (getBy $ UniquePermitTopicEnableRemoteTopic remoteID)
+
+    tryPermitJoin permitID = do
+        _ <- MaybeT $ getBy $ UniquePermitFulfillsJoin permitID
+        pure ()
+
+    tryPermitInviteAccept permitID topic = do
+        _fulfillsID <- MaybeT $ getKeyBy $ UniquePermitFulfillsInvite permitID
+        case topic of
+            Left localID ->
+                const () <$> MaybeT (getBy $ UniquePermitTopicAcceptLocalTopic localID)
+            Right remoteID ->
+                const () <$> MaybeT (getBy $ UniquePermitTopicAcceptRemoteTopic remoteID)