diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 2145e08..2e4123a 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -84,7 +84,7 @@ import Crypto.PublicVerifKey import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub hiding (Follow, Ticket) +import Web.ActivityPub hiding (Patch, Ticket, Follow) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI @@ -110,6 +110,7 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Model.Repo import Vervis.Model.Ticket import Vervis.RemoteActorStore import Vervis.Settings @@ -488,8 +489,8 @@ checkFederation remoteRecips = do unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients found" -verifyProjectRecip (Right _) _ = return () -verifyProjectRecip (Left (shr, prj)) localRecips = +verifyProjectRecipOld (Right _) _ = return () +verifyProjectRecipOld (Left (shr, prj)) localRecips = fromMaybeE verify "Local context project isn't listed as a recipient" where verify = do @@ -497,6 +498,22 @@ verifyProjectRecip (Left (shr, prj)) localRecips = projectSet <- lookup prj $ localRecipProjectRelated sharerSet guard $ localRecipProject $ localRecipProjectDirect projectSet +verifyProjectRecip (Right _) _ = return () +verifyProjectRecip (Left (WTTProject shr prj)) localRecips = + fromMaybeE verify "Local context project isn't listed as a recipient" + where + verify = do + sharerSet <- lookup shr localRecips + projectSet <- lookup prj $ localRecipProjectRelated sharerSet + guard $ localRecipProject $ localRecipProjectDirect projectSet +verifyProjectRecip (Left (WTTRepo shr rp _ _ _)) localRecips = + fromMaybeE verify "Local context repo isn't listed as a recipient" + where + verify = do + sharerSet <- lookup shr localRecips + repoSet <- lookup rp $ localRecipRepoRelated sharerSet + guard $ localRecipRepo $ localRecipRepoDirect repoSet + -- | Handle a Ticket submitted by a local user to their outbox. The ticket's -- context project may be local or remote. Return an error message if the -- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'. @@ -516,7 +533,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT mrecips <- parseAudience audience fromMaybeE mrecips "Create Ticket with no recipients" checkFederation remoteRecips - verifyProjectRecip context localRecips + verifyProjectRecipOld context localRecips tracker <- fetchTracker context uTarget now <- liftIO getCurrentTime (_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do @@ -970,7 +987,7 @@ offerTicketC -> ExceptT Text Handler OutboxItemId offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do let shrUser = sharerIdent sharerUser - (title, desc, source, target) <- checkTicket shrUser ticket uTarget + (target, title, desc, source) <- checkOfferTicket shrUser ticket uTarget ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience fromMaybeE mrecips "Offer Ticket with no recipients" @@ -982,18 +999,26 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do mproject <- case target of - Left (shr, prj) -> Just <$> do + Left (WTTProject shr prj) -> Just . Left <$> do mproj <- lift $ runMaybeT $ do Entity sid s <- MaybeT $ getBy $ UniqueSharer shr ej <- MaybeT $ getBy $ UniqueProject prj sid return (s, ej) fromMaybeE mproj "Offer target no such local project in DB" + Left (WTTRepo shr rp mb vcs diff) -> Just . Right <$> do + mproj <- lift $ runMaybeT $ do + Entity sid s <- MaybeT $ getBy $ UniqueSharer shr + er <- MaybeT $ getBy $ UniqueRepo rp sid + return (s, er) + (s, er@(Entity _ r)) <- fromMaybeE mproj "Offer target no such local repo in DB" + unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch" + return (s, er, mb, diff) Right _ -> return Nothing (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded remotesHttpOffer <- do let sieve = case target of - Left (shr, prj) -> + Left (WTTProject shr prj) -> makeRecipientSet [ LocalActorProject shr prj ] @@ -1001,6 +1026,14 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar , LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectFollowers shr prj ] + Left (WTTRepo shr rp _ _ _) -> + makeRecipientSet + [ LocalActorRepo shr rp + ] + [ LocalPersonCollectionSharerFollowers shrUser + , LocalPersonCollectionRepoTeam shr rp + , LocalPersonCollectionRepoFollowers shr rp + ] Right _ -> makeRecipientSet [] @@ -1016,19 +1049,35 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar unless (federation || null moreRemoteRecips) $ throwE "Federation disabled, but recipient collection remote members found" lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips - maccept <- lift $ for mproject $ \ (s, Entity jid j) -> do - let shrJ = sharerIdent s - prj = projectIdent j - obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now - ltid <- insertTicket pidUser now title desc source jid obiid obiidAccept - (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer shrJ prj obiidAccept ltid + maccept <- lift $ for mproject $ \ project -> do + let obid = + case project of + Left (_, Entity _ j) -> projectOutbox j + Right (_, Entity _ r, _, _) -> repoOutbox r + obiidAccept <- insertEmptyOutboxItem obid now + let insertTXL = + case project of + Left (_, Entity jid _) -> + \ tclid -> insert_ $ TicketProjectLocal tclid jid + Right (_, Entity rid _, mb, _) -> + \ tclid -> insert_ $ TicketRepoLocal tclid rid mb + (tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept + case project of + Left _ -> return () + Right (_, _, _, diff) -> insert_ $ Patch tid now diff + (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid + let (actor, ibid) = + case project of + Left (s, Entity _ j) -> + ( LocalActorProject (sharerIdent s) (projectIdent j) + , projectInbox j + ) + Right (s, Entity _ r, _, _) -> + ( LocalActorRepo (sharerIdent s) (repoIdent r) + , repoInbox r + ) knownRemoteRecipsAccept <- - deliverLocal' - False - (LocalActorProject shrJ prj) - (projectInbox j) - obiidAccept - localRecipsAccept + deliverLocal' False actor ibid obiidAccept localRecipsAccept (obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept return (obiid, doc, remotesHttpOffer, maccept) lift $ do @@ -1037,28 +1086,23 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept return obiidOffer where - checkTicket - shrUser - (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned resolved mmr) - uTarget = do - verifyNothingE mlocal "Ticket with 'id'" - shrAttrib <- do - route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route" - case route of - SharerR shr -> return shr - _ -> throwE "Ticket attrib not a sharer route" - unless (shrAttrib == shrUser) $ - throwE "Ticket attibuted to someone else" - verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" - verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" - for_ muContext $ \ uContext -> - unless (uContext == uTarget) $ throwE "Offer target != ticket context" - verifyNothingE muAssigned "Ticket has 'assignedTo'" - when resolved $ throwE "Ticket is resolved" - verifyNothingE mmr "Ticket has 'attachment'" - target <- parseTarget uTarget - return (summary, content, source, target) + checkOfferTicket + :: ShrIdent + -> AP.Ticket URIMode + -> FedURI + -> ExceptT Text Handler + ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) + , TextHtml + , TextHtml + , TextPandocMarkdown + ) + checkOfferTicket shrUser ticket uTarget = do + target <- parseTarget uTarget + (muContext, summary, content, source, mmr) <- checkTicket shrUser ticket + for_ muContext $ + \ u -> unless (u == uTarget) $ throwE "Offer target != ticket context" + target' <- matchTargetAndMR target mmr + return (target', summary, content, source) where parseTarget u@(ObjURI h lu) = do hl <- hostIsLocal h @@ -1066,10 +1110,100 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar then Left <$> do route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route" case route of - ProjectR shr prj -> return (shr, prj) - RepoR _ _ -> throwE "Offering patch to repo not implemented yet" + ProjectR shr prj -> return $ Left (shr, prj) + RepoR shr rp -> return $ Right (shr, rp) _ -> throwE "Offer target is local but isn't a project/repo route" else return $ Right u + checkTicket + shrUser + (AP.Ticket mlocal attrib mpublished mupdated muContext summary + content source muAssigned resolved mmr) = do + verifyNothingE mlocal "Ticket with 'id'" + shrAttrib <- do + route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route" + case route of + SharerR shr -> return shr + _ -> throwE "Ticket attrib not a sharer route" + unless (shrAttrib == shrUser) $ + throwE "Ticket attibuted to someone else" + + verifyNothingE mpublished "Ticket with 'published'" + verifyNothingE mupdated "Ticket with 'updated'" + verifyNothingE muAssigned "Ticket has 'assignedTo'" + when resolved $ throwE "Ticket is resolved" + + mmr' <- traverse (uncurry checkMR) mmr + + return (muContext, summary, content, source, mmr') + where + checkMR h (MergeRequest muOrigin luTarget epatch) = do + verifyNothingE muOrigin "MR with 'origin'" + branch <- checkBranch h luTarget + (typ, content) <- + case epatch of + Left _ -> throwE "MR patch specified as a URI" + Right (hPatch, patch) -> checkPatch hPatch patch + return (branch, typ, content) + where + checkBranch h lu = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "MR target is local but isn't a valid route" + case route of + RepoR shr rp -> return (shr, rp, Nothing) + RepoBranchR shr rp b -> return (shr, rp, Just b) + _ -> + throwE + "MR target is a valid local route, but isn't a \ + \repo or branch route" + else return $ Right $ ObjURI h lu + checkPatch h (AP.Patch mlocal attrib mpub typ content) = do + verifyNothingE mlocal "Patch with 'id'" + hl <- hostIsLocal h + shrAttrib <- do + route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route" + case route of + SharerR shr -> return shr + _ -> throwE "Patch attrib not a sharer route" + unless (hl && shrAttrib == shrUser) $ + throwE "Ticket and Patch attrib mismatch" + verifyNothingE mpub "Patch has 'published'" + return (typ, content) + matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj + matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" + matchTargetAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" + matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, content)) = do + branch' <- + case branch of + Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb + _ -> throwE "MR target repo/branch and Offer target repo mismatch" + let vcs = typ2vcs typ + case vcs of + VCSDarcs -> + unless (isNothing branch') $ + throwE "Darcs MR specifies a branch" + VCSGit -> + unless (isJust branch') $ + throwE "Git MR doesn't specify the branch" + return $ Left $ WTTRepo shr rp branch' vcs content + where + typ2vcs PatchTypeDarcs = VCSDarcs + matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) + matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, content)) = do + luBranch <- + case branch of + Right (ObjURI h' lu') | h == h' -> return lu + _ -> throwE "MR target repo/branch and Offer target repo mismatch" + let patch = + ( if lu == luBranch then Nothing else Just luBranch + , typ + , content + ) + return $ Right (h, lu, Just patch) insertOfferToOutbox shrUser now obid blinded = do hLocal <- asksSite siteInstanceHost obiid <- insertEmptyOutboxItem obid now @@ -1086,7 +1220,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar } update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) - insertTicket pidAuthor now title desc source jid obiid obiidAccept = do + insertTicket pidAuthor now title desc source insertTXL obiid obiidAccept = do did <- insert Discussion fsid <- insert FollowerSet tid <- insert Ticket @@ -1109,10 +1243,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar { ticketContextLocalTicket = tid , ticketContextLocalAccept = obiidAccept } - insert_ TicketProjectLocal - { ticketProjectLocalContext = tclid - , ticketProjectLocalProject = jid - } + insertTXL tclid talid <- insert TicketAuthorLocal { ticketAuthorLocalTicket = ltid , ticketAuthorLocalAuthor = pidAuthor @@ -1122,33 +1253,50 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar { ticketUnderProjectProject = tclid , ticketUnderProjectAuthor = talid } - return ltid - insertAccept shrUser luOffer shrJ prj obiidAccept ltid = do + return (tid, ltid) + insertAccept shrUser luOffer project obiidAccept ltid = do + let (collections, outboxItemRoute, projectRoute, ticketRoute) = + case project of + Left (s, Entity _ j) -> + let shr = sharerIdent s + prj = projectIdent j + in ( [ LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj + ] + , ProjectOutboxItemR shr prj + , ProjectR shr prj + , ProjectTicketR shr prj + ) + Right (s, Entity _ r, _, _) -> + let shr = sharerIdent s + rp = repoIdent r + in ( [ LocalPersonCollectionRepoTeam shr rp + , LocalPersonCollectionRepoFollowers shr rp + ] + , RepoOutboxItemR shr rp + , RepoR shr rp + , RepoPatchR shr rp + ) encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost obikhidAccept <- encodeKeyHashid obiidAccept ltkhid <- encodeKeyHashid ltid let actors = [LocalActorSharer shrUser] - collections = - [ LocalPersonCollectionProjectTeam shrJ prj - , LocalPersonCollectionProjectFollowers shrJ prj - ] recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection collections doc = Doc hLocal Activity { activityId = - Just $ encodeRouteLocal $ - ProjectOutboxItemR shrJ prj obikhidAccept - , activityActor = encodeRouteLocal $ ProjectR shrJ prj + Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept + , activityActor = encodeRouteLocal projectRoute , activitySummary = Nothing , activityAudience = Audience recips [] [] [] [] [] , activitySpecific = AcceptActivity Accept { acceptObject = ObjURI hLocal luOffer , acceptResult = - Just $ encodeRouteLocal $ ProjectTicketR shrJ prj ltkhid + Just $ encodeRouteLocal $ ticketRoute ltkhid } } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 1dbfb2b..4444905 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -90,10 +90,6 @@ import Vervis.Patch import Vervis.Ticket import Vervis.WorkItem -data WorkItemTarget - = WTTProject ShrIdent PrjIdent - | WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text - checkOfferTicket :: RemoteAuthor -> AP.Ticket URIMode @@ -107,14 +103,14 @@ checkOfferTicket , TextPandocMarkdown ) checkOfferTicket author ticket uTarget = do - target <- checkProject uTarget + target <- parseTarget uTarget (muContext, summary, content, source, mmr) <- checkTicket ticket for_ muContext $ \ u -> unless (u == uTarget) $ throwE "Offer target != Ticket context" target' <- matchTargetAndMR target mmr return (target', summary, content, source) where - checkProject u@(ObjURI h lu) = do + parseTarget u@(ObjURI h lu) = do hl <- hostIsLocal h if hl then Left <$> do diff --git a/src/Vervis/WorkItem.hs b/src/Vervis/WorkItem.hs index cbe329b..7616ece 100644 --- a/src/Vervis/WorkItem.hs +++ b/src/Vervis/WorkItem.hs @@ -19,6 +19,7 @@ module Vervis.WorkItem , askWorkItemFollowers , contextAudience , getWorkItemDetail + , WorkItemTarget (..) ) where @@ -64,6 +65,7 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Model.Repo -- import Vervis.Model.Workflow -- import Vervis.Paginate import Vervis.Patch @@ -247,3 +249,7 @@ getWorkItemDetail name v = do _ -> throwE "Not a ticket author route" else return $ Right u mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro) + +data WorkItemTarget + = WTTProject ShrIdent PrjIdent + | WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text