diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 1eb4edb..932b5bd 100644 --- a/src/Vervis/Federation.hs +++ b/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 () diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 4da4a05..443224e 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/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