S2S: Deck Accept handler: Implement component mode
This commit is contained in:
Pere Lev
parent
e8970c1f4a
commit
9a78c83233
3 changed files with 408 additions and 125 deletions
|
|
@ -193,21 +193,54 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor accepted something
|
||||
-- Behavior:
|
||||
-- * If it's on an Invite where I'm the resource:
|
||||
-- * Verify the Accept is by the Invite target
|
||||
-- * Forward the Accept to my followers
|
||||
-- * Send a Grant:
|
||||
-- * To: Accepter (i.e. Invite target)
|
||||
-- * CC: Invite sender, Accepter's followers, my followers
|
||||
-- * If it's on a Join where I'm the resource:
|
||||
-- * Verify the Accept is authorized
|
||||
-- * Forward the Accept to my followers
|
||||
-- * Send a Grant:
|
||||
-- * To: Join sender
|
||||
-- * CC: Accept sender, Join sender's followers, my followers
|
||||
-- * If it's an Invite (that I know about) where I'm invited to a project:
|
||||
-- * If I haven't yet seen the project's approval:
|
||||
-- * Verify the author is the project
|
||||
-- * Record the approval in the Stem record in DB
|
||||
-- * If I saw project's approval, but not my collaborators' approval:
|
||||
-- * Verify the Accept is authorized
|
||||
-- * Record the approval in the Stem record in DB
|
||||
-- * Forward to my followers
|
||||
-- * Publish and send an Accept:
|
||||
-- * To: Inviter, project, Accept author
|
||||
-- * CC: Project followers, my followers
|
||||
-- * Record it in the Stem record in DB as well
|
||||
-- * If I already saw both approvals, respond with error
|
||||
-- * If it's an Add (that I know about and already Accepted) where I'm
|
||||
-- invited to a project:
|
||||
-- * If I've already seen the project's accept, respond with error
|
||||
-- * Otherwise, just ignore the Accept
|
||||
-- * Otherwise respond with error
|
||||
topicAccept
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> GrantResourceBy f)
|
||||
-> (forall f. f topic -> ComponentBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) accept = do
|
||||
topicAccept topicActor topicResource topicComponent now recipKey (Verse authorIdMsig body) accept = do
|
||||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- Verify the capability URI, if provided, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCap <-
|
||||
|
|
@ -215,13 +248,13 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
|
|||
(nameExceptT "Accept capability" . parseActivityURI')
|
||||
(AP.activityCapability $ actbActivity body)
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ withDB $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
collabOrStem <- withDBExcept $ do
|
||||
|
||||
-- Find the accepted activity in our DB
|
||||
accepteeDB <- do
|
||||
|
|
@ -230,126 +263,28 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
|
|||
|
||||
-- See if the accepted activity is an Invite or Join to a local
|
||||
-- resource, grabbing the Collab record from our DB
|
||||
collab <- do
|
||||
maybeCollab <-
|
||||
lift $ runMaybeT $
|
||||
Left <$> tryInvite accepteeDB <|>
|
||||
Right <$> tryJoin accepteeDB
|
||||
fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"
|
||||
-- See if the accepted activity is an Invite or Add on a local
|
||||
-- component, grabbing the Stem record from our DB
|
||||
maybeCollabOrStem <-
|
||||
lift $ runMaybeT $
|
||||
Left . Left <$> tryInviteCollab accepteeDB <|>
|
||||
Left . Right <$> tryJoinCollab accepteeDB <|>
|
||||
Right . Left <$> tryInviteComp accepteeDB <|>
|
||||
Right . Right <$> tryAddComp accepteeDB
|
||||
fromMaybeE maybeCollabOrStem "Accepted activity isn't an Invite/Join/Add I'm aware of"
|
||||
|
||||
-- Find the local resource and verify it's me
|
||||
collabID <-
|
||||
lift $ case collab of
|
||||
Left (fulfillsID, _) ->
|
||||
collabFulfillsInviteCollab <$> getJust fulfillsID
|
||||
Right (fulfillsID, _) ->
|
||||
collabFulfillsJoinCollab <$> getJust fulfillsID
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (topicResource recipKey == topic) $
|
||||
throwE "Accept object is an Invite/Join for some other resource"
|
||||
|
||||
idsForAccept <-
|
||||
case collab of
|
||||
|
||||
-- If accepting an Invite, find the Collab recipient and verify
|
||||
-- it's the sender of the Accept
|
||||
Left (fulfillsID, _) -> Left <$> 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
|
||||
Right (fulfillsID, _) -> Right <$> do
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
capability <-
|
||||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
|
||||
verifyCapability'
|
||||
capability
|
||||
authorIdMsig
|
||||
(topicResource recipKey)
|
||||
AP.RoleAdmin
|
||||
return fulfillsID
|
||||
|
||||
-- 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 on the Collab
|
||||
case (idsForAccept, acceptDB) of
|
||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||
unless (isNothing 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 "topicAccept impossible"
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
grantInfo <- do
|
||||
|
||||
-- Enable the Collab in our DB
|
||||
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
lift $ insert_ $ CollabEnable collabID grantID
|
||||
|
||||
-- Prepare a Grant activity and insert to my outbox
|
||||
let inviterOrJoiner = either snd snd collab
|
||||
isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- do
|
||||
Collab role <- lift $ getJust collabID
|
||||
lift $ prepareGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
return (recipActorID, sieve, grantInfo)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "Forwarded the Accept and published a Grant"
|
||||
case collabOrStem of
|
||||
Left collab ->
|
||||
topicAcceptCollab maybeCap recipActorID recipActor collab
|
||||
Right stem ->
|
||||
topicAcceptStem maybeCap recipActorID recipActor stem
|
||||
|
||||
where
|
||||
|
||||
tryInvite (Left (actorByKey, _actorEntity, itemID)) =
|
||||
tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) =
|
||||
(,Left actorByKey) . collabInviterLocalCollab <$>
|
||||
MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
|
||||
tryInvite (Right remoteActivityID) = do
|
||||
tryInviteCollab (Right remoteActivityID) = do
|
||||
CollabInviterRemote collab actorID _ <-
|
||||
MaybeT $ getValBy $
|
||||
UniqueCollabInviterRemoteInvite remoteActivityID
|
||||
|
|
@ -358,10 +293,10 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
|
|||
lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
|
||||
return (collab, Right sender)
|
||||
|
||||
tryJoin (Left (actorByKey, _actorEntity, itemID)) =
|
||||
tryJoinCollab (Left (actorByKey, _actorEntity, itemID)) =
|
||||
(,Left actorByKey) . collabRecipLocalJoinFulfills <$>
|
||||
MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
|
||||
tryJoin (Right remoteActivityID) = do
|
||||
tryJoinCollab (Right remoteActivityID) = do
|
||||
CollabRecipRemoteJoin recipID fulfillsID _ <-
|
||||
MaybeT $ getValBy $
|
||||
UniqueCollabRecipRemoteJoinJoin remoteActivityID
|
||||
|
|
@ -371,6 +306,33 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
|
|||
lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
|
||||
return (fulfillsID, Right joiner)
|
||||
|
||||
tryInviteComp (Left (actorByKey, _actorEntity, itemID)) =
|
||||
(,Left (actorByKey, itemID)) . stemProjectGestureLocalOrigin <$>
|
||||
MaybeT (getValBy $ UniqueStemProjectGestureLocalInvite itemID)
|
||||
tryInviteComp (Right remoteActivityID) = do
|
||||
StemProjectGestureRemote originID actorID _ <-
|
||||
MaybeT $ getValBy $
|
||||
UniqueStemProjectGestureRemoteInvite remoteActivityID
|
||||
actor <- lift $ getJust actorID
|
||||
inviter <-
|
||||
lift $ (,remoteActorFollowers actor, remoteActivityID) <$> getRemoteActorURI actor
|
||||
return (originID, Right inviter)
|
||||
|
||||
tryAddComp (Left (actorByKey, _actorEntity, itemID)) = do
|
||||
StemComponentGestureLocal stemID _ <-
|
||||
MaybeT $ getValBy $ UniqueStemComponentGestureLocalActivity itemID
|
||||
originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID
|
||||
return (stemID, originID, Left (actorByKey, itemID))
|
||||
tryAddComp (Right remoteActivityID) = do
|
||||
StemComponentGestureRemote stemID actorID _ <-
|
||||
MaybeT $ getValBy $
|
||||
UniqueStemComponentGestureRemoteActivity remoteActivityID
|
||||
originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID
|
||||
actor <- lift $ getJust actorID
|
||||
adder <-
|
||||
lift $ (,remoteActorFollowers actor,remoteActivityID) <$> getRemoteActorURI actor
|
||||
return (stemID, originID, Right adder)
|
||||
|
||||
prepareGrant isInvite sender role = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -433,6 +395,296 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
topicAcceptCollab maybeCap recipActorID recipActor collab = do
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Find the local resource and verify it's me
|
||||
collabID <-
|
||||
lift $ case collab of
|
||||
Left (fulfillsID, _) ->
|
||||
collabFulfillsInviteCollab <$> getJust fulfillsID
|
||||
Right (fulfillsID, _) ->
|
||||
collabFulfillsJoinCollab <$> getJust fulfillsID
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (topicResource recipKey == topic) $
|
||||
throwE "Accept object is an Invite/Join for some other resource"
|
||||
|
||||
idsForAccept <-
|
||||
case collab of
|
||||
|
||||
-- If accepting an Invite, find the Collab recipient and verify
|
||||
-- it's the sender of the Accept
|
||||
Left (fulfillsID, _) -> Left <$> 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
|
||||
Right (fulfillsID, _) -> Right <$> do
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
capability <-
|
||||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
|
||||
verifyCapability'
|
||||
capability
|
||||
authorIdMsig
|
||||
(topicResource recipKey)
|
||||
AP.RoleAdmin
|
||||
return fulfillsID
|
||||
|
||||
-- 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 on the Collab
|
||||
case (idsForAccept, acceptDB) of
|
||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||
unless (isNothing 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 "topicAccept impossible"
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
grantInfo <- do
|
||||
|
||||
-- Enable the Collab in our DB
|
||||
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
lift $ insert_ $ CollabEnable collabID grantID
|
||||
|
||||
-- Prepare a Grant activity and insert to my outbox
|
||||
let inviterOrJoiner = either snd snd collab
|
||||
isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- do
|
||||
Collab role <- lift $ getJust collabID
|
||||
lift $ prepareGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
return (recipActorID, sieve, grantInfo)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "Forwarded the Accept and published a Grant"
|
||||
|
||||
prepareReact project inviter = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
(audInviter, uInvite) <-
|
||||
case inviter of
|
||||
Left (byKey, itemID) -> do
|
||||
byHash <- hashLocalActor byKey
|
||||
itemHash <- encodeKeyHashid itemID
|
||||
return
|
||||
( AudLocal [byHash] []
|
||||
, encodeRouteHome $ activityRoute byHash itemHash
|
||||
)
|
||||
Right (ObjURI h lu, _followers, activityID) -> do
|
||||
objectID <- remoteActivityIdent <$> getJust activityID
|
||||
luAct <- remoteObjectIdent <$> getJust objectID
|
||||
return (AudRemote h [lu] [], ObjURI h luAct)
|
||||
audProject <-
|
||||
case project of
|
||||
Left (Entity _ (StemProjectLocal _ projectID)) -> do
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
return $
|
||||
AudLocal
|
||||
[LocalActorProject projectHash]
|
||||
[LocalStageProjectFollowers projectHash]
|
||||
Right (Entity _ (StemProjectRemote _ actorID)) -> do
|
||||
actor <- getJust actorID
|
||||
ObjURI h lu <- getRemoteActorURI actor
|
||||
let followers = remoteActorFollowers actor
|
||||
return $ AudRemote h [lu] (maybeToList followers)
|
||||
audAccepter <- lift $ makeAudSenderOnly authorIdMsig
|
||||
audMe <-
|
||||
AudLocal [] . pure . localActorFollowers .
|
||||
grantResourceLocalActor . topicResource <$>
|
||||
encodeKeyHashid recipKey
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audInviter, audProject, audAccepter, audMe]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uInvite
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
topicAcceptStem maybeCap recipActorID recipActor stem = do
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Find the local component and verify it's me
|
||||
stemID <-
|
||||
lift $ case stem of
|
||||
Left (originInviteID, _inviter) ->
|
||||
stemOriginInviteStem <$> getJust originInviteID
|
||||
Right (stemID, _originAddID, _adder) ->
|
||||
return stemID
|
||||
ident <- lift $ getStemIdent stemID
|
||||
unless (topicComponent recipKey == ident) $
|
||||
throwE "Accept object is an Invite/Add for some other component"
|
||||
|
||||
project <-
|
||||
lift $
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueStemProjectLocal stemID)
|
||||
(getBy $ UniqueStemProjectRemote stemID)
|
||||
"Found Stem with no project"
|
||||
"Found Stem with multiple projects"
|
||||
|
||||
idsForLater <- bitraverse
|
||||
|
||||
-- Accepting an Invite
|
||||
-- If I haven't seen the project's approval, verify
|
||||
-- the author is the project
|
||||
-- Otherwise, verify the Accept is authorized
|
||||
(\ (originInviteID, inviter) -> do
|
||||
scgl <- lift $ getBy $ UniqueStemComponentGestureLocal stemID
|
||||
scgr <- lift $ getBy $ UniqueStemComponentGestureRemote stemID
|
||||
unless (isNothing scgl && isNothing scgr) $
|
||||
throwE "I've already recorded my collaborator's Accept on the Invite, no need for further Accepts from anyone"
|
||||
seen <-
|
||||
lift $ case project of
|
||||
Left (Entity k _) -> isJust <$> getBy (UniqueStemProjectAcceptLocalProject k)
|
||||
Right (Entity k _) -> isJust <$> getBy (UniqueStemProjectAcceptRemoteProject k)
|
||||
if seen
|
||||
then do
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
capability <-
|
||||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
|
||||
verifyCapability'
|
||||
capability
|
||||
authorIdMsig
|
||||
(topicResource recipKey)
|
||||
AP.RoleAdmin
|
||||
else case (project, authorIdMsig) of
|
||||
(Left (Entity _ sjl), Left (LocalActorProject projectID, _, _))
|
||||
| stemProjectLocalProject sjl == projectID ->
|
||||
return ()
|
||||
(Right (Entity _ sjr), Right (author, _, _))
|
||||
| stemProjectRemoteProject sjr == remoteAuthorId author ->
|
||||
return ()
|
||||
_ -> throwE "The Accept I'm waiting for is by the project"
|
||||
return (originInviteID, seen, inviter)
|
||||
)
|
||||
|
||||
(\ (_stemID, _originAddID, _adder) -> do
|
||||
seen <-
|
||||
lift $ case project of
|
||||
Left (Entity k _) -> isJust <$> getBy (UniqueStemProjectGrantLocalProject k)
|
||||
Right (Entity k _) -> isJust <$> getBy (UniqueStemProjectGrantRemoteProject k)
|
||||
when seen $
|
||||
throwE "Already saw project's Grant, no need for any Accepts"
|
||||
)
|
||||
|
||||
stem
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ acceptDB ->
|
||||
|
||||
case idsForLater of
|
||||
|
||||
Left (originInviteID, seen, inviter) -> do
|
||||
|
||||
if not seen
|
||||
then do
|
||||
lift $ case (project, acceptDB) of
|
||||
(Left (Entity j _), Left (_, _, acceptID)) ->
|
||||
insert_ $ StemProjectAcceptLocal originInviteID j acceptID
|
||||
(Right (Entity j _), Right (_, _, acceptID)) ->
|
||||
insert_ $ StemProjectAcceptRemote originInviteID j acceptID
|
||||
_ -> error "topicAccept Impossible"
|
||||
return Nothing
|
||||
else do
|
||||
lift $ case acceptDB of
|
||||
Left (_, _, acceptID) ->
|
||||
insert_ $ StemComponentGestureLocal stemID acceptID
|
||||
Right (author, _, acceptID) ->
|
||||
insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) acceptID
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
reactInfo <- do
|
||||
|
||||
-- Record the fresh Accept in our DB
|
||||
reactID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
lift $ insert_ $ StemComponentAccept stemID reactID
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
react@(actionReact, _, _, _) <- lift $ prepareReact project inviter
|
||||
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||
_luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact
|
||||
return (reactID, react)
|
||||
|
||||
return $ Just (sieve, reactInfo)
|
||||
|
||||
Right () -> return Nothing
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just Nothing -> done "Done"
|
||||
Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsReact
|
||||
remoteRecipsReact fwdHostsReact reactID actionReact
|
||||
done "Forwarded the Accept and published an Accept"
|
||||
|
||||
topicReject
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ActorId)
|
||||
|
|
|
|||
|
|
@ -372,6 +372,23 @@ deckFollow now recipDeckID verse follow = do
|
|||
-- * Send a Grant:
|
||||
-- * To: Join sender
|
||||
-- * CC: Accept sender, Join sender's followers, my followers
|
||||
-- * If it's an Invite (that I know about) where I'm invited to a project:
|
||||
-- * If I haven't yet seen the project's approval:
|
||||
-- * Verify the author is the project
|
||||
-- * Record the approval in the Stem record in DB
|
||||
-- * If I saw project's approval, but not my collaborators' approval:
|
||||
-- * Verify the Accept is authorized
|
||||
-- * Record the approval in the Stem record in DB
|
||||
-- * Forward to my followers
|
||||
-- * Publish and send an Accept:
|
||||
-- * To: Inviter, project, Accept author
|
||||
-- * CC: Project followers, my followers
|
||||
-- * Record it in the Stem record in DB as well
|
||||
-- * If I already saw both approvals, respond with error
|
||||
-- * If it's an Add (that I know about and already Accepted) where I'm
|
||||
-- invited to a project:
|
||||
-- * If I've already seen the project's accept, respond with error
|
||||
-- * Otherwise, just ignore the Accept
|
||||
-- * Otherwise respond with error
|
||||
deckAccept
|
||||
:: UTCTime
|
||||
|
|
@ -379,7 +396,7 @@ deckAccept
|
|||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckAccept = topicAccept deckActor GrantResourceDeck
|
||||
deckAccept = topicAccept deckActor GrantResourceDeck ComponentDeck
|
||||
|
||||
-- Meaning: An actor rejected something
|
||||
-- Behavior:
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
module Vervis.Persist.Collab
|
||||
( getCollabTopic
|
||||
, getCollabTopic'
|
||||
, getStemIdent
|
||||
, getGrantRecip
|
||||
, getComponentE
|
||||
, getTopicGrants
|
||||
|
|
@ -107,6 +108,19 @@ getCollabTopic' collabID = do
|
|||
(delete k, GrantResourceProject $ collabTopicProjectProject l)
|
||||
_ -> error "Found Collab with multiple topics"
|
||||
|
||||
getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)
|
||||
getStemIdent stemID = do
|
||||
maybeRepo <- getValBy $ UniqueStemIdentRepo stemID
|
||||
maybeDeck <- getValBy $ UniqueStemIdentDeck stemID
|
||||
maybeLoom <- getValBy $ UniqueStemIdentLoom stemID
|
||||
return $
|
||||
case (maybeRepo, maybeDeck, maybeLoom) of
|
||||
(Nothing, Nothing, Nothing) -> error "Found Stem without ident"
|
||||
(Just r, Nothing, Nothing) -> ComponentRepo $ stemIdentRepoRepo r
|
||||
(Nothing, Just d, Nothing) -> ComponentDeck $ stemIdentDeckDeck d
|
||||
(Nothing, Nothing, Just l) -> ComponentLoom $ stemIdentLoomLoom l
|
||||
_ -> error "Found Stem with multiple idents"
|
||||
|
||||
getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
|
||||
|
||||
getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e
|
||||
|
|
|
|||
Loading…
Reference in a new issue