S2S: Project: Accept: Implement child/parent mode
This commit is contained in:
Pere Lev
parent
ff2c5659af
commit
bdce87cf76
2 changed files with 622 additions and 140 deletions
|
|
@ -207,7 +207,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
acceptee <- parseAccept accept
|
acceptee <- parseAccept accept
|
||||||
let muCap = AP.activityCapability $ actbActivity body
|
let muCap = AP.activityCapability $ actbActivity body
|
||||||
|
|
||||||
collabOrComp <- withDBExcept $ do
|
collabOrComp_or_child <- withDBExcept $ do
|
||||||
|
|
||||||
-- Find the accepted activity in our DB
|
-- Find the accepted activity in our DB
|
||||||
accepteeDB <- do
|
accepteeDB <- do
|
||||||
|
|
@ -221,92 +221,197 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
||||||
maybeCollab <-
|
maybeCollab <-
|
||||||
ExceptT $ fmap adapt $ runMaybeT $
|
ExceptT $ fmap adapt $ runMaybeT $
|
||||||
runExceptT (Left <$> tryInviteCollab accepteeDB) <|>
|
runExceptT (Left . Left <$> tryInviteCollab accepteeDB) <|>
|
||||||
runExceptT (Left <$> tryJoinCollab accepteeDB) <|>
|
runExceptT (Left . Left <$> tryJoinCollab accepteeDB) <|>
|
||||||
runExceptT (Right <$> tryInviteComp accepteeDB) <|>
|
runExceptT (Left . Right <$> tryInviteComp accepteeDB) <|>
|
||||||
runExceptT (Right <$> tryAddComp accepteeDB)
|
runExceptT (Left . Right <$> tryAddComp accepteeDB) <|>
|
||||||
|
runExceptT (Right <$> tryAddChildActive accepteeDB) <|>
|
||||||
|
runExceptT (Right <$> tryAddChildPassive accepteeDB) <|>
|
||||||
|
runExceptT (Right <$> tryAddParentActive accepteeDB) <|>
|
||||||
|
runExceptT (Right <$> tryAddParentPassive accepteeDB)
|
||||||
fromMaybeE
|
fromMaybeE
|
||||||
maybeCollab
|
maybeCollab
|
||||||
"Accepted activity isn't an Invite/Join/Add I'm aware of"
|
"Accepted activity isn't an Invite/Join/Add I'm aware of"
|
||||||
|
|
||||||
idsForAccept <- bitraverse
|
idsForAccept <- bitraverse
|
||||||
|
|
||||||
(\ (collabID, fulfills, inviterOrJoiner) -> (collabID,inviterOrJoiner,) <$> bitraverse
|
(bitraverse
|
||||||
|
|
||||||
-- If accepting an Invite, find the Collab recipient and verify
|
(\ (collabID, fulfills, inviterOrJoiner) -> (collabID,inviterOrJoiner,) <$> bitraverse
|
||||||
-- it's the sender of the Accept
|
|
||||||
(\ fulfillsID -> withDBExcept $ do
|
-- If accepting an Invite, find the Collab recipient and verify
|
||||||
recip <-
|
-- it's the sender of the Accept
|
||||||
lift $
|
(\ fulfillsID -> withDBExcept $ do
|
||||||
requireEitherAlt
|
recip <-
|
||||||
(getBy $ UniqueCollabRecipLocal collabID)
|
lift $
|
||||||
(getBy $ UniqueCollabRecipRemote collabID)
|
requireEitherAlt
|
||||||
"Found Collab with no recip"
|
(getBy $ UniqueCollabRecipLocal collabID)
|
||||||
"Found Collab with multiple recips"
|
(getBy $ UniqueCollabRecipRemote collabID)
|
||||||
case (recip, authorIdMsig) of
|
"Found Collab with no recip"
|
||||||
(Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
|
"Found Collab with multiple recips"
|
||||||
| collabRecipLocalPerson crl == personID ->
|
case (recip, authorIdMsig) of
|
||||||
return (fulfillsID, Left crlid)
|
(Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
|
||||||
(Right (Entity crrid crr), Right (author, _, _))
|
| collabRecipLocalPerson crl == personID ->
|
||||||
| collabRecipRemoteActor crr == remoteAuthorId author ->
|
return (fulfillsID, Left crlid)
|
||||||
return (fulfillsID, Right crrid)
|
(Right (Entity crrid crr), Right (author, _, _))
|
||||||
_ -> throwE "Accepting an Invite whose recipient is someone else"
|
| 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
|
||||||
)
|
)
|
||||||
|
|
||||||
-- If accepting a Join, verify accepter has permission
|
(\ (componentID, ident, inviteOrAdd) -> (componentID, ident,) <$> bitraverse
|
||||||
(\ fulfillsID -> do
|
|
||||||
uCap <- fromMaybeE muCap "No capability provided"
|
-- If accepting an Invite-component, there's nothing to check
|
||||||
verifyCapability''
|
-- at this point
|
||||||
uCap
|
pure
|
||||||
authorIdMsig
|
|
||||||
(LocalActorProject projectID)
|
-- If accepting an Add-component:
|
||||||
AP.RoleAdmin
|
-- * If the sender is the component, verify I haven't seen
|
||||||
return fulfillsID
|
-- 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
|
||||||
)
|
)
|
||||||
|
|
||||||
fulfills
|
|
||||||
)
|
)
|
||||||
|
|
||||||
(\ (componentID, ident, inviteOrAdd) -> (componentID, ident,) <$> bitraverse
|
-- Child/Parent mode
|
||||||
|
(bitraverse
|
||||||
|
|
||||||
-- If accepting an Invite-component, there's nothing to check
|
-- Adding-a-new-child mode
|
||||||
-- at this point
|
(\ (sourceID, topic, mode) -> (sourceID,topic,) <$> bitraverse
|
||||||
pure
|
|
||||||
|
|
||||||
-- If accepting an Add-component:
|
-- Child-active mode
|
||||||
-- * If the sender is the component, verify I haven't seen
|
-- Verify we haven't yet seen child's Accept
|
||||||
-- a component-Accept on this Add
|
(\ () -> do
|
||||||
-- * Otherwise, verify I've seen the component-Accept for
|
maybeChildAccept <-
|
||||||
-- this Add and that the new Accept is authorized
|
lift $ withDB $
|
||||||
(\ () -> do
|
case bimap fst fst topic of
|
||||||
maybeComponentAccept <-
|
Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID)
|
||||||
lift $ withDB $
|
Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID)
|
||||||
case bimap fst fst ident of
|
verifyNothingE maybeChildAccept "I already saw child's Accept"
|
||||||
Left localID -> (() <$) <$> getBy (UniqueComponentAcceptLocal localID)
|
)
|
||||||
Right remoteID -> (() <$) <$> getBy (UniqueComponentAcceptRemote remoteID)
|
|
||||||
if componentIsAuthor ident
|
-- Child-passive mode
|
||||||
then
|
-- Option 1: We haven't seen child's Accept yet
|
||||||
verifyNothingE
|
-- * Verify sender is the child
|
||||||
maybeComponentAccept
|
-- Option 2: We saw it, but not my collaborator's Accept
|
||||||
"I've already seen a ComponentAccept* on \
|
-- * Verify the Accept is authorized
|
||||||
\that Add"
|
-- Otherwise respond with error, no Accept is needed
|
||||||
else do
|
(\ () -> do
|
||||||
fromMaybeE
|
(maybeChildAccept, maybeGrant) <-
|
||||||
maybeComponentAccept
|
lift $ withDB $ liftA2 (,)
|
||||||
"I haven't yet seen the Component's Accept on \
|
(case bimap fst fst topic of
|
||||||
\the Add"
|
Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID)
|
||||||
uCap <- fromMaybeE muCap "No capability provided"
|
Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID)
|
||||||
verifyCapability''
|
)
|
||||||
uCap
|
(getBy $ UniqueSourceUsSendDelegator sourceID)
|
||||||
authorIdMsig
|
case (isJust maybeChildAccept, isJust maybeGrant) of
|
||||||
(LocalActorProject projectID)
|
(False, True) -> error "Impossible/bug, didn't see child's Accept but sent a Grant"
|
||||||
AP.RoleAdmin
|
(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
|
||||||
)
|
)
|
||||||
|
|
||||||
inviteOrAdd
|
-- 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
|
collabOrComp_or_child
|
||||||
|
|
||||||
maybeNew <- withDBExcept $ do
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
|
@ -318,84 +423,180 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
|
|
||||||
-- In collab mode, verify the Collab isn't already validated
|
-- In collab mode, verify the Collab isn't already validated
|
||||||
-- In component mode, verify the Component 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
|
(bitraverse_
|
||||||
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
|
(\ (collabID, _, _) -> do
|
||||||
verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
|
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"
|
||||||
|
)
|
||||||
)
|
)
|
||||||
(\ (componentID, _, _) -> do
|
pure
|
||||||
maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID
|
collabOrComp_or_child
|
||||||
verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add"
|
|
||||||
)
|
|
||||||
collabOrComp
|
|
||||||
|
|
||||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||||
for maybeAcceptDB $ \ acceptDB -> do
|
for maybeAcceptDB $ \ acceptDB -> do
|
||||||
|
|
||||||
idsForGrant <- case idsForAccept of
|
idsForGrant <-
|
||||||
|
bitraverse
|
||||||
|
|
||||||
-- In collab mode, record the Accept and enable the Collab
|
(\case
|
||||||
Left (collabID, inviterOrJoiner, collab) -> Left <$> do
|
-- In collab mode, record the Accept and enable the Collab
|
||||||
case (collab, acceptDB) of
|
Left (collabID, inviterOrJoiner, collab) -> Left <$> do
|
||||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
case (collab, acceptDB) of
|
||||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||||
unless (isJust maybeAccept) $
|
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||||
throwE "This Invite already has an Accept by recip"
|
unless (isJust maybeAccept) $
|
||||||
(Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
|
throwE "This Invite already has an Accept by recip"
|
||||||
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
(Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
|
||||||
unless (isJust maybeAccept) $
|
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
||||||
throwE "This Invite already has an Accept by recip"
|
unless (isJust maybeAccept) $
|
||||||
(Right fulfillsID, Left (_, _, acceptID)) -> do
|
throwE "This Invite already has an Accept by recip"
|
||||||
maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID
|
(Right fulfillsID, Left (_, _, acceptID)) -> do
|
||||||
unless (isJust maybeAccept) $
|
maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID
|
||||||
throwE "This Join already has an Accept"
|
unless (isJust maybeAccept) $
|
||||||
(Right fulfillsID, Right (author, _, acceptID)) -> do
|
throwE "This Join already has an Accept"
|
||||||
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
|
(Right fulfillsID, Right (author, _, acceptID)) -> do
|
||||||
unless (isJust maybeAccept) $
|
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
|
||||||
throwE "This Join already has an Accept"
|
unless (isJust maybeAccept) $
|
||||||
_ -> error "projectAccept impossible"
|
throwE "This Join already has an Accept"
|
||||||
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
_ -> error "projectAccept impossible"
|
||||||
enableID <- lift $ insert $ CollabEnable collabID grantID
|
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
return (collabID, inviterOrJoiner, collab, grantID, enableID)
|
enableID <- lift $ insert $ CollabEnable collabID grantID
|
||||||
|
return (collabID, inviterOrJoiner, collab, grantID, enableID)
|
||||||
|
|
||||||
-- In Invite-component mode, only if the Accept author is the
|
-- In Invite-component mode, only if the Accept author is the
|
||||||
-- component, record the Accept and enable the Component
|
-- component, record the Accept and enable the Component
|
||||||
Right (componentID, ident, Left ()) -> fmap Right $
|
Right (componentID, ident, Left ()) -> fmap Right $
|
||||||
lift $ if componentIsAuthor ident
|
lift $ if componentIsAuthor ident
|
||||||
then Just <$> do
|
then Just <$> do
|
||||||
case (ident, acceptDB) of
|
case (ident, acceptDB) of
|
||||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||||
insert_ $ ComponentAcceptLocal localID acceptID
|
insert_ $ ComponentAcceptLocal localID acceptID
|
||||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||||
insert_ $ ComponentAcceptRemote remoteID acceptID
|
insert_ $ ComponentAcceptRemote remoteID acceptID
|
||||||
_ -> error "personAccept impossible ii"
|
_ -> error "personAccept impossible ii"
|
||||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
enableID <- insert $ ComponentEnable componentID grantID
|
enableID <- insert $ ComponentEnable componentID grantID
|
||||||
return (componentID, ident, grantID, enableID, False)
|
return (componentID, ident, grantID, enableID, False)
|
||||||
else pure Nothing
|
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
|
||||||
|
|
||||||
-- 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)
|
|
||||||
|
|
||||||
-- Prepare forwarding of Accept to my followers
|
-- Prepare forwarding of Accept to my followers
|
||||||
let recipByID = LocalActorProject projectID
|
let recipByID = LocalActorProject projectID
|
||||||
|
|
@ -406,7 +607,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
case idsForGrant of
|
case idsForGrant of
|
||||||
|
|
||||||
-- In collab mode, prepare a regular Grant
|
-- In collab mode, prepare a regular Grant
|
||||||
Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID) -> lift $ do
|
Left (Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID)) -> lift $ do
|
||||||
let isInvite = isLeft collab
|
let isInvite = isLeft collab
|
||||||
grant@(actionGrant, _, _, _) <- do
|
grant@(actionGrant, _, _, _) <- do
|
||||||
Collab role <- getJust collabID
|
Collab role <- getJust collabID
|
||||||
|
|
@ -420,13 +621,36 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
--
|
--
|
||||||
-- In Add-component mode, only if the Accept author isn't
|
-- In Add-component mode, only if the Accept author isn't
|
||||||
-- the component, prepare a delegator-Grant
|
-- the component, prepare a delegator-Grant
|
||||||
Right comp -> for comp $ \ (_componentID, ident, grantID, enableID, includeAuthor) -> lift $ do
|
Left (Right comp) -> for comp $ \ (_componentID, ident, grantID, enableID, includeAuthor) -> lift $ do
|
||||||
grant@(actionGrant, _, _, _) <-
|
grant@(actionGrant, _, _, _) <-
|
||||||
prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
|
prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
|
||||||
let recipByKey = LocalActorProject projectID
|
let recipByKey = LocalActorProject projectID
|
||||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||||
return (grantID, grant)
|
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)
|
return (recipActorID, sieve, maybeGrant)
|
||||||
|
|
||||||
case maybeNew of
|
case maybeNew of
|
||||||
|
|
@ -438,7 +662,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
sendActivity
|
sendActivity
|
||||||
recipByID recipActorID localRecipsGrant
|
recipByID recipActorID localRecipsGrant
|
||||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||||
done "Forwarded the Accept and maybe published a Grant"
|
done "Forwarded the Accept and maybe published a Grant/Accept"
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -533,10 +757,125 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
ident <- lift $ lift $ getComponentIdent componentID
|
ident <- lift $ lift $ getComponentIdent componentID
|
||||||
return (componentID, ident, Right ())
|
return (componentID, ident, Right ())
|
||||||
|
|
||||||
|
verifySourceHolder :: SourceId -> ActDBE ()
|
||||||
|
verifySourceHolder sourceID = do
|
||||||
|
mh <- lift $ getValBy $ UniqueSourceHolderProject sourceID
|
||||||
|
case mh of
|
||||||
|
Just (SourceHolderProject _ j) | j == projectID -> pure ()
|
||||||
|
_ -> throwE "Accept object is an Add for some other project/team"
|
||||||
|
|
||||||
|
tryAddChildActive' usID = do
|
||||||
|
SourceOriginUs sourceID <- lift . lift $ getJust usID
|
||||||
|
ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID
|
||||||
|
topic <- do
|
||||||
|
t <- lift . lift $ getSourceTopic sourceID
|
||||||
|
bitraverse
|
||||||
|
(\ (l, k) ->
|
||||||
|
case k of
|
||||||
|
Left j -> pure (l, j)
|
||||||
|
Right _ -> error "Project Source topic is a Group, impossible"
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
t
|
||||||
|
return $ Left (sourceID, topic, Left ())
|
||||||
|
|
||||||
|
tryAddChildActive (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||||
|
SourceUsGestureLocal usID _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueSourceUsGestureLocalAdd itemID
|
||||||
|
tryAddChildActive' usID
|
||||||
|
tryAddChildActive (Right remoteActivityID) = do
|
||||||
|
SourceUsGestureRemote usID _ _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueSourceUsGestureRemoteAdd remoteActivityID
|
||||||
|
tryAddChildActive' usID
|
||||||
|
|
||||||
|
tryAddChildPassive' themID = do
|
||||||
|
SourceOriginThem sourceID <- lift . lift $ getJust themID
|
||||||
|
ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID
|
||||||
|
topic <- do
|
||||||
|
t <- lift . lift $ getSourceTopic sourceID
|
||||||
|
bitraverse
|
||||||
|
(\ (l, k) ->
|
||||||
|
case k of
|
||||||
|
Left j -> pure (l, j)
|
||||||
|
Right _ -> error "Project Source topic is a Group, impossible"
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
t
|
||||||
|
return $ Left (sourceID, topic, Right ())
|
||||||
|
|
||||||
|
tryAddChildPassive (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||||
|
SourceThemGestureLocal themID _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueSourceThemGestureLocalAdd itemID
|
||||||
|
tryAddChildPassive' themID
|
||||||
|
tryAddChildPassive (Right remoteActivityID) = do
|
||||||
|
SourceThemGestureRemote themID _ _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueSourceThemGestureRemoteAdd remoteActivityID
|
||||||
|
tryAddChildPassive' themID
|
||||||
|
|
||||||
|
verifyDestHolder :: DestId -> ActDBE ()
|
||||||
|
verifyDestHolder destID = do
|
||||||
|
mh <- lift $ getValBy $ UniqueDestHolderProject destID
|
||||||
|
case mh of
|
||||||
|
Just (DestHolderProject _ j) | j == projectID -> pure ()
|
||||||
|
_ -> throwE "Accept object is an Add for some other project/team"
|
||||||
|
|
||||||
|
tryAddParentActive' destID = do
|
||||||
|
usID <- lift $ MaybeT $ getKeyBy $ UniqueDestOriginUs destID
|
||||||
|
ExceptT $ lift $ runExceptT $ verifyDestHolder destID
|
||||||
|
topic <- do
|
||||||
|
t <- lift . lift $ getDestTopic destID
|
||||||
|
bitraverse
|
||||||
|
(\ (l, k) ->
|
||||||
|
case k of
|
||||||
|
Left j -> pure (l, j)
|
||||||
|
Right _ -> error "Project Dest topic is a Group, impossible"
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
t
|
||||||
|
return $ Right (destID, topic, Left ())
|
||||||
|
|
||||||
|
tryAddParentActive (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||||
|
DestUsGestureLocal destID _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueDestUsGestureLocalActivity itemID
|
||||||
|
tryAddParentActive' destID
|
||||||
|
tryAddParentActive (Right remoteActivityID) = do
|
||||||
|
DestUsGestureRemote destID _ _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueDestUsGestureRemoteActivity remoteActivityID
|
||||||
|
tryAddParentActive' destID
|
||||||
|
|
||||||
|
tryAddParentPassive' themID = do
|
||||||
|
DestOriginThem destID <- lift . lift $ getJust themID
|
||||||
|
ExceptT $ lift $ runExceptT $ verifyDestHolder destID
|
||||||
|
topic <- do
|
||||||
|
t <- lift . lift $ getDestTopic destID
|
||||||
|
bitraverse
|
||||||
|
(\ (l, k) ->
|
||||||
|
case k of
|
||||||
|
Left j -> pure (l, j)
|
||||||
|
Right _ -> error "Project Dest topic is a Group, impossible"
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
t
|
||||||
|
return $ Right (destID, topic, Right themID)
|
||||||
|
|
||||||
|
tryAddParentPassive (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||||
|
DestThemGestureLocal themID _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueDestThemGestureLocalAdd itemID
|
||||||
|
tryAddParentPassive' themID
|
||||||
|
tryAddParentPassive (Right remoteActivityID) = do
|
||||||
|
DestThemGestureRemote themID _ _ <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd remoteActivityID
|
||||||
|
tryAddParentPassive' themID
|
||||||
|
|
||||||
componentIsAuthor ident =
|
componentIsAuthor ident =
|
||||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||||
in author == bimap (componentActor . snd) snd ident
|
in author == bimap (componentActor . snd) snd ident
|
||||||
|
|
||||||
|
theyIsAuthor :: Either (a, ProjectId) (b, RemoteActorId) -> Bool
|
||||||
|
theyIsAuthor ident =
|
||||||
|
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||||
|
in author == bimap (LocalActorProject . snd) snd ident
|
||||||
|
|
||||||
prepareCollabGrant isInvite sender role = do
|
prepareCollabGrant isInvite sender role = do
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
@ -650,6 +989,95 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
prepareSourceDelegGrant ident includeAuthor = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
(uSource, audSource) <-
|
||||||
|
case ident of
|
||||||
|
Left j -> do
|
||||||
|
h <- encodeKeyHashid j
|
||||||
|
return
|
||||||
|
( encodeRouteHome $ ProjectR h
|
||||||
|
, AudLocal [LocalActorProject h] [LocalStageProjectFollowers h]
|
||||||
|
)
|
||||||
|
Right raID -> do
|
||||||
|
ra <- getJust raID
|
||||||
|
u@(ObjURI h lu) <- getRemoteActorURI ra
|
||||||
|
return
|
||||||
|
( u
|
||||||
|
, AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||||
|
)
|
||||||
|
audAuthor <- lift $ makeAudSenderOnly authorIdMsig
|
||||||
|
projectHash <- encodeKeyHashid projectID
|
||||||
|
let audProject = AudLocal [] [LocalStageProjectFollowers projectHash]
|
||||||
|
|
||||||
|
audience =
|
||||||
|
if includeAuthor
|
||||||
|
then [audSource, audProject, audAuthor]
|
||||||
|
else [audSource, audProject]
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience audience
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [AP.acceptObject accept]
|
||||||
|
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||||
|
{ AP.grantObject = AP.RXDelegator
|
||||||
|
, AP.grantContext = encodeRouteHome $ ProjectR projectHash
|
||||||
|
, AP.grantTarget = uSource
|
||||||
|
, AP.grantResult = Nothing
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.Invoke
|
||||||
|
, AP.grantDelegates = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
prepareDestAccept topic = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
|
||||||
|
audMyCollab <- lift $ makeAudSenderOnly authorIdMsig
|
||||||
|
audDest <-
|
||||||
|
case topic of
|
||||||
|
Left j -> do
|
||||||
|
h <- encodeKeyHashid j
|
||||||
|
return $
|
||||||
|
AudLocal [LocalActorProject h] [LocalStageProjectFollowers h]
|
||||||
|
Right raID -> do
|
||||||
|
ra <- getJust raID
|
||||||
|
ObjURI h lu <- getRemoteActorURI ra
|
||||||
|
return $
|
||||||
|
AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||||
|
audMe <-
|
||||||
|
AudLocal [] . pure . LocalStageProjectFollowers <$>
|
||||||
|
encodeKeyHashid projectID
|
||||||
|
uCollabAccept <- lift $ getActivityURI authorIdMsig
|
||||||
|
let uAdd = AP.acceptObject accept
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience [audMyCollab, audDest, audMe]
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [uCollabAccept]
|
||||||
|
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||||
|
{ AP.acceptObject = uAdd
|
||||||
|
, AP.acceptResult = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
checkExistingComponents
|
checkExistingComponents
|
||||||
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
|
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
|
||||||
checkExistingComponents projectID componentDB = do
|
checkExistingComponents projectID componentDB = do
|
||||||
|
|
|
||||||
|
|
@ -33,6 +33,8 @@ module Vervis.Persist.Collab
|
||||||
, getGrant
|
, getGrant
|
||||||
|
|
||||||
, getComponentIdent
|
, getComponentIdent
|
||||||
|
, getSourceTopic
|
||||||
|
, getDestTopic
|
||||||
|
|
||||||
, checkExistingStems
|
, checkExistingStems
|
||||||
, checkExistingPermits
|
, checkExistingPermits
|
||||||
|
|
@ -486,6 +488,58 @@ getComponentIdent componentID = do
|
||||||
(\ (Entity k v) -> pure (k, componentRemoteActor v))
|
(\ (Entity k v) -> pure (k, componentRemoteActor v))
|
||||||
ident
|
ident
|
||||||
|
|
||||||
|
getSourceTopic
|
||||||
|
:: MonadIO m
|
||||||
|
=> SourceId
|
||||||
|
-> ReaderT SqlBackend m
|
||||||
|
(Either
|
||||||
|
(SourceTopicLocalId, Either ProjectId GroupId)
|
||||||
|
(SourceTopicRemoteId, RemoteActorId)
|
||||||
|
)
|
||||||
|
getSourceTopic sourceID = do
|
||||||
|
ident <-
|
||||||
|
requireEitherAlt
|
||||||
|
(getKeyBy $ UniqueSourceTopicLocal sourceID)
|
||||||
|
(getBy $ UniqueSourceTopicRemote sourceID)
|
||||||
|
"Found Source without topic"
|
||||||
|
"Found Source with both local and remote topic"
|
||||||
|
bitraverse
|
||||||
|
(\ localID -> (localID,) <$> do
|
||||||
|
requireEitherAlt
|
||||||
|
(fmap sourceTopicProjectChild <$> getValBy (UniqueSourceTopicProjectTopic localID))
|
||||||
|
(fmap sourceTopicGroupParent <$> getValBy (UniqueSourceTopicGroupTopic localID))
|
||||||
|
"Found SourceTopicLocal without topic"
|
||||||
|
"Found SourceTopicLocal with multiple topics"
|
||||||
|
)
|
||||||
|
(\ (Entity k v) -> pure (k, sourceTopicRemoteTopic v))
|
||||||
|
ident
|
||||||
|
|
||||||
|
getDestTopic
|
||||||
|
:: MonadIO m
|
||||||
|
=> DestId
|
||||||
|
-> ReaderT SqlBackend m
|
||||||
|
(Either
|
||||||
|
(DestTopicLocalId, Either ProjectId GroupId)
|
||||||
|
(DestTopicRemoteId, RemoteActorId)
|
||||||
|
)
|
||||||
|
getDestTopic destID = do
|
||||||
|
ident <-
|
||||||
|
requireEitherAlt
|
||||||
|
(getKeyBy $ UniqueDestTopicLocal destID)
|
||||||
|
(getBy $ UniqueDestTopicRemote destID)
|
||||||
|
"Found Dest without topic"
|
||||||
|
"Found Dest with both local and remote topic"
|
||||||
|
bitraverse
|
||||||
|
(\ localID -> (localID,) <$> do
|
||||||
|
requireEitherAlt
|
||||||
|
(fmap destTopicProjectParent <$> getValBy (UniqueDestTopicProjectTopic localID))
|
||||||
|
(fmap destTopicGroupChild <$> getValBy (UniqueDestTopicGroupTopic localID))
|
||||||
|
"Found DestTopicLocal without topic"
|
||||||
|
"Found DestTopicLocal with multiple topics"
|
||||||
|
)
|
||||||
|
(\ (Entity k v) -> pure (k, destTopicRemoteTopic v))
|
||||||
|
ident
|
||||||
|
|
||||||
checkExistingStems
|
checkExistingStems
|
||||||
:: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
|
:: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
|
||||||
checkExistingStems componentByID projectDB = do
|
checkExistingStems componentByID projectDB = do
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue