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

This commit is contained in:
Pere Lev 2023-11-22 19:30:33 +02:00
parent 05d3a1eaef
commit 3c0a3d1317
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
2 changed files with 221 additions and 20 deletions

View file

@ -26,6 +26,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -535,7 +536,17 @@ personAdd now recipPersonID (Verse authorIdMsig body) add = do
-- Meaning: Someone invited someone to a resource -- Meaning: Someone invited someone to a resource
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * 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 personInvite
:: UTCTime :: UTCTime
-> PersonId -> PersonId
@ -545,10 +556,42 @@ personInvite
personInvite now recipPersonID (Verse authorIdMsig body) invite = do personInvite now recipPersonID (Verse authorIdMsig body) invite = do
-- Check input -- Check input
recipientOrComp <- do maybeRoleAndResourceDB <- do
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig 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 maybeNew <- withDBExcept $ do
@ -558,31 +601,64 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True 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 case maybeNew of
Nothing -> done "I already have this activity in my inbox" 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 forwardActivity
authorIdMsig body (LocalActorPerson recipPersonID) authorIdMsig body (LocalActorPerson recipPersonID)
actorID sieve actorID sieve
done done
"I'm the target; Inserted to inbox; \ "I'm the target; Inserted to inbox; Inserted Permit; \
\Forwarded to followers if addressed" \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 -- Meaning: Someone removed someone from a resource
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox

View file

@ -33,6 +33,7 @@ module Vervis.Persist.Collab
, getComponentIdent , getComponentIdent
, checkExistingStems , checkExistingStems
, checkExistingPermits
) )
where where
@ -508,3 +509,127 @@ checkExistingStems componentByID projectDB = do
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID) const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
Right remoteID -> Right remoteID ->
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject 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)