S2S: Upgrade the Project Invite handler to handle components
This commit is contained in:
parent
5e87dd99d3
commit
4a2f97d9dd
3 changed files with 235 additions and 147 deletions
|
@ -842,7 +842,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
||||||
return $ AudLocal [LocalActorPerson ph] []
|
return $ AudLocal [LocalActorPerson ph] []
|
||||||
Right (ObjURI h lu) -> return $ AudRemote h [lu] []
|
Right (ObjURI h lu) -> return $ AudRemote h [lu] []
|
||||||
audTopic <-
|
audTopic <-
|
||||||
flip AudLocal [] . pure . grantResourceLocalActor . topicResource <$>
|
AudLocal [] . pure . localActorFollowers .
|
||||||
|
grantResourceLocalActor . topicResource <$>
|
||||||
encodeKeyHashid topicKey
|
encodeKeyHashid topicKey
|
||||||
uInvite <- getActivityURI authorIdMsig
|
uInvite <- getActivityURI authorIdMsig
|
||||||
|
|
||||||
|
|
|
@ -27,6 +27,7 @@ import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
import Control.Monad.Trans.Reader
|
import Control.Monad.Trans.Reader
|
||||||
|
import Data.Barbie
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Bitraversable
|
import Data.Bitraversable
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
|
@ -67,7 +68,7 @@ import Vervis.FedURI
|
||||||
import Vervis.Federation.Util
|
import Vervis.Federation.Util
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model hiding (projectCreate)
|
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.RemoteActorStore
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
import Vervis.Persist.Collab
|
import Vervis.Persist.Collab
|
||||||
|
@ -97,6 +98,93 @@ projectAccept
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
projectAccept = topicAccept projectActor GrantResourceProject
|
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
|
-- Meaning: An actor is adding some object to some target
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify my components list is the target
|
-- * Verify my components list is the target
|
||||||
|
@ -166,32 +254,9 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
(p,) <$> getJust (projectActor p)
|
(p,) <$> getJust (projectActor p)
|
||||||
|
|
||||||
-- Find existing Component records I have for this component
|
-- Find existing Component records I have for this component
|
||||||
componentIDs <- lift $ getExistingComponents componentDB
|
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
|
||||||
|
-- mode
|
||||||
-- Grab all the enabled ones, make sure none are enabled, and even if
|
checkExistingComponents projectID componentDB
|
||||||
-- 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"
|
|
||||||
|
|
||||||
-- Insert the Add to my inbox
|
-- Insert the Add to my inbox
|
||||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||||
|
@ -218,59 +283,6 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
|
|
||||||
where
|
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
|
insertComponent componentDB addDB = do
|
||||||
componentID <- insert $ Component projectID AP.RoleAdmin
|
componentID <- insert $ Component projectID AP.RoleAdmin
|
||||||
originID <- insert $ ComponentOriginAdd componentID
|
originID <- insert $ ComponentOriginAdd componentID
|
||||||
|
@ -359,16 +371,25 @@ projectFollow now recipProjectID verse follow = do
|
||||||
|
|
||||||
-- Meaning: An actor A invited actor B to a resource
|
-- Meaning: An actor A invited actor B to a resource
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify the resource is my collabs list
|
-- * Verify the resource is my collabs or components list
|
||||||
-- * If invitee is local, verify it's a Person and not a Component
|
-- * 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 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 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
|
-- * Forward the Invite to my followers
|
||||||
-- * Send Accept to A, B (and followers if it's a component), 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"
|
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||||
|
|
||||||
-- Check invite
|
-- Check invite
|
||||||
(role, targetByKey) <- do
|
(role, invited) <- do
|
||||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||||
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
|
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
|
||||||
unless (Left (Left $ GrantResourceProject projectID) == resourceOrComps) $
|
mode <-
|
||||||
throwE "Invite topic isn't my collabs URI"
|
case resourceOrComps of
|
||||||
recipient <-
|
Left (Left (GrantResourceProject j)) | j == projectID ->
|
||||||
bitraverse
|
Left <$>
|
||||||
(\case
|
bitraverse
|
||||||
Left r -> pure r
|
(\case
|
||||||
Right _ -> throwE "Not accepting component actors as collabs"
|
Left r -> pure r
|
||||||
)
|
Right _ -> throwE "Not accepting local component actors as collabs"
|
||||||
pure
|
)
|
||||||
recipientOrComp
|
pure
|
||||||
return (role, recipient)
|
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 local, find it in our DB
|
||||||
-- If target is remote, HTTP GET it, verify it's an actor, and store in
|
-- 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
|
-- handler result (approve/disapprove the Invite) would be sent later in a
|
||||||
-- separate (e.g. Accept) activity. But for the PoC level, the current
|
-- separate (e.g. Accept) activity. But for the PoC level, the current
|
||||||
-- situation will hopefully do.
|
-- situation will hopefully do.
|
||||||
targetDB <-
|
invitedDB <-
|
||||||
bitraverse
|
bitraverse
|
||||||
(withDBExcept . flip getGrantRecip "Invitee not found in DB")
|
(bitraverse
|
||||||
(\ u@(ObjURI h lu) -> do
|
(withDBExcept . flip getGrantRecip "Invitee not found in DB")
|
||||||
instanceID <-
|
getRemoteActorFromURI
|
||||||
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
|
|
||||||
)
|
)
|
||||||
targetByKey
|
(bitraverse
|
||||||
|
(withDBExcept . flip getComponentE "Invitee not found in DB")
|
||||||
|
getRemoteActorFromURI
|
||||||
|
)
|
||||||
|
invited
|
||||||
|
|
||||||
maybeNew <- withDBExcept $ do
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
@ -453,38 +480,29 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
||||||
verifyCapability'
|
verifyCapability'
|
||||||
capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin
|
capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin
|
||||||
|
|
||||||
-- Verify that target doesn't already have a Collab for me
|
case invitedDB of
|
||||||
existingCollabIDs <-
|
|
||||||
lift $ case targetDB of
|
-- Verify that target doesn't already have a Collab for me
|
||||||
Left (GrantRecipPerson (Entity personID _)) ->
|
Left collab -> do
|
||||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
existingCollabIDs <- lift $ getExistingCollabs collab
|
||||||
E.on $
|
case existingCollabIDs of
|
||||||
topic E.^. CollabTopicProjectCollab E.==.
|
[] -> pure ()
|
||||||
recipl E.^. CollabRecipLocalCollab
|
[_] -> throwE "I already have a Collab for the target"
|
||||||
E.where_ $
|
_ -> error "Multiple collabs found for target"
|
||||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
|
|
||||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
-- Find existing Component records I have for this component
|
||||||
return $ recipl E.^. CollabRecipLocalCollab
|
-- Make sure none are enabled / in Add-Accept mode / in
|
||||||
Right remoteActorID ->
|
-- Invite-Accept mode
|
||||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
Right component -> checkExistingComponents projectID component
|
||||||
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"
|
|
||||||
|
|
||||||
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
|
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
|
||||||
lift $ for maybeInviteDB $ \ inviteDB -> do
|
lift $ for maybeInviteDB $ \ inviteDB -> do
|
||||||
|
|
||||||
-- Insert Collab record to DB
|
-- Insert Collab or Component record to DB
|
||||||
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
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
|
-- Prepare forwarding Invite to my followers
|
||||||
sieve <- do
|
sieve <- do
|
||||||
|
@ -492,7 +510,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
||||||
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
|
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
|
||||||
|
|
||||||
-- Prepare an Accept activity and insert to my outbox
|
-- Prepare an Accept activity and insert to my outbox
|
||||||
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
|
accept@(actionAccept, _, _, _) <- prepareAccept invitedDB
|
||||||
_luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
|
_luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
|
||||||
|
|
||||||
return (topicActorID, sieve, acceptID, accept)
|
return (topicActorID, sieve, acceptID, accept)
|
||||||
|
@ -509,6 +527,37 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
||||||
|
|
||||||
where
|
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
|
insertCollab role recipient inviteDB acceptID = do
|
||||||
collabID <- insert $ Collab role
|
collabID <- insert $ Collab role
|
||||||
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
|
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
|
||||||
|
@ -525,20 +574,53 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
||||||
Right remoteActorID ->
|
Right remoteActorID ->
|
||||||
insert_ $ CollabRecipRemote collabID 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
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
|
||||||
audInviter <- makeAudSenderOnly authorIdMsig
|
audInviter <- lift $ makeAudSenderOnly authorIdMsig
|
||||||
audInvited <-
|
audInvited <-
|
||||||
case invited of
|
case invitedDB of
|
||||||
Left (GrantRecipPerson p) -> do
|
Left (Left (GrantRecipPerson (Entity p _))) -> do
|
||||||
ph <- encodeKeyHashid p
|
ph <- encodeKeyHashid p
|
||||||
return $ AudLocal [LocalActorPerson ph] []
|
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 <-
|
audTopic <-
|
||||||
flip AudLocal [] . pure . LocalActorProject <$>
|
AudLocal [] . pure . LocalStageProjectFollowers <$>
|
||||||
encodeKeyHashid projectID
|
encodeKeyHashid projectID
|
||||||
uInvite <- getActivityURI authorIdMsig
|
uInvite <- lift $ getActivityURI authorIdMsig
|
||||||
|
|
||||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
collectAudience [audInviter, audInvited, audTopic]
|
collectAudience [audInviter, audInvited, audTopic]
|
||||||
|
|
|
@ -47,6 +47,7 @@ module Vervis.Data.Collab
|
||||||
, grantResourceLocalActor
|
, grantResourceLocalActor
|
||||||
|
|
||||||
, ComponentBy (..)
|
, ComponentBy (..)
|
||||||
|
, hashComponent
|
||||||
, componentActor
|
, componentActor
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
@ -485,6 +486,10 @@ parseComponent (DeckR d) = Just $ ComponentDeck d
|
||||||
parseComponent (LoomR l) = Just $ ComponentLoom l
|
parseComponent (LoomR l) = Just $ ComponentLoom l
|
||||||
parseComponent _ = Nothing
|
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
|
unhashComponentPure ctx = f
|
||||||
where
|
where
|
||||||
f (ComponentRepo r) =
|
f (ComponentRepo r) =
|
||||||
|
|
Loading…
Reference in a new issue