Person: Port the Accept{Follow} handler

src/Vervis/API.hs

@@ -168,7 +168,8 @@ acceptC
     -> AP.Accept URIMode
     -> ExceptT Text Handler OutboxItemId
 acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action accept = do
-
+    error "acceptC temporarily disabled due to actor refactoring"
+{-
     -- Check input
     verifyNothingE maybeCap "Capability not needed"
     acceptee <- parseAccept accept
@@ -374,6 +375,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}
 
 addBundleC
     :: Entity Person

src/Vervis/Actor/Person.hs

@@ -217,6 +217,69 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
         (\ () -> pure [])
         now recipPersonID author body mfwd luFollow follow
 
+-- Meaning: A remote actor accepted something
+-- Behavior:
+--      * Insert to my inbox
+--      * If it's a Follow I sent to them, add to my following list in DB
+personAccept
+    :: UTCTime
+    -> PersonId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Accept URIMode
+    -> ActE (Text, Act (), Next)
+personAccept now recipPersonID author body mfwd luAccept accept = do
+
+    -- Check input
+    acceptee <- parseAccept accept
+
+    maybeAccept <- 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) luAccept True
+        for mractid $ \ acceptID -> runMaybeT $ do
+
+            -- Find the accepted activity in our DB
+            accepteeDB <- MaybeT $ getActivity acceptee
+
+            tryFollow (personActor personRecip) accepteeDB acceptID
+
+    case maybeAccept 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 Accept on the Follow request I sent"
+
+    where
+
+    tryFollow actorID (Left (_, _, outboxItemID)) acceptID = 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 Accepting a Follow I sent to someone else"
+        lift $ lift $ delete key
+        lift $ lift $ insert_ FollowRemote
+            { followRemoteActor  = actorID
+            , followRemoteRecip  = remoteAuthorId author
+            , followRemoteTarget = followRemoteRequestTarget val
+            , followRemotePublic = followRemoteRequestPublic val
+            , followRemoteFollow = outboxItemID
+            , followRemoteAccept = acceptID
+            }
+    tryFollow _ (Right _) _ = mzero
+
 ------------------------------------------------------------------------------
 -- Commenting
 ------------------------------------------------------------------------------
@@ -487,6 +550,8 @@ personBehavior now personID (Left event) =
         _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event)
 personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
     case AP.activitySpecific $ actbActivity body of
+        AP.AcceptActivity accept ->
+            personAccept now personID author body mfwd luActivity accept
         AP.CreateActivity (AP.Create obj mtarget) ->
             case obj of
                 AP.CreateNote _ note ->

src/Vervis/Data/Actor.hs

@@ -15,7 +15,9 @@
 
 module Vervis.Data.Actor
     ( parseLocalActivityURI
+    , parseLocalActivityURI'
     , parseActivityURI
+    , parseActivityURI'
     , activityRoute
     , stampRoute
     , parseStampRoute
@@ -47,6 +49,9 @@ import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import qualified Web.Actor as WA
+import qualified Web.Actor.Persist as WAP
+
 import Control.Monad.Trans.Except.Local
 
 import Vervis.FedURI
@@ -54,6 +59,8 @@ import Vervis.Foundation
 import Vervis.Model
 import Vervis.Recipient
 
+import qualified Vervis.Actor as VA
+
 parseLocalActivityURI
     :: (MonadSite m, YesodHashids (SiteEnv m))
     => LocalURI
@@ -75,6 +82,26 @@ parseLocalActivityURI luAct = do
     parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
     parseOutboxItemRoute _                       = Nothing
 
+parseLocalActivityURI'
+    :: LocalURI
+    -> VA.ActE (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
+parseLocalActivityURI' luAct = do
+    route <- fromMaybeE (WA.decodeRouteLocal luAct) "Not a valid route"
+    (actorHash, outboxItemHash) <-
+        fromMaybeE
+            (parseOutboxItemRoute route)
+            "Valid local route, but not an outbox item route"
+    outboxItemID <- WAP.decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
+    actorKey <- VA.unhashLocalActorE actorHash "Invalid actor hash"
+    return (actorKey, actorHash, outboxItemID)
+    where
+    parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
+    parseOutboxItemRoute (GroupOutboxItemR g i)  = Just (LocalActorGroup g, i)
+    parseOutboxItemRoute (RepoOutboxItemR r i)   = Just (LocalActorRepo r, i)
+    parseOutboxItemRoute (DeckOutboxItemR d i)   = Just (LocalActorDeck d, i)
+    parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
+    parseOutboxItemRoute _                       = Nothing
+
 -- | If the given URI is remote, return as is. If the URI is local, verify that
 -- it parses as an activity URI, i.e. an outbox item route, and return the
 -- parsed route.
@@ -92,6 +119,22 @@ parseActivityURI u@(ObjURI h lu) = do
         then Left <$> parseLocalActivityURI lu
         else pure $ Right u
 
+-- | If the given URI is remote, return as is. If the URI is local, verify that
+-- it parses as an activity URI, i.e. an outbox item route, and return the
+-- parsed route.
+parseActivityURI'
+    :: FedURI
+    -> VA.ActE
+        (Either
+            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
+            FedURI
+        )
+parseActivityURI' u@(ObjURI h lu) = do
+    hl <- WA.hostIsLocal h
+    if hl
+        then Left <$> parseLocalActivityURI' lu
+        else pure $ Right u
+
 activityRoute :: LocalActorBy KeyHashid -> KeyHashid OutboxItem -> Route App
 activityRoute (LocalActorPerson p) = PersonOutboxItemR p
 activityRoute (LocalActorGroup g) = GroupOutboxItemR g

src/Vervis/Data/Collab.hs

@@ -232,9 +232,9 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
             else pure $ Right u
 
 parseAccept (AP.Accept object mresult) = do
-    verifyNothingE mresult "Accept must not contain 'result'"
+    --verifyNothingE mresult "Accept must not contain 'result'"
     first (\ (actor, _, item) -> (actor, item)) <$>
-        nameExceptT "Accept object" (parseActivityURI object)
+        nameExceptT "Accept object" (parseActivityURI' object)
 
 grantResourceActorID :: GrantResourceBy Identity -> ActorId
 grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r

src/Vervis/Federation/Collab.hs

@@ -357,7 +357,8 @@ topicAcceptF
     -> AP.Accept URIMode
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept accept = (,Nothing) <$> do
-
+    error "topicAcceptF temporarily disabled due to actor refactoring"
+{-
     -- Check input
     acceptee <- parseAccept accept
 
@@ -564,6 +565,7 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}
 
 repoAcceptF
     :: UTCTime