S2S: Person: Update Invite handler to create a Permit record
This commit is contained in:
Pere Lev
parent
05d3a1eaef
commit
3c0a3d1317
2 changed files with 221 additions and 20 deletions
|
|
@ -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
|
||||
return target
|
||||
(role, resource, recip) <- parseInvite author invite
|
||||
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 ->
|
||||
return $ personActor personRecip
|
||||
for maybeInviteDB $ \ inviteDB -> do
|
||||
|
||||
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
|
||||
let targetIsRecip =
|
||||
case recipientOrComp of
|
||||
Left (Left (GrantRecipPerson p)) -> p == recipPersonID
|
||||
_ -> False
|
||||
if not targetIsRecip
|
||||
then done "I'm not the target; Inserted to inbox"
|
||||
else do
|
||||
recipHash <- encodeKeyHashid recipPersonID
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalStagePersonFollowers recipHash]
|
||||
Just (actorID, maybePermit) ->
|
||||
case maybePermit of
|
||||
Nothing -> done "I'm not the target; Inserted to inbox"
|
||||
Just sieve -> do
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue