Implement S2S unfollowing using Undo{Follow}

src/Vervis/Federation.hs

@@ -229,6 +229,8 @@ handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
             sharerOfferTicketF now shrRecip author body offer
         RejectActivity reject ->
             sharerRejectF shrRecip now author body reject
+        UndoActivity undo ->
+            sharerUndoF shrRecip now author body undo
         _ -> return "Unsupported activity type"
 
 handleProjectInbox
@@ -257,6 +259,8 @@ handleProjectInbox now shrRecip prjRecip auth body = do
             projectFollowF shrRecip prjRecip now remoteAuthor body follow
         OfferActivity offer ->
             projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer
+        UndoActivity undo ->
+            projectUndoF shrRecip prjRecip now remoteAuthor body undo
         _ -> return "Unsupported activity type"
 
 handleRepoInbox
@@ -281,6 +285,8 @@ handleRepoInbox now shrRecip rpRecip auth body = do
     case activitySpecific $ actbActivity body of
         FollowActivity follow ->
             repoFollowF shrRecip rpRecip now remoteAuthor body follow
+        UndoActivity undo->
+            repoUndoF shrRecip rpRecip now remoteAuthor body undo
         _ -> return "Unsupported activity type"
 
 fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()

src/Vervis/Federation/Offer.hs

@@ -21,6 +21,10 @@ module Vervis.Federation.Offer
     , sharerFollowF
     , projectFollowF
     , repoFollowF
+
+    , sharerUndoF
+    , projectUndoF
+    , repoUndoF
     )
 where
 
@@ -401,3 +405,138 @@ repoFollowF shr rp =
     getRecip () = do
         sid <- getKeyBy404 $ UniqueSharer shr
         getValBy404 $ UniqueRepo rp sid
+
+undoF
+    :: Route App
+    -> AppDB (Entity a)
+    -> (a -> InboxId)
+    -> (a -> FollowerSetId)
+    -> (Key a -> FollowerSetId -> AppDB (Maybe Text))
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Undo URIMode
+    -> ExceptT Text Handler Text
+undoF
+    recipRoute getRecip recipInbox recipFollowers trySubObjects
+    now author body (Undo luObj) = do
+        luUndo <-
+            fromMaybeE (activityId $ actbActivity body) "Undo without 'id'"
+        lift $ runDB $ do
+            Entity idRecip recip <- getRecip
+            ractid <- insertActivity luUndo
+            mreason <- deleteRemoteFollow idRecip (recipFollowers recip)
+            case mreason of
+                Just reason -> return $ "Not using this Undo: " <> reason
+                Nothing -> do
+                    inserted <- insertToInbox luUndo (recipInbox recip) ractid
+                    encodeRouteLocal <- getEncodeRouteLocal
+                    let me = localUriPath $ encodeRouteLocal recipRoute
+                    return $
+                        if inserted
+                            then "Undo applied and inserted to inbox of " <> me
+                            else "Undo applied and already exists in inbox of " <> me
+    where
+    insertActivity luUndo =
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = persistJSONFromBL $ actbBL body
+            ract = RemoteActivity iidAuthor luUndo jsonObj now
+        in  either entityKey id <$> insertBy' ract
+    deleteRemoteFollow idRecip fsidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+        mraidObj <- getKeyBy $ UniqueRemoteActivity iidAuthor luObj
+        case mraidObj of
+            Nothing -> return $ Just "Undo object isn't a known activity"
+            Just raidObj -> do
+                merf <- getBy $ UniqueRemoteFollowFollow raidObj
+                case merf of
+                    Nothing -> return $ Just "Undo object doesn't match an active RemoteFollow"
+                    Just (Entity rfid rf)
+                        | remoteFollowActor rf /= remoteAuthorId author ->
+                            return $ Just "Undo sent by different actor than the one who sent the Follow"
+                        | remoteFollowTarget rf == fsidRecip -> do
+                            delete rfid
+                            return Nothing
+                        | otherwise -> do
+                            mr <- trySubObjects idRecip (remoteFollowTarget rf)
+                            when (isNothing mr) $ delete rfid
+                            return mr
+    insertToInbox luUndo ibidRecip ractid = do
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = persistJSONFromBL $ actbBL body
+            ract = RemoteActivity iidAuthor luUndo jsonObj now
+        ibiid <- insert $ InboxItem False
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return False
+            Just _ -> return True
+
+sharerUndoF
+    :: ShrIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Undo URIMode
+    -> ExceptT Text Handler Text
+sharerUndoF shr =
+    undoF
+        (SharerR shr)
+        getRecip
+        personInbox
+        personFollowers
+        (\ _ _ -> return $ Just "Undo object is a RemoteFollow, but isn't under this sharer")
+    where
+    getRecip = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        getBy404 $ UniquePersonIdent sid
+
+projectUndoF
+    :: ShrIdent
+    -> PrjIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Undo URIMode
+    -> ExceptT Text Handler Text
+projectUndoF shr prj =
+    undoF
+        (ProjectR shr prj)
+        getRecip
+        projectInbox
+        projectFollowers
+        tryTicket
+    where
+    getRecip = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        getBy404 $ UniqueProject prj sid
+    tryTicket jid fsid = do
+        mt <- getValBy $ UniqueTicketFollowers fsid
+        return $
+            case mt of
+                Nothing -> Just "Undo object is a RemoteFollow, but isn't under this project"
+                Just t ->
+                    if ticketProject t /= jid
+                        then Just "Undo object is a RemoteFollow of a ticket of another project"
+                        else Nothing
+
+repoUndoF
+    :: ShrIdent
+    -> RpIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Undo URIMode
+    -> ExceptT Text Handler Text
+repoUndoF shr rp =
+    undoF
+        (RepoR shr rp)
+        getRecip
+        repoInbox
+        repoFollowers
+        (\ _ _ -> return $ Just "Undo object is a RemoteFollow, but isn't under this repo")
+    where
+    getRecip = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        getBy404 $ UniqueRepo rp sid