S2S: Deck Invite handler: Implement component mode
This commit is contained in:
Pere Lev
parent
521eed8bb2
commit
e8970c1f4a
3 changed files with 330 additions and 182 deletions
|
|
@ -667,82 +667,171 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor A invited actor B to a resource
|
||||
-- Behavior:
|
||||
-- * If resource is my collaborators collection:
|
||||
-- * Verify A isn't inviting themselves
|
||||
-- * Verify A is authorized by me to invite actors to me
|
||||
-- * Verify B doesn't already have an invite/join/grant for me
|
||||
-- * Remember the invite in DB
|
||||
-- * Forward the Invite to my followers
|
||||
-- * Send Accept to A, B, my-followers
|
||||
-- * If I'm B, i.e. I'm the one being invited:
|
||||
-- * Verify the resource is some project's components collection URI
|
||||
-- * For each Stem record I have for this project:
|
||||
-- * Verify it's not enabled yet, i.e. I'm not already a component
|
||||
-- of this project
|
||||
-- * Verify it's not in Invite-Accept state, already got the
|
||||
-- project's Accept and waiting for my approval
|
||||
-- * Verify it's not in Add-Accept state, has my approval and
|
||||
-- waiting for the project's side
|
||||
-- * Create a Stem record in DB
|
||||
-- * Insert the Invite to my inbox
|
||||
-- * Forward the Invite to my followers
|
||||
topicInvite
|
||||
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
|
||||
, PersistRecordBackend ct SqlBackend
|
||||
, PersistRecordBackend si SqlBackend
|
||||
)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> GrantResourceBy f)
|
||||
-> (forall f. f topic -> ComponentBy f)
|
||||
-> EntityField ct (Key topic)
|
||||
-> EntityField ct CollabId
|
||||
-> (CollabId -> Key topic -> ct)
|
||||
-> (StemId -> Key topic -> si)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Invite URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) invite = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
|
||||
|
||||
-- Verify the capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
topicInvite grabActor topicResource topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
|
||||
|
||||
-- Check invite
|
||||
(role, targetByKey) <- do
|
||||
recipOrProject <- do
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
|
||||
unless (Left (Left $ topicResource topicKey) == 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)
|
||||
let collabMode =
|
||||
Left (Left $ topicResource topicKey) == resourceOrComps
|
||||
compMode =
|
||||
Left (Right $ topicComponent topicKey) == recipientOrComp
|
||||
case (collabMode, compMode) of
|
||||
(False, False) -> throwE "Invite is unrelated to me"
|
||||
(True, True) -> throwE "I'm being invited as a collaborator in myself"
|
||||
(True, False) -> Left . (role,) <$>
|
||||
bitraverse
|
||||
(\case
|
||||
Left r -> pure r
|
||||
Right _ -> throwE "Not accepting component actors as collabs"
|
||||
)
|
||||
pure
|
||||
recipientOrComp
|
||||
(False, True) -> Right <$> do
|
||||
unless (role == AP.RoleAdmin) $
|
||||
throwE "Invite-component role isn't admin"
|
||||
bitraverse
|
||||
(\case
|
||||
Left _ -> throwE "Inviting me to be a collaborator doesn't make sense to me"
|
||||
Right j -> pure j
|
||||
)
|
||||
pure
|
||||
resourceOrComps
|
||||
|
||||
-- If target is local, find it in our DB
|
||||
-- If target is remote, HTTP GET it, verify it's an actor, and store in
|
||||
-- our DB (if it's already there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the Invite handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- 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 <-
|
||||
recipOrProjectDB <-
|
||||
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
|
||||
(\ (role, targetByKey) -> do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
|
||||
|
||||
-- Verify the capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
|
||||
-- If target is local, find it in our DB
|
||||
-- If target is remote, HTTP GET it, verify it's an actor, and store in
|
||||
-- our DB (if it's already there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the Invite handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- 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 <-
|
||||
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
|
||||
)
|
||||
targetByKey
|
||||
|
||||
return (role, capability, targetByKey, targetDB)
|
||||
)
|
||||
targetByKey
|
||||
|
||||
-- If project is local, find it in our DB
|
||||
-- If project is remote, HTTP GET it and store in our DB (if it's already
|
||||
-- there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result would be sent later in a separate (e.g. Accept) activity.
|
||||
-- But for the PoC level, the current situation will hopefully do.
|
||||
(bitraverse
|
||||
(withDBExcept . flip getEntityE "Project not found in DB")
|
||||
(\ u@(ObjURI h luComps) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
collection <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID
|
||||
manager
|
||||
(AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
|
||||
h
|
||||
luComps
|
||||
luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
|
||||
project <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
|
||||
unless (AP.projectComponents project == luComps) $
|
||||
throwE "The collection isn't the project's components collection"
|
||||
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h luProject
|
||||
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) -> do
|
||||
unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
|
||||
throwE "Remote project type isn't Project"
|
||||
return $ entityKey actor
|
||||
)
|
||||
)
|
||||
|
||||
recipOrProject
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
|
|
@ -752,43 +841,49 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
|||
let actorID = grabActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
|
||||
case recipOrProjectDB of
|
||||
Left (role, capability, _targetByKey, targetDB) -> do
|
||||
|
||||
-- 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.^. topicCollabField E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey 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.^. topicCollabField E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey 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"
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (topicResource topicKey) 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.^. topicCollabField E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey 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.^. topicCollabField E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey 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"
|
||||
|
||||
Right projectDB ->
|
||||
|
||||
-- Find existing Stem records I have for this project
|
||||
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
|
||||
-- mode
|
||||
checkExistingStems (topicComponent topicKey) projectDB
|
||||
|
||||
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
|
||||
lift $ for maybeInviteDB $ \ inviteDB -> do
|
||||
|
||||
-- Insert Collab record to DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||
insertCollab role targetDB inviteDB acceptID
|
||||
|
||||
-- Prepare forwarding Invite to my followers
|
||||
sieve <- do
|
||||
topicHash <- encodeKeyHashid topicKey
|
||||
|
|
@ -796,22 +891,33 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
|||
grantResourceLocalActor $ topicResource topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
|
||||
-- Prepare an Accept activity and inser to my outbox
|
||||
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
|
||||
let topicByKey = grantResourceLocalActor $ topicResource topicKey
|
||||
_luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
|
||||
-- Insert Collab or Stem record to DB
|
||||
-- In Collab mode: Prepare an Accept activity and insert to my
|
||||
-- outbox
|
||||
maybeAccept <- case recipOrProjectDB of
|
||||
Left (role, _capability, targetByKey, targetDB) -> Just <$> do
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||
insertCollab role targetDB inviteDB acceptID
|
||||
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
|
||||
let topicByKey = grantResourceLocalActor $ topicResource topicKey
|
||||
_luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
|
||||
return (acceptID, accept)
|
||||
Right projectDB -> do
|
||||
insertStem projectDB inviteDB
|
||||
return Nothing
|
||||
|
||||
return (topicActorID, sieve, acceptID, accept)
|
||||
return (topicActorID, sieve, maybeAccept)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
Just (topicActorID, sieve, maybeAccept) -> do
|
||||
let topicByID = grantResourceLocalActor $ topicResource topicKey
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
lift $ sendActivity
|
||||
topicByID topicActorID localRecipsAccept remoteRecipsAccept
|
||||
fwdHostsAccept acceptID actionAccept
|
||||
done "Recorded and forwarded the Invite, sent an Accept"
|
||||
lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) ->
|
||||
sendActivity
|
||||
topicByID topicActorID localRecipsAccept remoteRecipsAccept
|
||||
fwdHostsAccept acceptID actionAccept
|
||||
done "Recorded and forwarded the Invite, sent an Accept if collab"
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -831,6 +937,21 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
|
|||
Right remoteActorID ->
|
||||
insert_ $ CollabRecipRemote collabID remoteActorID
|
||||
|
||||
insertStem projectDB inviteDB = do
|
||||
stemID <- insert $ Stem AP.RoleAdmin
|
||||
insert_ $ stemIdentCtor stemID topicKey
|
||||
case projectDB of
|
||||
Left (Entity projectID _) ->
|
||||
insert_ $ StemProjectLocal stemID projectID
|
||||
Right remoteActorID ->
|
||||
insert_ $ StemProjectRemote stemID remoteActorID
|
||||
originID <- insert $ StemOriginInvite stemID
|
||||
case inviteDB of
|
||||
Left (_, _, inviteID) ->
|
||||
insert_ $ StemProjectGestureLocal originID inviteID
|
||||
Right (author, _, inviteID) ->
|
||||
insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) inviteID
|
||||
|
||||
prepareAccept invited = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
|
|
|
|||
|
|
@ -74,81 +74,6 @@ import Vervis.Persist.Discussion
|
|||
import Vervis.RemoteActorStore
|
||||
import Vervis.Ticket
|
||||
|
||||
checkExistingStems
|
||||
:: DeckId -> Either (Entity Project) RemoteActorId -> ActDBE ()
|
||||
checkExistingStems deckID projectDB = do
|
||||
|
||||
-- Find existing Stem records I have for this project
|
||||
stemIDs <- lift $ getExistingStems projectDB
|
||||
|
||||
-- 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 stemIDs $ \ (_, stem) ->
|
||||
isJust <$> runMaybeT (tryStemEnabled stem)
|
||||
case length $ filter id byEnabled of
|
||||
0 -> return ()
|
||||
1 -> throwE "I already have a StemProjectGrant* for this project"
|
||||
_ -> error "Multiple StemProjectGrant* for a project"
|
||||
|
||||
-- Verify none of the Stem records are already in
|
||||
-- Add-waiting-for-project or Invite-waiting-for-my-collaborator state
|
||||
anyStarted <-
|
||||
lift $ runMaybeT $ asum $
|
||||
map (\ (stemID, project) ->
|
||||
tryStemAddAccept stemID <|>
|
||||
tryStemInviteAccept stemID project
|
||||
)
|
||||
stemIDs
|
||||
unless (isNothing anyStarted) $
|
||||
throwE
|
||||
"One of the Stem records is already in Add-Accept or \
|
||||
\Invite-Accept state"
|
||||
|
||||
where
|
||||
|
||||
getExistingStems (Left (Entity projectID _)) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
|
||||
E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. StemIdentDeckStem
|
||||
E.where_ $
|
||||
project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
|
||||
ident E.^. StemIdentDeckDeck E.==. E.val deckID
|
||||
return
|
||||
( project E.^. StemProjectLocalStem
|
||||
, project E.^. StemProjectLocalId
|
||||
)
|
||||
getExistingStems (Right remoteActorID) =
|
||||
fmap (map $ bimap E.unValue (Right . E.unValue)) $
|
||||
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
|
||||
E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. StemIdentDeckStem
|
||||
E.where_ $
|
||||
project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
|
||||
ident E.^. StemIdentDeckDeck E.==. E.val deckID
|
||||
return
|
||||
( project E.^. StemProjectRemoteStem
|
||||
, project E.^. StemProjectRemoteId
|
||||
)
|
||||
|
||||
tryStemEnabled (Left localID) =
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)
|
||||
tryStemEnabled (Right remoteID) =
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectGrantRemoteProject remoteID)
|
||||
|
||||
tryStemAddAccept stemID = do
|
||||
_ <- MaybeT $ getBy $ UniqueStemOriginAdd stemID
|
||||
_ <- MaybeT $ getBy $ UniqueStemComponentAccept stemID
|
||||
pure ()
|
||||
|
||||
tryStemInviteAccept stemID project = do
|
||||
originID <- MaybeT $ getKeyBy $ UniqueStemOriginInvite stemID
|
||||
case project of
|
||||
Left localID ->
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
|
||||
Right remoteID ->
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
|
||||
|
||||
-- Meaning: An actor is adding some object to some target
|
||||
-- Behavior:
|
||||
-- * Verify that the object is me
|
||||
|
|
@ -260,7 +185,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
|
|||
-- Find existing Stem records I have for this project
|
||||
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
|
||||
-- mode
|
||||
checkExistingStems deckID projectDB
|
||||
checkExistingStems (ComponentDeck deckID) projectDB
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
|
|
@ -483,13 +408,25 @@ deckReject = topicReject deckActor GrantResourceDeck
|
|||
|
||||
-- Meaning: An actor A invited actor B to a resource
|
||||
-- Behavior:
|
||||
-- * Verify the resource is me
|
||||
-- * Verify A isn't inviting themselves
|
||||
-- * Verify A is authorized by me to invite actors to me
|
||||
-- * Verify B doesn't already have an invite/join/grant for me
|
||||
-- * Remember the invite in DB
|
||||
-- * Forward the Invite to my followers
|
||||
-- * Send Accept to A, B, my-followers
|
||||
-- * If resource is my collaborators collection:
|
||||
-- * Verify A isn't inviting themselves
|
||||
-- * Verify A is authorized by me to invite actors to me
|
||||
-- * Verify B doesn't already have an invite/join/grant for me
|
||||
-- * Remember the invite in DB
|
||||
-- * Forward the Invite to my followers
|
||||
-- * Send Accept to A, B, my-followers
|
||||
-- * If I'm B, i.e. I'm the one being invited:
|
||||
-- * Verify the resource is some project's components collection URI
|
||||
-- * For each Stem record I have for this project:
|
||||
-- * Verify it's not enabled yet, i.e. I'm not already a component
|
||||
-- of this project
|
||||
-- * Verify it's not in Invite-Accept state, already got the
|
||||
-- project's Accept and waiting for my approval
|
||||
-- * Verify it's not in Add-Accept state, has my approval and
|
||||
-- waiting for the project's side
|
||||
-- * Create a Stem record in DB
|
||||
-- * Insert the Invite to my inbox
|
||||
-- * Forward the Invite to my followers
|
||||
deckInvite
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
|
|
@ -498,8 +435,9 @@ deckInvite
|
|||
-> ActE (Text, Act (), Next)
|
||||
deckInvite =
|
||||
topicInvite
|
||||
deckActor GrantResourceDeck
|
||||
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
|
||||
deckActor GrantResourceDeck ComponentDeck
|
||||
CollabTopicDeckDeck CollabTopicDeckCollab
|
||||
CollabTopicDeck StemIdentDeck
|
||||
|
||||
-- Meaning: An actor A is removing actor B from a resource
|
||||
-- Behavior:
|
||||
|
|
|
|||
|
|
@ -28,20 +28,27 @@ module Vervis.Persist.Collab
|
|||
, getGrant
|
||||
|
||||
, getComponentIdent
|
||||
|
||||
, checkExistingStems
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist.Sql
|
||||
import Optics.Core
|
||||
|
||||
|
|
@ -393,3 +400,85 @@ getComponentIdent componentID = do
|
|||
)
|
||||
(\ (Entity k v) -> pure (k, componentRemoteActor v))
|
||||
ident
|
||||
|
||||
checkExistingStems
|
||||
:: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
|
||||
checkExistingStems componentByID projectDB = do
|
||||
|
||||
-- Find existing Stem records I have for this project
|
||||
stemIDs <- lift $ getExistingStems componentByID
|
||||
|
||||
-- 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 stemIDs $ \ (_, stem) ->
|
||||
isJust <$> runMaybeT (tryStemEnabled stem)
|
||||
case length $ filter id byEnabled of
|
||||
0 -> return ()
|
||||
1 -> throwE "I already have a StemProjectGrant* for this project"
|
||||
_ -> error "Multiple StemProjectGrant* for a project"
|
||||
|
||||
-- Verify none of the Stem records are already in
|
||||
-- Add-waiting-for-project or Invite-waiting-for-my-collaborator state
|
||||
anyStarted <-
|
||||
lift $ runMaybeT $ asum $
|
||||
map (\ (stemID, project) ->
|
||||
tryStemAddAccept stemID <|>
|
||||
tryStemInviteAccept stemID project
|
||||
)
|
||||
stemIDs
|
||||
unless (isNothing anyStarted) $
|
||||
throwE
|
||||
"One of the Stem records is already in Add-Accept or \
|
||||
\Invite-Accept state"
|
||||
|
||||
where
|
||||
|
||||
getExistingStems' compID stemField compField (Left (Entity projectID _)) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
|
||||
E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. stemField
|
||||
E.where_ $
|
||||
project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
|
||||
ident E.^. compField E.==. E.val compID
|
||||
return
|
||||
( project E.^. StemProjectLocalStem
|
||||
, project E.^. StemProjectLocalId
|
||||
)
|
||||
getExistingStems' compID stemField compField (Right remoteActorID) =
|
||||
fmap (map $ bimap E.unValue (Right . E.unValue)) $
|
||||
E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
|
||||
E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. stemField
|
||||
E.where_ $
|
||||
project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
|
||||
ident E.^. compField E.==. E.val compID
|
||||
return
|
||||
( project E.^. StemProjectRemoteStem
|
||||
, project E.^. StemProjectRemoteId
|
||||
)
|
||||
|
||||
getExistingStems (ComponentRepo repoID) =
|
||||
getExistingStems' repoID StemIdentRepoStem StemIdentRepoRepo projectDB
|
||||
getExistingStems (ComponentDeck deckID) =
|
||||
getExistingStems' deckID StemIdentDeckStem StemIdentDeckDeck projectDB
|
||||
getExistingStems (ComponentLoom loomID) =
|
||||
getExistingStems' loomID StemIdentLoomStem StemIdentLoomLoom projectDB
|
||||
|
||||
tryStemEnabled (Left localID) =
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)
|
||||
tryStemEnabled (Right remoteID) =
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectGrantRemoteProject remoteID)
|
||||
|
||||
tryStemAddAccept stemID = do
|
||||
_ <- MaybeT $ getBy $ UniqueStemOriginAdd stemID
|
||||
_ <- MaybeT $ getBy $ UniqueStemComponentAccept stemID
|
||||
pure ()
|
||||
|
||||
tryStemInviteAccept stemID project = do
|
||||
originID <- MaybeT $ getKeyBy $ UniqueStemOriginInvite stemID
|
||||
case project of
|
||||
Left localID ->
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
|
||||
Right remoteID ->
|
||||
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
|
||||
|
|
|
|||
Loading…
Reference in a new issue