diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index cbd214b..d82bec1 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -193,21 +193,54 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m return (action, recipientSet, remoteActors, fwdHosts) +-- Meaning: An actor accepted something +-- Behavior: +-- * If it's on an Invite where I'm the resource: +-- * Verify the Accept is by the Invite target +-- * Forward the Accept to my followers +-- * Send a Grant: +-- * To: Accepter (i.e. Invite target) +-- * CC: Invite sender, Accepter's followers, my followers +-- * If it's on a Join where I'm the resource: +-- * Verify the Accept is authorized +-- * Forward the Accept to my followers +-- * Send a Grant: +-- * To: Join sender +-- * CC: Accept sender, Join sender's followers, my followers +-- * If it's an Invite (that I know about) where I'm invited to a project: +-- * If I haven't yet seen the project's approval: +-- * Verify the author is the project +-- * Record the approval in the Stem record in DB +-- * If I saw project's approval, but not my collaborators' approval: +-- * Verify the Accept is authorized +-- * Record the approval in the Stem record in DB +-- * Forward to my followers +-- * Publish and send an Accept: +-- * To: Inviter, project, Accept author +-- * CC: Project followers, my followers +-- * Record it in the Stem record in DB as well +-- * If I already saw both approvals, respond with error +-- * If it's an Add (that I know about and already Accepted) where I'm +-- invited to a project: +-- * If I've already seen the project's accept, respond with error +-- * Otherwise, just ignore the Accept +-- * Otherwise respond with error topicAccept :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ActorId) -> (forall f. f topic -> GrantResourceBy f) + -> (forall f. f topic -> ComponentBy f) -> UTCTime -> Key topic -> Verse -> AP.Accept URIMode -> ActE (Text, Act (), Next) -topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) accept = do +topicAccept topicActor topicResource topicComponent now recipKey (Verse authorIdMsig body) accept = do -- Check input acceptee <- parseAccept accept - -- Verify the capability URI is one of: + -- Verify the capability URI, if provided, is one of: -- * Outbox item URI of a local actor, i.e. a local activity -- * A remote URI maybeCap <- @@ -215,13 +248,13 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce (nameExceptT "Accept capability" . parseActivityURI') (AP.activityCapability $ actbActivity body) - maybeNew <- withDBExcept $ do + -- Grab me from DB + (recipActorID, recipActor) <- lift $ withDB $ do + recip <- getJust recipKey + let actorID = topicActor recip + (actorID,) <$> getJust actorID - -- Grab me from DB - (recipActorID, recipActor) <- lift $ do - recip <- getJust recipKey - let actorID = topicActor recip - (actorID,) <$> getJust actorID + collabOrStem <- withDBExcept $ do -- Find the accepted activity in our DB accepteeDB <- do @@ -230,126 +263,28 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce -- See if the accepted activity is an Invite or Join to a local -- resource, grabbing the Collab record from our DB - collab <- do - maybeCollab <- - lift $ runMaybeT $ - Left <$> tryInvite accepteeDB <|> - Right <$> tryJoin accepteeDB - fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of" + -- See if the accepted activity is an Invite or Add on a local + -- component, grabbing the Stem record from our DB + maybeCollabOrStem <- + lift $ runMaybeT $ + Left . Left <$> tryInviteCollab accepteeDB <|> + Left . Right <$> tryJoinCollab accepteeDB <|> + Right . Left <$> tryInviteComp accepteeDB <|> + Right . Right <$> tryAddComp accepteeDB + fromMaybeE maybeCollabOrStem "Accepted activity isn't an Invite/Join/Add I'm aware of" - -- Find the local resource and verify it's me - collabID <- - lift $ case collab of - Left (fulfillsID, _) -> - collabFulfillsInviteCollab <$> getJust fulfillsID - Right (fulfillsID, _) -> - collabFulfillsJoinCollab <$> getJust fulfillsID - topic <- lift $ getCollabTopic collabID - unless (topicResource recipKey == topic) $ - throwE "Accept object is an Invite/Join for some other resource" - - idsForAccept <- - case collab of - - -- If accepting an Invite, find the Collab recipient and verify - -- it's the sender of the Accept - Left (fulfillsID, _) -> Left <$> do - recip <- - lift $ - requireEitherAlt - (getBy $ UniqueCollabRecipLocal collabID) - (getBy $ UniqueCollabRecipRemote collabID) - "Found Collab with no recip" - "Found Collab with multiple recips" - case (recip, authorIdMsig) of - (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _)) - | collabRecipLocalPerson crl == personID -> - return (fulfillsID, Left crlid) - (Right (Entity crrid crr), Right (author, _, _)) - | collabRecipRemoteActor crr == remoteAuthorId author -> - return (fulfillsID, Right crrid) - _ -> throwE "Accepting an Invite whose recipient is someone else" - - -- If accepting a Join, verify accepter has permission - Right (fulfillsID, _) -> Right <$> do - capID <- fromMaybeE maybeCap "No capability provided" - capability <- - case capID of - Left (capActor, _, capItem) -> return (capActor, capItem) - Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" - verifyCapability' - capability - authorIdMsig - (topicResource recipKey) - AP.RoleAdmin - return fulfillsID - - -- Verify the Collab isn't already validated - maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID - verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" - - maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False - for maybeAcceptDB $ \ acceptDB -> do - - -- Record the Accept on the Collab - case (idsForAccept, acceptDB) of - (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID - unless (isNothing maybeAccept) $ - throwE "This Invite already has an Accept by recip" - (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID - unless (isJust maybeAccept) $ - throwE "This Invite already has an Accept by recip" - (Right fulfillsID, Left (_, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID - unless (isJust maybeAccept) $ - throwE "This Join already has an Accept" - (Right fulfillsID, Right (author, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID - unless (isJust maybeAccept) $ - throwE "This Join already has an Accept" - _ -> error "topicAccept impossible" - - -- Prepare forwarding of Accept to my followers - let recipByID = grantResourceLocalActor $ topicResource recipKey - recipByHash <- hashLocalActor recipByID - let sieve = makeRecipientSet [] [localActorFollowers recipByHash] - - grantInfo <- do - - -- Enable the Collab in our DB - grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now - lift $ insert_ $ CollabEnable collabID grantID - - -- Prepare a Grant activity and insert to my outbox - let inviterOrJoiner = either snd snd collab - isInvite = isLeft collab - grant@(actionGrant, _, _, _) <- do - Collab role <- lift $ getJust collabID - lift $ prepareGrant isInvite inviterOrJoiner role - let recipByKey = grantResourceLocalActor $ topicResource recipKey - _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant - return (grantID, grant) - - return (recipActorID, sieve, grantInfo) - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do - let recipByID = grantResourceLocalActor $ topicResource recipKey - forwardActivity authorIdMsig body recipByID recipActorID sieve - lift $ sendActivity - recipByID recipActorID localRecipsGrant - remoteRecipsGrant fwdHostsGrant grantID actionGrant - done "Forwarded the Accept and published a Grant" + case collabOrStem of + Left collab -> + topicAcceptCollab maybeCap recipActorID recipActor collab + Right stem -> + topicAcceptStem maybeCap recipActorID recipActor stem where - tryInvite (Left (actorByKey, _actorEntity, itemID)) = + tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) = (,Left actorByKey) . collabInviterLocalCollab <$> MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID) - tryInvite (Right remoteActivityID) = do + tryInviteCollab (Right remoteActivityID) = do CollabInviterRemote collab actorID _ <- MaybeT $ getValBy $ UniqueCollabInviterRemoteInvite remoteActivityID @@ -358,10 +293,10 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor return (collab, Right sender) - tryJoin (Left (actorByKey, _actorEntity, itemID)) = + tryJoinCollab (Left (actorByKey, _actorEntity, itemID)) = (,Left actorByKey) . collabRecipLocalJoinFulfills <$> MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID) - tryJoin (Right remoteActivityID) = do + tryJoinCollab (Right remoteActivityID) = do CollabRecipRemoteJoin recipID fulfillsID _ <- MaybeT $ getValBy $ UniqueCollabRecipRemoteJoinJoin remoteActivityID @@ -371,6 +306,33 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor return (fulfillsID, Right joiner) + tryInviteComp (Left (actorByKey, _actorEntity, itemID)) = + (,Left (actorByKey, itemID)) . stemProjectGestureLocalOrigin <$> + MaybeT (getValBy $ UniqueStemProjectGestureLocalInvite itemID) + tryInviteComp (Right remoteActivityID) = do + StemProjectGestureRemote originID actorID _ <- + MaybeT $ getValBy $ + UniqueStemProjectGestureRemoteInvite remoteActivityID + actor <- lift $ getJust actorID + inviter <- + lift $ (,remoteActorFollowers actor, remoteActivityID) <$> getRemoteActorURI actor + return (originID, Right inviter) + + tryAddComp (Left (actorByKey, _actorEntity, itemID)) = do + StemComponentGestureLocal stemID _ <- + MaybeT $ getValBy $ UniqueStemComponentGestureLocalActivity itemID + originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID + return (stemID, originID, Left (actorByKey, itemID)) + tryAddComp (Right remoteActivityID) = do + StemComponentGestureRemote stemID actorID _ <- + MaybeT $ getValBy $ + UniqueStemComponentGestureRemoteActivity remoteActivityID + originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID + actor <- lift $ getJust actorID + adder <- + lift $ (,remoteActorFollowers actor,remoteActivityID) <$> getRemoteActorURI actor + return (stemID, originID, Right adder) + prepareGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal @@ -433,6 +395,296 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce return (action, recipientSet, remoteActors, fwdHosts) + topicAcceptCollab maybeCap recipActorID recipActor collab = do + + maybeNew <- withDBExcept $ do + + -- Find the local resource and verify it's me + collabID <- + lift $ case collab of + Left (fulfillsID, _) -> + collabFulfillsInviteCollab <$> getJust fulfillsID + Right (fulfillsID, _) -> + collabFulfillsJoinCollab <$> getJust fulfillsID + topic <- lift $ getCollabTopic collabID + unless (topicResource recipKey == topic) $ + throwE "Accept object is an Invite/Join for some other resource" + + idsForAccept <- + case collab of + + -- If accepting an Invite, find the Collab recipient and verify + -- it's the sender of the Accept + Left (fulfillsID, _) -> Left <$> do + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + case (recip, authorIdMsig) of + (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _)) + | collabRecipLocalPerson crl == personID -> + return (fulfillsID, Left crlid) + (Right (Entity crrid crr), Right (author, _, _)) + | collabRecipRemoteActor crr == remoteAuthorId author -> + return (fulfillsID, Right crrid) + _ -> throwE "Accepting an Invite whose recipient is someone else" + + -- If accepting a Join, verify accepter has permission + Right (fulfillsID, _) -> Right <$> do + capID <- fromMaybeE maybeCap "No capability provided" + capability <- + case capID of + Left (capActor, _, capItem) -> return (capActor, capItem) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" + verifyCapability' + capability + authorIdMsig + (topicResource recipKey) + AP.RoleAdmin + return fulfillsID + + -- Verify the Collab isn't already validated + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeAcceptDB $ \ acceptDB -> do + + -- Record the Accept on the Collab + case (idsForAccept, acceptDB) of + (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID + unless (isNothing maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Right fulfillsID, Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + (Right fulfillsID, Right (author, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + _ -> error "topicAccept impossible" + + -- Prepare forwarding of Accept to my followers + let recipByID = grantResourceLocalActor $ topicResource recipKey + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + grantInfo <- do + + -- Enable the Collab in our DB + grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + lift $ insert_ $ CollabEnable collabID grantID + + -- Prepare a Grant activity and insert to my outbox + let inviterOrJoiner = either snd snd collab + isInvite = isLeft collab + grant@(actionGrant, _, _, _) <- do + Collab role <- lift $ getJust collabID + lift $ prepareGrant isInvite inviterOrJoiner role + let recipByKey = grantResourceLocalActor $ topicResource recipKey + _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant + return (grantID, grant) + + return (recipActorID, sieve, grantInfo) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do + let recipByID = grantResourceLocalActor $ topicResource recipKey + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + done "Forwarded the Accept and published a Grant" + + prepareReact project inviter = do + encodeRouteHome <- getEncodeRouteHome + + (audInviter, uInvite) <- + case inviter of + Left (byKey, itemID) -> do + byHash <- hashLocalActor byKey + itemHash <- encodeKeyHashid itemID + return + ( AudLocal [byHash] [] + , encodeRouteHome $ activityRoute byHash itemHash + ) + Right (ObjURI h lu, _followers, activityID) -> do + objectID <- remoteActivityIdent <$> getJust activityID + luAct <- remoteObjectIdent <$> getJust objectID + return (AudRemote h [lu] [], ObjURI h luAct) + audProject <- + case project of + Left (Entity _ (StemProjectLocal _ projectID)) -> do + projectHash <- encodeKeyHashid projectID + return $ + AudLocal + [LocalActorProject projectHash] + [LocalStageProjectFollowers projectHash] + Right (Entity _ (StemProjectRemote _ actorID)) -> do + actor <- getJust actorID + ObjURI h lu <- getRemoteActorURI actor + let followers = remoteActorFollowers actor + return $ AudRemote h [lu] (maybeToList followers) + audAccepter <- lift $ makeAudSenderOnly authorIdMsig + audMe <- + AudLocal [] . pure . localActorFollowers . + grantResourceLocalActor . topicResource <$> + encodeKeyHashid recipKey + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audInviter, audProject, audAccepter, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uInvite + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + topicAcceptStem maybeCap recipActorID recipActor stem = do + + maybeNew <- withDBExcept $ do + + -- Find the local component and verify it's me + stemID <- + lift $ case stem of + Left (originInviteID, _inviter) -> + stemOriginInviteStem <$> getJust originInviteID + Right (stemID, _originAddID, _adder) -> + return stemID + ident <- lift $ getStemIdent stemID + unless (topicComponent recipKey == ident) $ + throwE "Accept object is an Invite/Add for some other component" + + project <- + lift $ + requireEitherAlt + (getBy $ UniqueStemProjectLocal stemID) + (getBy $ UniqueStemProjectRemote stemID) + "Found Stem with no project" + "Found Stem with multiple projects" + + idsForLater <- bitraverse + + -- Accepting an Invite + -- If I haven't seen the project's approval, verify + -- the author is the project + -- Otherwise, verify the Accept is authorized + (\ (originInviteID, inviter) -> do + scgl <- lift $ getBy $ UniqueStemComponentGestureLocal stemID + scgr <- lift $ getBy $ UniqueStemComponentGestureRemote stemID + unless (isNothing scgl && isNothing scgr) $ + throwE "I've already recorded my collaborator's Accept on the Invite, no need for further Accepts from anyone" + seen <- + lift $ case project of + Left (Entity k _) -> isJust <$> getBy (UniqueStemProjectAcceptLocalProject k) + Right (Entity k _) -> isJust <$> getBy (UniqueStemProjectAcceptRemoteProject k) + if seen + then do + capID <- fromMaybeE maybeCap "No capability provided" + capability <- + case capID of + Left (capActor, _, capItem) -> return (capActor, capItem) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" + verifyCapability' + capability + authorIdMsig + (topicResource recipKey) + AP.RoleAdmin + else case (project, authorIdMsig) of + (Left (Entity _ sjl), Left (LocalActorProject projectID, _, _)) + | stemProjectLocalProject sjl == projectID -> + return () + (Right (Entity _ sjr), Right (author, _, _)) + | stemProjectRemoteProject sjr == remoteAuthorId author -> + return () + _ -> throwE "The Accept I'm waiting for is by the project" + return (originInviteID, seen, inviter) + ) + + (\ (_stemID, _originAddID, _adder) -> do + seen <- + lift $ case project of + Left (Entity k _) -> isJust <$> getBy (UniqueStemProjectGrantLocalProject k) + Right (Entity k _) -> isJust <$> getBy (UniqueStemProjectGrantRemoteProject k) + when seen $ + throwE "Already saw project's Grant, no need for any Accepts" + ) + + stem + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeAcceptDB $ \ acceptDB -> + + case idsForLater of + + Left (originInviteID, seen, inviter) -> do + + if not seen + then do + lift $ case (project, acceptDB) of + (Left (Entity j _), Left (_, _, acceptID)) -> + insert_ $ StemProjectAcceptLocal originInviteID j acceptID + (Right (Entity j _), Right (_, _, acceptID)) -> + insert_ $ StemProjectAcceptRemote originInviteID j acceptID + _ -> error "topicAccept Impossible" + return Nothing + else do + lift $ case acceptDB of + Left (_, _, acceptID) -> + insert_ $ StemComponentGestureLocal stemID acceptID + Right (author, _, acceptID) -> + insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) acceptID + + -- Prepare forwarding of Accept to my followers + let recipByID = grantResourceLocalActor $ topicResource recipKey + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + reactInfo <- do + + -- Record the fresh Accept in our DB + reactID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + lift $ insert_ $ StemComponentAccept stemID reactID + + -- Prepare an Accept activity and insert to my outbox + react@(actionReact, _, _, _) <- lift $ prepareReact project inviter + let recipByKey = grantResourceLocalActor $ topicResource recipKey + _luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact + return (reactID, react) + + return $ Just (sieve, reactInfo) + + Right () -> return Nothing + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just Nothing -> done "Done" + Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do + let recipByID = grantResourceLocalActor $ topicResource recipKey + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ sendActivity + recipByID recipActorID localRecipsReact + remoteRecipsReact fwdHostsReact reactID actionReact + done "Forwarded the Accept and published an Accept" + topicReject :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ActorId) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 2fd9cad..fdcd737 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -372,6 +372,23 @@ deckFollow now recipDeckID verse follow = do -- * Send a Grant: -- * To: Join sender -- * CC: Accept sender, Join sender's followers, my followers +-- * If it's an Invite (that I know about) where I'm invited to a project: +-- * If I haven't yet seen the project's approval: +-- * Verify the author is the project +-- * Record the approval in the Stem record in DB +-- * If I saw project's approval, but not my collaborators' approval: +-- * Verify the Accept is authorized +-- * Record the approval in the Stem record in DB +-- * Forward to my followers +-- * Publish and send an Accept: +-- * To: Inviter, project, Accept author +-- * CC: Project followers, my followers +-- * Record it in the Stem record in DB as well +-- * If I already saw both approvals, respond with error +-- * If it's an Add (that I know about and already Accepted) where I'm +-- invited to a project: +-- * If I've already seen the project's accept, respond with error +-- * Otherwise, just ignore the Accept -- * Otherwise respond with error deckAccept :: UTCTime @@ -379,7 +396,7 @@ deckAccept -> Verse -> AP.Accept URIMode -> ActE (Text, Act (), Next) -deckAccept = topicAccept deckActor GrantResourceDeck +deckAccept = topicAccept deckActor GrantResourceDeck ComponentDeck -- Meaning: An actor rejected something -- Behavior: diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 2299084..cb58b8e 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -16,6 +16,7 @@ module Vervis.Persist.Collab ( getCollabTopic , getCollabTopic' + , getStemIdent , getGrantRecip , getComponentE , getTopicGrants @@ -107,6 +108,19 @@ getCollabTopic' collabID = do (delete k, GrantResourceProject $ collabTopicProjectProject l) _ -> error "Found Collab with multiple topics" +getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key) +getStemIdent stemID = do + maybeRepo <- getValBy $ UniqueStemIdentRepo stemID + maybeDeck <- getValBy $ UniqueStemIdentDeck stemID + maybeLoom <- getValBy $ UniqueStemIdentLoom stemID + return $ + case (maybeRepo, maybeDeck, maybeLoom) of + (Nothing, Nothing, Nothing) -> error "Found Stem without ident" + (Just r, Nothing, Nothing) -> ComponentRepo $ stemIdentRepoRepo r + (Nothing, Just d, Nothing) -> ComponentDeck $ stemIdentDeckDeck d + (Nothing, Nothing, Just l) -> ComponentLoom $ stemIdentLoomLoom l + _ -> error "Found Stem with multiple idents" + getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e