S2S: Person: Accept: If topic is approving an Invite, update Permit record

src/Data/Maybe/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,9 +16,12 @@
 module Data.Maybe.Local
     ( partitionMaybes
     , partitionMaybePairs
+    , exactlyOneJust
     )
 where
 
+import Data.Maybe
+
 partitionMaybes :: [(Maybe a, b)] -> ([(a, b)], [b])
 partitionMaybes = foldr f ([], [])
     where
@@ -32,3 +35,10 @@ partitionMaybePairs = foldr f ([], [], [])
     f (Just x,  Nothing) (xs, ys, ps) = (x : xs, ys, ps)
     f (Nothing, Just y)  (xs, ys, ps) = (xs, y : ys, ps)
     f (Just x,  Just y)  (xs, ys, ps) = (xs, ys, (x, y) : ps)
+
+exactlyOneJust :: Monad m => [Maybe a] -> String -> String -> m a
+exactlyOneJust l none multiple =
+    case catMaybes l of
+        [] -> error none
+        [x] -> pure x
+        _ -> error multiple

src/Vervis/Actor/Person.hs

@@ -19,6 +19,7 @@ module Vervis.Actor.Person
     )
 where
 
+import Control.Applicative
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
@@ -274,7 +275,13 @@ personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do
 -- Meaning: An actor accepted something
 -- Behavior:
 --      * Insert to my inbox
---      * If it's a Follow I sent to them, add to my following list in DB
+--      * If it's on a Follow I sent to them:
+--          * Add to my following list in DB
+--      * If it's on an Invite-for-me to collaborate on a resource:
+--          * Verify I haven't yet seen the resource's accept
+--          * Verify the Accept author is the resource
+--          * Store it in the Permit record in DB
+--          * Forward to my followers
 personAccept
     :: UTCTime
     -> PersonId
@@ -299,13 +306,22 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
             -- Find the accepted activity in our DB
             accepteeDB <- MaybeT $ getActivity acceptee
 
-            tryFollow (personActor personRecip) accepteeDB acceptDB
+            let recipActorID = personActor personRecip
+            Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
+                Right <$> tryInvite recipActorID accepteeDB acceptDB
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just Nothing -> done "Not my Follow; Just inserted to my inbox"
+        Just Nothing -> done "Not my Follow/Invite; Just inserted to my inbox"
-        Just (Just ()) ->
+        Just (Just (Left ())) ->
             done "Recorded this Accept on the Follow request I sent"
+        Just (Just (Right (actorID, sieve))) -> do
+            forwardActivity
+                authorIdMsig body (LocalActorPerson recipPersonID)
+                actorID sieve
+            done
+                "Recorded this Accept on the Invite I've had & \
+                \forwarded to my followers"
 
     where
 
@@ -360,6 +376,56 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
         -}
     tryFollow _ (Right _) _ = mzero
 
+    tryInvite recipActorID accepteeDB acceptDB = do
+
+        -- Find a PermitFulfillsInvite
+        (permitID, fulfillsID) <-
+            case accepteeDB of
+                Left (actorByKey, _actorEntity, itemID) -> do
+                    PermitTopicGestureLocal fulfillsID _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
+                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
+                    return (permitID, fulfillsID)
+                Right remoteActivityID -> do
+                    PermitTopicGestureRemote fulfillsID _ _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
+                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
+                    return (permitID, fulfillsID)
+
+        -- Find the local person and verify it's me
+        Permit p _role <- lift . lift $ getJust permitID
+        guard $ p == recipPersonID
+
+        lift $ do
+            -- Find the topic
+            topic <- lift $ getPermitTopic permitID
+
+            -- Verify I haven't seen the topic's accept yet
+            maybeTopicAccept <-
+                lift $ case bimap fst fst topic of
+                    Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID)
+                    Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID)
+            unless (isNothing maybeTopicAccept) $
+                throwE "I've already seen the topic's Accept"
+
+            -- Verify topic is the Accept sender
+            case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of
+                (Left la, Left la') | la == la' -> pure ()
+                (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
+                _ -> throwE "Accept sender isn't the Invite topic"
+
+            -- Update the Permit record
+            lift $ case (bimap fst fst topic, bimap (view _3) (view _3) acceptDB)  of
+                (Left localID, Left acceptID) -> insert_ $ PermitTopicAcceptLocal fulfillsID localID acceptID
+                (Right remoteID, Right acceptID) -> insert_ $ PermitTopicAcceptRemote fulfillsID remoteID acceptID
+                _ -> error "personAccept impossible"
+
+            -- Prepare forwarding Accept to my followers
+            recipPersonHash <- encodeKeyHashid recipPersonID
+            let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
+
+            return (recipActorID, sieve)
+
 -- Meaning: An actor rejected something
 -- Behavior:
 --      * Insert to my inbox

src/Vervis/Persist/Collab.hs

@@ -17,6 +17,7 @@ module Vervis.Persist.Collab
     ( getCollabTopic
     , getCollabTopic'
     , getCollabRecip
+    , getPermitTopic
     , getStemIdent
     , getStemProject
     , getGrantRecip
@@ -64,6 +65,7 @@ import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
+import Data.Maybe.Local
 import Database.Persist.Local
 
 import Vervis.Actor
@@ -110,6 +112,46 @@ getCollabRecip collabID =
         "Collab without recip"
         "Collab with both local and remote recip"
 
+getPermitTopic
+    :: MonadIO m
+    => PermitId
+    -> ReaderT SqlBackend m
+        (Either
+            (PermitTopicLocalId, LocalActorBy Key)
+            (PermitTopicRemoteId, RemoteActorId)
+        )
+getPermitTopic permitID = do
+    topic <-
+        requireEitherAlt
+            (getKeyBy $ UniquePermitTopicLocal permitID)
+            (getBy $ UniquePermitTopicRemote permitID)
+            "Permit without topic"
+            "Permit with both local and remote topic"
+    bitraverse
+        (\ localID -> (localID,) <$> do
+            options <-
+                sequence
+                    [ fmap (LocalActorRepo . permitTopicRepoRepo) <$>
+                        getValBy (UniquePermitTopicRepo localID)
+                    , fmap (LocalActorDeck . permitTopicDeckDeck) <$>
+                        getValBy (UniquePermitTopicDeck localID)
+                    , fmap (LocalActorLoom . permitTopicLoomLoom) <$>
+                        getValBy (UniquePermitTopicLoom localID)
+                    , fmap (LocalActorProject . permitTopicProjectProject) <$>
+                        getValBy (UniquePermitTopicProject localID)
+                    , fmap (LocalActorGroup . permitTopicGroupGroup) <$>
+                        getValBy (UniquePermitTopicGroup localID)
+                    ]
+            exactlyOneJust
+                options
+                "Found Permit without topic"
+                "Found Permit with multiple topics"
+        )
+        (\ (Entity topicID (PermitTopicRemote _ actorID)) ->
+            return (topicID, actorID)
+        )
+        topic
+
 getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)
 getStemIdent stemID = do
     maybeRepo <- getValBy $ UniqueStemIdentRepo stemID