From 552ef760e606a60e13ca881dc2801883212c416e Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Mon, 5 Jun 2023 10:03:20 +0300
Subject: [PATCH] Person: Port Reject{Follow} handler

---
 src/Vervis/Actor/Person.hs | 59 +++++++++++++++++++++++++++++++++++++-
 src/Vervis/Data/Collab.hs  |  5 ++++
 2 files changed, 63 insertions(+), 1 deletion(-)

diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs
index 56196db..5557a21 100644
--- a/src/Vervis/Actor/Person.hs
+++ b/src/Vervis/Actor/Person.hs
@@ -230,7 +230,7 @@ personAccept
     -> LocalURI
     -> AP.Accept URIMode
     -> ActE (Text, Act (), Next)
-personAccept now recipPersonID author body mfwd luAccept accept = do
+personAccept now recipPersonID author body _mfwd luAccept accept = do
 
     -- Check input
     acceptee <- parseAccept accept
@@ -280,6 +280,61 @@ personAccept now recipPersonID author body mfwd luAccept accept = do
             }
     tryFollow _ (Right _) _ = mzero
 
+-- Meaning: A remote actor rejected something
+-- Behavior:
+--      * Insert to my inbox
+--      * If it's a Follow I sent to them, remove record from my DB
+personReject
+    :: UTCTime
+    -> PersonId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Reject URIMode
+    -> ActE (Text, Act (), Next)
+personReject now recipPersonID author body _mfwd luReject reject = do
+
+    -- Check input
+    rejectee <- parseReject reject
+
+    maybeReject <- withDBExcept $ do
+
+        -- Grab recipient person from DB
+        (personRecip, actorRecip) <- lift $ do
+            p <- getJust recipPersonID
+            (p,) <$> getJust (personActor p)
+
+        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luReject True
+        for mractid $ \ rejectID -> runMaybeT $ do
+
+            -- Find the rejected activity in our DB
+            rejecteeDB <- MaybeT $ getActivity rejectee
+
+            tryFollow rejecteeDB
+
+    case maybeReject of
+        Nothing -> done "I already have this activity in my inbox"
+        Just Nothing -> done "Not my Follow; Just inserted to my inbox"
+        Just (Just ()) ->
+            done "Recorded this Reject on the Follow request I sent"
+
+    where
+
+    tryFollow (Left (_, _, outboxItemID)) = do
+        Entity key val <-
+            MaybeT $ lift $
+                getBy $ UniqueFollowRemoteRequestActivity outboxItemID
+        guard $ followRemoteRequestPerson val == recipPersonID
+        let uRecip =
+                fromMaybe
+                    (followRemoteRequestTarget val)
+                    (followRemoteRequestRecip val)
+        unless (remoteAuthorURI author == uRecip) $
+            lift $ throwE "You're Rejecting a Follow I sent to someone else"
+        lift $ lift $ delete key
+    tryFollow (Right _) = mzero
+
 ------------------------------------------------------------------------------
 -- Commenting
 ------------------------------------------------------------------------------
@@ -569,4 +624,6 @@ personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
         AP.UndoActivity undo ->
             (,Nothing) <$> personUndoA now personID author body mfwd luActivity undo
         -}
+        AP.RejectActivity reject ->
+            personReject now personID author body mfwd luActivity reject
         _ -> throwE "Unsupported activity type for Person"
diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs
index c5cf07f..0c071fb 100644
--- a/src/Vervis/Data/Collab.hs
+++ b/src/Vervis/Data/Collab.hs
@@ -25,6 +25,7 @@ module Vervis.Data.Collab
     , parseJoin
     , parseGrant
     , parseAccept
+    , parseReject
 
     , grantResourceActorID
     )
@@ -236,6 +237,10 @@ parseAccept (AP.Accept object mresult) = do
     first (\ (actor, _, item) -> (actor, item)) <$>
         nameExceptT "Accept object" (parseActivityURI' object)
 
+parseReject (AP.Reject object) =
+    first (\ (actor, _, item) -> (actor, item)) <$>
+        nameExceptT "Reject object" (parseActivityURI' object)
+
 grantResourceActorID :: GrantResourceBy Identity -> ActorId
 grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
 grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d