From e8970c1f4a1f40d564ef32652f99351c0052ee2e Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 14 Aug 2023 15:24:08 +0300 Subject: [PATCH] S2S: Deck Invite handler: Implement component mode --- src/Vervis/Actor/Common.hs | 315 ++++++++++++++++++++++++----------- src/Vervis/Actor/Deck.hs | 108 +++--------- src/Vervis/Persist/Collab.hs | 89 ++++++++++ 3 files changed, 330 insertions(+), 182 deletions(-) diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index ff67a8c..cbd214b 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -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 diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index b13bb0c..2fd9cad 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -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: diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index c62662b..2299084 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -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)