C2S: Implement trivial Undo handler, remove old undoC code

src/Vervis/API.hs

@@ -27,7 +27,6 @@ module Vervis.API
     , createRepositoryC
     , followC
     --, offerDepC
-    , undoC
     )
 where
 
@@ -1973,176 +1972,3 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve
     update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
     return (doc, recipientSet, remoteActors, fwdHosts)
 -}
-
-undoC
-    :: Entity Person
-    -> Actor
-    -> Maybe
-        (Either
-            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
-            FedURI
-        )
-    -> RecipientRoutes
-    -> [(Host, NonEmpty LocalURI)]
-    -> [Host]
-    -> AP.Action URIMode
-    -> AP.Undo URIMode
-    -> ExceptT Text Handler OutboxItemId
-undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Undo uObject) = do
-
-    -- Check input
-    undone <-
-        first (\ (actor, _, item) -> (actor, item)) <$>
-            parseActivityURI uObject
-
-    now <- liftIO getCurrentTime
-    senderHash <- encodeKeyHashid senderPersonID
-
-    (undoID, deliverHttpUndo, maybeDeliverHttpAccept) <- runDBExcept $ do
-
-        -- Find the undone activity in our DB
-        undoneDB <- do
-            a <- getActivity undone
-            fromMaybeE a "Can't find undone in DB"
-
-        -- See if the undone activity is a Follow/Resolve on a local target
-        -- If it is, verify the relevant actor is addressed, verify
-        -- permissions, and perform the actual undoing in the DB
-        maybeUndoLocal <- do
-            maybeUndo <-
-                lift $ runMaybeT $
-                    Left <$> MaybeT (tryUnfollow undoneDB) <|>
-                    Right <$> MaybeT (tryUnresolve undoneDB)
-            case maybeUndo of
-                Nothing -> pure Nothing
-                Just (Left (updateDB, actorID, Left followerSetID)) -> do
-                    actorByKey <- lift $ getLocalActor actorID
-                    unless (actorByKey == LocalActorPerson senderPersonID) $
-                        throwE "Tryin to undo a Follow of someone else"
-                    (fByKey, fActorID, _) <- do
-                        followee <- lift $ getFollowee' followerSetID
-                        getFollowee followee
-                    fByHash <- hashLocalActor fByKey
-                    unless (actorIsAddressed localRecips fByHash) $
-                        throwE "Followee's actor not addressed by the Undo"
-                    lift updateDB
-                    fActor <- lift $ getJust fActorID
-                    return $ Just
-                        ( fByKey
-                        , Entity fActorID fActor
-                        , makeRecipientSet
-                            [fByHash]
-                            [LocalStagePersonFollowers senderHash]
-                        , [LocalActorPerson senderHash]
-                        , []
-                        )
-                Just (Left (updateDB, actorID, Right uTarget)) -> do
-                    actorByKey <- lift $ getLocalActor actorID
-                    unless (actorByKey == LocalActorPerson senderPersonID) $
-                        throwE "Trying to undo a Follow of someone else"
-                    verifyRemoteAddressed remoteRecips uTarget
-                    lift updateDB
-                    return Nothing
-                Just (Right (updateDB, ticketID)) -> do
-                    wiByKey <- lift $ getWorkItem ticketID
-                    wiByHash <- lift $ lift $ VA2.runAct $ hashWorkItem wiByKey
-                    let resource = workItemResource wiByKey
-                        actorByKey = workItemActor wiByKey
-                        actorByHash = workItemActor wiByHash
-                    unless (actorIsAddressed localRecips actorByHash) $
-                        throwE "Work item's actor not addressed by the Undo"
-                    capID <- fromMaybeE maybeCap "No capability provided"
-                    capability <-
-                        case capID of
-                            Left (capActor, _, capItem) -> return (capActor, capItem)
-                            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
-                    verifyCapability capability (Left senderPersonID) resource RoleTriage
-                    lift updateDB
-                    actorID <- do
-                        maybeActor <- lift $ getLocalActorEntity actorByKey
-                        case localActorID <$> maybeActor of
-                            Nothing -> error "Actor entity not in DB"
-                            Just aid -> pure aid
-                    actor <- lift $ getJust actorID
-                    return $ Just
-                        ( actorByKey
-                        , Entity actorID actor
-                        , makeRecipientSet
-                            [actorByHash]
-                            [ localActorFollowers actorByHash
-                            , workItemFollowers wiByHash
-                            , LocalStagePersonFollowers senderHash
-                            ]
-                        , [LocalActorPerson senderHash]
-                        , [ localActorFollowers actorByHash
-                          , workItemFollowers wiByHash
-                          , LocalStagePersonFollowers senderHash
-                          ]
-                        )
-
-        -- Insert the Undo activity to author's outbox
-        undoID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        luUndo <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) undoID action
-
-        -- Deliver the Undo activity to local recipients, and schedule delivery
-        -- for unavailable remote recipients
-        deliverHttpUndo <- do
-            let sieve =
-                    case maybeUndoLocal of
-                        Nothing ->
-                            makeRecipientSet
-                                [] [LocalStagePersonFollowers senderHash]
-                        Just (_, _, s, _, _) -> s
-                localRecipsFinal = localRecipSieve sieve False localRecips
-            deliverActivityDB
-                (LocalActorPerson senderHash) (personActor senderPerson)
-                localRecipsFinal remoteRecips fwdHosts undoID action
-
-        maybeDeliverHttpAccept <- for maybeUndoLocal $ \ (actorByKey, Entity actorID actor, _, acceptActors, acceptStages) -> do
-
-            -- Verify the relevant actor has received the Undp
-            verifyActorHasItem actorID undoID "Actor didn't receive the Undo"
-
-            -- Insert an Accept activity to actor's outbox
-            acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
-            actionAccept <- prepareAccept luUndo acceptActors acceptStages
-            _luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept
-
-            -- Deliver the Accept activity to local recipients, and schedule
-            -- delivery for unavailable remote recipients
-            let localRecipsAccept = makeRecipientSet acceptActors acceptStages
-            actorByHash <- hashLocalActor actorByKey
-            deliverActivityDB
-                actorByHash actorID localRecipsAccept [] []
-                acceptID actionAccept
-
-        -- Return instructions for HTTP delivery to remote recipients
-        return (undoID, deliverHttpUndo, maybeDeliverHttpAccept)
-
-    -- Launch asynchronous HTTP delivery of Undo and Accept
-    lift $ do
-        forkWorker "undoC: async HTTP Undo delivery" deliverHttpUndo
-        for_ maybeDeliverHttpAccept $
-            forkWorker "undoC: async HTTP Accept delivery"
-
-    return undoID
-
-    where
-
-    prepareAccept luUndo actors stages = do
-        encodeRouteHome <- getEncodeRouteHome
-        hLocal <- asksSite siteInstanceHost
-        let recips =
-                map encodeRouteHome $
-                        map renderLocalActor actors ++
-                        map renderLocalStage stages
-        return AP.Action
-            { AP.actionCapability = Nothing
-            , AP.actionSummary    = Nothing
-            , AP.actionAudience   = Audience recips [] [] [] [] []
-            , AP.actionFulfills   = []
-            , AP.actionSpecific   = AP.AcceptActivity AP.Accept
-                { AP.acceptObject   = ObjURI hLocal luUndo
-                , AP.acceptResult   = Nothing
-                }
-            }

src/Vervis/Actor/Person/Client.hs

@@ -1009,7 +1009,7 @@ clientResolve
     -> ActE OutboxItemId
 clientResolve now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) (AP.Resolve uObject) = do
 
-    (actorMeID, localRecipsFinal, acceptID) <- withDBExcept $ do
+    (actorMeID, localRecipsFinal, resolveID) <- withDBExcept $ do
 
         -- Grab me from DB
         (personMe, actorMe) <- lift $ do
@@ -1028,8 +1028,42 @@ clientResolve now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHos
 
     lift $ sendActivity
         (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
-        fwdHosts acceptID action
-    return acceptID
+        fwdHosts resolveID action
+    return resolveID
+
+-- Meaning: The human wants to unfollow or unresolve
+-- Behavior:
+--      * Insert the Undo to my inbox
+--      * Asynchrnously deliver without filter
+clientUndo
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.Undo URIMode
+    -> ActE OutboxItemId
+clientUndo now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) (AP.Undo uObject) = do
+
+    (actorMeID, localRecipsFinal, undoID) <- withDBExcept $ do
+
+        -- Grab me from DB
+        (personMe, actorMe) <- lift $ do
+            p <- getJust personMeID
+            (p,) <$> getJust (personActor p)
+
+        -- Insert the Undo activity to my outbox
+        acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+        _luAccept <- lift $ updateOutboxItem' (LocalActorPerson personMeID) acceptID action
+
+        return
+            ( personActor personMe
+            , localRecips
+            , acceptID
+            )
+
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+        fwdHosts undoID action
+    return undoID
 
 clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next)
 clientBehavior now personID msg =
@@ -1042,4 +1076,5 @@ clientBehavior now personID msg =
         AP.OfferActivity offer   -> clientOffer now personID msg offer
         AP.RemoveActivity remove -> clientRemove now personID msg remove
         AP.ResolveActivity resolve -> clientResolve now personID msg resolve
+        AP.UndoActivity undo     -> clientUndo now personID msg undo
         _ -> throwE "Unsupported activity type for C2S"

src/Vervis/Federation/Offer.hs

@@ -26,7 +26,6 @@ module Vervis.Federation.Offer
     --, repoFollowF
 
       --personUndoF
-      --deckUndoF
       loomUndoF
     , repoUndoF
     )

src/Vervis/Handler/Person.hs

@@ -254,7 +254,6 @@ postPersonOutboxR personHash = do
                         offerDepC eperson sharer summary audience dep target
                     -}
                     _ -> throwE "Unsupported Offer 'object' type"
-            AP.UndoActivity undo -> run undoC undo
             _ ->
                 handleViaActor
                     (entityKey eperson) maybeCap localRecips remoteRecips