forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Upgrade the Project Invite handler to handle components

Browse source
This commit is contained in:
Pere Lev 2023-06-28 21:34:19 +03:00
parent 5e87dd99d3
commit 4a2f97d9dd
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
3 changed files with 235 additions and 147 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -842,7 +842,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
return $ AudLocal [LocalActorPerson ph] []
Right (ObjURI h lu) -> return $ AudRemote h [lu] []
audTopic <-
flip AudLocal [] . pure . grantResourceLocalActor . topicResource <$>
AudLocal [] . pure . localActorFollowers .
grantResourceLocalActor . topicResource <$>
encodeKeyHashid topicKey
uInvite <- getActivityURI authorIdMsig

374
src/Vervis/Actor/Project.hs
View file

@ -27,6 +27,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
@ -67,7 +68,7 @@ import Vervis.FedURI
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model hiding (projectCreate)
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
import Vervis.RemoteActorStore
import Vervis.Persist.Actor
import Vervis.Persist.Collab
@ -97,6 +98,93 @@ projectAccept
-> ActE (Text, Act (), Next)
projectAccept = topicAccept projectActor GrantResourceProject
checkExistingComponents
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
checkExistingComponents projectID componentDB = do
-- Find existing Component records I have for this component
componentIDs <- lift $ getExistingComponents componentDB
-- Grab all the enabled ones, make sure none are enabled, and even if
-- any are enabled, make sure there's at most one (otherwise it's a
-- bug)
byEnabled <-
lift $ for componentIDs $ \ (componentID, _) ->
isJust <$> runMaybeT (tryComponentEnabled componentID)
case length $ filter id byEnabled of
0 -> return ()
1 -> throwE "I already have a ComponentEnable for this component"
_ -> error "Multiple ComponentEnable for a component"
-- Verify none of the Component records are already in
-- Add-waiting-for-project or Invite-waiting-for-component state
anyStarted <-
lift $ runMaybeT $ asum $
map (\ (componentID, identID) ->
tryComponentAddAccept componentID identID <|>
tryComponentInviteAccept componentID
)
componentIDs
unless (isNothing anyStarted) $
throwE
"One of the Component records is already in Add-Accept or \
\Invite-Accept state"
where
getExistingComponents (Left (ComponentRepo (Entity repoID _))) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ ident E.^. ComponentLocalRepoComponent E.==. local E.^. ComponentLocalId
E.where_ $
ident E.^. ComponentLocalRepoRepo E.==. E.val repoID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, local E.^. ComponentLocalId)
getExistingComponents (Left (ComponentDeck (Entity deckID _))) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ ident E.^. ComponentLocalDeckComponent E.==. local E.^. ComponentLocalId
E.where_ $
ident E.^. ComponentLocalDeckDeck E.==. E.val deckID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, local E.^. ComponentLocalId)
getExistingComponents (Left (ComponentLoom (Entity loomID _))) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ ident E.^. ComponentLocalLoomComponent E.==. local E.^. ComponentLocalId
E.where_ $
ident E.^. ComponentLocalLoomLoom E.==. E.val loomID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, local E.^. ComponentLocalId)
getExistingComponents (Right remoteActorID) =
fmap (map $ bimap E.unValue (Right . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` comp) -> do
E.on $ ident E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
E.where_ $
ident E.^. ComponentRemoteActor E.==. E.val remoteActorID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, ident E.^. ComponentRemoteId)
tryComponentEnabled componentID =
const () <$> MaybeT (getBy $ UniqueComponentEnable componentID)
tryComponentAddAccept componentID identID = do
_ <- MaybeT $ getBy $ UniqueComponentOriginAdd componentID
case identID of
Left localID ->
const () <$>
MaybeT (getBy $ UniqueComponentAcceptLocal localID)
Right remoteID ->
const () <$>
MaybeT (getBy $ UniqueComponentAcceptRemote remoteID)
tryComponentInviteAccept componentID = do
originID <- MaybeT $ getKeyBy $ UniqueComponentOriginInvite componentID
const () <$> MaybeT (getBy $ UniqueComponentProjectAccept originID)
-- Meaning: An actor is adding some object to some target
-- Behavior:
-- * Verify my components list is the target
@ -166,32 +254,9 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
(p,) <$> getJust (projectActor p)
-- Find existing Component records I have for this component
componentIDs <- lift $ getExistingComponents componentDB
-- Grab all the enabled ones, make sure none are enabled, and even if
-- any are enabled, make sure there's at most one (otherwise it's a
-- bug)
byEnabled <-
lift $ for componentIDs $ \ (componentID, _) ->
isJust <$> runMaybeT (tryComponentEnabled componentID)
case length $ filter id byEnabled of
0 -> return ()
1 -> throwE "I already have a ComponentEnable for this component"
_ -> error "Multiple ComponentEnable for a component"
-- Verify none of the Component records are already in
-- Add-waiting-for-project or Invite-waiting-for-component state
anyStarted <-
lift $ runMaybeT $ asum $
map (\ (componentID, identID) ->
tryComponentAddAccept componentID identID <|>
tryComponentInviteAccept componentID
)
componentIDs
unless (isNothing anyStarted) $
throwE
"One of the Component records is already in Add-Accept or \
\Invite-Accept state"
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
-- mode
checkExistingComponents projectID componentDB
-- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
@ -218,59 +283,6 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
where
getExistingComponents (Left (ComponentRepo (Entity repoID _))) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ ident E.^. ComponentLocalRepoComponent E.==. local E.^. ComponentLocalId
E.where_ $
ident E.^. ComponentLocalRepoRepo E.==. E.val repoID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, local E.^. ComponentLocalId)
getExistingComponents (Left (ComponentDeck (Entity deckID _))) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ ident E.^. ComponentLocalDeckComponent E.==. local E.^. ComponentLocalId
E.where_ $
ident E.^. ComponentLocalDeckDeck E.==. E.val deckID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, local E.^. ComponentLocalId)
getExistingComponents (Left (ComponentLoom (Entity loomID _))) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
E.on $ ident E.^. ComponentLocalLoomComponent E.==. local E.^. ComponentLocalId
E.where_ $
ident E.^. ComponentLocalLoomLoom E.==. E.val loomID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, local E.^. ComponentLocalId)
getExistingComponents (Right remoteActorID) =
fmap (map $ bimap E.unValue (Right . E.unValue)) $
E.select $ E.from $ \ (ident `E.InnerJoin` comp) -> do
E.on $ ident E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
E.where_ $
ident E.^. ComponentRemoteActor E.==. E.val remoteActorID E.&&.
comp E.^. ComponentProject E.==. E.val projectID
return (comp E.^. ComponentId, ident E.^. ComponentRemoteId)
tryComponentEnabled componentID =
const () <$> MaybeT (getBy $ UniqueComponentEnable componentID)
tryComponentAddAccept componentID identID = do
_ <- MaybeT $ getBy $ UniqueComponentOriginAdd componentID
case identID of
Left localID ->
const () <$>
MaybeT (getBy $ UniqueComponentAcceptLocal localID)
Right remoteID ->
const () <$>
MaybeT (getBy $ UniqueComponentAcceptRemote remoteID)
tryComponentInviteAccept componentID = do
originID <- MaybeT $ getKeyBy $ UniqueComponentOriginInvite componentID
const () <$> MaybeT (getBy $ UniqueComponentProjectAccept originID)
insertComponent componentDB addDB = do
componentID <- insert $ Component projectID AP.RoleAdmin
originID <- insert $ ComponentOriginAdd componentID
@ -359,16 +371,25 @@ projectFollow now recipProjectID verse follow = do
-- Meaning: An actor A invited actor B to a resource
-- Behavior:
-- * Verify the resource is my collabs list
-- * If invitee is local, verify it's a Person and not a Component
-- * Verify the resource is my collabs or components list
-- * If resource is collabs and B is local, verify it's a Person
-- * If resource is components and B is local, verify it's a Component
-- * Verify A isn't inviting themselves
-- * Verify A is authorized by me to invite collabs to me
-- * Verify A is authorized by me to invite collabs/components to me
--
-- * Verify B doesn't already have an invite/join/grant for me
-- * In collab mode,
-- * Verify B doesn't already have an invite/join/grant for me
-- * In component mode,
-- * Verify B isn't already an active component of mine
-- * Verify B isn't already in a Add-Accept process waiting for
-- project collab to accept too
-- * Verify B isn't already in an Invite-Accept process waiting for
-- component (or its collaborator) to accept too
--
-- * Insert the Invite to my inbox
--
-- * Insert a Collab record to DB
-- * In collab mode, Insert a Collab record to DB
-- * In component mode, Create a Component record in DB
--
-- * Forward the Invite to my followers
-- * Send Accept to A, B (and followers if it's a component), my-followers
@ -400,20 +421,31 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
_ -> throwE "Capability is remote i.e. definitely not by me"
-- Check invite
(role, targetByKey) <- do
(role, invited) <- do
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
unless (Left (Left $ GrantResourceProject projectID) == resourceOrComps) $
throwE "Invite topic isn't my collabs URI"
recipient <-
bitraverse
(\case
Left r -> pure r
Right _ -> throwE "Not accepting component actors as collabs"
)
pure
recipientOrComp
return (role, recipient)
mode <-
case resourceOrComps of
Left (Left (GrantResourceProject j)) | j == projectID ->
Left <$>
bitraverse
(\case
Left r -> pure r
Right _ -> throwE "Not accepting local component actors as collabs"
)
pure
recipientOrComp
Left (Right j) | j == projectID ->
Right <$>
bitraverse
(\case
Left _ -> throwE "Not accepting local Persons as components"
Right r -> pure r
)
pure
recipientOrComp
_ -> throwE "Invite topic isn't my collabs or components URI"
return (role, mode)
-- If target is local, find it in our DB
-- If target is remote, HTTP GET it, verify it's an actor, and store in
@ -424,22 +456,17 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
-- handler result (approve/disapprove the Invite) would be sent later in a
-- separate (e.g. Accept) activity. But for the PoC level, the current
-- situation will hopefully do.
targetDB <-
invitedDB <-
bitraverse
(withDBExcept . flip getGrantRecip "Invitee not found in DB")
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
result <-
ExceptT $ first (T.pack . displayException) <$>
fetchRemoteActor' instanceID h lu
case result of
Left Nothing -> throwE "Target @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Target isn't an actor"
Right (Just actor) -> return $ entityKey actor
(bitraverse
(withDBExcept . flip getGrantRecip "Invitee not found in DB")
getRemoteActorFromURI
)
targetByKey
(bitraverse
(withDBExcept . flip getComponentE "Invitee not found in DB")
getRemoteActorFromURI
)
invited
maybeNew <- withDBExcept $ do
@ -453,38 +480,29 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
verifyCapability'
capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin
-- Verify that target doesn't already have a Collab for me
existingCollabIDs <-
lift $ case targetDB of
Left (GrantRecipPerson (Entity personID _)) ->
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
E.on $
topic E.^. CollabTopicProjectCollab E.==.
recipl E.^. CollabRecipLocalCollab
E.where_ $
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return $ recipl E.^. CollabRecipLocalCollab
Right remoteActorID ->
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
E.on $
topic E.^. CollabTopicProjectCollab E.==.
recipr E.^. CollabRecipRemoteCollab
E.where_ $
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return $ recipr E.^. CollabRecipRemoteCollab
case existingCollabIDs of
[] -> pure ()
[_] -> throwE "I already have a Collab for the target"
_ -> error "Multiple collabs found for target"
case invitedDB of
-- Verify that target doesn't already have a Collab for me
Left collab -> do
existingCollabIDs <- lift $ getExistingCollabs collab
case existingCollabIDs of
[] -> pure ()
[_] -> throwE "I already have a Collab for the target"
_ -> error "Multiple collabs found for target"
-- Find existing Component records I have for this component
-- Make sure none are enabled / in Add-Accept mode / in
-- Invite-Accept mode
Right component -> checkExistingComponents projectID component
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for maybeInviteDB $ \ inviteDB -> do
-- Insert Collab record to DB
-- Insert Collab or Component record to DB
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
insertCollab role targetDB inviteDB acceptID
case invitedDB of
Left collab -> insertCollab role collab inviteDB acceptID
Right component -> insertComponent component inviteDB acceptID
-- Prepare forwarding Invite to my followers
sieve <- do
@ -492,7 +510,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
-- Prepare an Accept activity and insert to my outbox
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
accept@(actionAccept, _, _, _) <- prepareAccept invitedDB
_luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
return (topicActorID, sieve, acceptID, accept)
@ -509,6 +527,37 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
where
getRemoteActorFromURI (ObjURI h lu) = do
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
result <-
ExceptT $ first (T.pack . displayException) <$>
fetchRemoteActor' instanceID h lu
case result of
Left Nothing -> throwE "Target @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Target isn't an actor"
Right (Just actor) -> return $ entityKey actor
getExistingCollabs (Left (GrantRecipPerson (Entity personID _))) =
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
E.on $
topic E.^. CollabTopicProjectCollab E.==.
recipl E.^. CollabRecipLocalCollab
E.where_ $
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return $ recipl E.^. CollabRecipLocalCollab
getExistingCollabs (Right remoteActorID) =
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
E.on $
topic E.^. CollabTopicProjectCollab E.==.
recipr E.^. CollabRecipRemoteCollab
E.where_ $
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return $ recipr E.^. CollabRecipRemoteCollab
insertCollab role recipient inviteDB acceptID = do
collabID <- insert $ Collab role
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
@ -525,20 +574,53 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
Right remoteActorID ->
insert_ $ CollabRecipRemote collabID remoteActorID
prepareAccept invited = do
insertComponent componentDB inviteDB acceptID = do
componentID <- insert $ Component projectID AP.RoleAdmin
originID <- insert $ ComponentOriginInvite componentID
case inviteDB of
Left (_, _, inviteID) ->
insert_ $ ComponentProjectGestureLocal componentID inviteID
Right (author, _, inviteID) ->
insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) inviteID
case componentDB of
Left l -> do
identID <- insert $ ComponentLocal componentID
case l of
ComponentRepo (Entity repoID _) ->
insert_ $ ComponentLocalRepo identID repoID
ComponentDeck (Entity deckID _) ->
insert_ $ ComponentLocalDeck identID deckID
ComponentLoom (Entity loomID _) ->
insert_ $ ComponentLocalLoom identID loomID
Right remoteActorID ->
insert_ $ ComponentRemote componentID remoteActorID
insert_ $ ComponentProjectAccept originID acceptID
prepareAccept invitedDB = do
encodeRouteHome <- getEncodeRouteHome
audInviter <- makeAudSenderOnly authorIdMsig
audInviter <- lift $ makeAudSenderOnly authorIdMsig
audInvited <-
case invited of
Left (GrantRecipPerson p) -> do
case invitedDB of
Left (Left (GrantRecipPerson (Entity p _))) -> do
ph <- encodeKeyHashid p
return $ AudLocal [LocalActorPerson ph] []
Right (ObjURI h lu) -> return $ AudRemote h [lu] []
Left (Right remoteActorID) -> do
ra <- getJust remoteActorID
ObjURI h lu <- getRemoteActorURI ra
return $ AudRemote h [lu] []
Right (Left componentByEnt) -> do
componentByHash <- hashComponent $ bmap entityKey componentByEnt
let actor = componentActor componentByHash
return $ AudLocal [actor] [localActorFollowers actor]
Right (Right remoteActorID) -> do
ra <- getJust remoteActorID
ObjURI h lu <- getRemoteActorURI ra
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
audTopic <-
flip AudLocal [] . pure . LocalActorProject <$>
AudLocal [] . pure . LocalStageProjectFollowers <$>
encodeKeyHashid projectID
uInvite <- getActivityURI authorIdMsig
uInvite <- lift $ getActivityURI authorIdMsig
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audInviter, audInvited, audTopic]

5
src/Vervis/Data/Collab.hs
View file

@ -47,6 +47,7 @@ module Vervis.Data.Collab
, grantResourceLocalActor
, ComponentBy (..)
, hashComponent
, componentActor
)
where
@ -485,6 +486,10 @@ parseComponent (DeckR d) = Just $ ComponentDeck d
parseComponent (LoomR l) = Just $ ComponentLoom l
parseComponent _ = Nothing
hashComponent (ComponentRepo k) = ComponentRepo <$> WAP.encodeKeyHashid k
hashComponent (ComponentDeck k) = ComponentDeck <$> WAP.encodeKeyHashid k
hashComponent (ComponentLoom k) = ComponentLoom <$> WAP.encodeKeyHashid k
unhashComponentPure ctx = f
where
f (ComponentRepo r) =