S2S: Project: Accept: Split the different modes into separate functions
This commit is contained in:
Pere Lev
parent
048c429def
commit
bf8ae421ff
1 changed files with 479 additions and 431 deletions
|
|
@ -206,7 +206,6 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
|
||||
collabOrComp_or_child <- withDBExcept $ do
|
||||
|
||||
|
|
@ -234,436 +233,10 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
maybeCollab
|
||||
"Accepted activity isn't an Invite/Join/Add I'm aware of"
|
||||
|
||||
idsForAccept <- bitraverse
|
||||
|
||||
(bitraverse
|
||||
|
||||
(\ (collabID, fulfills, inviterOrJoiner) -> (collabID,inviterOrJoiner,) <$> bitraverse
|
||||
|
||||
-- If accepting an Invite, find the Collab recipient and verify
|
||||
-- it's the sender of the Accept
|
||||
(\ fulfillsID -> withDBExcept $ do
|
||||
recip <-
|
||||
lift $
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueCollabRecipLocal collabID)
|
||||
(getBy $ UniqueCollabRecipRemote collabID)
|
||||
"Found Collab with no recip"
|
||||
"Found Collab with multiple recips"
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
|
||||
| collabRecipLocalPerson crl == personID ->
|
||||
return (fulfillsID, Left crlid)
|
||||
(Right (Entity crrid crr), Right (author, _, _))
|
||||
| collabRecipRemoteActor crr == remoteAuthorId author ->
|
||||
return (fulfillsID, Right crrid)
|
||||
_ -> throwE "Accepting an Invite whose recipient is someone else"
|
||||
)
|
||||
|
||||
-- If accepting a Join, verify accepter has permission
|
||||
(\ fulfillsID -> do
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
return fulfillsID
|
||||
)
|
||||
|
||||
fulfills
|
||||
)
|
||||
|
||||
(\ (componentID, ident, inviteOrAdd) -> (componentID, ident,) <$> bitraverse
|
||||
|
||||
-- If accepting an Invite-component, there's nothing to check
|
||||
-- at this point
|
||||
pure
|
||||
|
||||
-- If accepting an Add-component:
|
||||
-- * If the sender is the component, verify I haven't seen
|
||||
-- a component-Accept on this Add
|
||||
-- * Otherwise, verify I've seen the component-Accept for
|
||||
-- this Add and that the new Accept is authorized
|
||||
(\ () -> do
|
||||
maybeComponentAccept <-
|
||||
lift $ withDB $
|
||||
case bimap fst fst ident of
|
||||
Left localID -> (() <$) <$> getBy (UniqueComponentAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueComponentAcceptRemote remoteID)
|
||||
if componentIsAuthor ident
|
||||
then
|
||||
verifyNothingE
|
||||
maybeComponentAccept
|
||||
"I've already seen a ComponentAccept* on \
|
||||
\that Add"
|
||||
else do
|
||||
fromMaybeE
|
||||
maybeComponentAccept
|
||||
"I haven't yet seen the Component's Accept on \
|
||||
\the Add"
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
)
|
||||
|
||||
inviteOrAdd
|
||||
)
|
||||
|
||||
)
|
||||
|
||||
-- Child/Parent mode
|
||||
(bitraverse
|
||||
|
||||
-- Adding-a-new-child mode
|
||||
(\ (sourceID, topic, mode) -> (sourceID,topic,) <$> bitraverse
|
||||
|
||||
-- Child-active mode
|
||||
-- Verify we haven't yet seen child's Accept
|
||||
(\ () -> do
|
||||
maybeChildAccept <-
|
||||
lift $ withDB $
|
||||
case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID)
|
||||
verifyNothingE maybeChildAccept "I already saw child's Accept"
|
||||
)
|
||||
|
||||
-- Child-passive mode
|
||||
-- Option 1: We haven't seen child's Accept yet
|
||||
-- * Verify sender is the child
|
||||
-- Option 2: We saw it, but not my collaborator's Accept
|
||||
-- * Verify the Accept is authorized
|
||||
-- Otherwise respond with error, no Accept is needed
|
||||
(\ () -> do
|
||||
(maybeChildAccept, maybeGrant) <-
|
||||
lift $ withDB $ liftA2 (,)
|
||||
(case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID)
|
||||
)
|
||||
(getBy $ UniqueSourceUsSendDelegator sourceID)
|
||||
case (isJust maybeChildAccept, isJust maybeGrant) of
|
||||
(False, True) -> error "Impossible/bug, didn't see child's Accept but sent a Grant"
|
||||
(False, False) -> do
|
||||
unless (theyIsAuthor topic) $
|
||||
throwE "The Accept I'm waiting for is from my new child"
|
||||
return $ Left ()
|
||||
(True, False) -> do
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Child already enabled, not needing any further Accept"
|
||||
)
|
||||
|
||||
mode
|
||||
)
|
||||
|
||||
-- Adding-a-new-parent mode
|
||||
(\ (destID, topic, mode) -> case mode of
|
||||
|
||||
-- Parent-active mode
|
||||
-- Respond with error, we aren't supposed to get any Accept
|
||||
Left () -> throwE "Parent-active (DestOriginUs) mode, I'm not expecting any Accept"
|
||||
|
||||
-- Parent-passive mode
|
||||
-- Option 1: I haven't yet seen parent's Accept
|
||||
-- * Verify sender is the parent
|
||||
-- Option 2: I saw it, but not my collaborator's Accept
|
||||
-- * Verify the accept is authorized
|
||||
-- Otherwise respond with error, no Accept is needed
|
||||
Right themID -> (destID,themID,topic,) <$> do
|
||||
(maybeParentAccept, maybeUsGesture) <-
|
||||
lift $ withDB $ liftA2 (,)
|
||||
(case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueDestThemAcceptLocalTopic localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueDestThemAcceptRemoteTopic remoteID)
|
||||
)
|
||||
(do l <- getBy $ UniqueDestUsGestureLocal destID
|
||||
r <- getBy $ UniqueDestUsGestureRemote destID
|
||||
case (isJust l, isJust r) of
|
||||
(False, False) -> pure Nothing
|
||||
(False, True) -> pure $ Just ()
|
||||
(True, False) -> pure $ Just ()
|
||||
(True, True) -> error "Both DestUsGestureLocal and DestUsGestureRemote"
|
||||
)
|
||||
case (isJust maybeParentAccept, isJust maybeUsGesture) of
|
||||
(False, True) -> error "Impossible/bug, didn't see parent's Accept but recorded my collaborator's Accept"
|
||||
(False, False) -> do
|
||||
unless (theyIsAuthor topic) $
|
||||
throwE "The Accept I'm waiting for is from my new parent"
|
||||
return $ Left ()
|
||||
(True, False) -> do
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept"
|
||||
)
|
||||
)
|
||||
|
||||
collabOrComp_or_child
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- In collab mode, verify the Collab isn't already validated
|
||||
-- In component mode, verify the Component isn't already validated
|
||||
-- In child/parent modes, no check at this point
|
||||
bitraverse_
|
||||
(bitraverse_
|
||||
(\ (collabID, _, _) -> do
|
||||
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
|
||||
verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
|
||||
)
|
||||
(\ (componentID, _, _) -> do
|
||||
maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID
|
||||
verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add"
|
||||
)
|
||||
)
|
||||
pure
|
||||
collabOrComp_or_child
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ acceptDB -> do
|
||||
|
||||
idsForGrant <-
|
||||
bitraverse
|
||||
|
||||
(\case
|
||||
-- In collab mode, record the Accept and enable the Collab
|
||||
Left (collabID, inviterOrJoiner, collab) -> Left <$> do
|
||||
case (collab, acceptDB) of
|
||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Right fulfillsID, Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
(Right fulfillsID, Right (author, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
_ -> error "projectAccept impossible"
|
||||
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
enableID <- lift $ insert $ CollabEnable collabID grantID
|
||||
return (collabID, inviterOrJoiner, collab, grantID, enableID)
|
||||
|
||||
-- In Invite-component mode, only if the Accept author is the
|
||||
-- component, record the Accept and enable the Component
|
||||
Right (componentID, ident, Left ()) -> fmap Right $
|
||||
lift $ if componentIsAuthor ident
|
||||
then Just <$> do
|
||||
case (ident, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptRemote remoteID acceptID
|
||||
_ -> error "personAccept impossible ii"
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
enableID <- insert $ ComponentEnable componentID grantID
|
||||
return (componentID, ident, grantID, enableID, False)
|
||||
else pure Nothing
|
||||
|
||||
-- In Add-component mode:
|
||||
-- * If the sender is the component, record the Accept
|
||||
-- * Otherwise, record the Accept and enable the Component
|
||||
Right (componentID, ident, Right ()) -> fmap Right $
|
||||
lift $ if componentIsAuthor ident
|
||||
then do
|
||||
case (ident, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptRemote remoteID acceptID
|
||||
_ -> error "personAccept impossible iii"
|
||||
return Nothing
|
||||
else Just <$> do
|
||||
case acceptDB of
|
||||
Left (_, _, acceptID) ->
|
||||
insert_ $ ComponentProjectGestureLocal componentID acceptID
|
||||
Right (author, _, acceptID) ->
|
||||
insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) acceptID
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
enableID <- insert $ ComponentEnable componentID grantID
|
||||
return (componentID, ident, grantID, enableID, True)
|
||||
)
|
||||
|
||||
-- Child/parent mode
|
||||
(bitraverse
|
||||
|
||||
-- Child mode
|
||||
(\ (sourceID, topic, mode) -> lift $ bitraverse
|
||||
|
||||
-- Child-active mode
|
||||
-- If sender is child, record the Accept into the
|
||||
-- Source record & prepare to send degelator-Grant
|
||||
-- Othrerwise do nothing
|
||||
(\ () ->
|
||||
if theyIsAuthor topic
|
||||
then Just <$> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptRemote remoteID acceptID
|
||||
_ -> error "projectAccept impossible iv"
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ SourceUsSendDelegator sourceID grantID
|
||||
return (topic, grantID)
|
||||
else pure Nothing
|
||||
)
|
||||
|
||||
-- Child-passive mode
|
||||
(\case
|
||||
|
||||
-- Getting an Accept from the child
|
||||
-- Record child's Accept in Source record
|
||||
Left () -> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptRemote remoteID acceptID
|
||||
_ -> error "projectAccept impossible v"
|
||||
return Nothing
|
||||
|
||||
-- Getting an Accept from my collaborator
|
||||
-- Record my collaborator's Accept
|
||||
-- Prepare to send delegator-Grant
|
||||
Right () -> Just <$> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptRemote remoteID acceptID
|
||||
_ -> error "projectAccept impossible iv"
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ SourceUsSendDelegator sourceID grantID
|
||||
return (topic, grantID)
|
||||
)
|
||||
|
||||
mode
|
||||
)
|
||||
|
||||
-- Parent-passive mode
|
||||
(\ (destID, themID, topic, mode) -> lift $ case mode of
|
||||
|
||||
-- Getting an Accept from the parent
|
||||
-- Record parent's Accept in the Dest record
|
||||
Left () -> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ DestThemAcceptLocal themID localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ DestThemAcceptRemote themID remoteID acceptID
|
||||
_ -> error "projectAccept impossible v"
|
||||
return Nothing
|
||||
|
||||
-- Getting an Accept from my collaborator
|
||||
-- Record my collaborator's Accept in the Dest record
|
||||
-- Prepare to send my own Accept
|
||||
Right () -> Just <$> do
|
||||
case acceptDB of
|
||||
Left (_, _, acceptID) ->
|
||||
insert_ $ DestUsGestureLocal destID acceptID
|
||||
Right (author, _, acceptID) ->
|
||||
insert_ $ DestUsGestureRemote destID (remoteAuthorId author) acceptID
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ DestUsAccept destID acceptID
|
||||
return (topic, acceptID)
|
||||
)
|
||||
)
|
||||
|
||||
idsForAccept
|
||||
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = LocalActorProject projectID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
maybeGrant <-
|
||||
case idsForGrant of
|
||||
|
||||
-- In collab mode, prepare a regular Grant
|
||||
Left (Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID)) -> lift $ do
|
||||
let isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- do
|
||||
Collab role <- getJust collabID
|
||||
prepareCollabGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return $ Just (grantID, grant)
|
||||
|
||||
-- In Invite-component mode, only if the Accept author is
|
||||
-- the component, prepare a delegator-Grant
|
||||
--
|
||||
-- In Add-component mode, only if the Accept author isn't
|
||||
-- the component, prepare a delegator-Grant
|
||||
Left (Right comp) -> for comp $ \ (_componentID, ident, grantID, enableID, includeAuthor) -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
-- Add child/parent modes
|
||||
|
||||
Right (Left (Left mg)) -> for mg $ \ (topic, grantID) -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareSourceDelegGrant (bimap snd snd topic) False
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
Right (Left (Right mg)) -> for mg $ \ (topic, grantID) -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareSourceDelegGrant (bimap snd snd topic) True
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
Right (Right ma) -> for ma $ \ (topic, acceptID) -> lift $ do
|
||||
accept@(actionAccept, _, _, _) <-
|
||||
prepareDestAccept (bimap snd snd topic)
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
|
||||
return (acceptID, accept)
|
||||
|
||||
return (recipActorID, sieve, maybeGrant)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, maybeGrant) -> do
|
||||
let recipByID = LocalActorProject projectID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "Forwarded the Accept and maybe published a Grant/Accept"
|
||||
case collabOrComp_or_child of
|
||||
Left (Left collab) -> addCollab collab
|
||||
Left (Right comp) -> addComp comp
|
||||
Right cp -> addChildParent cp
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -877,6 +450,481 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (LocalActorProject . snd) snd ident
|
||||
|
||||
addCollab (collabID, fulfills, inviterOrJoiner) = do
|
||||
|
||||
collab <-
|
||||
bitraverse
|
||||
|
||||
-- If accepting an Invite, find the Collab recipient and verify
|
||||
-- it's the sender of the Accept
|
||||
(\ fulfillsID -> withDBExcept $ do
|
||||
recip <-
|
||||
lift $
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueCollabRecipLocal collabID)
|
||||
(getBy $ UniqueCollabRecipRemote collabID)
|
||||
"Found Collab with no recip"
|
||||
"Found Collab with multiple recips"
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
|
||||
| collabRecipLocalPerson crl == personID ->
|
||||
return (fulfillsID, Left crlid)
|
||||
(Right (Entity crrid crr), Right (author, _, _))
|
||||
| collabRecipRemoteActor crr == remoteAuthorId author ->
|
||||
return (fulfillsID, Right crrid)
|
||||
_ -> throwE "Accepting an Invite whose recipient is someone else"
|
||||
)
|
||||
|
||||
-- If accepting a Join, verify accepter has permission
|
||||
(\ fulfillsID -> do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
return fulfillsID
|
||||
)
|
||||
|
||||
fulfills
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- In collab mode, verify the Collab isn't already validated
|
||||
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
|
||||
verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ acceptDB -> do
|
||||
|
||||
-- Record the Accept and enable the Collab
|
||||
(grantID, enableID) <- do
|
||||
case (collab, acceptDB) of
|
||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Right fulfillsID, Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
(Right fulfillsID, Right (author, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
_ -> error "projectAccept impossible"
|
||||
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
enableID <- lift $ insert $ CollabEnable collabID grantID
|
||||
return (grantID, enableID)
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = LocalActorProject projectID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
-- Prepare a regular Grant
|
||||
let isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- lift $ do
|
||||
Collab role <- getJust collabID
|
||||
prepareCollabGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
|
||||
|
||||
return (recipActorID, sieve, grantID, grant)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
|
||||
let recipByID = LocalActorProject projectID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "[Collab mode] Forwarded the Accept and published a Grant"
|
||||
|
||||
addComp (componentID, ident, inviteOrAdd) = do
|
||||
|
||||
comp <-
|
||||
bitraverse
|
||||
|
||||
-- If accepting an Invite-component, there's nothing to check
|
||||
-- at this point
|
||||
pure
|
||||
|
||||
-- If accepting an Add-component:
|
||||
-- * If the sender is the component, verify I haven't seen
|
||||
-- a component-Accept on this Add
|
||||
-- * Otherwise, verify I've seen the component-Accept for
|
||||
-- this Add and that the new Accept is authorized
|
||||
(\ () -> do
|
||||
maybeComponentAccept <-
|
||||
lift $ withDB $
|
||||
case bimap fst fst ident of
|
||||
Left localID -> (() <$) <$> getBy (UniqueComponentAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueComponentAcceptRemote remoteID)
|
||||
if componentIsAuthor ident
|
||||
then
|
||||
verifyNothingE
|
||||
maybeComponentAccept
|
||||
"I've already seen a ComponentAccept* on \
|
||||
\that Add"
|
||||
else do
|
||||
fromMaybeE
|
||||
maybeComponentAccept
|
||||
"I haven't yet seen the Component's Accept on \
|
||||
\the Add"
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
)
|
||||
|
||||
inviteOrAdd
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- In component mode, verify the Component isn't already validated
|
||||
maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID
|
||||
verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add"
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ acceptDB -> do
|
||||
|
||||
maybeGrantData <-
|
||||
case comp of
|
||||
|
||||
-- In Invite-component mode, only if the Accept author is the
|
||||
-- component, record the Accept and enable the Component
|
||||
Left () ->
|
||||
lift $ if componentIsAuthor ident
|
||||
then Just <$> do
|
||||
case (ident, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptRemote remoteID acceptID
|
||||
_ -> error "personAccept impossible ii"
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
enableID <- insert $ ComponentEnable componentID grantID
|
||||
return (grantID, enableID, False)
|
||||
else pure Nothing
|
||||
|
||||
-- In Add-component mode:
|
||||
-- * If the sender is the component, record the Accept
|
||||
-- * Otherwise, record the Accept and enable the Component
|
||||
Right () ->
|
||||
lift $ if componentIsAuthor ident
|
||||
then do
|
||||
case (ident, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ ComponentAcceptRemote remoteID acceptID
|
||||
_ -> error "personAccept impossible iii"
|
||||
return Nothing
|
||||
else Just <$> do
|
||||
case acceptDB of
|
||||
Left (_, _, acceptID) ->
|
||||
insert_ $ ComponentProjectGestureLocal componentID acceptID
|
||||
Right (author, _, acceptID) ->
|
||||
insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) acceptID
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
enableID <- insert $ ComponentEnable componentID grantID
|
||||
return (grantID, enableID, True)
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = LocalActorProject projectID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
-- In Invite-component mode, only if the Accept author is
|
||||
-- the component, prepare a delegator-Grant
|
||||
--
|
||||
-- In Add-component mode, only if the Accept author isn't
|
||||
-- the component, prepare a delegator-Grant
|
||||
maybeGrant <- for maybeGrantData $ \ (grantID, enableID, includeAuthor) -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
return (recipActorID, sieve, maybeGrant)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, maybeGrant) -> do
|
||||
let recipByID = LocalActorProject projectID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "[Component mode] Forwarded the Accept and maybe published a Grant"
|
||||
|
||||
addChildParent cp = do
|
||||
|
||||
idsForAccept <-
|
||||
bitraverse
|
||||
|
||||
-- Adding-a-new-child mode
|
||||
(\ (sourceID, topic, mode) -> (sourceID,topic,) <$> bitraverse
|
||||
|
||||
-- Child-active mode
|
||||
-- Verify we haven't yet seen child's Accept
|
||||
(\ () -> do
|
||||
maybeChildAccept <-
|
||||
lift $ withDB $
|
||||
case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID)
|
||||
verifyNothingE maybeChildAccept "I already saw child's Accept"
|
||||
)
|
||||
|
||||
-- Child-passive mode
|
||||
-- Option 1: We haven't seen child's Accept yet
|
||||
-- * Verify sender is the child
|
||||
-- Option 2: We saw it, but not my collaborator's Accept
|
||||
-- * Verify the Accept is authorized
|
||||
-- Otherwise respond with error, no Accept is needed
|
||||
(\ () -> do
|
||||
(maybeChildAccept, maybeGrant) <-
|
||||
lift $ withDB $ liftA2 (,)
|
||||
(case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID)
|
||||
)
|
||||
(getBy $ UniqueSourceUsSendDelegator sourceID)
|
||||
case (isJust maybeChildAccept, isJust maybeGrant) of
|
||||
(False, True) -> error "Impossible/bug, didn't see child's Accept but sent a Grant"
|
||||
(False, False) -> do
|
||||
unless (theyIsAuthor topic) $
|
||||
throwE "The Accept I'm waiting for is from my new child"
|
||||
return $ Left ()
|
||||
(True, False) -> do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Child already enabled, not needing any further Accept"
|
||||
)
|
||||
|
||||
mode
|
||||
)
|
||||
|
||||
-- Adding-a-new-parent mode
|
||||
(\ (destID, topic, mode) -> case mode of
|
||||
|
||||
-- Parent-active mode
|
||||
-- Respond with error, we aren't supposed to get any Accept
|
||||
Left () -> throwE "Parent-active (DestOriginUs) mode, I'm not expecting any Accept"
|
||||
|
||||
-- Parent-passive mode
|
||||
-- Option 1: I haven't yet seen parent's Accept
|
||||
-- * Verify sender is the parent
|
||||
-- Option 2: I saw it, but not my collaborator's Accept
|
||||
-- * Verify the accept is authorized
|
||||
-- Otherwise respond with error, no Accept is needed
|
||||
Right themID -> (destID,themID,topic,) <$> do
|
||||
(maybeParentAccept, maybeUsGesture) <-
|
||||
lift $ withDB $ liftA2 (,)
|
||||
(case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueDestThemAcceptLocalTopic localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueDestThemAcceptRemoteTopic remoteID)
|
||||
)
|
||||
(do l <- getBy $ UniqueDestUsGestureLocal destID
|
||||
r <- getBy $ UniqueDestUsGestureRemote destID
|
||||
case (isJust l, isJust r) of
|
||||
(False, False) -> pure Nothing
|
||||
(False, True) -> pure $ Just ()
|
||||
(True, False) -> pure $ Just ()
|
||||
(True, True) -> error "Both DestUsGestureLocal and DestUsGestureRemote"
|
||||
)
|
||||
case (isJust maybeParentAccept, isJust maybeUsGesture) of
|
||||
(False, True) -> error "Impossible/bug, didn't see parent's Accept but recorded my collaborator's Accept"
|
||||
(False, False) -> do
|
||||
unless (theyIsAuthor topic) $
|
||||
throwE "The Accept I'm waiting for is from my new parent"
|
||||
return $ Left ()
|
||||
(True, False) -> do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept"
|
||||
)
|
||||
|
||||
cp
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ acceptDB -> do
|
||||
|
||||
idsForGrant <-
|
||||
bitraverse
|
||||
|
||||
-- Child mode
|
||||
(\ (sourceID, topic, mode) -> lift $ bitraverse
|
||||
|
||||
-- Child-active mode
|
||||
-- If sender is child, record the Accept into the
|
||||
-- Source record & prepare to send degelator-Grant
|
||||
-- Othrerwise do nothing
|
||||
(\ () ->
|
||||
if theyIsAuthor topic
|
||||
then Just <$> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptRemote remoteID acceptID
|
||||
_ -> error "projectAccept impossible iv"
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ SourceUsSendDelegator sourceID grantID
|
||||
return (topic, grantID)
|
||||
else pure Nothing
|
||||
)
|
||||
|
||||
-- Child-passive mode
|
||||
(\case
|
||||
|
||||
-- Getting an Accept from the child
|
||||
-- Record child's Accept in Source record
|
||||
Left () -> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptRemote remoteID acceptID
|
||||
_ -> error "projectAccept impossible v"
|
||||
return Nothing
|
||||
|
||||
-- Getting an Accept from my collaborator
|
||||
-- Record my collaborator's Accept
|
||||
-- Prepare to send delegator-Grant
|
||||
Right () -> Just <$> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptLocal localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ SourceThemAcceptRemote remoteID acceptID
|
||||
_ -> error "projectAccept impossible iv"
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ SourceUsSendDelegator sourceID grantID
|
||||
return (topic, grantID)
|
||||
)
|
||||
|
||||
mode
|
||||
)
|
||||
|
||||
-- Parent-passive mode
|
||||
(\ (destID, themID, topic, mode) -> lift $ case mode of
|
||||
|
||||
-- Getting an Accept from the parent
|
||||
-- Record parent's Accept in the Dest record
|
||||
Left () -> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ DestThemAcceptLocal themID localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ DestThemAcceptRemote themID remoteID acceptID
|
||||
_ -> error "projectAccept impossible v"
|
||||
return Nothing
|
||||
|
||||
-- Getting an Accept from my collaborator
|
||||
-- Record my collaborator's Accept in the Dest record
|
||||
-- Prepare to send my own Accept
|
||||
Right () -> Just <$> do
|
||||
case acceptDB of
|
||||
Left (_, _, acceptID) ->
|
||||
insert_ $ DestUsGestureLocal destID acceptID
|
||||
Right (author, _, acceptID) ->
|
||||
insert_ $ DestUsGestureRemote destID (remoteAuthorId author) acceptID
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ DestUsAccept destID acceptID
|
||||
return (topic, acceptID)
|
||||
)
|
||||
|
||||
idsForAccept
|
||||
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = LocalActorProject projectID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
maybeAct <-
|
||||
case idsForGrant of
|
||||
Left (Left mg) -> for mg $ \ (topic, grantID) -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareSourceDelegGrant (bimap snd snd topic) False
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
Left (Right mg) -> for mg $ \ (topic, grantID) -> lift $ do
|
||||
grant@(actionGrant, _, _, _) <-
|
||||
prepareSourceDelegGrant (bimap snd snd topic) True
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
Right ma -> for ma $ \ (topic, acceptID) -> lift $ do
|
||||
accept@(actionAccept, _, _, _) <-
|
||||
prepareDestAccept (bimap snd snd topic)
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
|
||||
return (acceptID, accept)
|
||||
|
||||
return (recipActorID, sieve, maybeAct)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, maybeGrant) -> do
|
||||
let recipByID = LocalActorProject projectID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "[Child/Parent mode] Forwarded the Accept and maybe published a Grant/Accept"
|
||||
|
||||
prepareCollabGrant isInvite sender role = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
|
|||
Loading…
Reference in a new issue