forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Deck Accept handler: Implement component mode

Browse source
This commit is contained in:
Pere Lev 2023-09-01 19:50:48 +03:00
parent e8970c1f4a
commit 9a78c83233
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
3 changed files with 408 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

422
src/Vervis/Actor/Common.hs
View file

@ -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,14 +248,14 @@ 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 $ do
(recipActorID, recipActor) <- lift $ withDB $ do
recip <- getJust recipKey
let actorID = topicActor recip
(actorID,) <$> getJust actorID
collabOrStem <- withDBExcept $ do
-- Find the accepted activity in our DB
accepteeDB <- do
a <- getActivity acceptee
@ -230,12 +263,141 @@ 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 <-
-- 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 <$> tryInvite accepteeDB <|>
Right <$> tryJoin accepteeDB
fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"
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"
case collabOrStem of
Left collab ->
topicAcceptCollab maybeCap recipActorID recipActor collab
Right stem ->
topicAcceptStem maybeCap recipActorID recipActor stem
where
tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) =
(,Left actorByKey) . collabInviterLocalCollab <$>
MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
tryInviteCollab (Right remoteActivityID) = do
CollabInviterRemote collab actorID _ <-
MaybeT $ getValBy $
UniqueCollabInviterRemoteInvite remoteActivityID
actor <- lift $ getJust actorID
sender <-
lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
return (collab, Right sender)
tryJoinCollab (Left (actorByKey, _actorEntity, itemID)) =
(,Left actorByKey) . collabRecipLocalJoinFulfills <$>
MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
tryJoinCollab (Right remoteActivityID) = do
CollabRecipRemoteJoin recipID fulfillsID _ <-
MaybeT $ getValBy $
UniqueCollabRecipRemoteJoinJoin remoteActivityID
remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID
actor <- lift $ getJust remoteActorID
joiner <-
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
audAccepter <- makeAudSenderWithFollowers authorIdMsig
audApprover <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash
senderHash <- bitraverse hashLocalActor pure sender
uAccepter <- lift $ getActorURI authorIdMsig
let audience =
if isInvite
then
let audInviter =
case senderHash of
Left actor -> AudLocal [actor] []
Right (ObjURI h lu, _followers) ->
AudRemote h [lu] []
audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audInviter, audAccepter, audTopic]
else
let audJoiner =
case senderHash of
Left actor -> AudLocal [actor] [localActorFollowers actor]
Right (ObjURI h lu, followers) ->
AudRemote h [lu] (maybeToList followers)
audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audJoiner, audApprover, audTopic]
(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.RXRole role
, AP.grantContext =
encodeRouteHome $ renderLocalActor topicByHash
, AP.grantTarget =
if isInvite
then uAccepter
else case senderHash of
Left actor ->
encodeRouteHome $ renderLocalActor actor
Right (ObjURI h lu, _) -> ObjURI h lu
, AP.grantResult = Nothing
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
topicAcceptCollab maybeCap recipActorID recipActor collab = do
maybeNew <- withDBExcept $ do
-- Find the local resource and verify it's me
collabID <-
@ -344,95 +506,185 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
remoteRecipsGrant fwdHostsGrant grantID actionGrant
done "Forwarded the Accept and published a Grant"
where
tryInvite (Left (actorByKey, _actorEntity, itemID)) =
(,Left actorByKey) . collabInviterLocalCollab <$>
MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
tryInvite (Right remoteActivityID) = do
CollabInviterRemote collab actorID _ <-
MaybeT $ getValBy $
UniqueCollabInviterRemoteInvite remoteActivityID
actor <- lift $ getJust actorID
sender <-
lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
return (collab, Right sender)
tryJoin (Left (actorByKey, _actorEntity, itemID)) =
(,Left actorByKey) . collabRecipLocalJoinFulfills <$>
MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
tryJoin (Right remoteActivityID) = do
CollabRecipRemoteJoin recipID fulfillsID _ <-
MaybeT $ getValBy $
UniqueCollabRecipRemoteJoinJoin remoteActivityID
remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID
actor <- lift $ getJust remoteActorID
joiner <-
lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
return (fulfillsID, Right joiner)
prepareGrant isInvite sender role = do
prepareReact project inviter = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
audAccepter <- makeAudSenderWithFollowers authorIdMsig
audApprover <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey
let topicByHash = grantResourceLocalActor $ topicResource recipHash
(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
senderHash <- bitraverse hashLocalActor pure sender
uAccepter <- lift $ getActorURI authorIdMsig
let audience =
if isInvite
then
let audInviter =
case senderHash of
Left actor -> AudLocal [actor] []
Right (ObjURI h lu, _followers) ->
AudRemote h [lu] []
audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audInviter, audAccepter, audTopic]
else
let audJoiner =
case senderHash of
Left actor -> AudLocal [actor] [localActorFollowers actor]
Right (ObjURI h lu, followers) ->
AudRemote h [lu] (maybeToList followers)
audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audJoiner, audApprover, audTopic]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience audience
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.acceptObject accept]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RXRole role
, AP.grantContext =
encodeRouteHome $ renderLocalActor topicByHash
, AP.grantTarget =
if isInvite
then uAccepter
else case senderHash of
Left actor ->
encodeRouteHome $ renderLocalActor actor
Right (ObjURI h lu, _) -> ObjURI h lu
, AP.grantResult = Nothing
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Nothing
, 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)

19
src/Vervis/Actor/Deck.hs
View file

@ -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:

14
src/Vervis/Persist/Collab.hs
View file

@ -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