forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S & C2S: Switch from single-patch MR version to multi-patch bundle support

Browse source
This commit is contained in:
fr33domlover 2020-08-13 10:26:20 +00:00
parent da01fcf451
commit b16c9505af
19 changed files with 901 additions and 593 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
config/models
View file

@ -450,8 +450,11 @@ TicketUnderProject
UniqueTicketUnderProjectProject project
UniqueTicketUnderProjectAuthor author
Patch
Bundle
ticket TicketId
Patch
bundle BundleId
created UTCTime
content Text

34
config/routes
View file

@ -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

2
migrations/2020_08_10_bundle.model Normal file
View file

@ -0,0 +1,2 @@
Bundle
ticket TicketId

19
migrations/2020_08_10_bundle_mig.model Normal file
View file

@ -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

337
src/Vervis/API.hs
View file

@ -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,6 +712,14 @@ 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
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
@ -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,53 +950,28 @@ 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.BundleOffer
(Just
( hLocal
, BundleLocal
{ bundleId = luBundle
, bundleContext = luTicket
, bundlePrevVersions = []
, bundleCurrentVersion = Nothing
}
)
)
(NE.map
(\ (ptkhid, diff) -> AP.Patch
{ AP.patchLocal = Just
( hLocal
, PatchLocal
{ patchId =
case mptkhid of
Nothing -> error "mptkhid is Nothing"
Just ptkhid ->
encodeRouteLocal $
SharerPatchVersionR shrUser talkhid ptkhid
, patchContext = luTicket
, patchPrevVersions = []
, patchCurrentVersion = Nothing
}
)
, AP.patchAttributedTo = luAttrib
, AP.patchPublished = Just now
, AP.patchType =
case vcs of
VCSDarcs -> PatchTypeDarcs
VCSGit -> error "createTicketC VCSGit"
, AP.patchContent = diff
}
)
}
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
( hLocal
, PatchLocal
{ patchId =
case mptkhid of
Nothing -> error "mptkhid is Nothing"
Just ptkhid ->
encodeRouteLocal $
SharerPatchVersionR shrUser talkhid ptkhid
, patchContext = luTicket
, patchPrevVersions = []
, patchCurrentVersion = Nothing
SharerProposalBundlePatchR shrUser talkhid bnkhid ptkhid
, patchContext = luBundle
}
)
, AP.patchAttributedTo = luAttrib
@ -975,10 +980,60 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, AP.patchContent = diff
}
)
(NE.zip ptkhids diffs)
)
)
}
in (uRepo, uRepo, Just (hLocal, mr))
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
, 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)
)
)
}
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,6 +1500,14 @@ 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
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
@ -1455,10 +1520,10 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
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
@ -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)

12
src/Vervis/ActivityPub.hs
View file

@ -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

36
src/Vervis/ActivityPub/Recipient.hs
View file

@ -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)

18
src/Vervis/Federation/Discussion.hs
View file

@ -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

16
src/Vervis/Federation/Offer.hs
View file

@ -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 =

218
src/Vervis/Federation/Ticket.hs
View file

@ -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,6 +172,14 @@ 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
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) $
@ -179,10 +187,10 @@ checkOfferTicket author ticket uTarget = do
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
data RemoteBundle = RemoteBundle
{ rpBranch :: Maybe LocalURI
, rpType :: PatchType
, rpContent :: Text
, 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,6 +636,29 @@ 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
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
@ -640,13 +671,9 @@ checkCreateTicket author ticket muTarget = do
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
mlocal' <-
for mlocal $
\ (h', PatchLocal luId luContext versions mcurr) -> do
\ (h', PatchLocal luId luContext) -> 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"
@ -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
diffs <- for patches $ \ (_mluId, mpub, diff) -> do
for_ mpub $ \ pub' ->
unless (pub == pub') $
throwE "Ticket & Patch 'published' differ"
let patch =
RemotePatch
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
]

3
src/Vervis/Foundation.hs
View file

@ -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

393
src/Vervis/Handler/Patch.hs
View file

@ -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
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"
<*> do pt <- get404 ptid
unless (patchTicket pt == tid) notFound
return pt
<*> pure (if ptid == v then (vs, Nothing) else ([], Just v))
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
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
(repoVcs repo,,,)
<$> do pt <- get404 ptid
unless (patchTicket pt == tid) notFound
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
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
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

12
src/Vervis/Handler/Ticket.hs
View file

@ -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

21
src/Vervis/Migration.hs
View file

@ -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

11
src/Vervis/Migration/Model.hs
View file

@ -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")

48
src/Vervis/Patch.hs
View file

@ -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

34
src/Vervis/Ticket.hs
View file

@ -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 ()

30
src/Vervis/WorkItem.hs
View file

@ -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)

103
src/Web/ActivityPub.hs
View file

@ -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
@ -843,8 +845,6 @@ instance ToJSON PatchType where
data PatchLocal = PatchLocal
{ patchId :: LocalURI
, patchContext :: LocalURI
, patchPrevVersions :: [LocalURI]
, patchCurrentVersion :: Maybe 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)