From b16c9505af0b5ec3a843839c0d053a62d83dfe7c Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 13 Aug 2020 10:26:20 +0000 Subject: [PATCH] S2S & C2S: Switch from single-patch MR version to multi-patch bundle support --- config/models | 5 +- config/routes | 34 +- migrations/2020_08_10_bundle.model | 2 + migrations/2020_08_10_bundle_mig.model | 19 ++ src/Vervis/API.hs | 401 ++++++++++++++---------- src/Vervis/ActivityPub.hs | 12 +- src/Vervis/ActivityPub/Recipient.hs | 36 +-- src/Vervis/Federation/Discussion.hs | 18 +- src/Vervis/Federation/Offer.hs | 16 +- src/Vervis/Federation/Ticket.hs | 276 +++++++++-------- src/Vervis/Foundation.hs | 3 +- src/Vervis/Handler/Patch.hs | 409 +++++++++++++++---------- src/Vervis/Handler/Ticket.hs | 12 +- src/Vervis/Migration.hs | 21 ++ src/Vervis/Migration/Model.hs | 11 + src/Vervis/Patch.hs | 48 +-- src/Vervis/Ticket.hs | 34 +- src/Vervis/WorkItem.hs | 30 +- src/Web/ActivityPub.hs | 107 ++++++- 19 files changed, 901 insertions(+), 593 deletions(-) create mode 100644 migrations/2020_08_10_bundle.model create mode 100644 migrations/2020_08_10_bundle_mig.model diff --git a/config/models b/config/models index 5c86469..883d38d 100644 --- a/config/models +++ b/config/models @@ -450,8 +450,11 @@ TicketUnderProject UniqueTicketUnderProjectProject project UniqueTicketUnderProjectAuthor author +Bundle + ticket TicketId + Patch - ticket TicketId + bundle BundleId created UTCTime content Text diff --git a/config/routes b/config/routes index bfc14cb..18f2b32 100644 --- a/config/routes +++ b/config/routes @@ -110,16 +110,17 @@ /s/#ShrIdent/r/#RpIdent/d/!new RepoDevNewR GET /s/#ShrIdent/r/#RpIdent/d/#ShrIdent RepoDevR GET DELETE POST -/s/#ShrIdent/r/#RpIdent/pt RepoPatchesR GET +/s/#ShrIdent/r/#RpIdent/mr RepoProposalsR GET -/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid RepoPatchR GET -/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/d RepoPatchDiscussionR GET -/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/deps RepoPatchDepsR GET -/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/rdeps RepoPatchReverseDepsR GET -/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/followers RepoPatchFollowersR GET -/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/events RepoPatchEventsR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid RepoProposalR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/d RepoProposalDiscussionR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/deps RepoProposalDepsR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/rdeps RepoProposalReverseDepsR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/followers RepoProposalFollowersR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/events RepoProposalEventsR GET -/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/v/#PatchKeyHashid RepoPatchVersionR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/b/#BundleKeyHashid RepoProposalBundleR GET +/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/b/#BundleKeyHashid/pt/#PatchKeyHashid RepoProposalBundlePatchR GET /s/#ShrIdent/r/#RpIdent/_darcs/+Texts DarcsDownloadR GET @@ -203,15 +204,16 @@ /s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/team SharerTicketTeamR GET /s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/events SharerTicketEventsR GET -/s/#ShrIdent/pt SharerPatchesR GET +/s/#ShrIdent/mr SharerProposalsR GET -/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid SharerPatchR GET -/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/d SharerPatchDiscussionR GET -/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/deps SharerPatchDepsR GET -/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/rdeps SharerPatchReverseDepsR GET -/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/followers SharerPatchFollowersR GET -/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/events SharerPatchEventsR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid SharerProposalR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/d SharerProposalDiscussionR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/deps SharerProposalDepsR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/rdeps SharerProposalReverseDepsR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/followers SharerProposalFollowersR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/events SharerProposalEventsR GET -/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/v/#PatchKeyHashid SharerPatchVersionR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/b/#BundleKeyHashid SharerProposalBundleR GET +/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/b/#BundleKeyHashid/pt/#PatchKeyHashid SharerProposalBundlePatchR GET /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET diff --git a/migrations/2020_08_10_bundle.model b/migrations/2020_08_10_bundle.model new file mode 100644 index 0000000..ff211c1 --- /dev/null +++ b/migrations/2020_08_10_bundle.model @@ -0,0 +1,2 @@ +Bundle + ticket TicketId diff --git a/migrations/2020_08_10_bundle_mig.model b/migrations/2020_08_10_bundle_mig.model new file mode 100644 index 0000000..66f38f6 --- /dev/null +++ b/migrations/2020_08_10_bundle_mig.model @@ -0,0 +1,19 @@ +Person + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status Text + +Bundle + ticket TicketId + +Patch + ticket TicketId + bundle BundleId + created UTCTime + content Text diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index d04c532..63e8189 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -207,18 +207,18 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge ] NoteContextSharerTicket shr talid True -> let talkhid = hashTAL talid - in [ -- LocalPersonCollectionSharerPatchTeam shr talkhid - LocalPersonCollectionSharerPatchFollowers shr talkhid + in [ -- LocalPersonCollectionSharerProposalTeam shr talkhid + LocalPersonCollectionSharerProposalFollowers shr talkhid ] NoteContextProjectTicket shr prj ltid -> let ltkhid = hashLT ltid in [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid LocalPersonCollectionProjectTicketFollowers shr prj ltkhid ] - NoteContextRepoPatch shr rp ltid -> + NoteContextRepoProposal shr rp ltid -> let ltkhid = hashLT ltid - in [ -- LocalPersonCollectionRepoPatchTeam shr rp ltkhid - LocalPersonCollectionRepoPatchFollowers shr rp ltkhid + in [ -- LocalPersonCollectionRepoProposalTeam shr rp ltkhid + LocalPersonCollectionRepoProposalFollowers shr rp ltkhid ] Right _ -> [] commenter = [LocalPersonCollectionSharerFollowers shrUser] @@ -251,7 +251,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge decodeKeyHashidE talkhid (name <> " sharer ticket invalid talkhid") - SharerPatchR shr talkhid -> + SharerProposalR shr talkhid -> flip (NoteContextSharerTicket shr) True <$> decodeKeyHashidE talkhid @@ -261,8 +261,8 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge decodeKeyHashidE ltkhid (name <> " project ticket invalid ltkhid") - RepoPatchR shr rp ltkhid -> - NoteContextRepoPatch shr rp <$> + RepoProposalR shr rp ltkhid -> + NoteContextRepoProposal shr rp <$> decodeKeyHashidE ltkhid (name <> " repo patch invalid ltkhid") @@ -329,7 +329,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge sharerSet <- lookup shr localRecips projectSet <- lookup prj $ localRecipProjectRelated sharerSet guard $ localRecipProject $ localRecipProjectDirect projectSet - verifyContextRecip (Left (NoteContextRepoPatch shr rp _)) localRecips _ = + verifyContextRecip (Left (NoteContextRepoProposal shr rp _)) localRecips _ = fromMaybeE verify "Local context patch's hosting repo isn't listed as a recipient" @@ -360,7 +360,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge return (mproj, localTicketDiscuss lt) NoteContextSharerTicket shr talid True -> do (_, Entity _ lt, _, repo, _, _) <- do - mticket <- lift $ getSharerPatch shr talid + mticket <- lift $ getSharerProposal shr talid fromMaybeE mticket "Note context no such local sharer-hosted patch" mproj <- case repo of @@ -372,9 +372,9 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge mticket <- lift $ getProjectTicket shr prj ltid fromMaybeE mticket "Note context no such local project-hosted ticket" return (Just $ Left (shr, prj), localTicketDiscuss lt) - NoteContextRepoPatch shr rp ltid -> do + NoteContextRepoProposal shr rp ltid -> do (_, _, _, Entity _ lt, _, _, _, _, _) <- do - mticket <- lift $ getRepoPatch shr rp ltid + mticket <- lift $ getRepoProposal shr rp ltid fromMaybeE mticket "Note context no such local project-hosted ticket" return (Just $ Right (shr, rp), localTicketDiscuss lt) mmidParent <- for mparent $ \ parent -> @@ -491,14 +491,14 @@ checkFederation remoteRecips = do throwE "Federation disabled, but remote recipients found" verifyProjectRecip (Right _) _ = return () -verifyProjectRecip (Left (WTTProject shr prj)) localRecips = +verifyProjectRecip (Left (WITProject 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 = +verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips = fromMaybeE verify "Local context repo isn't listed as a recipient" where verify = do @@ -530,12 +530,12 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT (_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now project <- prepareProject now tracker - (talid, mptid) <- lift $ insertTicket now pidUser title desc source obiidCreate project - docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid + (talid, mbn) <- lift $ insertTicket now pidUser title desc source obiidCreate project + docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mbn remoteRecipsHttpCreate <- do let sieve = case context of - Left (WTTProject shr prj) -> + Left (WITProject shr prj) -> makeRecipientSet [ LocalActorProject shr prj ] @@ -543,7 +543,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectFollowers shr prj ] - Left (WTTRepo shr rp _ _ _) -> + Left (WITRepo shr rp _ _ _) -> makeRecipientSet [ LocalActorRepo shr rp ] @@ -612,7 +612,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT ( Host , LocalURI , LocalURI - , Maybe (Maybe LocalURI, PatchType, Text) + , Maybe (Maybe LocalURI, PatchType, NonEmpty Text) ) , TextHtml , TextHtml @@ -653,7 +653,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT checkTicket :: AP.Ticket URIMode -> ExceptT Text Handler - ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) + ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text)) , TextHtml , TextHtml , TextPandocMarkdown @@ -680,16 +680,16 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT -> ExceptT Text Handler ( Either (ShrIdent, RpIdent, Maybe Text) FedURI , PatchType - , Text + , NonEmpty Text ) - checkMR h (MergeRequest muOrigin luTarget epatch) = do + checkMR h (MergeRequest muOrigin luTarget ebundle) = 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) + (typ, diffs) <- + case ebundle of + Left _ -> throwE "MR bundle specified as a URI" + Right (hBundle, bundle) -> checkBundle hBundle bundle + return (branch, typ, diffs) where checkBranch :: Host @@ -712,21 +712,29 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT "MR target is a valid local route, but isn't a \ \repo or branch route" else return $ Right $ ObjURI h lu - checkPatch - :: Host - -> AP.Patch URIMode - -> ExceptT Text Handler - ( PatchType - , Text - ) - checkPatch h (AP.Patch mlocal attrib mpub typ content) = do - encodeRouteLocal <- getEncodeRouteLocal - verifyHostLocal h "Patch attributed to remote user" - verifyNothingE mlocal "Patch with 'id'" - unless (encodeRouteLocal (SharerR shr) == attrib) $ - throwE "Ticket and Patch attrib mismatch" - verifyNothingE mpub "Patch has 'published'" - return (typ, content) + checkBundle _ (AP.BundleHosted _ _) = + throwE "Patches specified as URIs" + checkBundle h (AP.BundleOffer mlocal patches) = do + verifyNothingE mlocal "Bundle has 'id'" + (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches + unless (all (== typ) typs) $ throwE "Different patch types" + return (typ, diffs) + where + checkPatch + :: Host + -> AP.Patch URIMode + -> ExceptT Text Handler + ( PatchType + , Text + ) + checkPatch h (AP.Patch mlocal attrib mpub typ content) = do + encodeRouteLocal <- getEncodeRouteLocal + verifyHostLocal h "Patch attributed to remote user" + verifyNothingE mlocal "Patch with 'id'" + unless (encodeRouteLocal (SharerR shr) == attrib) $ + throwE "Ticket and Patch attrib mismatch" + verifyNothingE mpub "Patch has 'published'" + return (typ, content) matchContextAndMR :: Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) @@ -734,20 +742,20 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT -> Maybe ( Either (ShrIdent, RpIdent, Maybe Text) FedURI , PatchType - , Text + , NonEmpty Text ) -> ExceptT Text Handler (Either WorkItemTarget ( Host , LocalURI - , Maybe (Maybe LocalURI, PatchType, Text) + , Maybe (Maybe LocalURI, PatchType, NonEmpty Text) ) ) - matchContextAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj + matchContextAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj matchContextAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" matchContextAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" - matchContextAndMR (Left (Right (shr, rp))) (Just (branch, typ, content)) = do + matchContextAndMR (Left (Right (shr, rp))) (Just (branch, typ, diffs)) = do branch' <- case branch of Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb @@ -760,56 +768,56 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT VCSGit -> unless (isJust branch') $ throwE "Git MR doesn't specify the branch" - return $ Left $ WTTRepo shr rp branch' vcs content + return $ Left $ WITRepo shr rp branch' vcs diffs where typ2vcs PatchTypeDarcs = VCSDarcs matchContextAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) - matchContextAndMR (Right (ObjURI h lu)) (Just (branch, typ, content)) = do + matchContextAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = do luBranch <- case branch of Right (ObjURI h' lu') | h == h' -> return lu _ -> throwE "MR target repo/branch and Ticket context repo mismatch" - let patch = + let bundle = ( if lu == luBranch then Nothing else Just luBranch , typ - , content + , diffs ) - return $ Right (h, lu, Just patch) + return $ Right (h, lu, Just bundle) checkTargetAndContext :: Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) FedURI -> Either WorkItemTarget - (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) + (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text)) -> ExceptT Text Handler (Either WorkItemTarget ( Host , LocalURI , LocalURI - , Maybe (Maybe LocalURI, PatchType, Text) + , Maybe (Maybe LocalURI, PatchType, NonEmpty Text) ) ) checkTargetAndContext (Left _) (Right _) = throwE "Create target is local but ticket context is remote" checkTargetAndContext (Right _) (Left _) = throwE "Create target is remote but ticket context is local" - checkTargetAndContext (Right (ObjURI hTarget luTarget)) (Right (hContext, luContext, mpatch)) = + checkTargetAndContext (Right (ObjURI hTarget luTarget)) (Right (hContext, luContext, mbundle)) = if hTarget == hContext - then return $ Right (hContext, luTarget, luContext, mpatch) + then return $ Right (hContext, luTarget, luContext, mbundle) else throwE "Create target and ticket context on different \ \remote hosts" checkTargetAndContext (Left proj) (Left wit) = case (proj, wit) of - (Left (shr, prj), WTTProject shr' prj') + (Left (shr, prj), WITProject shr' prj') | shr == shr' && prj == prj' -> return $ Left wit - (Right (shr, rp), WTTRepo shr' rp' _ _ _) + (Right (shr, rp), WITRepo shr' rp' _ _ _) | shr == shr' && rp == rp' -> return $ Left wit _ -> throwE "Create target and ticket context are different \ \local projects" - fetchTracker (h, luTarget, luContext, mpatch) = do + fetchTracker (h, luTarget, luContext, mbundle) = do (iid, era) <- do iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) result <- lift $ fetchRemoteActor iid h luTarget @@ -819,16 +827,16 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT Right (Right mera) -> do era <- fromMaybeE mera "target found to be a collection, not an actor" return (iid, era) - return (iid, era, if luTarget == luContext then Nothing else Just luContext, mpatch) + return (iid, era, if luTarget == luContext then Nothing else Just luContext, mbundle) - prepareProject now (Left (WTTProject shr prj)) = Left <$> do + prepareProject now (Left (WITProject shr prj)) = Left <$> do mej <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getBy $ UniqueProject prj sid ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project" obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now return (shr, Left ej, obiidAccept) - prepareProject now (Left (WTTRepo shr rp mb vcs diff)) = Left <$> do + prepareProject now (Left (WITRepo shr rp mb vcs diff)) = Left <$> do mer <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getBy $ UniqueRepo rp sid @@ -867,7 +875,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , ticketAuthorLocalAuthor = pidUser , ticketAuthorLocalOpen = obiidCreate } - mptid <- + mbn <- case project of Left (_shr, ent, obiidAccept) -> do tclid <- insert TicketContextLocal @@ -881,38 +889,60 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , ticketProjectLocalProject = jid } return Nothing - Right (Entity rid _, mb, diff) -> Just <$> do + Right (Entity rid _, mb, diffs) -> Just <$> do insert_ TicketRepoLocal { ticketRepoLocalContext = tclid , ticketRepoLocalRepo = rid , ticketRepoLocalBranch = mb } - insert $ Patch tid now diff - Right (Entity raid _, mroid, mpatch) -> do + bnid <- insert $ Bundle tid + (bnid,) . toNE <$> + insertMany + (NE.toList $ NE.map (Patch bnid now) diffs) + Right (Entity raid _, mroid, mbundle) -> do insert_ TicketProjectRemote { ticketProjectRemoteTicket = talid , ticketProjectRemoteTracker = raid , ticketProjectRemoteProject = mroid } - for mpatch $ \ (_typ, diff) -> insert $ Patch tid now diff - return (talid, mptid) + for mbundle $ \ (_typ, diffs) -> do + bnid <- insert $ Bundle tid + (bnid,) . toNE <$> + insertMany + (NE.toList $ NE.map (Patch bnid now) diffs) + return (talid, mbn) + where + toNE = fromMaybe (error "No Patch IDs returned from DB") . NE.nonEmpty - insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid = do + insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mbn = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost talkhid <- encodeKeyHashid talid - mptkhid <- traverse encodeKeyHashid mptid + mkh <- for mbn $ \ (bnid, ptids) -> + (,) <$> encodeKeyHashid bnid + <*> traverse encodeKeyHashid ptids obikhid <- encodeKeyHashid obiidCreate let luTicket = encodeRouteLocal $ SharerTicketR shrUser talkhid luAttrib = encodeRouteLocal $ SharerR shrUser (uTarget, uContext, mmr) = case context of - Left (WTTProject shr prj) -> + Left (WITProject shr prj) -> let uProject = encodeRouteHome $ ProjectR shr prj in (uProject, uProject, Nothing) - Left (WTTRepo shr rp mb vcs diff) -> + Left (WITRepo shr rp mb vcs diffs) -> let uRepo = encodeRouteHome $ RepoR shr rp + (bnkhid, ptkhids) = + case mkh of + Nothing -> error "mkh is Nothing" + Just v -> v + luBundle = + encodeRouteLocal $ + SharerProposalBundleR shrUser talkhid bnkhid + typ = + case vcs of + VCSDarcs -> PatchTypeDarcs + VCSGit -> error "createTicketC VCSGit" mr = MergeRequest { mrOrigin = Nothing , mrTarget = @@ -920,65 +950,90 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT case mb of Nothing -> RepoR shr rp Just b -> RepoBranchR shr rp b - , mrPatch = Right + , mrBundle = Right ( hLocal - , AP.Patch - { AP.patchLocal = Just + , AP.BundleOffer + (Just ( hLocal - , PatchLocal - { patchId = - case mptkhid of - Nothing -> error "mptkhid is Nothing" - Just ptkhid -> - encodeRouteLocal $ - SharerPatchVersionR shrUser talkhid ptkhid - , patchContext = luTicket - , patchPrevVersions = [] - , patchCurrentVersion = Nothing + , BundleLocal + { bundleId = luBundle + , bundleContext = luTicket + , bundlePrevVersions = [] + , bundleCurrentVersion = Nothing } ) - , AP.patchAttributedTo = luAttrib - , AP.patchPublished = Just now - , AP.patchType = - case vcs of - VCSDarcs -> PatchTypeDarcs - VCSGit -> error "createTicketC VCSGit" - , AP.patchContent = diff - } + ) + (NE.map + (\ (ptkhid, diff) -> AP.Patch + { AP.patchLocal = Just + ( hLocal + , PatchLocal + { patchId = + encodeRouteLocal $ + SharerProposalBundlePatchR shrUser talkhid bnkhid ptkhid + , patchContext = luBundle + } + ) + , AP.patchAttributedTo = luAttrib + , AP.patchPublished = Just now + , AP.patchType = typ + , AP.patchContent = diff + } + ) + (NE.zip ptkhids diffs) + ) ) } in (uRepo, uRepo, Just (hLocal, mr)) - Right (hContext, luTarget, luContext, mpatch) -> - let mr (mluBranch, typ, diff) = MergeRequest - { mrOrigin = Nothing - , mrTarget = fromMaybe luContext mluBranch - , mrPatch = Right - ( hLocal - , AP.Patch - { AP.patchLocal = Just + Right (hContext, luTarget, luContext, mbundle) -> + let mr (mluBranch, typ, diffs) = + let (bnkhid, ptkhids) = + case mkh of + Nothing -> error "mkh is Nothing" + Just v -> v + luBundle = + encodeRouteLocal $ + SharerProposalBundleR shrUser talkhid bnkhid + in MergeRequest + { mrOrigin = Nothing + , mrTarget = fromMaybe luContext mluBranch + , mrBundle = Right ( hLocal - , PatchLocal - { patchId = - case mptkhid of - Nothing -> error "mptkhid is Nothing" - Just ptkhid -> - encodeRouteLocal $ - SharerPatchVersionR shrUser talkhid ptkhid - , patchContext = luTicket - , patchPrevVersions = [] - , patchCurrentVersion = Nothing - } + , AP.BundleOffer + (Just + ( hLocal + , BundleLocal + { bundleId = luBundle + , bundleContext = luTicket + , bundlePrevVersions = [] + , bundleCurrentVersion = Nothing + } + ) + ) + (NE.map + (\ (ptkhid, diff) -> AP.Patch + { AP.patchLocal = Just + ( hLocal + , PatchLocal + { patchId = + encodeRouteLocal $ + SharerProposalBundlePatchR shrUser talkhid bnkhid ptkhid + , patchContext = luBundle + } + ) + , AP.patchAttributedTo = luAttrib + , AP.patchPublished = Just now + , AP.patchType = typ + , AP.patchContent = diff + } + ) + (NE.zip ptkhids diffs) + ) ) - , AP.patchAttributedTo = luAttrib - , AP.patchPublished = Just now - , AP.patchType = typ - , AP.patchContent = diff } - ) - } in ( ObjURI hContext luTarget , ObjURI hContext luContext - , (hContext,) . mr <$> mpatch + , (hContext,) . mr <$> mbundle ) tlocal = TicketLocal { ticketId = luTicket @@ -1046,11 +1101,11 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT data Followee = FolloweeSharer ShrIdent | FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal) - | FolloweeSharerPatch ShrIdent (KeyHashid TicketAuthorLocal) + | FolloweeSharerProposal ShrIdent (KeyHashid TicketAuthorLocal) | FolloweeProject ShrIdent PrjIdent | FolloweeProjectTicket ShrIdent PrjIdent (KeyHashid LocalTicket) | FolloweeRepo ShrIdent RpIdent - | FolloweeRepoPatch ShrIdent RpIdent (KeyHashid LocalTicket) + | FolloweeRepoProposal ShrIdent RpIdent (KeyHashid LocalTicket) followC :: ShrIdent @@ -1109,20 +1164,20 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do where parseFollowee (SharerR shr) = Just $ FolloweeSharer shr parseFollowee (SharerTicketR shr khid) = Just $ FolloweeSharerTicket shr khid - parseFollowee (SharerPatchR shr khid) = Just $ FolloweeSharerPatch shr khid + parseFollowee (SharerProposalR shr khid) = Just $ FolloweeSharerProposal shr khid parseFollowee (ProjectR shr prj) = Just $ FolloweeProject shr prj parseFollowee (ProjectTicketR shr prj num) = Just $ FolloweeProjectTicket shr prj num parseFollowee (RepoR shr rp) = Just $ FolloweeRepo shr rp - parseFollowee (RepoPatchR shr rp khid) = Just $ FolloweeRepoPatch shr rp khid + parseFollowee (RepoProposalR shr rp khid) = Just $ FolloweeRepoProposal shr rp khid parseFollowee _ = Nothing followeeActor (FolloweeSharer shr) = LocalActorSharer shr followeeActor (FolloweeSharerTicket shr _) = LocalActorSharer shr - followeeActor (FolloweeSharerPatch shr _) = LocalActorSharer shr + followeeActor (FolloweeSharerProposal shr _) = LocalActorSharer shr followeeActor (FolloweeProject shr prj) = LocalActorProject shr prj followeeActor (FolloweeProjectTicket shr prj _) = LocalActorProject shr prj followeeActor (FolloweeRepo shr rp) = LocalActorRepo shr rp - followeeActor (FolloweeRepoPatch shr rp _) = LocalActorRepo shr rp + followeeActor (FolloweeRepoProposal shr rp _) = LocalActorRepo shr rp getAuthor shr = do sid <- getKeyBy404 $ UniqueSharer shr @@ -1148,11 +1203,11 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do fromMaybeE mticket "Follow object: No such sharer-ticket in DB" p <- lift $ getJust $ ticketAuthorLocalAuthor tal return (localTicketFollowers lt, personInbox p, True, personOutbox p) - getFollowee (FolloweeSharerPatch shr talkhid) = do + getFollowee (FolloweeSharerProposal shr talkhid) = do (Entity _ tal, Entity _ lt, _, _, _, _) <- do mticket <- lift $ runMaybeT $ do talid <- decodeKeyHashidM talkhid - MaybeT $ getSharerPatch shr talid + MaybeT $ getSharerProposal shr talid fromMaybeE mticket "Follow object: No such sharer-patch in DB" p <- lift $ getJust $ ticketAuthorLocalAuthor tal return (localTicketFollowers lt, personInbox p, True, personOutbox p) @@ -1175,11 +1230,11 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do MaybeT $ getValBy $ UniqueRepo rp sid repo <- fromMaybeE mrepo "Follow object: No such repo in DB" return (repoFollowers repo, repoInbox repo, False, repoOutbox repo) - getFollowee (FolloweeRepoPatch shr rp ltkhid) = do + getFollowee (FolloweeRepoProposal shr rp ltkhid) = do (_, Entity _ r, _, Entity _ lt, _, _, _, _, _) <- do mticket <- lift $ runMaybeT $ do ltid <- decodeKeyHashidM ltkhid - MaybeT $ getRepoPatch shr rp ltid + MaybeT $ getRepoProposal shr rp ltid fromMaybeE mticket "Follow object: No such repo-patch in DB" return (localTicketFollowers lt, repoInbox r, False, repoOutbox r) @@ -1281,26 +1336,26 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do mproject <- case target of - Left (WTTProject shr prj) -> Just . Left <$> do + Left (WITProject 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 + Left (WITRepo shr rp mb vcs diffs) -> 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) + return (s, er, mb, diffs) Right _ -> return Nothing (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded remotesHttpOffer <- do let sieve = case target of - Left (WTTProject shr prj) -> + Left (WITProject shr prj) -> makeRecipientSet [ LocalActorProject shr prj ] @@ -1308,7 +1363,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar , LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectFollowers shr prj ] - Left (WTTRepo shr rp _ _ _) -> + Left (WITRepo shr rp _ _ _) -> makeRecipientSet [ LocalActorRepo shr rp ] @@ -1346,7 +1401,9 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar (tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept case project of Left _ -> return () - Right (_, _, _, diff) -> insert_ $ Patch tid now diff + Right (_, _, _, diffs) -> do + bnid <- insert $ Bundle tid + insertMany_ $ NE.toList $ NE.map (Patch bnid now) diffs (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid let (actor, ibid) = case project of @@ -1373,7 +1430,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler - ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) + ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text)) , TextHtml , TextHtml , TextPandocMarkdown @@ -1418,14 +1475,14 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar return (muContext, summary, content, source, mmr') where - checkMR h (MergeRequest muOrigin luTarget epatch) = do + checkMR h (MergeRequest muOrigin luTarget ebundle) = 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) + (typ, diffs) <- + case ebundle of + Left _ -> throwE "MR bundle specified as a URI" + Right (hBundle, bundle) -> checkBundle hBundle bundle + return (branch, typ, diffs) where checkBranch h lu = do hl <- hostIsLocal h @@ -1443,22 +1500,30 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar "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 + checkBundle _ (AP.BundleHosted _ _) = + throwE "Patches specified as URIs" + checkBundle h (AP.BundleOffer mlocal patches) = do + verifyNothingE mlocal "Bundle has 'id'" + (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches + unless (all (== typ) typs) $ throwE "Different patch types" + return (typ, diffs) + where + 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 $ WITProject 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 + matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, diffs)) = do branch' <- case branch of Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb @@ -1471,21 +1536,21 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar VCSGit -> unless (isJust branch') $ throwE "Git MR doesn't specify the branch" - return $ Left $ WTTRepo shr rp branch' vcs content + return $ Left $ WITRepo shr rp branch' vcs diffs 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 + matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = 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 = + let bundle = ( if lu == luBranch then Nothing else Just luBranch , typ - , content + , diffs ) - return $ Right (h, lu, Just patch) + return $ Right (h, lu, Just bundle) insertOfferToOutbox shrUser now obid blinded = do hLocal <- asksSite siteInstanceHost obiid <- insertEmptyOutboxItem obid now @@ -1555,7 +1620,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar ] , RepoOutboxItemR shr rp , RepoR shr rp - , RepoPatchR shr rp + , RepoProposalR shr rp ) encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome @@ -1594,7 +1659,7 @@ verifyHosterRecip localRecips name (Left wi) = sharerSet <- lookup shr localRecips projectSet <- lookup prj $ localRecipProjectRelated sharerSet guard $ localRecipProject $ localRecipProjectDirect projectSet - verify (WorkItemRepoPatch shr rp _) = do + verify (WorkItemRepoProposal shr rp _) = do sharerSet <- lookup shr localRecips repoSet <- lookup rp $ localRecipRepoRelated sharerSet guard $ localRecipRepo $ localRecipRepoDirect repoSet @@ -1629,7 +1694,7 @@ workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj -workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp +workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj @@ -1696,7 +1761,7 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = sid <- MaybeT $ getKeyBy $ UniqueSharer shr projectInbox <$> MaybeT (getValBy $ UniqueProject prj sid) - WorkItemRepoPatch shr rp _ -> do + WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr repoInbox <$> MaybeT (getValBy $ UniqueRepo rp sid) @@ -1723,7 +1788,7 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = sid <- MaybeT $ getKeyBy $ UniqueSharer shr j <- MaybeT (getValBy $ UniqueProject prj sid) return (projectOutbox j, projectInbox j) - WorkItemRepoPatch shr rp _ -> do + WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr r <- MaybeT (getValBy $ UniqueRepo rp sid) return (repoOutbox r, repoInbox r) @@ -1790,7 +1855,7 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = return tdid workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj - workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp + workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp insertAccept shrUser wiParent (WorkItemDetail _ parentCtx parentAuthor) (WorkItemDetail childId childCtx childAuthor) obiidOffer obiidAccept tdid = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome @@ -1944,7 +2009,7 @@ resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObjec sid <- MaybeT $ getKeyBy $ UniqueSharer shr j <- MaybeT (getValBy $ UniqueProject prj sid) return (projectOutbox j, projectInbox j) - WorkItemRepoPatch shr rp _ -> do + WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr r <- MaybeT (getValBy $ UniqueRepo rp sid) return (repoOutbox r, repoInbox r) @@ -2062,7 +2127,7 @@ undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObjec sid <- MaybeT $ getKeyBy $ UniqueSharer shr j <- MaybeT (getValBy $ UniqueProject prj sid) return (projectOutbox j, projectInbox j) - WorkItemRepoPatch shr rp _ -> do + WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr r <- MaybeT (getValBy $ UniqueRepo rp sid) return (repoOutbox r, repoInbox r) diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index cb5948f..a627005 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -140,7 +140,7 @@ import Vervis.Widget.Sharer data NoteContext = NoteContextSharerTicket ShrIdent TicketAuthorLocalId Bool | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId - | NoteContextRepoPatch ShrIdent RpIdent LocalTicketId + | NoteContextRepoProposal ShrIdent RpIdent LocalTicketId deriving Eq parseContext @@ -159,14 +159,14 @@ parseContext uContext = do SharerTicketR shr talkhid -> flip (NoteContextSharerTicket shr) False <$> decodeKeyHashidE talkhid "Note context invalid talkhid" - SharerPatchR shr talkhid -> + SharerProposalR 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" - RepoPatchR shr rp ltkhid -> - NoteContextRepoPatch shr rp <$> + RepoProposalR shr rp ltkhid -> + NoteContextRepoProposal shr rp <$> decodeKeyHashidE ltkhid "Note context invalid ltkhid" _ -> throwE "Local context isn't a ticket/patch route" else return $ Right uContext @@ -1032,12 +1032,12 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci let rpsP = if requireOwner then - [ (rp, localRecipRepoPatchRelated r) + [ (rp, localRecipRepoProposalRelated r) | (rp, r) <- repos , localRecipRepo (localRecipRepoDirect r) || isAuthor (LocalActorRepo shr rp) ] else - map (second localRecipRepoPatchRelated) repos + map (second localRecipRepoProposalRelated) repos fsidssP <- for rpsP $ \ (rp, patches) -> do mrid <- getKeyBy $ UniqueRepo rp sid case mrid of diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs index 389e74b..382006b 100644 --- a/src/Vervis/ActivityPub/Recipient.hs +++ b/src/Vervis/ActivityPub/Recipient.hs @@ -107,7 +107,7 @@ data LocalPersonCollection = LocalPersonCollectionSharerFollowers ShrIdent | LocalPersonCollectionSharerTicketTeam ShrIdent (KeyHashid TicketAuthorLocal) | LocalPersonCollectionSharerTicketFollowers ShrIdent (KeyHashid TicketAuthorLocal) - | LocalPersonCollectionSharerPatchFollowers ShrIdent (KeyHashid TicketAuthorLocal) + | LocalPersonCollectionSharerProposalFollowers ShrIdent (KeyHashid TicketAuthorLocal) | LocalPersonCollectionProjectTeam ShrIdent PrjIdent | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent @@ -116,7 +116,7 @@ data LocalPersonCollection | LocalPersonCollectionRepoTeam ShrIdent RpIdent | LocalPersonCollectionRepoFollowers ShrIdent RpIdent - | LocalPersonCollectionRepoPatchFollowers ShrIdent RpIdent (KeyHashid LocalTicket) + | LocalPersonCollectionRepoProposalFollowers ShrIdent RpIdent (KeyHashid LocalTicket) deriving (Eq, Ord) parseLocalPersonCollection @@ -127,8 +127,8 @@ parseLocalPersonCollection (SharerTicketTeamR shr talkhid) = Just $ LocalPersonCollectionSharerTicketTeam shr talkhid parseLocalPersonCollection (SharerTicketFollowersR shr talkhid) = Just $ LocalPersonCollectionSharerTicketFollowers shr talkhid -parseLocalPersonCollection (SharerPatchFollowersR shr talkhid) = - Just $ LocalPersonCollectionSharerPatchFollowers shr talkhid +parseLocalPersonCollection (SharerProposalFollowersR shr talkhid) = + Just $ LocalPersonCollectionSharerProposalFollowers shr talkhid parseLocalPersonCollection (ProjectTeamR shr prj) = Just $ LocalPersonCollectionProjectTeam shr prj parseLocalPersonCollection (ProjectFollowersR shr prj) = @@ -141,22 +141,22 @@ parseLocalPersonCollection (RepoTeamR shr rp) = Just $ LocalPersonCollectionRepoTeam shr rp parseLocalPersonCollection (RepoFollowersR shr rp) = Just $ LocalPersonCollectionRepoFollowers shr rp -parseLocalPersonCollection (RepoPatchFollowersR shr rp ltkhid) = - Just $ LocalPersonCollectionRepoPatchFollowers shr rp ltkhid +parseLocalPersonCollection (RepoProposalFollowersR shr rp ltkhid) = + Just $ LocalPersonCollectionRepoProposalFollowers shr rp ltkhid parseLocalPersonCollection _ = Nothing renderLocalPersonCollection :: LocalPersonCollection -> Route App renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr renderLocalPersonCollection (LocalPersonCollectionSharerTicketTeam shr talkhid) = SharerTicketTeamR shr talkhid renderLocalPersonCollection (LocalPersonCollectionSharerTicketFollowers shr talkhid) = SharerTicketFollowersR shr talkhid -renderLocalPersonCollection (LocalPersonCollectionSharerPatchFollowers shr talkhid) = SharerPatchFollowersR shr talkhid +renderLocalPersonCollection (LocalPersonCollectionSharerProposalFollowers shr talkhid) = SharerProposalFollowersR shr talkhid renderLocalPersonCollection (LocalPersonCollectionProjectTeam shr prj) = ProjectTeamR shr prj renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj renderLocalPersonCollection (LocalPersonCollectionProjectTicketTeam shr prj ltkhid) = ProjectTicketTeamR shr prj ltkhid renderLocalPersonCollection (LocalPersonCollectionProjectTicketFollowers shr prj ltkhid) = ProjectTicketParticipantsR shr prj ltkhid renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp) = RepoFollowersR shr rp -renderLocalPersonCollection (LocalPersonCollectionRepoPatchFollowers shr rp ltkhid) = RepoPatchFollowersR shr rp ltkhid +renderLocalPersonCollection (LocalPersonCollectionRepoProposalFollowers shr rp ltkhid) = RepoProposalFollowersR shr rp ltkhid parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalPersonCollection) @@ -195,7 +195,7 @@ data LocalRepoRecipientDirect data LocalRepoRecipient = LocalRepoDirect LocalRepoRecipientDirect - | LocalRepoPatchRelated (KeyHashid LocalTicket) LocalPatchRecipientDirect + | LocalRepoProposalRelated (KeyHashid LocalTicket) LocalPatchRecipientDirect deriving (Eq, Ord) data LocalSharerRecipientDirect @@ -206,7 +206,7 @@ data LocalSharerRecipientDirect data LocalSharerRecipient = LocalSharerDirect LocalSharerRecipientDirect | LocalSharerTicketRelated (KeyHashid TicketAuthorLocal) LocalTicketRecipientDirect - | LocalSharerPatchRelated (KeyHashid TicketAuthorLocal) LocalPatchRecipientDirect + | LocalSharerProposalRelated (KeyHashid TicketAuthorLocal) LocalPatchRecipientDirect | LocalProjectRelated PrjIdent LocalProjectRecipient | LocalRepoRelated RpIdent LocalRepoRecipient deriving (Eq, Ord) @@ -237,9 +237,9 @@ groupedRecipientFromCollection LocalSharerRelated shr $ LocalSharerTicketRelated talkhid LocalTicketFollowerz groupedRecipientFromCollection - (LocalPersonCollectionSharerPatchFollowers shr talkhid) = + (LocalPersonCollectionSharerProposalFollowers shr talkhid) = LocalSharerRelated shr $ - LocalSharerPatchRelated talkhid LocalPatchFollowers + LocalSharerProposalRelated talkhid LocalPatchFollowers groupedRecipientFromCollection (LocalPersonCollectionProjectTeam shr prj) = LocalSharerRelated shr $ LocalProjectRelated prj $ @@ -265,9 +265,9 @@ groupedRecipientFromCollection LocalSharerRelated shr $ LocalRepoRelated rp $ LocalRepoDirect LocalRepoFollowers groupedRecipientFromCollection - (LocalPersonCollectionRepoPatchFollowers shr rp ltkhid) = + (LocalPersonCollectionRepoProposalFollowers shr rp ltkhid) = LocalSharerRelated shr $ LocalRepoRelated rp $ - LocalRepoPatchRelated ltkhid LocalPatchFollowers + LocalRepoProposalRelated ltkhid LocalPatchFollowers ------------------------------------------------------------------------------- -- Recipient set types @@ -314,7 +314,7 @@ data LocalRepoDirectSet = LocalRepoDirectSet data LocalRepoRelatedSet = LocalRepoRelatedSet { localRecipRepoDirect :: LocalRepoDirectSet - , localRecipRepoPatchRelated + , localRecipRepoProposalRelated :: [(KeyHashid LocalTicket, LocalPatchDirectSet)] } deriving Eq @@ -330,7 +330,7 @@ data LocalSharerRelatedSet = LocalSharerRelatedSet :: LocalSharerDirectSet , localRecipSharerTicketRelated :: [(KeyHashid TicketAuthorLocal, LocalTicketDirectSet)] - , localRecipSharerPatchRelated + , localRecipSharerProposalRelated :: [(KeyHashid TicketAuthorLocal, LocalPatchDirectSet)] , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)] @@ -358,7 +358,7 @@ groupLocalRecipients (d:ds, ts, ps, js, rs) LocalSharerTicketRelated talkhid ltr -> (ds, (talkhid, ltr):ts, ps, js, rs) - LocalSharerPatchRelated talkhid lpr -> + LocalSharerProposalRelated talkhid lpr -> (ds, ts, (talkhid, lpr):ps, js, rs) LocalProjectRelated prj ljr -> (ds, ts, ps, (prj, ljr):js, rs) @@ -411,7 +411,7 @@ groupLocalRecipients lrr2set = uncurry mk . partitionEithers . map lrr2e . NE.toList where lrr2e (LocalRepoDirect d) = Left d - lrr2e (LocalRepoPatchRelated num ltrs) = Right (num, ltrs) + lrr2e (LocalRepoProposalRelated num ltrs) = Right (num, ltrs) mk ds ps = LocalRepoRelatedSet (lrrs2set ds) diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 26a9482..51199bd 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -236,9 +236,9 @@ sharerCreateNoteF now shrRecip author body mfwd luCreate note = do if patch then do (Entity _ tal, Entity _ lt, _, _, _, _) <- do - mticket <- lift $ getSharerPatch shr talid + mticket <- lift $ getSharerProposal shr talid fromMaybeE mticket "Context: No such sharer-patch" - return (tal, lt, LocalPersonCollectionSharerPatchFollowers) + return (tal, lt, LocalPersonCollectionSharerProposalFollowers) else do (Entity _ tal, Entity _ lt, _, _, _) <- do mticket <- lift $ getSharerTicket shr talid @@ -297,12 +297,12 @@ sharerCreateNoteF now shrRecip author body mfwd luCreate 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 + Left (NoteContextRepoProposal shr rp ltid) -> runDBExcept $ do personRecip <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip getValBy404 $ UniquePersonIdent sid (_, _, _, Entity _ lt, _, _, _, _, _) <- do - mticket <- lift $ getRepoPatch shr rp ltid + mticket <- lift $ getRepoProposal shr rp ltid fromMaybeE mticket "Context: No such repo-patch" let did = localTicketDiscuss lt _ <- traverse (getParent did) mparent @@ -429,7 +429,7 @@ projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate 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" + Left (NoteContextRepoProposal _ _ _) -> return "Context is a repo-patch, ignoring activity" where getProjectRecip404 = do sid <- getKeyBy404 $ UniqueSharer shrRecip @@ -456,7 +456,7 @@ repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do mremotesHttp <- runDBExcept $ do (rid, ibid) <- lift getRepoRecip404 (_, _, _, repo, _, _) <- do - mticket <- lift $ getSharerPatch shr talid + mticket <- lift $ getSharerProposal shr talid fromMaybeE mticket "Context: No such sharer-ticket" case repo of Left (_, Entity _ trl) @@ -489,11 +489,11 @@ repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do return "Stored to inbox and did inbox forwarding" Left (NoteContextProjectTicket _ _ _) -> return "Context is a project-ticket, ignoring activity" - Left (NoteContextRepoPatch shr rp ltid) -> do + Left (NoteContextRepoProposal shr rp ltid) -> do mremotesHttp <- runDBExcept $ do (rid, ibid) <- lift getRepoRecip404 (_, _, _, Entity _ lt, _, Entity _ trl, _, _, _) <- do - mticket <- lift $ getRepoPatch shr rp ltid + mticket <- lift $ getRepoProposal shr rp ltid fromMaybeE mticket "Context: No such repo-patch" if ticketRepoLocalRepo trl == rid then do @@ -518,7 +518,7 @@ repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do [] [ LocalPersonCollectionRepoFollowers shrRecip rpRecip , LocalPersonCollectionRepoTeam shrRecip rpRecip - , LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid + , LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid ] remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index bdde95b..730d4c3 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -223,7 +223,7 @@ sharerAcceptF shr now author body mfwd luAccept (Accept (ObjURI hOffer luOffer) let collections = [ let coll = if patch - then LocalPersonCollectionSharerPatchFollowers + then LocalPersonCollectionSharerProposalFollowers else LocalPersonCollectionSharerTicketFollowers in coll shr talkhid ] @@ -425,7 +425,7 @@ sharerFollowF shr = | shr == shr' = Just Nothing objRoute (SharerTicketR shr' talkhid) | shr == shr' = Just $ Just (talkhid, False) - objRoute (SharerPatchR shr' talkhid) + objRoute (SharerProposalR shr' talkhid) | shr == shr' = Just $ Just (talkhid, True) objRoute _ = Nothing @@ -436,7 +436,7 @@ sharerFollowF shr = talid <- decodeKeyHashidM talkhid if patch then do - (_, Entity _ lt, _, _, _, _) <- MaybeT $ getSharerPatch shr talid + (_, Entity _ lt, _, _, _, _) <- MaybeT $ getSharerProposal shr talid return lt else do (_, Entity _ lt, _, _, _) <- MaybeT $ getSharerTicket shr talid @@ -514,7 +514,7 @@ repoFollowF shr rp = where objRoute (RepoR shr' rp') | shr == shr' && rp == rp' = Just Nothing - objRoute (RepoPatchR shr' rp' ltkhid) + objRoute (RepoProposalR shr' rp' ltkhid) | shr == shr' && rp == rp' = Just $ Just ltkhid objRoute _ = Nothing @@ -523,7 +523,7 @@ repoFollowF shr rp = r <- getValBy404 $ UniqueRepo rp sid mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do ltid <- decodeKeyHashidM ltkhid - (_, _, _, Entity _ lt, _, _, _, _, _) <- MaybeT $ getRepoPatch shr rp ltid + (_, _, _, Entity _ lt, _, _, _, _, _) <- MaybeT $ getRepoProposal shr rp ltid return lt return $ case mmt of @@ -692,7 +692,7 @@ sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do let ObjURI hAuthor luAuthor = remoteAuthorURI author ticketFollowers = if patch - then LocalPersonCollectionSharerPatchFollowers shrRecip talkhid + then LocalPersonCollectionSharerProposalFollowers shrRecip talkhid else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid audAuthor = AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) @@ -866,7 +866,7 @@ repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do Just _ -> "Sent Accept" return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg where - myWorkItem (WorkItemRepoPatch shr rp ltid) + myWorkItem (WorkItemRepoProposal shr rp ltid) | shr == shrRecip && rp == rpRecip = Just ltid myWorkItem _ = Nothing @@ -875,7 +875,7 @@ repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do ra <- getJust $ remoteAuthorId author let ObjURI hAuthor luAuthor = remoteAuthorURI author ticketFollowers = - LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid + LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid audAuthor = AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) audTicket = diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 178c363..44be1fe 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -102,7 +102,7 @@ checkOfferTicket -> ExceptT Text Handler - ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) + ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text)) , TextHtml , TextHtml , TextPandocMarkdown @@ -147,14 +147,14 @@ checkOfferTicket author ticket uTarget = do return (muContext, summary, content, source, mmr') where - checkMR h (MergeRequest muOrigin luTarget epatch) = do + checkMR h (MergeRequest muOrigin luTarget ebundle) = 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) + (typ, diffs) <- + case ebundle of + Left _ -> throwE "MR bundle specified as a URI" + Right (hBundle, bundle) -> checkBundle hBundle bundle + return (branch, typ, diffs) where checkBranch h lu = do hl <- hostIsLocal h @@ -172,17 +172,25 @@ checkOfferTicket author ticket uTarget = do "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'" - unless (ObjURI h attrib == remoteAuthorURI author) $ - throwE "Ticket and Patch attrib mismatch" - verifyNothingE mpub "Patch has 'published'" - return (typ, content) + checkBundle _ (AP.BundleHosted _ _) = + throwE "Patches specified as URIs" + checkBundle h (AP.BundleOffer mlocal patches) = do + verifyNothingE mlocal "Bundle with 'id'" + (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches + unless (all (== typ) typs) $ throwE "Different patch types" + return (typ, diffs) + where + checkPatch h (AP.Patch mlocal attrib mpub typ content) = do + verifyNothingE mlocal "Patch with 'id'" + unless (ObjURI h attrib == remoteAuthorURI author) $ + 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))) Nothing = return $ Left $ WITProject 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 + matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, diffs)) = do branch' <- case branch of Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb @@ -195,21 +203,21 @@ checkOfferTicket author ticket uTarget = do VCSGit -> unless (isJust branch') $ throwE "Git MR doesn't specify the branch" - return $ Left $ WTTRepo shr rp branch' vcs content + return $ Left $ WITRepo shr rp branch' vcs diffs 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 + matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = 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 = + let bundle = ( if lu == luBranch then Nothing else Just luBranch , typ - , content + , diffs ) - return $ Right (h, lu, Just patch) + return $ Right (h, lu, Just bundle) sharerOfferTicketF :: UTCTime @@ -228,12 +236,12 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do sid <- getKeyBy404 $ UniqueSharer shrRecip personInbox <$> getValBy404 (UniquePersonIdent sid) case target of - Left (WTTProject shr prj) -> do + Left (WITProject shr prj) -> do mjid <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getKeyBy $ UniqueProject prj sid void $ fromMaybeE mjid "Offer target: No such local project" - Left (WTTRepo shr rp _ _ _) -> do + Left (WITRepo shr rp _ _ _) -> do mrid <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getKeyBy $ UniqueRepo rp sid @@ -337,7 +345,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge Nothing -> "Accepted new ticket, no inbox-forwarding to do" Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer" where - targetRelevance (Left (WTTProject shr prj)) + targetRelevance (Left (WITProject shr prj)) | shr == shrRecip && prj == prjRecip = Just () targetRelevance _ = Nothing insertAccept shr prj author luOffer ltid obiidAccept = do @@ -394,7 +402,7 @@ repoOfferTicketF -> ExceptT Text Handler Text repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = do (target, summary, content, source) <- checkOfferTicket author ticket uTarget - mmhttp <- for (targetRelevance target) $ \ (mb, vcs, diff) -> runDBExcept $ do + mmhttp <- for (targetRelevance target) $ \ (mb, vcs, diffs) -> runDBExcept $ do Entity rid r <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip getBy404 $ UniqueRepo rpRecip sid @@ -418,7 +426,8 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now let makeTRL tclid = TicketRepoLocal tclid rid mb (tid, ltid) <- insertLocalTicket now author makeTRL summary content source ractid obiidAccept - insert_ $ Patch tid now diff + bnid <- insert $ Bundle tid + insertMany_ $ NE.toList $ NE.map (Patch bnid now) diffs (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- insertAccept shrRecip rpRecip author luOffer ltid obiidAccept knownRemoteRecipsAccept <- @@ -447,8 +456,8 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = Nothing -> "Accepted new patch, no inbox-forwarding to do" Just _ -> "Accepted new patch and ran inbox-forwarding of the Offer" where - targetRelevance (Left (WTTRepo shr rp mb vcs diff)) - | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff) + targetRelevance (Left (WITRepo shr rp mb vcs diffs)) + | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diffs) targetRelevance _ = Nothing insertAccept shr rp author luOffer ltid obiidAccept = do encodeRouteLocal <- getEncodeRouteLocal @@ -485,29 +494,29 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = , activitySpecific = AcceptActivity Accept { acceptObject = ObjURI hAuthor luOffer , acceptResult = - Just $ encodeRouteLocal $ RepoPatchR shr rp ltkhid + Just $ encodeRouteLocal $ RepoProposalR shr rp ltkhid } } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) -data RemotePatch = RemotePatch - { rpBranch :: Maybe LocalURI - , rpType :: PatchType - , rpContent :: Text +data RemoteBundle = RemoteBundle + { rpBranch :: Maybe LocalURI + , rpType :: PatchType + , rpDiffs :: NonEmpty Text } data RemoteWorkItem = RemoteWorkItem { rwiHost :: Host , rwiTarget :: Maybe LocalURI , rwiContext :: LocalURI - , rwiPatch :: Maybe RemotePatch + , rwiBundle :: Maybe RemoteBundle } data RemoteWorkItem' = RemoteWorkItem' { rwiHost' :: Host , rwiContext' :: LocalURI - , rwiPatch' :: Maybe RemotePatch + , rwiBundle' :: Maybe RemoteBundle } data ParsedCreateTicket = ParsedCreateTicket @@ -559,7 +568,7 @@ checkCreateTicket author ticket muTarget = do checkTicket :: AP.Ticket URIMode -> ExceptT Text Handler - ( Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch) + ( Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle) , TicketLocal , UTCTime , TextHtml @@ -583,29 +592,28 @@ checkCreateTicket author ticket muTarget = do verifyNothingE muAssigned "Ticket has 'assignedTo'" when (isJust mresolved) $ throwE "Ticket is resolved" - mmr' <- traverse (uncurry checkMR) mmr + mmr' <- traverse (uncurry $ checkMR $ ticketId tlocal) mmr context' <- matchTicketAndMR (AP.ticketId tlocal) pub context mmr' return (context', tlocal, pub, summary, content, source) where checkMR - :: Host + :: LocalURI + -> Host -> MergeRequest URIMode -> ExceptT Text Handler ( Either (ShrIdent, RpIdent, Maybe Text) FedURI - , Maybe (LocalURI, LocalURI) - , Maybe UTCTime , PatchType - , Text + , NonEmpty (Maybe LocalURI, Maybe UTCTime, Text) ) - checkMR h (MergeRequest muOrigin luTarget epatch) = do + checkMR luTicket h (MergeRequest muOrigin luTarget ebundle) = do verifyNothingE muOrigin "MR with 'origin'" branch <- checkBranch h luTarget - (mlocal, mpub, typ, content) <- - case epatch of - Left _ -> throwE "MR patch specified as a URI" - Right (hPatch, patch) -> checkPatch hPatch patch - return (branch, mlocal, mpub, typ, content) + (typ, patches) <- + case ebundle of + Left _ -> throwE "MR bundle specified as a URI" + Right (hBundle, bundle) -> checkBundle hBundle bundle + return (branch, typ, patches) where checkBranch :: Host @@ -628,29 +636,48 @@ checkCreateTicket author ticket muTarget = do "MR target is a valid local route, but isn't a \ \repo or branch route" else return $ Right $ ObjURI h lu - checkPatch - :: Host - -> AP.Patch URIMode - -> ExceptT Text Handler - ( Maybe (LocalURI, LocalURI) - , Maybe UTCTime - , PatchType - , Text - ) - checkPatch h (AP.Patch mlocal attrib mpub typ content) = do - mlocal' <- - for mlocal $ - \ (h', PatchLocal luId luContext versions mcurr) -> do - unless (h == h') $ - throwE "Patch & its author on different hosts" - unless (null versions) $ - throwE "Patch has versions" - unless (isNothing mcurr) $ - throwE "Patch has 'currentVersion'" - return (luId, luContext) - unless (ObjURI h attrib == remoteAuthorURI author) $ - throwE "Ticket & Patch attrib mismatch" - return (mlocal', mpub, typ, content) + checkBundle _ (AP.BundleHosted _ _) = + throwE "Patches specified as URIs" + checkBundle h (AP.BundleOffer mblocal patches) = do + for_ mblocal $ \ (h', BundleLocal _luId luCtx prevs mcurr) -> do + unless (h == h') $ + throwE "Bundle and author hosts differ" + unless (luCtx == luTicket) $ + throwE "Bundle 'context' doesn't match Ticket 'id'" + unless (null prevs) $ + throwE "Bundle has previous versions" + unless (isNothing mcurr) $ + throwE "Bundle has a more recent version" + (mlocal, mpub, typ, diff) :| patches' <- traverse (checkPatch h) patches + patches'' <- for patches' $ \ (mlocal', mpub', typ', diff') -> do + mluId <- for mlocal' $ \ (luId', luContext') -> do + for_ mlocal $ \ (_, luContext) -> + unless (luContext == luContext') $ + throwE "Patches have different context" + return luId' + unless (typ == typ') $ throwE "Different patch types" + return (mluId, mpub', diff') + return (typ, (fst <$> mlocal, mpub, diff) :| patches'') + where + checkPatch + :: Host + -> AP.Patch URIMode + -> ExceptT Text Handler + ( Maybe (LocalURI, LocalURI) + , Maybe UTCTime + , PatchType + , Text + ) + checkPatch h (AP.Patch mlocal attrib mpub typ content) = do + mlocal' <- + for mlocal $ + \ (h', PatchLocal luId luContext) -> do + unless (h == h') $ + throwE "Patch & its author on different hosts" + return (luId, luContext) + unless (ObjURI h attrib == remoteAuthorURI author) $ + throwE "Ticket & Patch attrib mismatch" + return (mlocal', mpub, typ, content) matchTicketAndMR :: LocalURI -> UTCTime @@ -659,27 +686,18 @@ checkCreateTicket author ticket muTarget = do FedURI -> Maybe ( Either (ShrIdent, RpIdent, Maybe Text) FedURI - , Maybe (LocalURI, LocalURI) - , Maybe UTCTime , PatchType - , Text + , NonEmpty (Maybe LocalURI, Maybe UTCTime, Text) ) - -> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch)) - matchTicketAndMR _ _ (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj + -> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle)) + matchTicketAndMR _ _ (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj matchTicketAndMR _ _ (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" matchTicketAndMR _ _ (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" - matchTicketAndMR luTicket pub (Left (Right (shr, rp))) (Just (branch, mlocal, mpub, typ, content)) = do + matchTicketAndMR luTicket pub (Left (Right (shr, rp))) (Just (branch, typ, patches)) = 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" - _mluPatch <- for mlocal $ \ (luPatch, luPatchContext) -> do - unless (luPatchContext == luTicket) $ - throwE "Patch 'context' != Ticket 'id'" - return luPatch - for_ mpub $ \ pub' -> - unless (pub == pub') $ - throwE "Ticket & Patch 'published' differ" let vcs = typ2vcs typ case vcs of VCSDarcs -> @@ -688,58 +706,61 @@ checkCreateTicket author ticket muTarget = do VCSGit -> unless (isJust branch') $ throwE "Git MR doesn't specify the branch" - return $ Left $ WTTRepo shr rp branch' vcs content + diffs <- for patches $ \ (_mluId, mpub, diff) -> do + for_ mpub $ \ pub' -> + unless (pub == pub') $ + throwE "Ticket & Patch 'published' differ" + return diff + return $ Left $ WITRepo shr rp branch' vcs diffs where typ2vcs PatchTypeDarcs = VCSDarcs matchTicketAndMR _ _ (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) - matchTicketAndMR luTicket pub (Right (ObjURI h lu)) (Just (branch, mlocal, mpub, typ, content)) = do + matchTicketAndMR luTicket pub (Right (ObjURI h lu)) (Just (branch, typ, patches)) = do luBranch <- case branch of Right (ObjURI h' lu') | h == h' -> return lu _ -> throwE "MR target repo/branch and Offer target repo mismatch" - _mluPatch <- for mlocal $ \ (luPatch, luPatchContext) -> do - unless (luPatchContext == luTicket) $ - throwE "Patch 'context' != Ticket 'id'" - return luPatch - for_ mpub $ \ pub' -> - unless (pub == pub') $ - throwE "Ticket & Patch 'published' differ" - let patch = - RemotePatch + diffs <- for patches $ \ (_mluId, mpub, diff) -> do + for_ mpub $ \ pub' -> + unless (pub == pub') $ + throwE "Ticket & Patch 'published' differ" + return diff + let bundle = + RemoteBundle (if lu == luBranch then Nothing else Just luBranch) typ - content - return $ Right (h, lu, Just patch) + diffs + return $ Right (h, lu, Just bundle) checkTargetAndContext :: Maybe ( Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) FedURI ) - -> Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch) + -> Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle) -> ExceptT Text Handler (Either (Bool, WorkItemTarget) RemoteWorkItem) checkTargetAndContext Nothing context = return $ case context of Left wit -> Left (False, wit) - Right (h, luCtx, mpatch) -> Right $ RemoteWorkItem h Nothing luCtx mpatch + Right (h, luCtx, mbundle) -> Right $ RemoteWorkItem h Nothing luCtx mbundle checkTargetAndContext (Just target) context = case (target, context) of (Left _, Right _) -> throwE "Create target is local but ticket context is remote" (Right _, Left _) -> throwE "Create target is remote but ticket context is local" - (Right (ObjURI hTarget luTarget), Right (hContext, luContext, mpatch)) -> + (Right (ObjURI hTarget luTarget), Right (hContext, luContext, mbundle)) -> if hTarget == hContext - then return $ Right $ RemoteWorkItem hTarget (Just luTarget) luContext mpatch + then return $ Right $ RemoteWorkItem hTarget (Just luTarget) luContext mbundle else throwE "Create target and ticket context on \ \different remote hosts" (Left proj, Left wit) -> case (proj, wit) of - (Left (shr, prj), WTTProject shr' prj') + (Left (shr, prj), WITProject shr' prj') | shr == shr' && prj == prj' -> return $ Left (True, wit) - (Right (shr, rp), WTTRepo shr' rp' _ _ _) + (Right (shr, rp), WITRepo shr' rp' _ _ _) | shr == shr' && rp == rp' -> return $ Left (True, wit) _ -> throwE @@ -769,12 +790,12 @@ sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do Nothing -> "Activity already exists in my inbox" Just _ -> "Activity inserted to my inbox" where - checkTargetAndContextDB (Left (_, WTTProject shr prj)) = do + checkTargetAndContextDB (Left (_, WITProject shr prj)) = do mj <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getBy $ UniqueProject prj sid unless (isJust mj) $ throwE "Local context: No such project" - checkTargetAndContextDB (Left (_, WTTRepo shr rp _ _ _)) = do + checkTargetAndContextDB (Left (_, WITRepo shr rp _ _ _)) = do mr <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getBy $ UniqueRepo rp sid @@ -966,7 +987,7 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa Nothing -> "Accepted and listed ticket, no inbox-forwarding to do" Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create" where - targetRelevance (Left (_, WTTProject shr prj)) + targetRelevance (Left (_, WITProject shr prj)) | shr == shrRecip && prj == prjRecip = Just () targetRelevance _ = Nothing @@ -984,7 +1005,7 @@ repoCreateTicketF repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do ParsedCreateTicket targetAndContext tlocal published title desc src <- checkCreateTicket author ticket muTarget - mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, vcs, diff) -> runDBExcept $ do + mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, vcs, diffs) -> runDBExcept $ do Entity rid r <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip getBy404 $ UniqueRepo rpRecip sid @@ -996,7 +1017,8 @@ repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget result <- insertRemoteTicket mkTRL author (AP.ticketId tlocal) published title desc src ractid obiidAccept unless (isRight result) $ delete obiidAccept for result $ \ tid -> do - insert_ $ Patch tid published diff + bnid <- insert $ Bundle tid + insertMany_ $ NE.toList $ NE.map (Patch bnid published) diffs mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do let sieve = makeRecipientSet @@ -1041,8 +1063,8 @@ repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget Nothing -> "Accepted and listed MR, no inbox-forwarding to do" Just _ -> "Accepted and listed MR and ran inbox-forwarding of the Create" where - targetRelevance (Left (_, WTTRepo shr rp mb vcs diff)) - | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff) + targetRelevance (Left (_, WITRepo shr rp mb vcs diffs)) + | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diffs) targetRelevance _ = Nothing sharerOfferDepF @@ -1076,7 +1098,7 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do if patch then do (_, Entity ltid _, _, context, _, _) <- do - mticket <- lift $ getSharerPatch shrRecip talid + mticket <- lift $ getSharerProposal shrRecip talid fromMaybeE mticket $ "Parent" <> ": No such sharer-patch" context' <- lift $ @@ -1170,7 +1192,7 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do if patch then do (_, Entity ltid _, _, _, _, _) <- do - mticket <- lift $ getSharerPatch shrRecip talid + mticket <- lift $ getSharerProposal shrRecip talid fromMaybeE mticket $ "Child" <> ": No such sharer-patch" return ltid else do @@ -1189,7 +1211,7 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do followers hashTALID (talid, patch) = let coll = if patch - then LocalPersonCollectionSharerPatchFollowers + then LocalPersonCollectionSharerProposalFollowers else LocalPersonCollectionSharerTicketFollowers in coll shrRecip (hashTALID talid) insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, WorkItemDetail childId childCtx childAuthor) = do @@ -1247,7 +1269,7 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do return $ \ talid patch -> let coll = if patch - then LocalPersonCollectionSharerPatchFollowers + then LocalPersonCollectionSharerProposalFollowers else LocalPersonCollectionSharerTicketFollowers in coll shrRecip (hashTALID talid) @@ -1469,7 +1491,7 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do for (ticketRelevance shrRecip rpRecip parent) $ \ parentLtid -> do parentAuthor <- runSiteDBExcept $ do (_, _, _, _, _, _, author, _, _) <- do - mticket <- lift $ getRepoPatch shrRecip rpRecip parentLtid + mticket <- lift $ getRepoProposal shrRecip rpRecip parentLtid fromMaybeE mticket $ "Parent" <> ": No such repo-patch" lift $ getWorkItemAuthorDetail author childDetail <- getWorkItemDetail "Child" child @@ -1522,14 +1544,14 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do (Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do" (Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer" where - ticketRelevance shr rp (Left (WorkItemRepoPatch shr' rp' ltid)) + ticketRelevance shr rp (Left (WorkItemRepoProposal shr' rp' ltid)) | shr == shr' && rp == rp' = Just ltid ticketRelevance _ _ _ = Nothing insertDepOffer _ (Left _) _ = return () insertDepOffer ibiidOffer (Right _) child = for_ (ticketRelevance shrRecip rpRecip child) $ \ ltid -> do _ <- do - mticket <- lift $ getRepoPatch shrRecip rpRecip ltid + mticket <- lift $ getRepoProposal shrRecip rpRecip ltid fromMaybeE mticket $ "Child" <> ": No such repo-patch" lift $ insert_ TicketDependencyOffer { ticketDependencyOfferOffer = ibiidOffer @@ -1541,7 +1563,7 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do \ shr rp wi -> followers hashLTID <$> ticketRelevance shr rp wi where followers hashLTID ltid = - LocalPersonCollectionRepoPatchFollowers + LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip (hashLTID ltid) insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do encodeRouteLocal <- getEncodeRouteLocal @@ -1606,20 +1628,20 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do hashLTID <- getEncodeKeyHashid return $ \ ltid -> - LocalPersonCollectionRepoPatchFollowers + LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip (hashLTID ltid) verifyWorkItemExists (WorkItemSharerTicket shr talid False) = do mticket <- lift $ getSharerTicket shr talid verifyNothingE mticket $ "Object" <> ": No such sharer-ticket" verifyWorkItemExists (WorkItemSharerTicket shr talid True) = do - mticket <- lift $ getSharerPatch shr talid + mticket <- lift $ getSharerProposal shr talid verifyNothingE mticket $ "Object" <> ": No such sharer-patch" verifyWorkItemExists (WorkItemProjectTicket shr prj ltid) = do mticket <- lift $ getProjectTicket shr prj ltid verifyNothingE mticket $ "Object" <> ": No such project-ticket" -verifyWorkItemExists (WorkItemRepoPatch shr rp ltid) = do - mticket <- lift $ getRepoPatch shr rp ltid +verifyWorkItemExists (WorkItemRepoProposal shr rp ltid) = do + mticket <- lift $ getRepoProposal shr rp ltid verifyNothingE mticket $ "Object" <> ": No such repo-patch" insertResolve author ltid ractid obiidAccept = do @@ -1665,7 +1687,7 @@ sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do let followers = let collection = if patch - then LocalPersonCollectionSharerPatchFollowers + then LocalPersonCollectionSharerProposalFollowers else LocalPersonCollectionSharerTicketFollowers in collection shrRecip $ hashTALID talid sieve = @@ -1725,7 +1747,7 @@ sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do getObjectLtid talid True = do (_, Entity ltid _, Entity tid _, _, _, _) <- do - mticket <- lift $ getSharerPatch shrRecip talid + mticket <- lift $ getSharerProposal shrRecip talid fromMaybeE mticket $ "Object" <> ": No such sharer-patch" return (ltid, tid) getObjectLtid talid False = do @@ -1749,7 +1771,7 @@ sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do audTicket = let followers = if patch - then LocalPersonCollectionSharerPatchFollowers + then LocalPersonCollectionSharerProposalFollowers else LocalPersonCollectionSharerTicketFollowers in AudLocal [] [followers shrRecip talkhid] @@ -1932,7 +1954,7 @@ repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) = let sieve = makeRecipientSet [] - [ LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid + [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid , LocalPersonCollectionRepoTeam shrRecip rpRecip , LocalPersonCollectionRepoFollowers shrRecip rpRecip ] @@ -1981,13 +2003,13 @@ repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) = then "Ticket is mine, now resolved, did inbox-forwarding" else "Ticket is mine, now resolved, no inbox-forwarding to do" where - relevantObject (Left (WorkItemRepoPatch shr rp ltid)) + relevantObject (Left (WorkItemRepoProposal shr rp ltid)) | shr == shrRecip && rp == rpRecip = Just ltid relevantObject _ = Nothing getObjectLtid ltid = do (_, _, Entity tid _, _, _, _, _, _, _) <- do - mticket <- lift $ getRepoPatch shrRecip rpRecip ltid + mticket <- lift $ getRepoProposal shrRecip rpRecip ltid fromMaybeE mticket $ "Object" <> ": No such repo-patch" return tid @@ -2006,7 +2028,7 @@ repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) = audTicket = AudLocal [] - [ LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid + [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid , LocalPersonCollectionRepoTeam shrRecip rpRecip , LocalPersonCollectionRepoFollowers shrRecip rpRecip ] diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 813f79a..c155ea3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -72,7 +72,7 @@ import qualified Network.HTTP.Signature as S (Algorithm (..)) import Crypto.PublicVerifKey import Network.FedURI import Web.ActivityAccess -import Web.ActivityPub hiding (Ticket, TicketDependency, Patch) +import Web.ActivityPub hiding (Ticket, TicketDependency, Bundle, Patch) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -133,6 +133,7 @@ type LocalMessageKeyHashid = KeyHashid LocalMessage type LocalTicketKeyHashid = KeyHashid LocalTicket type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal type TicketDepKeyHashid = KeyHashid LocalTicketDependency +type BundleKeyHashid = KeyHashid Bundle type PatchKeyHashid = KeyHashid Patch -- This is where we define all of the routes in our application. For a full diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 32eaca2..98a119e 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -14,23 +14,25 @@ -} module Vervis.Handler.Patch - ( getSharerPatchesR - , getSharerPatchR - , getSharerPatchDiscussionR - , getSharerPatchDepsR - , getSharerPatchReverseDepsR - , getSharerPatchFollowersR - , getSharerPatchEventsR - , getSharerPatchVersionR + ( getSharerProposalsR + , getSharerProposalR + , getSharerProposalDiscussionR + , getSharerProposalDepsR + , getSharerProposalReverseDepsR + , getSharerProposalFollowersR + , getSharerProposalEventsR + , getSharerProposalBundleR + , getSharerProposalBundlePatchR - , getRepoPatchesR - , getRepoPatchR - , getRepoPatchDiscussionR - , getRepoPatchDepsR - , getRepoPatchReverseDepsR - , getRepoPatchFollowersR - , getRepoPatchEventsR - , getRepoPatchVersionR + , getRepoProposalsR + , getRepoProposalR + , getRepoProposalDiscussionR + , getRepoProposalDepsR + , getRepoProposalReverseDepsR + , getRepoProposalFollowersR + , getRepoProposalEventsR + , getRepoProposalBundleR + , getRepoProposalBundlePatchR ) where @@ -38,7 +40,7 @@ import Control.Monad import Data.Bifunctor import Data.Bitraversable import Data.Function -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Text (Text) import Data.Traversable import Database.Persist @@ -50,7 +52,7 @@ import qualified Data.List.Ordered as LO import qualified Database.Esqueleto as E import Network.FedURI -import Web.ActivityPub hiding (Ticket (..), Patch (..)) +import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -73,9 +75,9 @@ import Vervis.Paginate import Vervis.Patch import Vervis.Ticket -getSharerPatchesR :: ShrIdent -> Handler TypedContent -getSharerPatchesR = - getSharerWorkItems SharerPatchesR SharerPatchR countPatches selectPatches +getSharerProposalsR :: ShrIdent -> Handler TypedContent +getSharerProposalsR = + getSharerWorkItems SharerProposalsR SharerProposalR countPatches selectPatches where countPatches pid = fmap toOne $ E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do @@ -85,8 +87,8 @@ getSharerPatchesR = tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. E.isNothing (tup E.?. TicketUnderProjectId) E.&&. E.exists - (E.from $ \ pt -> - E.where_ $ lt E.^. LocalTicketTicket E.==. pt E.^. PatchTicket + (E.from $ \ bn -> + E.where_ $ lt E.^. LocalTicketTicket E.==. bn E.^. BundleTicket ) return $ E.count $ tal E.^. TicketAuthorLocalId where @@ -101,20 +103,20 @@ getSharerPatchesR = tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. E.isNothing (tup E.?. TicketUnderProjectId) E.&&. E.exists - (E.from $ \ pt -> - E.where_ $ lt E.^. LocalTicketTicket E.==. pt E.^. PatchTicket + (E.from $ \ bn -> + E.where_ $ lt E.^. LocalTicketTicket E.==. bn E.^. BundleTicket ) E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId] E.offset $ fromIntegral off E.limit $ fromIntegral lim return $ tal E.^. TicketAuthorLocalId -getSharerPatchR +getSharerProposalR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchR shr talkhid = do - (ticket, ptid, repo, massignee) <- runDB $ do - (_, _, Entity tid t, tp, _, ptid :| _) <- getSharerPatch404 shr talkhid - (,,,) t ptid +getSharerProposalR shr talkhid = do + (ticket, bnid, repo, massignee) <- runDB $ do + (_, _, Entity tid t, tp, _, bnid :| _) <- getSharerProposal404 shr talkhid + (,,,) t bnid <$> bitraverse (\ (_, Entity _ trl) -> do r <- getJust $ ticketRepoLocalRepo trl @@ -140,24 +142,24 @@ getSharerPatchR shr talkhid = do hLocal <- getsYesod siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - encodePatchId <- getEncodeKeyHashid - let patchAP = AP.Ticket + encodeBundleId <- getEncodeKeyHashid + let ticketAP = AP.Ticket { AP.ticketLocal = Just ( hLocal , AP.TicketLocal { AP.ticketId = - encodeRouteLocal $ SharerPatchR shr talkhid + encodeRouteLocal $ SharerProposalR shr talkhid , AP.ticketReplies = - encodeRouteLocal $ SharerPatchDiscussionR shr talkhid + encodeRouteLocal $ SharerProposalDiscussionR shr talkhid , AP.ticketParticipants = - encodeRouteLocal $ SharerPatchFollowersR shr talkhid + encodeRouteLocal $ SharerProposalFollowersR shr talkhid , AP.ticketTeam = Nothing , AP.ticketEvents = - encodeRouteLocal $ SharerPatchEventsR shr talkhid + encodeRouteLocal $ SharerProposalEventsR shr talkhid , AP.ticketDeps = - encodeRouteLocal $ SharerPatchDepsR shr talkhid + encodeRouteLocal $ SharerProposalDepsR shr talkhid , AP.ticketReverseDeps = - encodeRouteLocal $ SharerPatchReverseDepsR shr talkhid + encodeRouteLocal $ SharerProposalReverseDepsR shr talkhid } ) , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr @@ -196,95 +198,143 @@ getSharerPatchR shr talkhid = do RepoBranchR (sharerIdent s) (repoIdent r) b Right (_, ro) -> remoteObjectIdent ro - , mrPatch = + , mrBundle = Left $ encodeRouteHome $ - SharerPatchVersionR shr talkhid $ - encodePatchId ptid + SharerProposalBundleR shr talkhid $ + encodeBundleId bnid } ) } - provideHtmlAndAP patchAP $ redirectToPrettyJSON here + provideHtmlAndAP ticketAP $ redirectToPrettyJSON here where - here = SharerPatchR shr talkhid + here = SharerProposalR shr talkhid -getSharerPatchDiscussionR +getSharerProposalDiscussionR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchDiscussionR shr talkhid = - getRepliesCollection (SharerPatchDiscussionR shr talkhid) $ do - (_, Entity _ lt, _, _, _, _) <- getSharerPatch404 shr talkhid +getSharerProposalDiscussionR shr talkhid = + getRepliesCollection (SharerProposalDiscussionR shr talkhid) $ do + (_, Entity _ lt, _, _, _, _) <- getSharerProposal404 shr talkhid return $ localTicketDiscuss lt -getSharerPatchDepsR +getSharerProposalDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchDepsR shr talkhid = +getSharerProposalDepsR shr talkhid = getDependencyCollection here getTicket404 where - here = SharerPatchDepsR shr talkhid + here = SharerProposalDepsR shr talkhid getTicket404 = do - (_, Entity ltid _, _, _, _, _) <- getSharerPatch404 shr talkhid + (_, Entity ltid _, _, _, _, _) <- getSharerProposal404 shr talkhid return ltid -getSharerPatchReverseDepsR +getSharerProposalReverseDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchReverseDepsR shr talkhid = +getSharerProposalReverseDepsR shr talkhid = getReverseDependencyCollection here getTicket404 where - here = SharerPatchDepsR shr talkhid + here = SharerProposalDepsR shr talkhid getTicket404 = do - (_, Entity ltid _, _, _, _, _) <- getSharerPatch404 shr talkhid + (_, Entity ltid _, _, _, _, _) <- getSharerProposal404 shr talkhid return ltid -getSharerPatchFollowersR +getSharerProposalFollowersR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchFollowersR shr talkhid = getFollowersCollection here getFsid +getSharerProposalFollowersR shr talkhid = getFollowersCollection here getFsid where - here = SharerPatchFollowersR shr talkhid + here = SharerProposalFollowersR shr talkhid getFsid = do - (_, Entity _ lt, _, _, _, _) <- getSharerPatch404 shr talkhid + (_, Entity _ lt, _, _, _, _) <- getSharerProposal404 shr talkhid return $ localTicketFollowers lt -getSharerPatchEventsR +getSharerProposalEventsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchEventsR shr talkhid = do - _ <- runDB $ getSharerPatch404 shr talkhid +getSharerProposalEventsR shr talkhid = do + _ <- runDB $ getSharerProposal404 shr talkhid provideEmptyCollection CollectionTypeOrdered - (SharerPatchEventsR shr talkhid) + (SharerProposalEventsR shr talkhid) -getSharerPatchVersionR +getSharerProposalBundleR :: ShrIdent -> KeyHashid TicketAuthorLocal + -> KeyHashid Bundle + -> Handler TypedContent +getSharerProposalBundleR shr talkhid bnkhid = do + (ptids, prevs, mcurr) <- runDB $ do + (_, _, Entity tid _, _, _, v :| vs) <- getSharerProposal404 shr talkhid + bnid <- decodeKeyHashid404 bnkhid + bn <- get404 bnid + unless (bundleTicket bn == tid) notFound + ptids <- selectKeysList [PatchBundle ==. bnid] [Desc PatchId] + ptidsNE <- + case nonEmpty ptids of + Nothing -> error "Bundle without any Patches in DB" + Just ne -> return ne + let (prevs, mcurr) = + if bnid == v + then (vs, Nothing) + else ([], Just v) + return (ptidsNE, prevs, mcurr) + + encodeRouteLocal <- getEncodeRouteLocal + encodeBNID <- getEncodeKeyHashid + encodePTID <- getEncodeKeyHashid + + let versionRoute = SharerProposalBundleR shr talkhid . encodeBNID + local = BundleLocal + { bundleId = encodeRouteLocal here + , bundleContext = + encodeRouteLocal $ SharerProposalR shr talkhid + , bundlePrevVersions = + map (encodeRouteLocal . versionRoute) prevs + , bundleCurrentVersion = encodeRouteLocal . versionRoute <$> mcurr + } + bundleAP = + AP.BundleHosted + (Just local) + (NE.map + ( encodeRouteLocal + . SharerProposalBundlePatchR shr talkhid bnkhid + . encodePTID + ) + ptids + ) + provideHtmlAndAP bundleAP $ redirectToPrettyJSON here + where + here = SharerProposalBundleR shr talkhid bnkhid + +getSharerProposalBundlePatchR + :: ShrIdent + -> KeyHashid TicketAuthorLocal + -> KeyHashid Bundle -> KeyHashid Patch -> Handler TypedContent -getSharerPatchVersionR shr talkhid ptkhid = do - (vcs, patch, (versions, mcurr)) <- runDB $ do - (_, _, Entity tid _, repo, _, v :| vs) <- getSharerPatch404 shr talkhid +getSharerProposalBundlePatchR shr talkhid bnkhid ptkhid = do + (vcs, patch) <- runDB $ do + (_, _, _, repo, _, vers) <- getSharerProposal404 shr talkhid + bnid <- decodeKeyHashid404 bnkhid + unless (bnid `elem` vers) notFound ptid <- decodeKeyHashid404 ptkhid - (,,) <$> case repo of - Left (_, Entity _ trl) -> - repoVcs <$> getJust (ticketRepoLocalRepo trl) - Right _ -> - error "TODO determine mediaType of patch of remote repo" - <*> do pt <- get404 ptid - unless (patchTicket pt == tid) notFound - return pt - <*> pure (if ptid == v then (vs, Nothing) else ([], Just v)) + pt <- get404 ptid + unless (patchBundle pt == bnid) notFound + vcs <- + case repo of + Left (_, Entity _ trl) -> + repoVcs <$> getJust (ticketRepoLocalRepo trl) + Right _ -> + error "TODO determine mediaType of patch of remote repo" + return (vcs, pt) + encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodePatchId <- getEncodeKeyHashid hLocal <- getsYesod siteInstanceHost - let versionUrl = SharerPatchVersionR shr talkhid . encodePatchId - versionAP = AP.Patch + + let patchAP = AP.Patch { AP.patchLocal = Just ( hLocal , AP.PatchLocal { AP.patchId = encodeRouteLocal here , AP.patchContext = - encodeRouteLocal $ SharerPatchR shr talkhid - , AP.patchPrevVersions = - map (encodeRouteLocal . versionUrl) versions - , AP.patchCurrentVersion = - encodeRouteLocal . versionUrl <$> mcurr + encodeRouteLocal $ + SharerProposalBundleR shr talkhid bnkhid } ) , AP.patchAttributedTo = encodeRouteLocal $ SharerR shr @@ -295,12 +345,12 @@ getSharerPatchVersionR shr talkhid ptkhid = do VCSGit -> error "TODO add PatchType for git patches" , AP.patchContent = patchContent patch } - provideHtmlAndAP versionAP $ redirectToPrettyJSON here + provideHtmlAndAP patchAP $ redirectToPrettyJSON here where - here = SharerPatchVersionR shr talkhid ptkhid + here = SharerProposalBundlePatchR shr talkhid bnkhid ptkhid -getRepoPatchesR :: ShrIdent -> RpIdent -> Handler TypedContent -getRepoPatchesR shr rp = do +getRepoProposalsR :: ShrIdent -> RpIdent -> Handler TypedContent +getRepoProposalsR shr rp = do (total, pages, mpage) <- runDB $ do sid <- getKeyBy404 $ UniqueSharer shr rid <- getKeyBy404 $ UniqueRepo rp sid @@ -309,16 +359,16 @@ getRepoPatchesR shr rp = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal encodeRoutePageLocal <- getEncodeRoutePageLocal - let here = RepoPatchesR shr rp + let here = RepoProposalsR shr rp pageUrl = encodeRoutePageLocal here encodeLT <- getEncodeKeyHashid encodeTAL <- getEncodeKeyHashid let patchUrl (Left (E.Value ltid, E.Value mtalid, E.Value mshr, E.Value mtupid)) = encodeRouteHome $ case (mtalid, mshr, mtupid) of - (Nothing, Nothing, Nothing) -> RepoPatchR shr rp $ encodeLT ltid - (Just talid, Just shrA, Nothing) -> SharerPatchR shrA $ encodeTAL talid - (Just _, Just _, Just _) -> RepoPatchR shr rp $ encodeLT ltid + (Nothing, Nothing, Nothing) -> RepoProposalR shr rp $ encodeLT ltid + (Just talid, Just shrA, Nothing) -> SharerProposalR shrA $ encodeTAL talid + (Just _, Just _, Just _) -> RepoProposalR shr rp $ encodeLT ltid _ -> error "Impossible" patchUrl (Right (E.Value h, E.Value lu)) = ObjURI h lu @@ -401,12 +451,12 @@ getRepoPatchesR shr rp = do (map (second Left) locals) (map (second Right) remotes) -getRepoPatchR +getRepoProposalR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchR shr rp ltkhid = do - (ticket, ptid, trl, author, massignee, mresolved) <- runDB $ do - (_, _, Entity tid t, _, _, Entity _ trl, ta, tr, ptid :| _) <- getRepoPatch404 shr rp ltkhid - (,,,,,) t ptid trl +getRepoProposalR shr rp ltkhid = do + (ticket, bnid, trl, author, massignee, mresolved) <- runDB $ do + (_, _, Entity tid t, _, _, Entity _ trl, ta, tr, bnid :| _) <- getRepoProposal404 shr rp ltkhid + (,,,,,) t bnid trl <$> bitraverse (\ (Entity _ tal, _) -> do p <- getJust $ ticketAuthorLocalAuthor tal @@ -445,29 +495,29 @@ getRepoPatchR shr rp ltkhid = do hLocal <- getsYesod siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - encodePatchId <- getEncodeKeyHashid + encodeBundleId <- getEncodeKeyHashid encodeObiid <- getEncodeKeyHashid let host = case author of Left _ -> hLocal Right (i, _) -> instanceHost i - patchAP = AP.Ticket + ticketAP = AP.Ticket { AP.ticketLocal = Just ( hLocal , AP.TicketLocal { AP.ticketId = - encodeRouteLocal $ RepoPatchR shr rp ltkhid + encodeRouteLocal $ RepoProposalR shr rp ltkhid , AP.ticketReplies = - encodeRouteLocal $ RepoPatchDiscussionR shr rp ltkhid + encodeRouteLocal $ RepoProposalDiscussionR shr rp ltkhid , AP.ticketParticipants = - encodeRouteLocal $ RepoPatchFollowersR shr rp ltkhid + encodeRouteLocal $ RepoProposalFollowersR shr rp ltkhid , AP.ticketTeam = Nothing , AP.ticketEvents = - encodeRouteLocal $ RepoPatchEventsR shr rp ltkhid + encodeRouteLocal $ RepoProposalEventsR shr rp ltkhid , AP.ticketDeps = - encodeRouteLocal $ RepoPatchDepsR shr rp ltkhid + encodeRouteLocal $ RepoProposalDepsR shr rp ltkhid , AP.ticketReverseDeps = - encodeRouteLocal $ RepoPatchReverseDepsR shr rp ltkhid + encodeRouteLocal $ RepoProposalReverseDepsR shr rp ltkhid } ) , AP.ticketAttributedTo = @@ -500,74 +550,128 @@ getRepoPatchR shr rp ltkhid = do case ticketRepoLocalBranch trl of Nothing -> RepoR shr rp Just b -> RepoBranchR shr rp b - , mrPatch = + , mrBundle = Left $ encodeRouteHome $ - RepoPatchVersionR shr rp ltkhid $ - encodePatchId ptid + RepoProposalBundleR shr rp ltkhid $ + encodeBundleId bnid } ) } - provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here + provideHtmlAndAP' host ticketAP $ redirectToPrettyJSON here where - here = RepoPatchR shr rp ltkhid + here = RepoProposalR shr rp ltkhid -getRepoPatchDiscussionR +getRepoProposalDiscussionR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchDiscussionR shr rp ltkhid = - getRepliesCollection (RepoPatchDiscussionR shr rp ltkhid) $ do - (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid +getRepoProposalDiscussionR shr rp ltkhid = + getRepliesCollection (RepoProposalDiscussionR shr rp ltkhid) $ do + (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid return $ localTicketDiscuss lt -getRepoPatchDepsR +getRepoProposalDepsR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchDepsR shr rp ltkhid = +getRepoProposalDepsR shr rp ltkhid = getDependencyCollection here getTicketId404 where - here = RepoPatchDepsR shr rp ltkhid + here = RepoProposalDepsR shr rp ltkhid getTicketId404 = do - (_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid + (_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid return ltid -getRepoPatchReverseDepsR +getRepoProposalReverseDepsR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchReverseDepsR shr rp ltkhid = +getRepoProposalReverseDepsR shr rp ltkhid = getReverseDependencyCollection here getTicketId404 where - here = RepoPatchReverseDepsR shr rp ltkhid + here = RepoProposalReverseDepsR shr rp ltkhid getTicketId404 = do - (_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid + (_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid return ltid -getRepoPatchFollowersR +getRepoProposalFollowersR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchFollowersR shr rp ltkhid = getFollowersCollection here getFsid +getRepoProposalFollowersR shr rp ltkhid = getFollowersCollection here getFsid where - here = RepoPatchFollowersR shr rp ltkhid + here = RepoProposalFollowersR shr rp ltkhid getFsid = do - (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid + (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid return $ localTicketFollowers lt -getRepoPatchEventsR +getRepoProposalEventsR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchEventsR shr rp ltkhid = do - _ <- runDB $ getRepoPatch404 shr rp ltkhid +getRepoProposalEventsR shr rp ltkhid = do + _ <- runDB $ getRepoProposal404 shr rp ltkhid provideEmptyCollection CollectionTypeOrdered - (RepoPatchEventsR shr rp ltkhid) + (RepoProposalEventsR shr rp ltkhid) -getRepoPatchVersionR +getRepoProposalBundleR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket + -> KeyHashid Bundle + -> Handler TypedContent +getRepoProposalBundleR shr rp ltkhid bnkhid = do + (ptids, prevs, mcurr) <- runDB $ do + (_, _, Entity tid _, _, _, _, _, _, v :| vs) <- getRepoProposal404 shr rp ltkhid + bnid <- decodeKeyHashid404 bnkhid + bn <- get404 bnid + unless (bundleTicket bn == tid) notFound + ptids <- selectKeysList [PatchBundle ==. bnid] [Desc PatchId] + ptidsNE <- + case nonEmpty ptids of + Nothing -> error "Bundle without any Patches in DB" + Just ne -> return ne + let (prevs, mcurr) = + if bnid == v + then (vs, Nothing) + else ([], Just v) + return (ptidsNE, prevs, mcurr) + + encodeRouteLocal <- getEncodeRouteLocal + encodeBNID <- getEncodeKeyHashid + encodePTID <- getEncodeKeyHashid + + let versionRoute = RepoProposalBundleR shr rp ltkhid . encodeBNID + local = BundleLocal + { bundleId = encodeRouteLocal here + , bundleContext = + encodeRouteLocal $ RepoProposalR shr rp ltkhid + , bundlePrevVersions = + map (encodeRouteLocal . versionRoute) prevs + , bundleCurrentVersion = encodeRouteLocal . versionRoute <$> mcurr + } + bundleAP = + AP.BundleHosted + (Just local) + (NE.map + ( encodeRouteLocal + . RepoProposalBundlePatchR shr rp ltkhid bnkhid + . encodePTID + ) + ptids + ) + provideHtmlAndAP bundleAP $ redirectToPrettyJSON here + where + here = RepoProposalBundleR shr rp ltkhid bnkhid + +getRepoProposalBundlePatchR + :: ShrIdent + -> RpIdent + -> KeyHashid LocalTicket + -> KeyHashid Bundle -> KeyHashid Patch -> Handler TypedContent -getRepoPatchVersionR shr rp ltkhid ptkhid = do - (vcs, patch, author, (versions, mcurr)) <- runDB $ do - (_, Entity _ repo, Entity tid _, _, _, _, ta, _, v :| vs) <- getRepoPatch404 shr rp ltkhid - ptid <- decodeKeyHashid404 ptkhid - (repoVcs repo,,,) - <$> do pt <- get404 ptid - unless (patchTicket pt == tid) notFound +getRepoProposalBundlePatchR shr rp ltkhid bnkhid ptkhid = do + (vcs, patch, author) <- runDB $ do + (_, Entity _ repo, _, _, _, _, ta, _, vers) <- getRepoProposal404 shr rp ltkhid + (,,) + <$> pure (repoVcs repo) + <*> do bnid <- decodeKeyHashid404 bnkhid + unless (bnid `elem` vers) notFound + ptid <- decodeKeyHashid404 ptkhid + pt <- get404 ptid + unless (patchBundle pt == bnid) notFound return pt <*> bitraverse (\ (Entity _ tal, _) -> do @@ -581,27 +685,22 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do return (i, ro) ) ta - <*> pure (if ptid == v then (vs, Nothing) else ([], Just v)) + encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodePatchId <- getEncodeKeyHashid hLocal <- getsYesod siteInstanceHost - let versionUrl = RepoPatchVersionR shr rp ltkhid . encodePatchId - host = + + let host = case author of Left _ -> hLocal Right (i, _) -> instanceHost i - versionAP = AP.Patch - { AP.patchLocal = Just + patchAP = AP.Patch + { AP.patchLocal = Just ( hLocal , AP.PatchLocal - { AP.patchId = encodeRouteLocal here - , AP.patchContext = - encodeRouteLocal $ RepoPatchR shr rp ltkhid - , AP.patchPrevVersions = - map (encodeRouteLocal . versionUrl) versions - , AP.patchCurrentVersion = - encodeRouteLocal . versionUrl <$> mcurr + { AP.patchId = encodeRouteLocal here + , AP.patchContext = + encodeRouteLocal $ + RepoProposalBundleR shr rp ltkhid bnkhid } ) , AP.patchAttributedTo = @@ -616,6 +715,6 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do VCSGit -> error "TODO add PatchType for git patches" , AP.patchContent = patchContent patch } - provideHtmlAndAP' host versionAP $ redirectToPrettyJSON here + provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here where - here = RepoPatchVersionR shr rp ltkhid ptkhid + here = RepoProposalBundlePatchR shr rp ltkhid bnkhid ptkhid diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 16cc293..744db7b 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -1043,28 +1043,28 @@ getSharerTicketsR = getSharerWorkItems SharerTicketsR SharerTicketR countTickets selectTickets where countTickets pid = fmap toOne $ - E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` pt) -> do - E.on $ E.just (lt E.^. LocalTicketTicket) E.==. pt E.?. PatchTicket + E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` bn) -> do + E.on $ E.just (lt E.^. LocalTicketTicket) E.==. bn E.?. BundleTicket E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId E.where_ $ tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. E.isNothing (tup E.?. TicketUnderProjectId) E.&&. - E.isNothing (pt E.?. PatchId) + E.isNothing (bn E.?. BundleId) return $ E.count $ tal E.^. TicketAuthorLocalId where toOne [x] = E.unValue x toOne [] = error "toOne = 0" toOne _ = error "toOne > 1" selectTickets pid off lim = - E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` pt) -> do - E.on $ E.just (lt E.^. LocalTicketTicket) E.==. pt E.?. PatchTicket + E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` bn) -> do + E.on $ E.just (lt E.^. LocalTicketTicket) E.==. bn E.?. BundleTicket E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId E.where_ $ tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. E.isNothing (tup E.?. TicketUnderProjectId) E.&&. - E.isNothing (pt E.?. PatchId) + E.isNothing (bn E.?. BundleId) E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId] E.offset $ fromIntegral off E.limit $ fromIntegral lim diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 15b088d..ba4942b 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1752,6 +1752,27 @@ changes hLocal ctx = , removeField "Ticket" "closed" -- 278 , removeField "Ticket" "closer" + -- 279 + , addEntities model_2020_08_10 + -- 280 + , addFieldRefRequired'' + "Patch" + (do tid <- insert $ Ticket280 Nothing defaultTime "" "" "" Nothing "TSNew" + insertEntity $ Bundle280 tid + ) + (Just $ \ (Entity bnidTemp bnTemp) -> do + pts <- selectList ([] :: [Filter Patch280]) [] + for_ pts $ \ (Entity ptid pt) -> do + bnid <- insert $ Bundle280 $ patch280Ticket pt + update ptid [Patch280Bundle =. bnid] + + delete bnidTemp + delete $ bundle280Ticket bnTemp + ) + "bundle" + "Bundle" + -- 281 + , removeField "Patch" "ticket" ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 6596d88..9a4962e 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -238,6 +238,11 @@ module Vervis.Migration.Model , OutboxItem276Generic (..) , TicketProjectLocal276Generic (..) , Project276Generic (..) + , model_2020_08_10 + , Ticket280Generic (..) + , Bundle280Generic (..) + , Patch280 + , Patch280Generic (..) ) where @@ -465,3 +470,9 @@ model_2020_07_27 = $(schema "2020_07_27_ticket_resolve") makeEntitiesMigration "276" $(modelFile "migrations/2020_07_27_ticket_resolve_mig.model") + +model_2020_08_10 :: [Entity SqlBackend] +model_2020_08_10 = $(schema "2020_08_10_bundle") + +makeEntitiesMigration "280" + $(modelFile "migrations/2020_08_10_bundle_mig.model") diff --git a/src/Vervis/Patch.hs b/src/Vervis/Patch.hs index a6ef98b..2b913c3 100644 --- a/src/Vervis/Patch.hs +++ b/src/Vervis/Patch.hs @@ -14,10 +14,10 @@ -} module Vervis.Patch - ( getSharerPatch - , getSharerPatch404 - , getRepoPatch - , getRepoPatch404 + ( getSharerProposal + , getSharerProposal404 + , getRepoProposal + , getRepoProposal404 ) where @@ -61,7 +61,7 @@ getResolved ltid = do "No TRX" "Both TRL and TRR" -getSharerPatch +getSharerProposal :: MonadIO m => ShrIdent -> TicketAuthorLocalId @@ -83,10 +83,10 @@ getSharerPatch (Entity TicketResolveLocal) (Entity TicketResolveRemote) ) - , NonEmpty PatchId + , NonEmpty BundleId ) ) -getSharerPatch shr talid = runMaybeT $ do +getSharerProposal shr talid = runMaybeT $ do pid <- do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getKeyBy $ UniquePersonIdent sid @@ -96,9 +96,9 @@ getSharerPatch shr talid = runMaybeT $ do lt <- lift $ getJust ltid let tid = localTicketTicket lt t <- lift $ getJust tid - ptids <- + bnids <- MaybeT $ - nonEmpty <$> selectKeysList [PatchTicket ==. tid] [Desc PatchId] + nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId] repo <- requireEitherAlt (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid @@ -118,9 +118,9 @@ getSharerPatch shr talid = runMaybeT $ do "MR doesn't have context" "MR has both local and remote context" mresolved <- lift $ getResolved ltid - return (Entity talid tal, Entity ltid lt, Entity tid t, repo, mresolved, ptids) + return (Entity talid tal, Entity ltid lt, Entity tid t, repo, mresolved, bnids) -getSharerPatch404 +getSharerProposal404 :: ShrIdent -> KeyHashid TicketAuthorLocal -> AppDB @@ -140,16 +140,16 @@ getSharerPatch404 (Entity TicketResolveLocal) (Entity TicketResolveRemote) ) - , NonEmpty PatchId + , NonEmpty BundleId ) -getSharerPatch404 shr talkhid = do +getSharerProposal404 shr talkhid = do talid <- decodeKeyHashid404 talkhid - mpatch <- getSharerPatch shr talid + mpatch <- getSharerProposal shr talid case mpatch of Nothing -> notFound Just patch -> return patch -getRepoPatch +getRepoProposal :: MonadIO m => ShrIdent -> RpIdent @@ -171,10 +171,10 @@ getRepoPatch (Entity TicketResolveLocal) (Entity TicketResolveRemote) ) - , NonEmpty PatchId + , NonEmpty BundleId ) ) -getRepoPatch shr rp ltid = runMaybeT $ do +getRepoProposal shr rp ltid = runMaybeT $ do es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr er@(Entity rid _) <- MaybeT $ getBy $ UniqueRepo rp sid lt <- MaybeT $ get ltid @@ -183,9 +183,9 @@ getRepoPatch shr rp ltid = runMaybeT $ do etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid etrl@(Entity _ trl) <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid guard $ ticketRepoLocalRepo trl == rid - ptids <- + bnids <- MaybeT $ - nonEmpty <$> selectKeysList [PatchTicket ==. tid] [Desc PatchId] + nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId] author <- requireEitherAlt (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid @@ -200,9 +200,9 @@ getRepoPatch shr rp ltid = runMaybeT $ do "MR doesn't have author" "MR has both local and remote author" mresolved <- lift $ getResolved ltid - return (es, er, Entity tid t, Entity ltid lt, etcl, etrl, author, mresolved, ptids) + return (es, er, Entity tid t, Entity ltid lt, etcl, etrl, author, mresolved, bnids) -getRepoPatch404 +getRepoProposal404 :: ShrIdent -> RpIdent -> KeyHashid LocalTicket @@ -222,11 +222,11 @@ getRepoPatch404 (Entity TicketResolveLocal) (Entity TicketResolveRemote) ) - , NonEmpty PatchId + , NonEmpty BundleId ) -getRepoPatch404 shr rp ltkhid = do +getRepoProposal404 shr rp ltkhid = do ltid <- decodeKeyHashid404 ltkhid - mpatch <- getRepoPatch shr rp ltid + mpatch <- getRepoProposal shr rp ltid case mpatch of Nothing -> notFound Just patch -> return patch diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index 8916f42..feed587 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -54,7 +54,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Either import Data.Foldable (for_) -import Data.Maybe (isJust) +import Data.Maybe import Data.Text (Text) import Data.Traversable import Database.Persist @@ -496,8 +496,8 @@ getSharerTicket shr talid = runMaybeT $ do lt <- lift $ getJust ltid let tid = localTicketTicket lt t <- lift $ getJust tid - npatches <- lift $ count [PatchTicket ==. tid] - guard $ npatches <= 0 + mbn <- lift $ selectFirst [BundleTicket ==. tid] [] + guard $ isNothing mbn project <- requireEitherAlt (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid @@ -599,8 +599,8 @@ getProjectTicket shr prj ltid = runMaybeT $ do etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid guard $ ticketProjectLocalProject tpl == jid - npatches <- lift $ count [PatchTicket ==. tid] - guard $ npatches <= 0 + mbn <- lift $ selectFirst [BundleTicket ==. tid] [] + guard $ isNothing mbn author <- requireEitherAlt (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid @@ -760,7 +760,7 @@ getReverseDependencyCollection here getLocalTicketId404 = do data WorkItem = WorkItemSharerTicket ShrIdent TicketAuthorLocalId Bool | WorkItemProjectTicket ShrIdent PrjIdent LocalTicketId - | WorkItemRepoPatch ShrIdent RpIdent LocalTicketId + | WorkItemRepoProposal ShrIdent RpIdent LocalTicketId deriving Eq getWorkItemRoute @@ -773,9 +773,9 @@ askWorkItemRoute = do hashTALID <- getEncodeKeyHashid hashLTID <- getEncodeKeyHashid let route (WorkItemSharerTicket shr talid False) = SharerTicketR shr (hashTALID talid) - route (WorkItemSharerTicket shr talid True) = SharerPatchR shr (hashTALID talid) + route (WorkItemSharerTicket shr talid True) = SharerProposalR shr (hashTALID talid) route (WorkItemProjectTicket shr prj ltid) = ProjectTicketR shr prj (hashLTID ltid) - route (WorkItemRepoPatch shr rp ltid) = RepoPatchR shr rp (hashLTID ltid) + route (WorkItemRepoProposal shr rp ltid) = RepoProposalR shr rp (hashLTID ltid) return route getWorkItem :: MonadIO m => LocalTicketId -> ReaderT SqlBackend m WorkItem @@ -790,20 +790,20 @@ getWorkItem ltid = (either error return =<<) $ runExceptT $ do Just (Entity talid _) -> lift $ do metcr <- getBy (UniqueTicketProjectRemote talid) for metcr $ \ etcr -> - (etcr,) . (> 0) <$> count [PatchTicket ==. tid] + (etcr,) . (> 0) <$> count [BundleTicket ==. tid] mlocalContext <- do metcl <- lift $ getBy $ UniqueTicketContextLocal tid for metcl $ \ etcl@(Entity tclid _) -> do - npatches <- lift $ count [PatchTicket ==. tid] + mbn <- lift $ selectFirst [BundleTicket ==. tid] [] metpl <- lift $ getBy $ UniqueTicketProjectLocal tclid metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid case (metpl, metrl) of (Nothing, Nothing) -> throwE "TCL but no TPL and no TRL" (Just etpl, Nothing) -> do - when (npatches > 0) $ throwE "TPL but patches attached" + when (isJust mbn) $ throwE "TPL but patches attached" return (etcl, Left etpl) (Nothing, Just etrl) -> do - when (npatches < 1) $ throwE "TRL but no patches attached" + when (isNothing mbn) $ throwE "TRL but no patches attached" return (etcl, Right etrl) (Just _, Just _) -> throwE "Both TPL and TRL" metar <- @@ -858,7 +858,7 @@ getWorkItem ltid = (either error return =<<) $ runExceptT $ do contextHosted (Right (Entity _ trl)) = do r <- getJust $ ticketRepoLocalRepo trl s <- getJust $ repoSharer r - return $ WorkItemRepoPatch (sharerIdent s) (repoIdent r) ltid + return $ WorkItemRepoProposal (sharerIdent s) (repoIdent r) ltid authorHosted (Entity talid tal) patch = do p <- getJust $ ticketAuthorLocalAuthor tal s <- getJust $ personIdent p @@ -875,15 +875,15 @@ parseWorkItem name u@(ObjURI h lu) = do SharerTicketR shr talkhid -> do talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid" return $ WorkItemSharerTicket shr talid False - SharerPatchR shr talkhid -> do + SharerProposalR shr talkhid -> do talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid" return $ WorkItemSharerTicket shr talid True ProjectTicketR shr prj ltkhid -> do ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid" return $ WorkItemProjectTicket shr prj ltid - RepoPatchR shr rp ltkhid -> do + RepoProposalR shr rp ltkhid -> do ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid" - return $ WorkItemRepoPatch shr rp ltid + return $ WorkItemRepoProposal shr rp ltid _ -> throwE $ name <> ": not a work item route" else return $ Right u @@ -923,7 +923,7 @@ checkDepAndTarget where workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj - workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp + workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target" checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent" checkParentAndTarget (Right _) (Right _) = return () diff --git a/src/Vervis/WorkItem.hs b/src/Vervis/WorkItem.hs index 9efdc77..40a6a7e 100644 --- a/src/Vervis/WorkItem.hs +++ b/src/Vervis/WorkItem.hs @@ -28,22 +28,15 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except --- import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Bifunctor import Data.Bitraversable --- import Data.Either --- import Data.Foldable (for_) +import Data.List.NonEmpty (NonEmpty) import Data.Maybe import Data.Text (Text) --- import Data.Traversable import Database.Persist import Database.Persist.Sql --- import Yesod.Core (notFound) --- import Yesod.Core.Content --- import Yesod.Persist.Core --- import qualified Database.Esqueleto as E import qualified Data.Text as T import Network.FedURI @@ -56,10 +49,6 @@ import Yesod.MonadSite import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local --- import Data.Either.Local --- import Data.Paginate.Local --- import Database.Persist.Local --- import Yesod.Persist.Local import Vervis.ActivityPub.Recipient import Vervis.FedURI @@ -67,11 +56,8 @@ import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo --- import Vervis.Model.Workflow --- import Vervis.Paginate import Vervis.Patch import Vervis.Ticket --- import Vervis.Widget.Ticket (TicketSummary (..)) data WorkItemDetail = WorkItemDetail { widIdent :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI) @@ -105,9 +91,9 @@ askWorkItemFollowers = do hashTALID <- getEncodeKeyHashid hashLTID <- getEncodeKeyHashid let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid - workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid + workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerProposalFollowers shr $ hashTALID talid workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid - workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid + workItemFollowers (WorkItemRepoProposal shr rp ltid) = LocalPersonCollectionRepoProposalFollowers shr rp $ hashLTID ltid return workItemFollowers contextAudience @@ -198,7 +184,7 @@ getWorkItemDetail name v = do return (ltid, context', Left shr) getWorkItem name (WorkItemSharerTicket shr talid True) = do (_, Entity ltid _, _, context, _, _) <- do - mticket <- lift $ getSharerPatch shr talid + mticket <- lift $ getSharerProposal shr talid fromMaybeE mticket $ name <> ": No such sharer-patch" context' <- lift $ @@ -227,8 +213,8 @@ getWorkItemDetail name v = do fromMaybeE mticket $ name <> ": No such project-ticket" author' <- lift $ getWorkItemAuthorDetail author return (ltid, Left $ Left (sharerIdent s, projectIdent j), author') - getWorkItem name (WorkItemRepoPatch shr rp ltid) = do - mticket <- lift $ getRepoPatch shr rp ltid + getWorkItem name (WorkItemRepoProposal shr rp ltid) = do + mticket <- lift $ getRepoProposal shr rp ltid (Entity _ s, Entity _ r, _, _, _, _, author, _, _) <- fromMaybeE mticket $ name <> ": No such repo-patch" author' <- lift $ getWorkItemAuthorDetail author @@ -255,5 +241,5 @@ getWorkItemDetail name v = do mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro) data WorkItemTarget - = WTTProject ShrIdent PrjIdent - | WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text + = WITProject ShrIdent PrjIdent + | WITRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem (NonEmpty Text) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 54b754b..14507c9 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -49,6 +49,8 @@ module Web.ActivityPub , PatchType (..) , PatchLocal (..) , Patch (..) + , BundleLocal (..) + , Bundle (..) , TicketLocal (..) , MergeRequest (..) , Ticket (..) @@ -826,7 +828,7 @@ newtype TextPandocMarkdown = TextPandocMarkdown } deriving (FromJSON, ToJSON) -data PatchType = PatchTypeDarcs +data PatchType = PatchTypeDarcs deriving Eq instance FromJSON PatchType where parseJSON = withText "PatchType" parse @@ -841,10 +843,8 @@ instance ToJSON PatchType where render PatchTypeDarcs = "application/x-darcs-patch" :: Text data PatchLocal = PatchLocal - { patchId :: LocalURI - , patchContext :: LocalURI - , patchPrevVersions :: [LocalURI] - , patchCurrentVersion :: Maybe LocalURI + { patchId :: LocalURI + , patchContext :: LocalURI } parsePatchLocal @@ -854,16 +854,12 @@ parsePatchLocal o = do case mid of Nothing -> do verifyNothing "context" - verifyNothing "previousVersions" - verifyNothing "currentVersion" return Nothing Just (ObjURI a id_) -> fmap (Just . (a,)) $ PatchLocal <$> pure id_ <*> withAuthorityO a (o .: "context") - <*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= []) - <*> withAuthorityMaybeO a (o .:? "currentVersion") where verifyNothing t = if t `M.member` o @@ -871,11 +867,9 @@ parsePatchLocal o = do else return () encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series -encodePatchLocal a (PatchLocal id_ context versions mcurrent) +encodePatchLocal a (PatchLocal id_ context) = "id" .= ObjURI a id_ <> "context" .= ObjURI a context - <> "previousVersions" .= map (ObjURI a) versions - <> "currentVersion" .=? (ObjURI a <$> mcurrent) data Patch u = Patch { patchLocal :: Maybe (Authority u, PatchLocal) @@ -911,6 +905,89 @@ instance ActivityPub Patch where <> "mediaType" .= typ <> "content" .= content +data BundleLocal = BundleLocal + { bundleId :: LocalURI + , bundleContext :: LocalURI + , bundlePrevVersions :: [LocalURI] + , bundleCurrentVersion :: Maybe LocalURI + } + +parseBundleLocal + :: UriMode u => Object -> Parser (Maybe (Authority u, BundleLocal)) +parseBundleLocal o = do + mid <- o .:? "id" + case mid of + Nothing -> do + verifyNothing "context" + verifyNothing "previousVersions" + verifyNothing "currentVersion" + return Nothing + Just (ObjURI a id_) -> + fmap (Just . (a,)) $ + BundleLocal + <$> pure id_ + <*> withAuthorityO a (o .: "context") + <*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= []) + <*> withAuthorityMaybeO a (o .:? "currentVersion") + where + verifyNothing t = + if t `M.member` o + then fail $ T.unpack t ++ " field found, expected none" + else return () + +encodeBundleLocal :: UriMode u => Authority u -> BundleLocal -> Series +encodeBundleLocal a (BundleLocal id_ context versions mcurrent) + = "id" .= ObjURI a id_ + <> "context" .= ObjURI a context + <> "previousVersions" .= map (ObjURI a) versions + <> "currentVersion" .=? (ObjURI a <$> mcurrent) + +data Bundle u + = BundleHosted (Maybe BundleLocal) (NonEmpty LocalURI) + | BundleOffer (Maybe (Authority u, BundleLocal)) (NonEmpty (Patch u)) + +instance ActivityPub Bundle where + jsonldContext _ = [as2Context, forgeContext] + + parseObject o = do + typ <- o .: "type" + unless (typ == ("OrderedCollection" :: Text)) $ + fail "type isn't OrderedCollection" + + mlocal <- parseBundleLocal o + mtotal <- o .:? "totalItems" + + items <- toEither <$> o .: "orderedItems" <|> o .: "items" + case items of + Left (ObjURI h lu :| us) -> do + for_ mlocal $ \ (h', _) -> + unless (h == h') $ + fail "Patches in bundle not on the same host as bundle" + unless (all (== h) $ map objUriAuthority us) $ + fail "Patches in bundle on different hosts" + for_ mtotal $ \ total -> + unless (length us + 1 == total) $ + fail "Incorrect totalItems" + return (h, BundleHosted (snd <$> mlocal) $ lu :| map objUriLocal us) + Right (Doc h p :| ps) -> do + unless (all (== h) $ map docAuthority ps) $ + fail "Patches in bundle have different authors" + for_ mtotal $ \ total -> + unless (length ps + 1 == total) $ + fail "Incorrect totalItems" + return (h, BundleOffer mlocal $ p :| map docValue ps) + + toSeries hBundle (BundleHosted mlocal lus) + = maybe mempty (encodeBundleLocal hBundle) mlocal + <> "type" .= ("OrderedCollection" :: Text) + <> "totalItems" .= length lus + <> "orderedItems" .= NE.map (ObjURI hBundle) lus + toSeries hAttrib (BundleOffer mlocal patches) + = maybe mempty (uncurry encodeBundleLocal) mlocal + <> "type" .= ("OrderedCollection" :: Text) + <> "totalItems" .= length patches + <> "orderedItems" .= NE.map (Doc hAttrib) patches + data TicketLocal = TicketLocal { ticketId :: LocalURI , ticketReplies :: LocalURI @@ -964,7 +1041,7 @@ encodeTicketLocal data MergeRequest u = MergeRequest { mrOrigin :: Maybe (ObjURI u) , mrTarget :: LocalURI - , mrPatch :: Either (ObjURI u) (Authority u, Patch u) + , mrBundle :: Either (ObjURI u) (Authority u, Bundle u) } instance ActivityPub MergeRequest where @@ -985,11 +1062,11 @@ instance ActivityPub MergeRequest where where fromDoc (Doc h v) = (h, v) - toSeries h (MergeRequest morigin target patch) + toSeries h (MergeRequest morigin target bundle) = "type" .= ("Offer" :: Text) <> "origin" .=? morigin <> "target" .= ObjURI h target - <> "object" .= fromEither (second (uncurry Doc) patch) + <> "object" .= fromEither (second (uncurry Doc) bundle) data Ticket u = Ticket { ticketLocal :: Maybe (Authority u, TicketLocal)