S2S: Implement repoUndoF, loomUndoF, personUndoF

src/Vervis/Federation/Offer.hs

@@ -25,9 +25,10 @@ module Vervis.Federation.Offer
     , loomFollowF
     , repoFollowF
 
-    --, sharerUndoF
+    , personUndoF
     , deckUndoF
-    --, repoUndoF
+    , loomUndoF
+    , repoUndoF
     )
 where
 
@@ -677,6 +678,146 @@ repoFollowF now recipRepoHash =
         now
         recipRepoHash
 
+personUndoF
+    :: UTCTime
+    -> KeyHashid Person
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Undo URIMode
+    -> ExceptT Text Handler Text
+personUndoF now recipPersonHash author body mfwd luUndo (AP.Undo uObject) = do
+
+    -- Check input
+    recipPersonID <- decodeKeyHashid404 recipPersonHash
+    undone <-
+        first (\ (actor, _, item) -> (actor, item)) <$>
+            parseActivityURI uObject
+
+    -- Verify the capability URI, if provided, is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCapability <-
+        for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+            nameExceptT "Undo capability" $
+                first (\ (actor, _, item) -> (actor, item)) <$>
+                    parseActivityURI uCap
+
+    maybeHttp <- runDBExcept $ do
+
+        -- Find recipient person in DB, returning 404 if doesn't exist because we're
+        -- in the person's inbox post handler
+        (recipPersonActorID, recipPersonActor) <- lift $ do
+            person <- get404 recipPersonID
+            let actorID = personActor person
+            (actorID,) <$> getJust actorID
+
+        -- Insert the Undo to person's inbox
+        mractid <- lift $ insertToInbox now author body (actorInbox recipPersonActor) luUndo False
+        for mractid $ \ undoID -> do
+
+            maybeUndo <- runMaybeT $ do
+
+                -- Find the undone activity in our DB
+                undoneDB <- MaybeT $ getActivity undone
+
+                let followers = actorFollowers recipPersonActor
+                MaybeT $ lift $ runMaybeT $ tryUnfollow followers undoneDB
+
+            for maybeUndo $ \ (remoteFollowID, followerID) -> do
+
+                (sieve, acceptAudience) <- do
+                    (audSenderOnly, _audSenderAndFollowers) <- do
+                        ra <- lift $ getJust $ remoteAuthorId author
+                        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+                        return
+                            ( AudRemote hAuthor [luAuthor] []
+                            , AudRemote hAuthor
+                                [luAuthor]
+                                (maybeToList $ remoteActorFollowers ra)
+                            )
+                    unless (followerID == remoteAuthorId author) $
+                        throwE "Trying to undo someone else's Follow"
+                    lift $ delete remoteFollowID
+                    return
+                        ( makeRecipientSet [] []
+                        , [audSenderOnly]
+                        )
+
+                -- Forward the Undo activity to relevant local stages, and
+                -- schedule delivery for unavailable remote members of them
+                maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
+                    forwardActivityDB
+                        (actbBL body) localRecips sig recipPersonActorID
+                        (LocalActorPerson recipPersonHash) sieve undoID
+
+
+                -- Prepare an Accept activity and insert to person's outbox
+                acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipPersonActor) now
+                (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                    lift . lift $ prepareAccept acceptAudience
+                _luAccept <- lift $ updateOutboxItem (LocalActorPerson recipPersonID) acceptID actionAccept
+
+                -- Deliver the Accept to local recipients, and schedule delivery
+                -- for unavailable remote recipients
+                deliverHttpAccept <-
+                    deliverActivityDB
+                        (LocalActorPerson recipPersonHash) recipPersonActorID
+                        localRecipsAccept remoteRecipsAccept fwdHostsAccept
+                        acceptID actionAccept
+
+                -- Return instructions for HTTP inbox-forwarding of the Undo
+                -- activity, and for HTTP delivery of the Accept activity to
+                -- remote recipients
+                return (maybeHttpFwdUndo, deliverHttpAccept)
+
+    -- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
+    -- delivery of the Accept activity
+    case maybeHttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just Nothing -> return "Unrelated to me, just inserted to inbox"
+        Just (Just (maybeHttpFwdUndo, deliverHttpAccept)) -> do
+            forkWorker "personUndoF Accept HTTP delivery" deliverHttpAccept
+            case maybeHttpFwdUndo of
+                Nothing -> return "Undid, no inbox-forwarding to do"
+                Just forwardHttpUndo -> do
+                    forkWorker "personUndoF inbox-forwarding" forwardHttpUndo
+                    return "Undid and ran inbox-forwarding of the Undo"
+
+    where
+
+    tryUnfollow _               (Left _)                 = mzero
+    tryUnfollow personFollowersID (Right remoteActivityID) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        guard $ followerSetID == personFollowersID
+        return (remoteFollowID, followerID)
+
+    prepareAccept audience = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        let ObjURI hAuthor _ = remoteAuthorURI author
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience audience
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = []
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = ObjURI hAuthor luUndo
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 deckUndoF
     :: UTCTime
     -> KeyHashid Deck
@@ -888,274 +1029,352 @@ deckUndoF now recipDeckHash author body mfwd luUndo (AP.Undo uObject) = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-{-
-getFollow (Left _)        = return Nothing
-getFollow (Right ractid)  = getBy $ UniqueRemoteFollowFollow ractid
+loomUndoF
+    :: UTCTime
+    -> KeyHashid Loom
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Undo URIMode
+    -> ExceptT Text Handler Text
+loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
 
-getResolve (Left (_, obiid)) = fmap Left <$> getBy (UniqueTicketResolveLocalActivity obiid)
-getResolve (Right ractid)    = fmap Right <$> getBy (UniqueTicketResolveRemoteActivity ractid)
+    -- Check input
+    recipLoomID <- decodeKeyHashid404 recipLoomHash
+    undone <-
+        first (\ (actor, _, item) -> (actor, item)) <$>
+            parseActivityURI uObject
 
-deleteResolve myWorkItem prepareAccept tr = do
-    let (trid, trxid) =
-            case tr of
-                Left (Entity trlid trl) -> (ticketResolveLocalTicket trl, Left trlid)
-                Right (Entity trrid trr) -> (ticketResolveRemoteTicket trr, Right trrid)
-    ltid <- ticketResolveTicket <$> getJust trid
-    wi <- getWorkItem ltid
-    case myWorkItem wi of
-        Nothing -> return ("Undo is of a TicketResolve but not my ticket", Nothing, Nothing)
-        Just wiData -> do
-            bitraverse delete delete trxid
-            delete trid
-            tid <- localTicketTicket <$> getJust ltid
-            update tid [TicketStatus =. TSTodo]
-            (colls, accept) <- prepareAccept wiData
-            return ("Ticket unresolved", Just colls, Just accept)
+    -- Verify the capability URI, if provided, is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCapability <-
+        for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+            nameExceptT "Undo capability" $
+                first (\ (actor, _, item) -> (actor, item)) <$>
+                    parseActivityURI uCap
+
+    maybeHttp <- runDBExcept $ do
+
+        -- Find recipient loom in DB, returning 404 if doesn't exist because we're
+        -- in the loom's inbox post handler
+        (recipLoomActorID, recipLoomActor) <- lift $ do
+            loom <- get404 recipLoomID
+            let actorID = loomActor loom
+            (actorID,) <$> getJust actorID
+
+        -- Insert the Undo to loom's inbox
+        mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luUndo False
+        for mractid $ \ undoID -> do
+
+            -- Find the undone activity in our DB
+            undoneDB <- do
+                a <- getActivity undone
+                fromMaybeE a "Can't find undone in DB"
+
+            (sieve, acceptAudience) <- do
+                maybeUndo <- do
+                    let followers = actorFollowers recipLoomActor
+                    lift $ runMaybeT $
+                        Left <$> tryUnfollow recipLoomID followers undoneDB <|>
+                        Right <$> tryUnresolve recipLoomID undoneDB
+                undo <- fromMaybeE maybeUndo "Undone activity isn't a Follow or Resolve related to me"
+                (audSenderOnly, audSenderAndFollowers) <- do
+                    ra <- lift $ getJust $ remoteAuthorId author
+                    let ObjURI hAuthor luAuthor = remoteAuthorURI author
+                    return
+                        ( AudRemote hAuthor [luAuthor] []
+                        , AudRemote hAuthor
+                            [luAuthor]
+                            (maybeToList $ remoteActorFollowers ra)
+                        )
+                case undo of
+                    Left (remoteFollowID, followerID) -> do
+                        unless (followerID == remoteAuthorId author) $
+                            throwE "Trying to undo someone else's Follow"
+                        lift $ delete remoteFollowID
+                        return
+                            ( makeRecipientSet [] []
+                            , [audSenderOnly]
+                            )
+                    Right (deleteFromDB, clothID) -> do
+
+                        -- Verify the sender is authorized by the loom to unresolve a MR
+                        capability <- do
+                            cap <-
+                                fromMaybeE
+                                    maybeCapability
+                                    "Asking to unresolve MR but no capability provided"
+                            case cap of
+                                Left c -> pure c
+                                Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
+                        verifyCapability
+                            capability
+                            (Right $ remoteAuthorId author)
+                            (GrantResourceLoom recipLoomID)
+
+                        lift deleteFromDB
+
+                        clothHash <- encodeKeyHashid clothID
+                        return
+                            ( makeRecipientSet
+                                [LocalActorLoom recipLoomHash]
+                                [ LocalStageLoomFollowers recipLoomHash
+                                , LocalStageClothFollowers recipLoomHash clothHash
+                                ]
+                            , [ AudLocal
+                                    []
+                                    [ LocalStageLoomFollowers recipLoomHash
+                                    , LocalStageClothFollowers recipLoomHash clothHash
+                                    ]
+                              , audSenderAndFollowers
+                              ]
+                            )
+
+            -- Forward the Undo activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
+                forwardActivityDB
+                    (actbBL body) localRecips sig recipLoomActorID
+                    (LocalActorLoom recipLoomHash) sieve undoID
+
+
+            -- Prepare an Accept activity and insert to loom's outbox
+            acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
+            (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                lift . lift $ prepareAccept acceptAudience
+            _luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
+
+            -- Deliver the Accept to local recipients, and schedule delivery
+            -- for unavailable remote recipients
+            deliverHttpAccept <-
+                deliverActivityDB
+                    (LocalActorLoom recipLoomHash) recipLoomActorID
+                    localRecipsAccept remoteRecipsAccept fwdHostsAccept
+                    acceptID actionAccept
+
+            -- Return instructions for HTTP inbox-forwarding of the Undo
+            -- activity, and for HTTP delivery of the Accept activity to
+            -- remote recipients
+            return (maybeHttpFwdUndo, deliverHttpAccept)
+
+    -- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
+    -- delivery of the Accept activity
+    case maybeHttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just (maybeHttpFwdUndo, deliverHttpAccept) -> do
+            forkWorker "loomUndoF Accept HTTP delivery" deliverHttpAccept
+            case maybeHttpFwdUndo of
+                Nothing -> return "Undid, no inbox-forwarding to do"
+                Just forwardHttpUndo -> do
+                    forkWorker "loomUndoF inbox-forwarding" forwardHttpUndo
+                    return "Undid and ran inbox-forwarding of the Undo"
 
-deleteRemoteFollow myWorkItem author fsidRecip (Entity rfid rf)
-    | remoteFollowActor rf /= remoteAuthorId author =
-        return "Undo sent by different actor than the one who sent the Follow"
-    | remoteFollowTarget rf == fsidRecip = do
-        delete rfid
-        return "Undo applied to sharer RemoteFollow"
-    | otherwise = do
-        r <- tryTicket $ remoteFollowTarget rf
-        when (isRight r) $ delete rfid
-        return $ either id id r
     where
-    tryTicket fsid = do
-        mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid
-        case mltid of
-            Nothing -> return $ Left "Undo object is a RemoteFollow, but not for me and not for a ticket"
-            Just ltid -> do
-                wi <- getWorkItem ltid
-                return $
-                    if myWorkItem wi
-                        then Right "Undo applied to RemoteFollow of my ticket"
-                        else Left "Undo is of RemoteFollow of a ticket that isn't mine"
 
-insertAcceptOnUndo actor author luUndo obiid auds = do
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    hLocal <- asksSite siteInstanceHost
-    obikhid <- encodeKeyHashid obiid
-    let hAuthor = objUriAuthority $ remoteAuthorURI author
+    tryUnfollow _      _               (Left _)                 = mzero
+    tryUnfollow loomID loomFollowersID (Right remoteActivityID) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        if followerSetID == loomFollowersID
+            then pure ()
+            else do
+                ticketID <-
+                    MaybeT $ getKeyBy $ UniqueTicketFollowers followerSetID
+                TicketLoom _ l _ <-
+                    MaybeT $ getValBy $ UniqueTicketLoom ticketID
+                guard $ l == loomID
+        return (remoteFollowID, followerID)
 
-        (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-            collectAudience auds
+    tryUnresolve loomID undone = do
+        (deleteFromDB, ticketID) <- findTicket undone
+        Entity clothID (TicketLoom _ l _) <-
+            MaybeT $ getBy $ UniqueTicketLoom ticketID
+        guard $ l == loomID
+        return (deleteFromDB, clothID)
+        where
+        findTicket (Left (_actorByKey, _actorEntity, itemID)) = do
+            Entity resolveLocalID resolveLocal <-
+                MaybeT $ getBy $ UniqueTicketResolveLocalActivity itemID
+            let resolveID = ticketResolveLocalTicket resolveLocal
+            resolve <- lift $ getJust resolveID
+            let ticketID = ticketResolveTicket resolve
+            return
+                ( delete resolveLocalID >> delete resolveID
+                , ticketID
+                )
+        findTicket (Right remoteActivityID) = do
+            Entity resolveRemoteID resolveRemote <-
+                MaybeT $ getBy $
+                    UniqueTicketResolveRemoteActivity remoteActivityID
+            let resolveID = ticketResolveRemoteTicket resolveRemote
+            resolve <- lift $ getJust resolveID
+            let ticketID = ticketResolveTicket resolve
+            return
+                ( delete resolveRemoteID >> delete resolveID
+                , ticketID
+                )
 
-        recips = map encodeRouteHome audLocal ++ audRemote
-        doc = Doc hLocal Activity
-            { activityId       =
-                Just $ encodeRouteLocal $ actorOutboxItem actor obikhid
-            , activityActor    = encodeRouteLocal $ renderLocalActor actor
-            , activityCapability = Nothing
-            , activitySummary  = Nothing
-            , activityAudience = Audience recips [] [] [] [] []
-            , activitySpecific = AcceptActivity Accept
-                { acceptObject = ObjURI hAuthor luUndo
-                , acceptResult = Nothing
+    prepareAccept audience = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        let ObjURI hAuthor _ = remoteAuthorURI author
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience audience
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = []
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = ObjURI hAuthor luUndo
+                    , AP.acceptResult   = Nothing
+                    }
                 }
-            }
-    update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-    return (doc, recipientSet, remoteActors, fwdHosts)
-    where
-    actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr
-    actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
-    actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
 
-sharerUndoF
-    :: KeyHashid Person
-    -> UTCTime
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
-    -> LocalURI
-    -> Undo URIMode
-    -> ExceptT Text Handler Text
-sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
-    error "sharerUndoF temporarily disabled"
+        return (action, recipientSet, remoteActors, fwdHosts)
 
-
-
-
-    object <- parseActivity uObj
-    mmmhttp <- runDBExcept $ do
-        p <- lift $ do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            getValBy404 $ UniquePersonIdent sid
-        mractid <- lift $ insertToInbox now author body (personInbox p) luUndo True
-        for mractid $ \ ractid -> do
-            mobject' <- getActivity object
-            lift $ for mobject' $ \ object' -> do
-                mobject'' <- runMaybeT $
-                    Left <$> MaybeT (getFollow object') <|>
-                    Right <$> MaybeT (getResolve object')
-                for mobject'' $ \ object'' -> do
-                    (result, mfwdColl, macceptAuds) <-
-                        case object'' of
-                            Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (personFollowers p) erf
-                            Right tr -> deleteResolve myWorkItem prepareAccept tr
-                    mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
-                        let sieve = makeRecipientSet [] colls
-                        remoteRecips <-
-                            insertRemoteActivityToLocalInboxes
-                                False ractid $
-                                    localRecipSieve'
-                                        sieve False False localRecips
-                        (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent p) sig remoteRecips
-                    mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
-                        obiidAccept <- insertEmptyOutboxItem (personOutbox p) now
-                        (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                            insertAcceptOnUndo (LocalActorSharer shrRecip) author luUndo obiidAccept acceptAuds
-                        knownRemoteRecipsAccept <-
-                            deliverLocal'
-                                False
-                                (LocalActorSharer shrRecip)
-                                (personInbox p)
-                                obiidAccept
-                                localRecipsAccept
-                        (obiidAccept,docAccept,fwdHostsAccept,) <$>
-                            deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
-                    return (result, mremotesHttpFwd, mremotesHttpAccept)
-    case mmmhttp of
-        Nothing -> return "Activity already in my inbox"
-        Just mmhttp ->
-            case mmhttp of
-                Nothing -> return "Undo object isn't a known activity"
-                Just mhttp ->
-                    case mhttp of
-                        Nothing -> return "Undo object isn't in use"
-                        Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
-                            for_ mremotesHttpFwd $ \ (sig, remotes) ->
-                                forkWorker "sharerUndoF inbox-forwarding" $
-                                    deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes
-                            for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
-                                forkWorker "sharerUndoF Accept HTTP delivery" $
-                                    deliverRemoteHttp' fwdHosts obiid doc remotes
-                            let fwdMsg =
-                                    case mremotesHttpFwd of
-                                        Nothing -> "No inbox-forwarding"
-                                        Just _ -> "Did inbox-forwarding"
-                                acceptMsg =
-                                    case mremotesHttpAccept of
-                                        Nothing -> "Didn't send Accept"
-                                        Just _ -> "Sent Accept"
-                            return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
-    where
-    myWorkItem (WorkItemSharerTicket shr talid patch)
-        | shr == shrRecip = Just (talid, patch)
-    myWorkItem _ = Nothing
-
-    prepareAccept (talid, patch) = do
-        talkhid <- encodeKeyHashid talid
-        ra <- getJust $ remoteAuthorId author
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-            ticketFollowers =
-                if patch
-                    then LocalPersonCollectionSharerProposalFollowers shrRecip talkhid
-                    else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
-            audAuthor =
-                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
-            audTicket =
-                AudLocal [] [ticketFollowers]
-        return ([ticketFollowers], [audAuthor, audTicket])
--}
-
-{-
 repoUndoF
-    :: KeyHashid Repo
-    -> UTCTime
+    :: UTCTime
+    -> KeyHashid Repo
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
-    -> Undo URIMode
+    -> AP.Undo URIMode
     -> ExceptT Text Handler Text
-repoUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
-    error "repoUndoF temporarily disabled"
+repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
+
+    -- Check input
+    recipRepoID <- decodeKeyHashid404 recipRepoHash
+    undone <-
+        first (\ (actor, _, item) -> (actor, item)) <$>
+            parseActivityURI uObject
+
+    -- Verify the capability URI, if provided, is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCapability <-
+        for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+            nameExceptT "Undo capability" $
+                first (\ (actor, _, item) -> (actor, item)) <$>
+                    parseActivityURI uCap
+
+    maybeHttp <- runDBExcept $ do
+
+        -- Find recipient repo in DB, returning 404 if doesn't exist because we're
+        -- in the repo's inbox post handler
+        (recipRepoActorID, recipRepoActor) <- lift $ do
+            repo <- get404 recipRepoID
+            let actorID = repoActor repo
+            (actorID,) <$> getJust actorID
+
+        -- Insert the Undo to repo's inbox
+        mractid <- lift $ insertToInbox now author body (actorInbox recipRepoActor) luUndo False
+        for mractid $ \ undoID -> do
+
+            -- Find the undone activity in our DB
+            undoneDB <- do
+                a <- getActivity undone
+                fromMaybeE a "Can't find undone in DB"
+
+            (sieve, acceptAudience) <- do
+                (remoteFollowID, followerID) <- do
+                    maybeUndo <- do
+                        let followers = actorFollowers recipRepoActor
+                        lift $ runMaybeT $ tryUnfollow followers undoneDB
+                    fromMaybeE maybeUndo "Undone activity isn't a Follow related to me"
+                (audSenderOnly, _audSenderAndFollowers) <- do
+                    ra <- lift $ getJust $ remoteAuthorId author
+                    let ObjURI hAuthor luAuthor = remoteAuthorURI author
+                    return
+                        ( AudRemote hAuthor [luAuthor] []
+                        , AudRemote hAuthor
+                            [luAuthor]
+                            (maybeToList $ remoteActorFollowers ra)
+                        )
+                unless (followerID == remoteAuthorId author) $
+                    throwE "Trying to undo someone else's Follow"
+                lift $ delete remoteFollowID
+                return
+                    ( makeRecipientSet [] []
+                    , [audSenderOnly]
+                    )
+
+            -- Forward the Undo activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
+                forwardActivityDB
+                    (actbBL body) localRecips sig recipRepoActorID
+                    (LocalActorRepo recipRepoHash) sieve undoID
 
 
+            -- Prepare an Accept activity and insert to repo's outbox
+            acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipRepoActor) now
+            (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                lift . lift $ prepareAccept acceptAudience
+            _luAccept <- lift $ updateOutboxItem (LocalActorRepo recipRepoID) acceptID actionAccept
 
+            -- Deliver the Accept to local recipients, and schedule delivery
+            -- for unavailable remote recipients
+            deliverHttpAccept <-
+                deliverActivityDB
+                    (LocalActorRepo recipRepoHash) recipRepoActorID
+                    localRecipsAccept remoteRecipsAccept fwdHostsAccept
+                    acceptID actionAccept
 
+            -- Return instructions for HTTP inbox-forwarding of the Undo
+            -- activity, and for HTTP delivery of the Accept activity to
+            -- remote recipients
+            return (maybeHttpFwdUndo, deliverHttpAccept)
+
+    -- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
+    -- delivery of the Accept activity
+    case maybeHttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just (maybeHttpFwdUndo, deliverHttpAccept) -> do
+            forkWorker "repoUndoF Accept HTTP delivery" deliverHttpAccept
+            case maybeHttpFwdUndo of
+                Nothing -> return "Undid, no inbox-forwarding to do"
+                Just forwardHttpUndo -> do
+                    forkWorker "repoUndoF inbox-forwarding" forwardHttpUndo
+                    return "Undid and ran inbox-forwarding of the Undo"
 
-    object <- parseActivity uObj
-    mmmhttp <- runDBExcept $ do
-        Entity rid r <- lift $ do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            getBy404 $ UniqueRepo rpRecip sid
-        mractid <- lift $ insertToInbox now author body (repoInbox r) luUndo False
-        for mractid $ \ ractid -> do
-            mobject' <- getActivity object
-            lift $ for mobject' $ \ object' -> do
-                mobject'' <- runMaybeT $
-                    Left <$> MaybeT (getFollow object') <|>
-                    Right <$> MaybeT (getResolve object')
-                for mobject'' $ \ object'' -> do
-                    (result, mfwdColl, macceptAuds) <-
-                        case object'' of
-                            Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (repoFollowers r) erf
-                            Right tr -> deleteResolve myWorkItem prepareAccept tr
-                    mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
-                        let sieve = makeRecipientSet [] colls
-                        remoteRecips <-
-                            insertRemoteActivityToLocalInboxes
-                                False ractid $
-                                    localRecipSieve'
-                                        sieve False False localRecips
-                        (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
-                    mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
-                        obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
-                        (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                            insertAcceptOnUndo (LocalActorRepo shrRecip rpRecip) author luUndo obiidAccept acceptAuds
-                        knownRemoteRecipsAccept <-
-                            deliverLocal'
-                                False
-                                (LocalActorRepo shrRecip rpRecip)
-                                (repoInbox r)
-                                obiidAccept
-                                localRecipsAccept
-                        (obiidAccept,docAccept,fwdHostsAccept,) <$>
-                            deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
-                    return (result, mremotesHttpFwd, mremotesHttpAccept)
-    case mmmhttp of
-        Nothing -> return "Activity already in my inbox"
-        Just mmhttp ->
-            case mmhttp of
-                Nothing -> return "Undo object isn't a known activity"
-                Just mhttp ->
-                    case mhttp of
-                        Nothing -> return "Undo object isn't in use"
-                        Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
-                            for_ mremotesHttpFwd $ \ (sig, remotes) ->
-                                forkWorker "repoUndoF inbox-forwarding" $
-                                    deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
-                            for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
-                                forkWorker "repoUndoF Accept HTTP delivery" $
-                                    deliverRemoteHttp' fwdHosts obiid doc remotes
-                            let fwdMsg =
-                                    case mremotesHttpFwd of
-                                        Nothing -> "No inbox-forwarding"
-                                        Just _ -> "Did inbox-forwarding"
-                                acceptMsg =
-                                    case mremotesHttpAccept of
-                                        Nothing -> "Didn't send Accept"
-                                        Just _ -> "Sent Accept"
-                            return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
     where
-    myWorkItem (WorkItemRepoProposal shr rp ltid)
-        | shr == shrRecip && rp == rpRecip = Just ltid
-    myWorkItem _ = Nothing
 
-    prepareAccept ltid = do
-        ltkhid <- encodeKeyHashid ltid
-        ra <- getJust $ remoteAuthorId author
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-            ticketFollowers =
-                LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
-            audAuthor =
-                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
-            audTicket =
-                AudLocal [] [ticketFollowers]
-        return ([ticketFollowers], [audAuthor, audTicket])
--}
+    tryUnfollow _               (Left _)                 = mzero
+    tryUnfollow repoFollowersID (Right remoteActivityID) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        guard $ followerSetID == repoFollowersID
+        return (remoteFollowID, followerID)
+
+    prepareAccept audience = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        let ObjURI hAuthor _ = remoteAuthorURI author
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience audience
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = []
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = ObjURI hAuthor luUndo
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)

src/Vervis/Handler/Loom.hs

@@ -171,6 +171,8 @@ postLoomInboxR recipLoomHash =
                     _ -> return ("Unsupported offer object type for looms", Nothing)
             AP.ResolveActivity resolve ->
                 loomResolveF now recipLoomHash author body mfwd luActivity resolve
+            AP.UndoActivity undo ->
+                (,Nothing) <$> loomUndoF now recipLoomHash author body mfwd luActivity undo
             _ -> return ("Unsupported activity type for looms", Nothing)
 
 getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent

src/Vervis/Handler/Person.hs

@@ -231,9 +231,9 @@ postPersonInboxR recipPersonHash = postInbox handle
                 (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
             ResolveActivity resolve ->
                 (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve
-            UndoActivity undo ->
-                (,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo
             -}
+            AP.UndoActivity undo ->
+                (,Nothing) <$> personUndoF now recipPersonHash author body mfwd luActivity undo
             _ -> return ("Unsupported activity type for Person", Nothing)
 
 getPersonOutboxR :: KeyHashid Person -> Handler TypedContent

src/Vervis/Handler/Repo.hs

@@ -280,16 +280,12 @@ postRepoInboxR recipRepoHash =
             {-
             OfferActivity (Offer obj target) ->
                 case obj of
-                    OfferTicket ticket ->
-                        (,Nothing) <$> repoOfferTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket target
                     OfferDep dep ->
                         repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
                     _ -> return ("Unsupported offer object type for repos", Nothing)
-            ResolveActivity resolve ->
-                (,Nothing) <$> repoResolveF now shrRecip rpRecip remoteAuthor body mfwd luActivity resolve
-            UndoActivity undo->
-                (,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body mfwd luActivity undo
             -}
+            AP.UndoActivity undo->
+                (,Nothing) <$> repoUndoF now recipRepoHash author body mfwd luActivity undo
             _ -> return ("Unsupported activity type for repos", Nothing)
 
 getRepoOutboxR :: KeyHashid Repo -> Handler TypedContent