C2S: Accept: If accepting an Invite-for-me, update the Permit record

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