diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index be4ecec..a0adfc4 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -54,6 +54,7 @@ import Yesod.MonadSite import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Data.Either.Local import Database.Persist.Local import Vervis.Access @@ -130,6 +131,13 @@ verifyRemoteAddressed remoteRecips u = -- Behavior: -- * Insert to my inbox -- * Deliver without filtering +-- * If it's an Invite (that I know about) where I'm invited to a project/team/component: +-- * If I haven't yet seen the topic's approval: +-- * Respond with error, we want to wait for the approval +-- * If I saw topic's approval, but not its direct-Grant: +-- * If I already accepted, raise error +-- * Otherwise, record the approval in the Permit record in DB +-- * If I already saw both, respond with error, as Permit is already enabled clientAccept :: UTCTime -> PersonId @@ -138,6 +146,9 @@ clientAccept -> ActE OutboxItemId clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) accept = do + -- Check input + acceptee <- parseAccept accept + (actorMeID, localRecipsFinal, acceptID) <- withDBExcept $ do -- Grab me from DB @@ -145,10 +156,56 @@ clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost p <- getJust personMeID (p,) <$> getJust (personActor p) + -- Find the accepted activity in our DB + accepteeDB <- do + a <- getActivity acceptee + fromMaybeE a "Can't find acceptee in DB" + -- Insert the Accept activity to my outbox acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now _luAccept <- lift $ updateOutboxItem' (LocalActorPerson personMeID) acceptID action + -- See if the accepted activity is an Invite to a resource, grabbing + -- the Permit record from our DB + maybePermit <- lift $ runMaybeT $ tryInvite accepteeDB + + for_ maybePermit $ \ (permitID, _fulfillsID) -> do + + -- Find the local person and verify it's me + Permit p _role <- lift $ getJust permitID + when (p == personMeID) $ do + + -- Find the topic + topic <- + lift $ + requireEitherAlt + (getKeyBy $ UniquePermitTopicLocal permitID) + (getKeyBy $ UniquePermitTopicRemote permitID) + "Permit without topic" + "Permit with both local and remote topic" + + -- If I haven't seen topic's Accept, raise error + maybeTopicAccept <- + lift $ case topic of + Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID) + Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID) + when (isNothing maybeTopicAccept) $ + throwE "Haven't seen topic's Accept yet, please wait for it" + + -- If I haven't seen the direct-Grant, and haven't already + -- accepted, record my accept + -- If I've already accepted or seen the direct-Grant, raise an error + maybeTopicEnable <- + lift $ case topic of + Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID) + Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID) + if isNothing maybeTopicEnable + then do + maybeInserted <- lift $ insertUnique $ PermitPersonGesture permitID acceptID + when (isNothing maybeInserted) $ + throwE "I already Accepted this Invite" + else throwE "I already have a direct-Grant for this Invite" + return ( personActor personMe , localRecips @@ -160,6 +217,19 @@ clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost fwdHosts acceptID action return acceptID + where + + tryInvite (Left (actorByKey, _actorEntity, itemID)) = do + PermitTopicGestureLocal fulfillsID _ <- + MaybeT $ getValBy $ UniquePermitTopicGestureLocalInvite itemID + PermitFulfillsInvite permitID <- lift $ getJust fulfillsID + return (permitID, fulfillsID) + tryInvite (Right remoteActivityID) = do + PermitTopicGestureRemote fulfillsID _ _ <- + MaybeT $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID + PermitFulfillsInvite permitID <- lift $ getJust fulfillsID + return (permitID, fulfillsID) + -- Meaning: The human wants to add component C to project P -- Behavior: -- * Some basic sanity checks