diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index d2d3a10..8d92d8e 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -37,6 +37,7 @@ import Control.Monad.Trans.Reader import Crypto.Hash import Data.Aeson import Data.Bifunctor +import Data.Bitraversable import Data.ByteString (ByteString) import Data.Either import Data.Foldable @@ -111,6 +112,7 @@ import Vervis.Model.Ident import Vervis.Model.Ticket import Vervis.RemoteActorStore import Vervis.Settings +import Vervis.Patch import Vervis.Ticket verifyIsLoggedInUser @@ -201,29 +203,44 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx let actors = case mproject of Nothing -> [] - Just (shr, prj) -> [LocalActorProject shr prj] + Just (Left (shr, prj)) -> [LocalActorProject shr prj] + Just (Right (shr, rp)) -> [LocalActorRepo shr rp] collections = let project = case mproject of Nothing -> [] - Just (shr, prj) -> + Just (Left (shr, prj)) -> [ LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectFollowers shr prj ] + Just (Right (shr, rp)) -> + [ LocalPersonCollectionRepoTeam shr rp + , LocalPersonCollectionRepoFollowers shr rp + ] ticket = case context of Left nc -> case nc of - NoteContextSharerTicket shr talid -> + NoteContextSharerTicket shr talid False -> let talkhid = hashTAL talid in [ -- LocalPersonCollectionSharerTicketTeam shr talkhid LocalPersonCollectionSharerTicketFollowers shr talkhid ] + NoteContextSharerTicket shr talid True -> + let talkhid = hashTAL talid + in [ -- LocalPersonCollectionSharerPatchTeam shr talkhid + LocalPersonCollectionSharerPatchFollowers shr talkhid + ] NoteContextProjectTicket shr prj ltid -> let ltkhid = hashLT ltid in [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid LocalPersonCollectionProjectTicketFollowers shr prj ltkhid ] + NoteContextRepoPatch shr rp ltid -> + let ltkhid = hashLT ltid + in [ -- LocalPersonCollectionRepoPatchTeam shr rp ltkhid + LocalPersonCollectionRepoPatchFollowers shr rp ltkhid + ] Right _ -> [] commenter = [LocalPersonCollectionSharerFollowers shrUser] in project ++ ticket ++ commenter @@ -251,15 +268,25 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx parseTopic name route = case route of SharerTicketR shr talkhid -> - NoteContextSharerTicket shr <$> + flip (NoteContextSharerTicket shr) False <$> decodeKeyHashidE talkhid (name <> " sharer ticket invalid talkhid") + SharerPatchR shr talkhid -> + flip (NoteContextSharerTicket shr) True <$> + decodeKeyHashidE + talkhid + (name <> " sharer patch invalid talkhid") ProjectTicketR shr prj ltkhid -> NoteContextProjectTicket shr prj <$> decodeKeyHashidE ltkhid (name <> " project ticket invalid ltkhid") + RepoPatchR shr rp ltkhid -> + NoteContextRepoPatch shr rp <$> + decodeKeyHashidE + ltkhid + (name <> " repo patch invalid ltkhid") _ -> throwE $ name <> " isn't a discussion topic route" parseNoteContext u@(ObjURI h lu) = do hl <- hostIsLocal h @@ -306,7 +333,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx unless (any ((== h) . fst) remoteRecips) $ throwE "Context is remote but no recipients of that host are listed" - verifyContextRecip (Left (NoteContextSharerTicket shr _)) localRecips _ = + verifyContextRecip (Left (NoteContextSharerTicket shr _ _)) localRecips _ = fromMaybeE verify "Local context ticket's hosting sharer isn't listed as a recipient" @@ -323,6 +350,15 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx sharerSet <- lookup shr localRecips projectSet <- lookup prj $ localRecipProjectRelated sharerSet guard $ localRecipProject $ localRecipProjectDirect projectSet + verifyContextRecip (Left (NoteContextRepoPatch shr rp _)) localRecips _ = + fromMaybeE + verify + "Local context patch's hosting repo isn't listed as a recipient" + where + verify = do + sharerSet <- lookup shr localRecips + repoSet <- lookup rp $ localRecipRepoRelated sharerSet + guard $ localRecipRepo $ localRecipRepoDirect repoSet insertEmptyOutboxItem obid now = do h <- asksSite siteInstanceHost insert OutboxItem @@ -334,23 +370,41 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx j <- getJust $ ticketProjectLocalProject tpl s <- getJust $ projectSharer j return (sharerIdent s, projectIdent j) + getRepo trl = do + r <- getJust $ ticketRepoLocalRepo trl + s <- getJust $ repoSharer r + return (sharerIdent s, repoIdent r) getTopicAndParent (Left context) mparent = do (mproject, did) <- case context of - NoteContextSharerTicket shr talid -> do + NoteContextSharerTicket shr talid False -> do (_, Entity _ lt, _, project) <- do mticket <- lift $ getSharerTicket shr talid fromMaybeE mticket "Note context no such local sharer-hosted ticket" mproj <- case project of - Left (_, Entity _ tpl) -> lift $ Just <$> getProject tpl + Left (_, Entity _ tpl) -> lift $ Just . Left <$> getProject tpl + Right _ -> return Nothing + return (mproj, localTicketDiscuss lt) + NoteContextSharerTicket shr talid True -> do + (_, Entity _ lt, _, repo, _) <- do + mticket <- lift $ getSharerPatch shr talid + fromMaybeE mticket "Note context no such local sharer-hosted patch" + mproj <- + case repo of + Left (_, Entity _ trl) -> lift $ Just . Right <$> getRepo trl Right _ -> return Nothing return (mproj, localTicketDiscuss lt) NoteContextProjectTicket shr prj ltid -> do (_, _, _, Entity _ lt, _, _, _) <- do mticket <- lift $ getProjectTicket shr prj ltid fromMaybeE mticket "Note context no such local project-hosted ticket" - return (Just (shr, prj), localTicketDiscuss lt) + return (Just $ Left (shr, prj), localTicketDiscuss lt) + NoteContextRepoPatch shr rp ltid -> do + (_, _, _, Entity _ lt, _, _, _, _) <- do + mticket <- lift $ getRepoPatch shr rp ltid + fromMaybeE mticket "Note context no such local project-hosted ticket" + return (Just $ Right (shr, rp), localTicketDiscuss lt) mmidParent <- for mparent $ \ parent -> case parent of Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent @@ -377,9 +431,14 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx rt <- MaybeT $ getValBy $ UniqueRemoteTicketDiscuss rdid tar <- lift $ getJust $ remoteTicketTicket rt let tclid = ticketAuthorRemoteTicket tar - tpl <- - MaybeT $ getValBy $ UniqueTicketProjectLocal tclid - lift $ getProject tpl + txl <- + lift $ + requireEitherAlt + (getValBy $ UniqueTicketProjectLocal tclid) + (getValBy $ UniqueTicketRepoLocal tclid) + "No specific TCL" + "Both TPL and TRL" + lift $ bitraverse getProject getRepo txl return (mproj, rd, False) Nothing -> do did <- insert Discussion diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 93f63df..625cf7b 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -130,8 +130,9 @@ import Vervis.Widget.Repo import Vervis.Widget.Sharer data NoteContext - = NoteContextSharerTicket ShrIdent TicketAuthorLocalId + = NoteContextSharerTicket ShrIdent TicketAuthorLocalId Bool | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId + | NoteContextRepoPatch ShrIdent RpIdent LocalTicketId deriving Eq hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool @@ -158,12 +159,18 @@ parseContext uContext = do Just r -> return r case route of SharerTicketR shr talkhid -> - NoteContextSharerTicket shr <$> + flip (NoteContextSharerTicket shr) False <$> + decodeKeyHashidE talkhid "Note context invalid talkhid" + SharerPatchR shr talkhid -> + flip (NoteContextSharerTicket shr) True <$> decodeKeyHashidE talkhid "Note context invalid talkhid" ProjectTicketR shr prj ltkhid -> NoteContextProjectTicket shr prj <$> decodeKeyHashidE ltkhid "Note context invalid ltkhid" - _ -> throwE "Local context isn't a ticket route" + RepoPatchR shr rp ltkhid -> + NoteContextRepoPatch shr rp <$> + decodeKeyHashidE ltkhid "Note context invalid ltkhid" + _ -> throwE "Local context isn't a ticket/patch route" else return $ Right uContext parseParent diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index e988a27..3741dba 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -336,6 +336,11 @@ handleRepoInbox now shrRecip rpRecip auth body = do ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthRemote ra -> return ra case activitySpecific $ actbActivity body of + CreateActivity (Create obj mtarget) -> + case obj of + CreateNote note -> + repoCreateNoteF now shrRecip rpRecip remoteAuthor body note + _ -> error "Unsupported create object type for repos" FollowActivity follow -> repoFollowF shrRecip rpRecip now remoteAuthor body follow UndoActivity undo-> diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 0932553..81b1872 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -16,6 +16,7 @@ module Vervis.Federation.Discussion ( sharerCreateNoteF , projectCreateNoteF + , repoCreateNoteF ) where @@ -72,6 +73,7 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Settings import Vervis.Ticket +import Vervis.Patch -- | Check the note in the remote Create Note activity delivered to us. checkNote @@ -256,12 +258,21 @@ sharerCreateNoteF now shrRecip author body note = do case mractid of Nothing -> "I already have this activity in my inbox, doing nothing" Just _ -> "Context is remote, so just inserting to my inbox" - Left (NoteContextSharerTicket shr talid) -> do + Left (NoteContextSharerTicket shr talid patch) -> do mremotesHttp <- runDBExcept $ do (sid, pid, ibid) <- lift getRecip404 - (Entity _ tal, Entity _ lt, _, _) <- do - mticket <- lift $ getSharerTicket shr talid - fromMaybeE mticket "Context: No such sharer-ticket" + (tal, lt, followers) <- + if patch + then do + (Entity _ tal, Entity _ lt, _, _, _) <- do + mticket <- lift $ getSharerPatch shr talid + fromMaybeE mticket "Context: No such sharer-patch" + return (tal, lt, LocalPersonCollectionSharerPatchFollowers) + else do + (Entity _ tal, Entity _ lt, _, _) <- do + mticket <- lift $ getSharerTicket shr talid + fromMaybeE mticket "Context: No such sharer-ticket" + return (tal, lt, LocalPersonCollectionSharerTicketFollowers) if ticketAuthorLocalAuthor tal == pid then do mractid <- lift $ insertToInbox now author body ibid luCreate True @@ -283,7 +294,7 @@ sharerCreateNoteF now shrRecip author body note = do let sieve = makeRecipientSet [] - [ LocalPersonCollectionSharerTicketFollowers shrRecip talkhid + [ followers shrRecip talkhid --, LocalPersonCollectionSharerTicketTeam shrRecip talkhid ] remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips @@ -315,6 +326,20 @@ sharerCreateNoteF now shrRecip author body note = do case mractid of Nothing -> "I already have this activity in my inbox, doing nothing" Just _ -> "Context is a project-ticket, so just inserting to my inbox" + Left (NoteContextRepoPatch shr rp ltid) -> runDBExcept $ do + personRecip <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getValBy404 $ UniquePersonIdent sid + (_, _, _, Entity _ lt, _, _, _, _) <- do + mticket <- lift $ getRepoPatch shr rp ltid + fromMaybeE mticket "Context: No such repo-patch" + let did = localTicketDiscuss lt + _ <- traverse (getParent did) mparent + mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True + return $ + case mractid of + Nothing -> "I already have this activity in my inbox, doing nothing" + Just _ -> "Context is a repo-patch, so just inserting to my inbox" where getRecip404 = do sid <- getKeyBy404 $ UniqueSharer shrRecip @@ -361,7 +386,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do msig <- checkForward $ LocalActorProject shrRecip prjRecip case context of Right _ -> return "Not using; context isn't local" - Left (NoteContextSharerTicket shr talid) -> do + Left (NoteContextSharerTicket shr talid False) -> do mremotesHttp <- runDBExcept $ do (jid, ibid) <- lift getProjectRecip404 (_, _, _, project) <- do @@ -396,6 +421,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do Right (sig, remotesHttp) -> do forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp return "Stored to inbox and did inbox forwarding" + Left (NoteContextSharerTicket _ _ True) -> return "Context is a sharer-patch, ignoring activity" Left (NoteContextProjectTicket shr prj ltid) -> do mremotesHttp <- runDBExcept $ do (jid, ibid) <- lift getProjectRecip404 @@ -436,8 +462,112 @@ projectCreateNoteF now shrRecip prjRecip author body note = do Right (sig, remotesHttp) -> do forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp return "Stored to inbox, cached comment, and did inbox forwarding" + Left (NoteContextRepoPatch _ _ _) -> return "Context is a repo-patch, ignoring activity" where getProjectRecip404 = do sid <- getKeyBy404 $ UniqueSharer shrRecip Entity jid j <- getBy404 $ UniqueProject prjRecip sid return (jid, projectInbox j) + +repoCreateNoteF + :: UTCTime + -> ShrIdent + -> RpIdent + -> RemoteAuthor + -> ActivityBody + -> Note URIMode + -> ExceptT Text Handler Text +repoCreateNoteF now shrRecip rpRecip author body note = do + luCreate <- + fromMaybeE (activityId $ actbActivity body) "Create without 'id'" + (luNote, published, context, mparent, source, content) <- checkNote note + (localRecips, _remoteRecips) <- do + mrecips <- parseAudience $ activityAudience $ actbActivity body + fromMaybeE mrecips "Create Note with no recipients" + msig <- checkForward $ LocalActorRepo shrRecip rpRecip + case context of + Right _ -> return "Not using; context isn't local" + Left (NoteContextSharerTicket _ _ False) -> + return "Context is a sharer-ticket, ignoring activity" + Left (NoteContextSharerTicket shr talid True) -> do + mremotesHttp <- runDBExcept $ do + (rid, ibid) <- lift getRepoRecip404 + (_, _, _, repo, _) <- do + mticket <- lift $ getSharerPatch shr talid + fromMaybeE mticket "Context: No such sharer-ticket" + case repo of + Left (_, Entity _ trl) + | ticketRepoLocalRepo trl == rid -> do + mractid <- lift $ insertToInbox now author body ibid luCreate False + case mractid of + Nothing -> return $ Left "Activity already in my inbox" + Just ractid -> + case msig of + Nothing -> + return $ Left + "Context is a sharer-patch, \ + \but no inbox forwarding \ + \header for me, so doing \ + \nothing, just storing in inbox" + Just sig -> lift $ Right <$> do + let sieve = + makeRecipientSet + [] + [ LocalPersonCollectionRepoFollowers shrRecip rpRecip + , LocalPersonCollectionRepoTeam shrRecip rpRecip + ] + remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips + (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips + _ -> return $ Left "Context is a sharer-patch of another repo" + case mremotesHttp of + Left msg -> return msg + Right (sig, remotesHttp) -> do + forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp + return "Stored to inbox and did inbox forwarding" + Left (NoteContextProjectTicket _ _ _) -> + return "Context is a project-ticket, ignoring activity" + Left (NoteContextRepoPatch shr rp ltid) -> do + mremotesHttp <- runDBExcept $ do + (rid, ibid) <- lift getRepoRecip404 + (_, _, _, Entity _ lt, _, Entity _ trl, _, _) <- do + mticket <- lift $ getRepoPatch shr rp ltid + fromMaybeE mticket "Context: No such repo-patch" + if ticketRepoLocalRepo trl == rid + then do + mractid <- lift $ insertToInbox now author body ibid luCreate False + case mractid of + Nothing -> return $ Left "Activity already in my inbox" + Just ractid -> do + let did = localTicketDiscuss lt + meparent <- traverse (getParent did) mparent + mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid + case mmid of + Nothing -> return $ Left "I already have this comment, just storing in inbox" + Just mid -> lift $ do + updateOrphans author luNote did mid + case msig of + Nothing -> + return $ Left "Storing in inbox, caching comment, no inbox forwarding header" + Just sig -> Right <$> do + ltkhid <- encodeKeyHashid ltid + let sieve = + makeRecipientSet + [] + [ LocalPersonCollectionRepoFollowers shrRecip rpRecip + , LocalPersonCollectionRepoTeam shrRecip rpRecip + , LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid + --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid + ] + remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips + (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips + else return $ Left "Context is a repo-patch of another repo" + case mremotesHttp of + Left msg -> return msg + Right (sig, remotesHttp) -> do + forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp + return "Stored to inbox, cached comment, and did inbox forwarding" + where + getRepoRecip404 = do + sid <- getKeyBy404 $ UniqueSharer shrRecip + Entity rid r <- getBy404 $ UniqueRepo rpRecip sid + return (rid, repoInbox r)