forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Deck Invite handler: Implement component mode

Browse source
This commit is contained in:
Pere Lev 2023-08-14 15:24:08 +03:00
parent 521eed8bb2
commit e8970c1f4a
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
3 changed files with 330 additions and 182 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -667,82 +667,171 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
return (action, recipientSet, remoteActors, fwdHosts) 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 topicInvite
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
, PersistRecordBackend ct SqlBackend , PersistRecordBackend ct SqlBackend
, PersistRecordBackend si SqlBackend
) )
=> (topic -> ActorId) => (topic -> ActorId)
-> (forall f. f topic -> GrantResourceBy f) -> (forall f. f topic -> GrantResourceBy f)
-> (forall f. f topic -> ComponentBy f)
-> EntityField ct (Key topic) -> EntityField ct (Key topic)
-> EntityField ct CollabId -> EntityField ct CollabId
-> (CollabId -> Key topic -> ct) -> (CollabId -> Key topic -> ct)
-> (StemId -> Key topic -> si)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) invite = do topicInvite grabActor topicResource topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor 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"
-- Check invite -- Check invite
(role, targetByKey) <- do recipOrProject <- 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 $ topicResource topicKey) == resourceOrComps) $ let collabMode =
throwE "Invite topic isn't my collabs URI" Left (Left $ topicResource topicKey) == resourceOrComps
recipient <- compMode =
bitraverse Left (Right $ topicComponent topicKey) == recipientOrComp
(\case case (collabMode, compMode) of
Left r -> pure r (False, False) -> throwE "Invite is unrelated to me"
Right _ -> throwE "Not accepting component actors as collabs" (True, True) -> throwE "I'm being invited as a collaborator in myself"
) (True, False) -> Left . (role,) <$>
pure bitraverse
recipientOrComp (\case
return (role, recipient) 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 recipOrProjectDB <-
-- 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 bitraverse
(withDBExcept . flip getGrantRecip "Invitee not found in DB") (\ (role, targetByKey) -> do
(\ u@(ObjURI h lu) -> do
instanceID <- -- Check capability
lift $ withDB $ either entityKey id <$> insertBy' (Instance h) capability <- do
result <-
ExceptT $ first (T.pack . displayException) <$> -- Verify that a capability is provided
fetchRemoteActor' instanceID h lu uCap <- do
case result of let muCap = AP.activityCapability $ actbActivity body
Left Nothing -> throwE "Target @id mismatch" fromMaybeE muCap "No capability provided"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Target isn't an actor" -- Verify the capability URI is one of:
Right (Just actor) -> return $ entityKey actor -- * 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 maybeNew <- withDBExcept $ do
@ -752,43 +841,49 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
let actorID = grabActor recip let actorID = grabActor recip
(actorID,) <$> getJust actorID (actorID,) <$> getJust actorID
-- Verify the specified capability gives relevant access case recipOrProjectDB of
verifyCapability' Left (role, capability, _targetByKey, targetDB) -> do
capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
-- Verify that target doesn't already have a Collab for me -- Verify the specified capability gives relevant access
existingCollabIDs <- verifyCapability'
lift $ case targetDB of capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
Left (GrantRecipPerson (Entity personID _)) ->
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do -- Verify that target doesn't already have a Collab for me
E.on $ existingCollabIDs <-
topic E.^. topicCollabField E.==. lift $ case targetDB of
recipl E.^. CollabRecipLocalCollab Left (GrantRecipPerson (Entity personID _)) ->
E.where_ $ E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
topic E.^. topicField E.==. E.val topicKey E.&&. E.on $
recipl E.^. CollabRecipLocalPerson E.==. E.val personID topic E.^. topicCollabField E.==.
return $ recipl E.^. CollabRecipLocalCollab recipl E.^. CollabRecipLocalCollab
Right remoteActorID -> E.where_ $
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do topic E.^. topicField E.==. E.val topicKey E.&&.
E.on $ recipl E.^. CollabRecipLocalPerson E.==. E.val personID
topic E.^. topicCollabField E.==. return $ recipl E.^. CollabRecipLocalCollab
recipr E.^. CollabRecipRemoteCollab Right remoteActorID ->
E.where_ $ E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
topic E.^. topicField E.==. E.val topicKey E.&&. E.on $
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID topic E.^. topicCollabField E.==.
return $ recipr E.^. CollabRecipRemoteCollab recipr E.^. CollabRecipRemoteCollab
case existingCollabIDs of E.where_ $
[] -> pure () topic E.^. topicField E.==. E.val topicKey E.&&.
[_] -> throwE "I already have a Collab for the target" recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
_ -> error "Multiple collabs found for target" 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 maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for maybeInviteDB $ \ inviteDB -> do 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 -- Prepare forwarding Invite to my followers
sieve <- do sieve <- do
topicHash <- encodeKeyHashid topicKey topicHash <- encodeKeyHashid topicKey
@ -796,22 +891,33 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
grantResourceLocalActor $ topicResource topicHash grantResourceLocalActor $ topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash] return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Prepare an Accept activity and inser to my outbox -- Insert Collab or Stem record to DB
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey -- In Collab mode: Prepare an Accept activity and insert to my
let topicByKey = grantResourceLocalActor $ topicResource topicKey -- outbox
_luAccept <- updateOutboxItem' topicByKey acceptID actionAccept 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 case maybeNew of
Nothing -> done "I already have this activity in my inbox" 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 let topicByID = grantResourceLocalActor $ topicResource topicKey
forwardActivity authorIdMsig body topicByID topicActorID sieve forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $ sendActivity lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) ->
topicByID topicActorID localRecipsAccept remoteRecipsAccept sendActivity
fwdHostsAccept acceptID actionAccept topicByID topicActorID localRecipsAccept remoteRecipsAccept
done "Recorded and forwarded the Invite, sent an Accept" fwdHostsAccept acceptID actionAccept
done "Recorded and forwarded the Invite, sent an Accept if collab"
where where
@ -831,6 +937,21 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
Right remoteActorID -> Right remoteActorID ->
insert_ $ CollabRecipRemote collabID 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 prepareAccept invited = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome

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

@ -74,81 +74,6 @@ import Vervis.Persist.Discussion
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Ticket 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 -- Meaning: An actor is adding some object to some target
-- Behavior: -- Behavior:
-- * Verify that the object is me -- * 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 -- Find existing Stem records I have for this project
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
-- mode -- mode
checkExistingStems deckID projectDB checkExistingStems (ComponentDeck deckID) projectDB
-- Verify the specified capability gives relevant access -- Verify the specified capability gives relevant access
verifyCapability' verifyCapability'
@ -483,13 +408,25 @@ deckReject = topicReject deckActor GrantResourceDeck
-- 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 me -- * If resource is my collaborators collection:
-- * Verify A isn't inviting themselves -- * Verify A isn't inviting themselves
-- * Verify A is authorized by me to invite actors to me -- * Verify A is authorized by me to invite actors to me
-- * Verify B doesn't already have an invite/join/grant for me -- * Verify B doesn't already have an invite/join/grant for me
-- * Remember the invite in DB -- * Remember the invite in DB
-- * Forward the Invite to my followers -- * Forward the Invite to my followers
-- * Send Accept to A, B, 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 deckInvite
:: UTCTime :: UTCTime
-> DeckId -> DeckId
@ -498,8 +435,9 @@ deckInvite
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckInvite = deckInvite =
topicInvite topicInvite
deckActor GrantResourceDeck deckActor GrantResourceDeck ComponentDeck
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck CollabTopicDeckDeck CollabTopicDeckCollab
CollabTopicDeck StemIdentDeck
-- Meaning: An actor A is removing actor B from a resource -- Meaning: An actor A is removing actor B from a resource
-- Behavior: -- Behavior:

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

@ -28,20 +28,27 @@ module Vervis.Persist.Collab
, getGrant , getGrant
, getComponentIdent , getComponentIdent
, checkExistingStems
) )
where where
import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Foldable
import Data.List (sortOn) import Data.List (sortOn)
import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock import Data.Time.Clock
import Data.Traversable
import Database.Persist.Sql import Database.Persist.Sql
import Optics.Core import Optics.Core
@ -393,3 +400,85 @@ getComponentIdent componentID = do
) )
(\ (Entity k v) -> pure (k, componentRemoteActor v)) (\ (Entity k v) -> pure (k, componentRemoteActor v))
ident 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)