C2S: Person: Implement Join handler, inserting a Permit record to DB

src/Vervis/Actor/Person.hs

@@ -616,7 +616,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
                 recipPersonHash <- encodeKeyHashid recipPersonID
                 let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
 
-                -- Insert Collab or Stem record to DB
+                -- Insert Permit record to DB
                 insertPermit resourceDB inviteDB role
 
                 return sieve

src/Vervis/Actor/Person/Client.hs

@@ -934,6 +934,150 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
         fwdHosts inviteID action
     return inviteID
 
+-- Meaning: The human wants to join a resource R
+-- Behavior:
+--      * Some basic sanity checks
+--          * Parse the Join
+--          * Make sure not joining myself
+--          * Verify that a capability isn't specified
+--          * If resource is local, verify it exists in DB
+--      * Verify the resource R is addressed in the Join
+--      * Insert Join to my outbox
+--
+--      * If R is referred by a collabs/members collection URI:
+--          * 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
+--
+--      * Asynchrnously deliver to:
+--          * Resource+followers
+--          * My followers
+clientJoin
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.Join URIMode
+    -> ActE OutboxItemId
+clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) join = do
+
+    -- Check input
+    (role, resource) <- parseJoin join
+    verifyNothingE maybeCap "Capability provided"
+
+    -- 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.
+    resourceDB <-
+        bitraverse
+            (withDBExcept . flip getLocalActorEntityE "Join resource not found in DB")
+            (\ 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
+                let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl
+                unless (isCollabs || mluComps == Just luColl) $
+                    throwE "Join resource isn't a collabs/components list"
+
+                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, isCollabs)
+                    Right (objectID, luManager, (Entity actorID _)) ->
+                        return (objectID, actorID, ObjURI h luManager, isCollabs)
+            )
+            resource
+
+    -- Verify that resource is addressed by the Join
+    bitraverse_
+        (verifyActorAddressed localRecips . bmap entityKey)
+        (\ (_, _, u, _) -> verifyRemoteAddressed remoteRecips u)
+        resourceDB
+
+    let maybePermit =
+            case resourceDB of
+                Left la -> Just $ Left la
+                Right (_, _, _, False) -> Nothing
+                Right (objectID, actorID, uActor, True) -> Just $ Right (objectID, actorID, uActor)
+
+    (actorMeID, localRecipsFinal, joinID) <- withDBExcept $ do
+
+        -- Grab me from DB
+        (personMe, actorMe) <- lift $ do
+            p <- getJust personMeID
+            (p,) <$> getJust (personActor p)
+
+        -- Insert the Join activity to my outbox
+        joinID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+        _luJoin <- lift $ updateOutboxItem' (LocalActorPerson personMeID) joinID action
+
+        for_ maybePermit $ \ topicDB -> do
+
+            -- Find existing Permit records I have for this topic
+            -- Make sure none are enabled / in Join mode / in Invite-Accept
+            -- mode
+            checkExistingPermits
+                personMeID
+                (bimap (bmap entityKey) (view _2) topicDB)
+
+            -- Insert Permit record to DB
+            insertPermit topicDB joinID role
+
+        -- Prepare local recipients for Join delivery
+        sieve <- lift $ do
+            resourceHash <- bitraverse hashLocalActor pure resource
+            senderHash <- encodeKeyHashid personMeID
+            let sieveActors = catMaybes
+                    [ case resourceHash of
+                        Left a  -> Just a
+                        Right _ -> Nothing
+                    ]
+                sieveStages = catMaybes
+                    [ Just $ LocalStagePersonFollowers senderHash
+                    , case resourceHash of
+                        Left a  -> Just $ localActorFollowers a
+                        Right _ -> Nothing
+                    ]
+            return $ makeRecipientSet sieveActors sieveStages
+        return
+            ( personActor personMe
+            , localRecipSieve sieve False localRecips
+            , joinID
+            )
+
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+        fwdHosts joinID action
+    return joinID
+
+    where
+
+    insertPermit resourceDB joinID role = do
+        permitID <- lift $ insert $ Permit personMeID 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
+            insert_ $ PermitFulfillsJoin permitID
+            insert_ $ PermitPersonGesture permitID joinID
+
 -- Meaning: The human wants to open a ticket/MR/dependency
 -- Behavior:
 --      * Basics checks on the provided ticket/MR (dependency not allowed)
@@ -1218,6 +1362,7 @@ clientBehavior now personID msg =
         AP.AddActivity add       -> clientAdd now personID msg add
         AP.CreateActivity create -> clientCreate now personID msg create
         AP.InviteActivity invite -> clientInvite now personID msg invite
+        AP.JoinActivity join     -> clientJoin now personID msg join
         AP.OfferActivity offer   -> clientOffer now personID msg offer
         AP.RemoveActivity remove -> clientRemove now personID msg remove
         AP.ResolveActivity resolve -> clientResolve now personID msg resolve