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 UniqueTicketUnderProjectProject project
UniqueTicketUnderProjectAuthor author UniqueTicketUnderProjectAuthor author
Bundle
ticket TicketId
Patch Patch
ticket TicketId bundle BundleId
created UTCTime created UTCTime
content Text content Text

34
config/routes
View file

@ -110,16 +110,17 @@
/s/#ShrIdent/r/#RpIdent/d/!new RepoDevNewR GET /s/#ShrIdent/r/#RpIdent/d/!new RepoDevNewR GET
/s/#ShrIdent/r/#RpIdent/d/#ShrIdent RepoDevR GET DELETE POST /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/mr/#LocalTicketKeyHashid RepoProposalR GET
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/d RepoPatchDiscussionR GET /s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/d RepoProposalDiscussionR GET
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/deps RepoPatchDepsR GET /s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/deps RepoProposalDepsR GET
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/rdeps RepoPatchReverseDepsR GET /s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/rdeps RepoProposalReverseDepsR GET
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/followers RepoPatchFollowersR GET /s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/followers RepoProposalFollowersR GET
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/events RepoPatchEventsR 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 /s/#ShrIdent/r/#RpIdent/_darcs/+Texts DarcsDownloadR GET
@ -203,15 +204,16 @@
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/team SharerTicketTeamR GET /s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/team SharerTicketTeamR GET
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/events SharerTicketEventsR 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/mr/#TicketAuthorLocalKeyHashid SharerProposalR GET
/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/d SharerPatchDiscussionR GET /s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/d SharerProposalDiscussionR GET
/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/deps SharerPatchDepsR GET /s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/deps SharerProposalDepsR GET
/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/rdeps SharerPatchReverseDepsR GET /s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/rdeps SharerProposalReverseDepsR GET
/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/followers SharerPatchFollowersR GET /s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/followers SharerProposalFollowersR GET
/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/events SharerPatchEventsR 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 /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

401
src/Vervis/API.hs
View file

@ -207,18 +207,18 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
] ]
NoteContextSharerTicket shr talid True -> NoteContextSharerTicket shr talid True ->
let talkhid = hashTAL talid let talkhid = hashTAL talid
in [ -- LocalPersonCollectionSharerPatchTeam shr talkhid in [ -- LocalPersonCollectionSharerProposalTeam shr talkhid
LocalPersonCollectionSharerPatchFollowers shr talkhid LocalPersonCollectionSharerProposalFollowers shr talkhid
] ]
NoteContextProjectTicket shr prj ltid -> NoteContextProjectTicket shr prj ltid ->
let ltkhid = hashLT ltid let ltkhid = hashLT ltid
in [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid in [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid
LocalPersonCollectionProjectTicketFollowers shr prj ltkhid LocalPersonCollectionProjectTicketFollowers shr prj ltkhid
] ]
NoteContextRepoPatch shr rp ltid -> NoteContextRepoProposal shr rp ltid ->
let ltkhid = hashLT ltid let ltkhid = hashLT ltid
in [ -- LocalPersonCollectionRepoPatchTeam shr rp ltkhid in [ -- LocalPersonCollectionRepoProposalTeam shr rp ltkhid
LocalPersonCollectionRepoPatchFollowers shr rp ltkhid LocalPersonCollectionRepoProposalFollowers shr rp ltkhid
] ]
Right _ -> [] Right _ -> []
commenter = [LocalPersonCollectionSharerFollowers shrUser] commenter = [LocalPersonCollectionSharerFollowers shrUser]
@ -251,7 +251,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
decodeKeyHashidE decodeKeyHashidE
talkhid talkhid
(name <> " sharer ticket invalid talkhid") (name <> " sharer ticket invalid talkhid")
SharerPatchR shr talkhid -> SharerProposalR shr talkhid ->
flip (NoteContextSharerTicket shr) True <$> flip (NoteContextSharerTicket shr) True <$>
decodeKeyHashidE decodeKeyHashidE
talkhid talkhid
@ -261,8 +261,8 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
decodeKeyHashidE decodeKeyHashidE
ltkhid ltkhid
(name <> " project ticket invalid ltkhid") (name <> " project ticket invalid ltkhid")
RepoPatchR shr rp ltkhid -> RepoProposalR shr rp ltkhid ->
NoteContextRepoPatch shr rp <$> NoteContextRepoProposal shr rp <$>
decodeKeyHashidE decodeKeyHashidE
ltkhid ltkhid
(name <> " repo patch invalid ltkhid") (name <> " repo patch invalid ltkhid")
@ -329,7 +329,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
sharerSet <- lookup shr localRecips sharerSet <- lookup shr localRecips
projectSet <- lookup prj $ localRecipProjectRelated sharerSet projectSet <- lookup prj $ localRecipProjectRelated sharerSet
guard $ localRecipProject $ localRecipProjectDirect projectSet guard $ localRecipProject $ localRecipProjectDirect projectSet
verifyContextRecip (Left (NoteContextRepoPatch shr rp _)) localRecips _ = verifyContextRecip (Left (NoteContextRepoProposal shr rp _)) localRecips _ =
fromMaybeE fromMaybeE
verify verify
"Local context patch's hosting repo isn't listed as a recipient" "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) return (mproj, localTicketDiscuss lt)
NoteContextSharerTicket shr talid True -> do NoteContextSharerTicket shr talid True -> do
(_, Entity _ lt, _, repo, _, _) <- 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" fromMaybeE mticket "Note context no such local sharer-hosted patch"
mproj <- mproj <-
case repo of case repo of
@ -372,9 +372,9 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
mticket <- lift $ getProjectTicket shr prj ltid mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Note context no such local project-hosted ticket" fromMaybeE mticket "Note context no such local project-hosted ticket"
return (Just $ Left (shr, prj), localTicketDiscuss lt) return (Just $ Left (shr, prj), localTicketDiscuss lt)
NoteContextRepoPatch shr rp ltid -> do NoteContextRepoProposal shr rp ltid -> do
(_, _, _, Entity _ lt, _, _, _, _, _) <- 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" fromMaybeE mticket "Note context no such local project-hosted ticket"
return (Just $ Right (shr, rp), localTicketDiscuss lt) return (Just $ Right (shr, rp), localTicketDiscuss lt)
mmidParent <- for mparent $ \ parent -> mmidParent <- for mparent $ \ parent ->
@ -491,14 +491,14 @@ checkFederation remoteRecips = do
throwE "Federation disabled, but remote recipients found" throwE "Federation disabled, but remote recipients found"
verifyProjectRecip (Right _) _ = return () 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" fromMaybeE verify "Local context project isn't listed as a recipient"
where where
verify = do verify = do
sharerSet <- lookup shr localRecips sharerSet <- lookup shr localRecips
projectSet <- lookup prj $ localRecipProjectRelated sharerSet projectSet <- lookup prj $ localRecipProjectRelated sharerSet
guard $ localRecipProject $ localRecipProjectDirect projectSet 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" fromMaybeE verify "Local context repo isn't listed as a recipient"
where where
verify = do verify = do
@ -530,12 +530,12 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
(_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do (_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
project <- prepareProject now tracker project <- prepareProject now tracker
(talid, mptid) <- lift $ insertTicket now pidUser title desc source obiidCreate project (talid, mbn) <- lift $ insertTicket now pidUser title desc source obiidCreate project
docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mbn
remoteRecipsHttpCreate <- do remoteRecipsHttpCreate <- do
let sieve = let sieve =
case context of case context of
Left (WTTProject shr prj) -> Left (WITProject shr prj) ->
makeRecipientSet makeRecipientSet
[ LocalActorProject shr prj [ LocalActorProject shr prj
] ]
@ -543,7 +543,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj , LocalPersonCollectionProjectFollowers shr prj
] ]
Left (WTTRepo shr rp _ _ _) -> Left (WITRepo shr rp _ _ _) ->
makeRecipientSet makeRecipientSet
[ LocalActorRepo shr rp [ LocalActorRepo shr rp
] ]
@ -612,7 +612,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
( Host ( Host
, LocalURI , LocalURI
, LocalURI , LocalURI
, Maybe (Maybe LocalURI, PatchType, Text) , Maybe (Maybe LocalURI, PatchType, NonEmpty Text)
) )
, TextHtml , TextHtml
, TextHtml , TextHtml
@ -653,7 +653,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
checkTicket checkTicket
:: AP.Ticket URIMode :: AP.Ticket URIMode
-> ExceptT Text Handler -> ExceptT Text Handler
( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
, TextHtml , TextHtml
, TextHtml , TextHtml
, TextPandocMarkdown , TextPandocMarkdown
@ -680,16 +680,16 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
-> ExceptT Text Handler -> ExceptT Text Handler
( Either (ShrIdent, RpIdent, Maybe Text) FedURI ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, PatchType , PatchType
, Text , NonEmpty Text
) )
checkMR h (MergeRequest muOrigin luTarget epatch) = do checkMR h (MergeRequest muOrigin luTarget ebundle) = do
verifyNothingE muOrigin "MR with 'origin'" verifyNothingE muOrigin "MR with 'origin'"
branch <- checkBranch h luTarget branch <- checkBranch h luTarget
(typ, content) <- (typ, diffs) <-
case epatch of case ebundle of
Left _ -> throwE "MR patch specified as a URI" Left _ -> throwE "MR bundle specified as a URI"
Right (hPatch, patch) -> checkPatch hPatch patch Right (hBundle, bundle) -> checkBundle hBundle bundle
return (branch, typ, content) return (branch, typ, diffs)
where where
checkBranch checkBranch
:: Host :: Host
@ -712,21 +712,29 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
"MR target is a valid local route, but isn't a \ "MR target is a valid local route, but isn't a \
\repo or branch route" \repo or branch route"
else return $ Right $ ObjURI h lu else return $ Right $ ObjURI h lu
checkPatch checkBundle _ (AP.BundleHosted _ _) =
:: Host throwE "Patches specified as URIs"
-> AP.Patch URIMode checkBundle h (AP.BundleOffer mlocal patches) = do
-> ExceptT Text Handler verifyNothingE mlocal "Bundle has 'id'"
( PatchType (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches
, Text unless (all (== typ) typs) $ throwE "Different patch types"
) return (typ, diffs)
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do where
encodeRouteLocal <- getEncodeRouteLocal checkPatch
verifyHostLocal h "Patch attributed to remote user" :: Host
verifyNothingE mlocal "Patch with 'id'" -> AP.Patch URIMode
unless (encodeRouteLocal (SharerR shr) == attrib) $ -> ExceptT Text Handler
throwE "Ticket and Patch attrib mismatch" ( PatchType
verifyNothingE mpub "Patch has 'published'" , Text
return (typ, content) )
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
encodeRouteLocal <- getEncodeRouteLocal
verifyHostLocal h "Patch attributed to remote user"
verifyNothingE mlocal "Patch with 'id'"
unless (encodeRouteLocal (SharerR shr) == attrib) $
throwE "Ticket and Patch attrib mismatch"
verifyNothingE mpub "Patch has 'published'"
return (typ, content)
matchContextAndMR matchContextAndMR
:: Either :: Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
@ -734,20 +742,20 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
-> Maybe -> Maybe
( Either (ShrIdent, RpIdent, Maybe Text) FedURI ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, PatchType , PatchType
, Text , NonEmpty Text
) )
-> ExceptT Text Handler -> ExceptT Text Handler
(Either (Either
WorkItemTarget WorkItemTarget
( Host ( Host
, LocalURI , 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 (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))) 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' <- branch' <-
case branch of case branch of
Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
@ -760,56 +768,56 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
VCSGit -> VCSGit ->
unless (isJust branch') $ unless (isJust branch') $
throwE "Git MR doesn't specify the 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 where
typ2vcs PatchTypeDarcs = VCSDarcs typ2vcs PatchTypeDarcs = VCSDarcs
matchContextAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) 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 <- luBranch <-
case branch of case branch of
Right (ObjURI h' lu') | h == h' -> return lu Right (ObjURI h' lu') | h == h' -> return lu
_ -> throwE "MR target repo/branch and Ticket context repo mismatch" _ -> throwE "MR target repo/branch and Ticket context repo mismatch"
let patch = let bundle =
( if lu == luBranch then Nothing else Just luBranch ( if lu == luBranch then Nothing else Just luBranch
, typ , typ
, content , diffs
) )
return $ Right (h, lu, Just patch) return $ Right (h, lu, Just bundle)
checkTargetAndContext checkTargetAndContext
:: Either :: Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI FedURI
-> Either -> Either
WorkItemTarget WorkItemTarget
(Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
-> ExceptT Text Handler -> ExceptT Text Handler
(Either (Either
WorkItemTarget WorkItemTarget
( Host ( Host
, LocalURI , LocalURI
, LocalURI , LocalURI
, Maybe (Maybe LocalURI, PatchType, Text) , Maybe (Maybe LocalURI, PatchType, NonEmpty Text)
) )
) )
checkTargetAndContext (Left _) (Right _) = checkTargetAndContext (Left _) (Right _) =
throwE "Create target is local but ticket context is remote" throwE "Create target is local but ticket context is remote"
checkTargetAndContext (Right _) (Left _) = checkTargetAndContext (Right _) (Left _) =
throwE "Create target is remote but ticket context is local" 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 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 \ else throwE "Create target and ticket context on different \
\remote hosts" \remote hosts"
checkTargetAndContext (Left proj) (Left wit) = checkTargetAndContext (Left proj) (Left wit) =
case (proj, wit) of case (proj, wit) of
(Left (shr, prj), WTTProject shr' prj') (Left (shr, prj), WITProject shr' prj')
| shr == shr' && prj == prj' -> return $ Left wit | 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 | shr == shr' && rp == rp' -> return $ Left wit
_ -> throwE "Create target and ticket context are different \ _ -> throwE "Create target and ticket context are different \
\local projects" \local projects"
fetchTracker (h, luTarget, luContext, mpatch) = do fetchTracker (h, luTarget, luContext, mbundle) = do
(iid, era) <- do (iid, era) <- do
iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
result <- lift $ fetchRemoteActor iid h luTarget result <- lift $ fetchRemoteActor iid h luTarget
@ -819,16 +827,16 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
Right (Right mera) -> do Right (Right mera) -> do
era <- fromMaybeE mera "target found to be a collection, not an actor" era <- fromMaybeE mera "target found to be a collection, not an actor"
return (iid, era) 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 mej <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid MaybeT $ getBy $ UniqueProject prj sid
ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project" ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
return (shr, Left ej, obiidAccept) 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 mer <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueRepo rp sid MaybeT $ getBy $ UniqueRepo rp sid
@ -867,7 +875,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, ticketAuthorLocalAuthor = pidUser , ticketAuthorLocalAuthor = pidUser
, ticketAuthorLocalOpen = obiidCreate , ticketAuthorLocalOpen = obiidCreate
} }
mptid <- mbn <-
case project of case project of
Left (_shr, ent, obiidAccept) -> do Left (_shr, ent, obiidAccept) -> do
tclid <- insert TicketContextLocal tclid <- insert TicketContextLocal
@ -881,38 +889,60 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, ticketProjectLocalProject = jid , ticketProjectLocalProject = jid
} }
return Nothing return Nothing
Right (Entity rid _, mb, diff) -> Just <$> do Right (Entity rid _, mb, diffs) -> Just <$> do
insert_ TicketRepoLocal insert_ TicketRepoLocal
{ ticketRepoLocalContext = tclid { ticketRepoLocalContext = tclid
, ticketRepoLocalRepo = rid , ticketRepoLocalRepo = rid
, ticketRepoLocalBranch = mb , ticketRepoLocalBranch = mb
} }
insert $ Patch tid now diff bnid <- insert $ Bundle tid
Right (Entity raid _, mroid, mpatch) -> do (bnid,) . toNE <$>
insertMany
(NE.toList $ NE.map (Patch bnid now) diffs)
Right (Entity raid _, mroid, mbundle) -> do
insert_ TicketProjectRemote insert_ TicketProjectRemote
{ ticketProjectRemoteTicket = talid { ticketProjectRemoteTicket = talid
, ticketProjectRemoteTracker = raid , ticketProjectRemoteTracker = raid
, ticketProjectRemoteProject = mroid , ticketProjectRemoteProject = mroid
} }
for mpatch $ \ (_typ, diff) -> insert $ Patch tid now diff for mbundle $ \ (_typ, diffs) -> do
return (talid, mptid) 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 encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
talkhid <- encodeKeyHashid talid talkhid <- encodeKeyHashid talid
mptkhid <- traverse encodeKeyHashid mptid mkh <- for mbn $ \ (bnid, ptids) ->
(,) <$> encodeKeyHashid bnid
<*> traverse encodeKeyHashid ptids
obikhid <- encodeKeyHashid obiidCreate obikhid <- encodeKeyHashid obiidCreate
let luTicket = encodeRouteLocal $ SharerTicketR shrUser talkhid let luTicket = encodeRouteLocal $ SharerTicketR shrUser talkhid
luAttrib = encodeRouteLocal $ SharerR shrUser luAttrib = encodeRouteLocal $ SharerR shrUser
(uTarget, uContext, mmr) = (uTarget, uContext, mmr) =
case context of case context of
Left (WTTProject shr prj) -> Left (WITProject shr prj) ->
let uProject = encodeRouteHome $ ProjectR shr prj let uProject = encodeRouteHome $ ProjectR shr prj
in (uProject, uProject, Nothing) in (uProject, uProject, Nothing)
Left (WTTRepo shr rp mb vcs diff) -> Left (WITRepo shr rp mb vcs diffs) ->
let uRepo = encodeRouteHome $ RepoR shr rp 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 mr = MergeRequest
{ mrOrigin = Nothing { mrOrigin = Nothing
, mrTarget = , mrTarget =
@ -920,65 +950,90 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
case mb of case mb of
Nothing -> RepoR shr rp Nothing -> RepoR shr rp
Just b -> RepoBranchR shr rp b Just b -> RepoBranchR shr rp b
, mrPatch = Right , mrBundle = Right
( hLocal ( hLocal
, AP.Patch , AP.BundleOffer
{ AP.patchLocal = Just (Just
( hLocal ( hLocal
, PatchLocal , BundleLocal
{ patchId = { bundleId = luBundle
case mptkhid of , bundleContext = luTicket
Nothing -> error "mptkhid is Nothing" , bundlePrevVersions = []
Just ptkhid -> , bundleCurrentVersion = Nothing
encodeRouteLocal $
SharerPatchVersionR shrUser talkhid ptkhid
, patchContext = luTicket
, patchPrevVersions = []
, patchCurrentVersion = Nothing
} }
) )
, AP.patchAttributedTo = luAttrib )
, AP.patchPublished = Just now (NE.map
, AP.patchType = (\ (ptkhid, diff) -> AP.Patch
case vcs of { AP.patchLocal = Just
VCSDarcs -> PatchTypeDarcs ( hLocal
VCSGit -> error "createTicketC VCSGit" , PatchLocal
, AP.patchContent = diff { patchId =
} encodeRouteLocal $
SharerProposalBundlePatchR shrUser talkhid bnkhid ptkhid
, patchContext = luBundle
}
)
, AP.patchAttributedTo = luAttrib
, AP.patchPublished = Just now
, AP.patchType = typ
, AP.patchContent = diff
}
)
(NE.zip ptkhids diffs)
)
) )
} }
in (uRepo, uRepo, Just (hLocal, mr)) in (uRepo, uRepo, Just (hLocal, mr))
Right (hContext, luTarget, luContext, mpatch) -> Right (hContext, luTarget, luContext, mbundle) ->
let mr (mluBranch, typ, diff) = MergeRequest let mr (mluBranch, typ, diffs) =
{ mrOrigin = Nothing let (bnkhid, ptkhids) =
, mrTarget = fromMaybe luContext mluBranch case mkh of
, mrPatch = Right Nothing -> error "mkh is Nothing"
( hLocal Just v -> v
, AP.Patch luBundle =
{ AP.patchLocal = Just encodeRouteLocal $
SharerProposalBundleR shrUser talkhid bnkhid
in MergeRequest
{ mrOrigin = Nothing
, mrTarget = fromMaybe luContext mluBranch
, mrBundle = Right
( hLocal ( hLocal
, PatchLocal , AP.BundleOffer
{ patchId = (Just
case mptkhid of ( hLocal
Nothing -> error "mptkhid is Nothing" , BundleLocal
Just ptkhid -> { bundleId = luBundle
encodeRouteLocal $ , bundleContext = luTicket
SharerPatchVersionR shrUser talkhid ptkhid , bundlePrevVersions = []
, patchContext = luTicket , bundleCurrentVersion = Nothing
, patchPrevVersions = [] }
, patchCurrentVersion = Nothing )
} )
(NE.map
(\ (ptkhid, diff) -> AP.Patch
{ AP.patchLocal = Just
( hLocal
, PatchLocal
{ patchId =
encodeRouteLocal $
SharerProposalBundlePatchR shrUser talkhid bnkhid ptkhid
, patchContext = luBundle
}
)
, AP.patchAttributedTo = luAttrib
, AP.patchPublished = Just now
, AP.patchType = typ
, AP.patchContent = diff
}
)
(NE.zip ptkhids diffs)
)
) )
, AP.patchAttributedTo = luAttrib
, AP.patchPublished = Just now
, AP.patchType = typ
, AP.patchContent = diff
} }
)
}
in ( ObjURI hContext luTarget in ( ObjURI hContext luTarget
, ObjURI hContext luContext , ObjURI hContext luContext
, (hContext,) . mr <$> mpatch , (hContext,) . mr <$> mbundle
) )
tlocal = TicketLocal tlocal = TicketLocal
{ ticketId = luTicket { ticketId = luTicket
@ -1046,11 +1101,11 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
data Followee data Followee
= FolloweeSharer ShrIdent = FolloweeSharer ShrIdent
| FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal) | FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal)
| FolloweeSharerPatch ShrIdent (KeyHashid TicketAuthorLocal) | FolloweeSharerProposal ShrIdent (KeyHashid TicketAuthorLocal)
| FolloweeProject ShrIdent PrjIdent | FolloweeProject ShrIdent PrjIdent
| FolloweeProjectTicket ShrIdent PrjIdent (KeyHashid LocalTicket) | FolloweeProjectTicket ShrIdent PrjIdent (KeyHashid LocalTicket)
| FolloweeRepo ShrIdent RpIdent | FolloweeRepo ShrIdent RpIdent
| FolloweeRepoPatch ShrIdent RpIdent (KeyHashid LocalTicket) | FolloweeRepoProposal ShrIdent RpIdent (KeyHashid LocalTicket)
followC followC
:: ShrIdent :: ShrIdent
@ -1109,20 +1164,20 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
where where
parseFollowee (SharerR shr) = Just $ FolloweeSharer shr parseFollowee (SharerR shr) = Just $ FolloweeSharer shr
parseFollowee (SharerTicketR shr khid) = Just $ FolloweeSharerTicket shr khid 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 (ProjectR shr prj) = Just $ FolloweeProject shr prj
parseFollowee (ProjectTicketR shr prj num) = Just $ FolloweeProjectTicket shr prj num parseFollowee (ProjectTicketR shr prj num) = Just $ FolloweeProjectTicket shr prj num
parseFollowee (RepoR shr rp) = Just $ FolloweeRepo shr rp 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 parseFollowee _ = Nothing
followeeActor (FolloweeSharer shr) = LocalActorSharer shr followeeActor (FolloweeSharer shr) = LocalActorSharer shr
followeeActor (FolloweeSharerTicket 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 (FolloweeProject shr prj) = LocalActorProject shr prj
followeeActor (FolloweeProjectTicket shr prj _) = LocalActorProject shr prj followeeActor (FolloweeProjectTicket shr prj _) = LocalActorProject shr prj
followeeActor (FolloweeRepo shr rp) = LocalActorRepo shr rp followeeActor (FolloweeRepo shr rp) = LocalActorRepo shr rp
followeeActor (FolloweeRepoPatch shr rp _) = LocalActorRepo shr rp followeeActor (FolloweeRepoProposal shr rp _) = LocalActorRepo shr rp
getAuthor shr = do getAuthor shr = do
sid <- getKeyBy404 $ UniqueSharer shr 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" fromMaybeE mticket "Follow object: No such sharer-ticket in DB"
p <- lift $ getJust $ ticketAuthorLocalAuthor tal p <- lift $ getJust $ ticketAuthorLocalAuthor tal
return (localTicketFollowers lt, personInbox p, True, personOutbox p) return (localTicketFollowers lt, personInbox p, True, personOutbox p)
getFollowee (FolloweeSharerPatch shr talkhid) = do getFollowee (FolloweeSharerProposal shr talkhid) = do
(Entity _ tal, Entity _ lt, _, _, _, _) <- do (Entity _ tal, Entity _ lt, _, _, _, _) <- do
mticket <- lift $ runMaybeT $ do mticket <- lift $ runMaybeT $ do
talid <- decodeKeyHashidM talkhid talid <- decodeKeyHashidM talkhid
MaybeT $ getSharerPatch shr talid MaybeT $ getSharerProposal shr talid
fromMaybeE mticket "Follow object: No such sharer-patch in DB" fromMaybeE mticket "Follow object: No such sharer-patch in DB"
p <- lift $ getJust $ ticketAuthorLocalAuthor tal p <- lift $ getJust $ ticketAuthorLocalAuthor tal
return (localTicketFollowers lt, personInbox p, True, personOutbox p) 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 MaybeT $ getValBy $ UniqueRepo rp sid
repo <- fromMaybeE mrepo "Follow object: No such repo in DB" repo <- fromMaybeE mrepo "Follow object: No such repo in DB"
return (repoFollowers repo, repoInbox repo, False, repoOutbox repo) 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 (_, Entity _ r, _, Entity _ lt, _, _, _, _, _) <- do
mticket <- lift $ runMaybeT $ do mticket <- lift $ runMaybeT $ do
ltid <- decodeKeyHashidM ltkhid ltid <- decodeKeyHashidM ltkhid
MaybeT $ getRepoPatch shr rp ltid MaybeT $ getRepoProposal shr rp ltid
fromMaybeE mticket "Follow object: No such repo-patch in DB" fromMaybeE mticket "Follow object: No such repo-patch in DB"
return (localTicketFollowers lt, repoInbox r, False, repoOutbox r) 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 (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do
mproject <- mproject <-
case target of case target of
Left (WTTProject shr prj) -> Just . Left <$> do Left (WITProject shr prj) -> Just . Left <$> do
mproj <- lift $ runMaybeT $ do mproj <- lift $ runMaybeT $ do
Entity sid s <- MaybeT $ getBy $ UniqueSharer shr Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
ej <- MaybeT $ getBy $ UniqueProject prj sid ej <- MaybeT $ getBy $ UniqueProject prj sid
return (s, ej) return (s, ej)
fromMaybeE mproj "Offer target no such local project in DB" 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 mproj <- lift $ runMaybeT $ do
Entity sid s <- MaybeT $ getBy $ UniqueSharer shr Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
er <- MaybeT $ getBy $ UniqueRepo rp sid er <- MaybeT $ getBy $ UniqueRepo rp sid
return (s, er) return (s, er)
(s, er@(Entity _ r)) <- fromMaybeE mproj "Offer target no such local repo in DB" (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" unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
return (s, er, mb, diff) return (s, er, mb, diffs)
Right _ -> return Nothing Right _ -> return Nothing
(obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded
remotesHttpOffer <- do remotesHttpOffer <- do
let sieve = let sieve =
case target of case target of
Left (WTTProject shr prj) -> Left (WITProject shr prj) ->
makeRecipientSet makeRecipientSet
[ LocalActorProject shr prj [ LocalActorProject shr prj
] ]
@ -1308,7 +1363,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
, LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj , LocalPersonCollectionProjectFollowers shr prj
] ]
Left (WTTRepo shr rp _ _ _) -> Left (WITRepo shr rp _ _ _) ->
makeRecipientSet makeRecipientSet
[ LocalActorRepo shr rp [ 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 (tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept
case project of case project of
Left _ -> return () 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 (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid
let (actor, ibid) = let (actor, ibid) =
case project of case project of
@ -1373,7 +1430,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
-> AP.Ticket URIMode -> AP.Ticket URIMode
-> FedURI -> FedURI
-> ExceptT Text Handler -> ExceptT Text Handler
( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
, TextHtml , TextHtml
, TextHtml , TextHtml
, TextPandocMarkdown , TextPandocMarkdown
@ -1418,14 +1475,14 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
return (muContext, summary, content, source, mmr') return (muContext, summary, content, source, mmr')
where where
checkMR h (MergeRequest muOrigin luTarget epatch) = do checkMR h (MergeRequest muOrigin luTarget ebundle) = do
verifyNothingE muOrigin "MR with 'origin'" verifyNothingE muOrigin "MR with 'origin'"
branch <- checkBranch h luTarget branch <- checkBranch h luTarget
(typ, content) <- (typ, diffs) <-
case epatch of case ebundle of
Left _ -> throwE "MR patch specified as a URI" Left _ -> throwE "MR bundle specified as a URI"
Right (hPatch, patch) -> checkPatch hPatch patch Right (hBundle, bundle) -> checkBundle hBundle bundle
return (branch, typ, content) return (branch, typ, diffs)
where where
checkBranch h lu = do checkBranch h lu = do
hl <- hostIsLocal h hl <- hostIsLocal h
@ -1443,22 +1500,30 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
"MR target is a valid local route, but isn't a \ "MR target is a valid local route, but isn't a \
\repo or branch route" \repo or branch route"
else return $ Right $ ObjURI h lu else return $ Right $ ObjURI h lu
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do checkBundle _ (AP.BundleHosted _ _) =
verifyNothingE mlocal "Patch with 'id'" throwE "Patches specified as URIs"
hl <- hostIsLocal h checkBundle h (AP.BundleOffer mlocal patches) = do
shrAttrib <- do verifyNothingE mlocal "Bundle has 'id'"
route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route" (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches
case route of unless (all (== typ) typs) $ throwE "Different patch types"
SharerR shr -> return shr return (typ, diffs)
_ -> throwE "Patch attrib not a sharer route" where
unless (hl && shrAttrib == shrUser) $ checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
throwE "Ticket and Patch attrib mismatch" verifyNothingE mlocal "Patch with 'id'"
verifyNothingE mpub "Patch has 'published'" hl <- hostIsLocal h
return (typ, content) shrAttrib <- do
matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route"
case route of
SharerR shr -> return shr
_ -> throwE "Patch attrib not a sharer route"
unless (hl && shrAttrib == shrUser) $
throwE "Ticket and Patch attrib mismatch"
verifyNothingE mpub "Patch has 'published'"
return (typ, content)
matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj
matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" matchTargetAndMR (Left (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))) 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' <- branch' <-
case branch of case branch of
Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
@ -1471,21 +1536,21 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
VCSGit -> VCSGit ->
unless (isJust branch') $ unless (isJust branch') $
throwE "Git MR doesn't specify the 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 where
typ2vcs PatchTypeDarcs = VCSDarcs typ2vcs PatchTypeDarcs = VCSDarcs
matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) 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 <- luBranch <-
case branch of case branch of
Right (ObjURI h' lu') | h == h' -> return lu Right (ObjURI h' lu') | h == h' -> return lu
_ -> throwE "MR target repo/branch and Offer target repo mismatch" _ -> throwE "MR target repo/branch and Offer target repo mismatch"
let patch = let bundle =
( if lu == luBranch then Nothing else Just luBranch ( if lu == luBranch then Nothing else Just luBranch
, typ , typ
, content , diffs
) )
return $ Right (h, lu, Just patch) return $ Right (h, lu, Just bundle)
insertOfferToOutbox shrUser now obid blinded = do insertOfferToOutbox shrUser now obid blinded = do
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
obiid <- insertEmptyOutboxItem obid now obiid <- insertEmptyOutboxItem obid now
@ -1555,7 +1620,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
] ]
, RepoOutboxItemR shr rp , RepoOutboxItemR shr rp
, RepoR shr rp , RepoR shr rp
, RepoPatchR shr rp , RepoProposalR shr rp
) )
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
@ -1594,7 +1659,7 @@ verifyHosterRecip localRecips name (Left wi) =
sharerSet <- lookup shr localRecips sharerSet <- lookup shr localRecips
projectSet <- lookup prj $ localRecipProjectRelated sharerSet projectSet <- lookup prj $ localRecipProjectRelated sharerSet
guard $ localRecipProject $ localRecipProjectDirect projectSet guard $ localRecipProject $ localRecipProjectDirect projectSet
verify (WorkItemRepoPatch shr rp _) = do verify (WorkItemRepoProposal shr rp _) = do
sharerSet <- lookup shr localRecips sharerSet <- lookup shr localRecips
repoSet <- lookup rp $ localRecipRepoRelated sharerSet repoSet <- lookup rp $ localRecipRepoRelated sharerSet
guard $ localRecipRepo $ localRecipRepoDirect repoSet guard $ localRecipRepo $ localRecipRepoDirect repoSet
@ -1629,7 +1694,7 @@ workItemRecipSieve wiFollowers (WorkItemDetail ident context author) =
workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj 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 (LocalActorSharer shr) = SharerOutboxItemR shr
actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj 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 sid <- MaybeT $ getKeyBy $ UniqueSharer shr
projectInbox <$> projectInbox <$>
MaybeT (getValBy $ UniqueProject prj sid) MaybeT (getValBy $ UniqueProject prj sid)
WorkItemRepoPatch shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
repoInbox <$> repoInbox <$>
MaybeT (getValBy $ UniqueRepo rp sid) MaybeT (getValBy $ UniqueRepo rp sid)
@ -1723,7 +1788,7 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget =
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
j <- MaybeT (getValBy $ UniqueProject prj sid) j <- MaybeT (getValBy $ UniqueProject prj sid)
return (projectOutbox j, projectInbox j) return (projectOutbox j, projectInbox j)
WorkItemRepoPatch shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
r <- MaybeT (getValBy $ UniqueRepo rp sid) r <- MaybeT (getValBy $ UniqueRepo rp sid)
return (repoOutbox r, repoInbox r) return (repoOutbox r, repoInbox r)
@ -1790,7 +1855,7 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget =
return tdid return tdid
workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj 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 insertAccept shrUser wiParent (WorkItemDetail _ parentCtx parentAuthor) (WorkItemDetail childId childCtx childAuthor) obiidOffer obiidAccept tdid = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
@ -1944,7 +2009,7 @@ resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObjec
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
j <- MaybeT (getValBy $ UniqueProject prj sid) j <- MaybeT (getValBy $ UniqueProject prj sid)
return (projectOutbox j, projectInbox j) return (projectOutbox j, projectInbox j)
WorkItemRepoPatch shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
r <- MaybeT (getValBy $ UniqueRepo rp sid) r <- MaybeT (getValBy $ UniqueRepo rp sid)
return (repoOutbox r, repoInbox r) return (repoOutbox r, repoInbox r)
@ -2062,7 +2127,7 @@ undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObjec
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
j <- MaybeT (getValBy $ UniqueProject prj sid) j <- MaybeT (getValBy $ UniqueProject prj sid)
return (projectOutbox j, projectInbox j) return (projectOutbox j, projectInbox j)
WorkItemRepoPatch shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
r <- MaybeT (getValBy $ UniqueRepo rp sid) r <- MaybeT (getValBy $ UniqueRepo rp sid)
return (repoOutbox r, repoInbox r) return (repoOutbox r, repoInbox r)

12
src/Vervis/ActivityPub.hs
View file

@ -140,7 +140,7 @@ import Vervis.Widget.Sharer
data NoteContext data NoteContext
= NoteContextSharerTicket ShrIdent TicketAuthorLocalId Bool = NoteContextSharerTicket ShrIdent TicketAuthorLocalId Bool
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
| NoteContextRepoPatch ShrIdent RpIdent LocalTicketId | NoteContextRepoProposal ShrIdent RpIdent LocalTicketId
deriving Eq deriving Eq
parseContext parseContext
@ -159,14 +159,14 @@ parseContext uContext = do
SharerTicketR shr talkhid -> SharerTicketR shr talkhid ->
flip (NoteContextSharerTicket shr) False <$> flip (NoteContextSharerTicket shr) False <$>
decodeKeyHashidE talkhid "Note context invalid talkhid" decodeKeyHashidE talkhid "Note context invalid talkhid"
SharerPatchR shr talkhid -> SharerProposalR shr talkhid ->
flip (NoteContextSharerTicket shr) True <$> flip (NoteContextSharerTicket shr) True <$>
decodeKeyHashidE talkhid "Note context invalid talkhid" decodeKeyHashidE talkhid "Note context invalid talkhid"
ProjectTicketR shr prj ltkhid -> ProjectTicketR shr prj ltkhid ->
NoteContextProjectTicket shr prj <$> NoteContextProjectTicket shr prj <$>
decodeKeyHashidE ltkhid "Note context invalid ltkhid" decodeKeyHashidE ltkhid "Note context invalid ltkhid"
RepoPatchR shr rp ltkhid -> RepoProposalR shr rp ltkhid ->
NoteContextRepoPatch shr rp <$> NoteContextRepoProposal shr rp <$>
decodeKeyHashidE ltkhid "Note context invalid ltkhid" decodeKeyHashidE ltkhid "Note context invalid ltkhid"
_ -> throwE "Local context isn't a ticket/patch route" _ -> throwE "Local context isn't a ticket/patch route"
else return $ Right uContext else return $ Right uContext
@ -1032,12 +1032,12 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
let rpsP = let rpsP =
if requireOwner if requireOwner
then then
[ (rp, localRecipRepoPatchRelated r) [ (rp, localRecipRepoProposalRelated r)
| (rp, r) <- repos | (rp, r) <- repos
, localRecipRepo (localRecipRepoDirect r) || isAuthor (LocalActorRepo shr rp) , localRecipRepo (localRecipRepoDirect r) || isAuthor (LocalActorRepo shr rp)
] ]
else else
map (second localRecipRepoPatchRelated) repos map (second localRecipRepoProposalRelated) repos
fsidssP <- for rpsP $ \ (rp, patches) -> do fsidssP <- for rpsP $ \ (rp, patches) -> do
mrid <- getKeyBy $ UniqueRepo rp sid mrid <- getKeyBy $ UniqueRepo rp sid
case mrid of case mrid of

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

@ -107,7 +107,7 @@ data LocalPersonCollection
= LocalPersonCollectionSharerFollowers ShrIdent = LocalPersonCollectionSharerFollowers ShrIdent
| LocalPersonCollectionSharerTicketTeam ShrIdent (KeyHashid TicketAuthorLocal) | LocalPersonCollectionSharerTicketTeam ShrIdent (KeyHashid TicketAuthorLocal)
| LocalPersonCollectionSharerTicketFollowers ShrIdent (KeyHashid TicketAuthorLocal) | LocalPersonCollectionSharerTicketFollowers ShrIdent (KeyHashid TicketAuthorLocal)
| LocalPersonCollectionSharerPatchFollowers ShrIdent (KeyHashid TicketAuthorLocal) | LocalPersonCollectionSharerProposalFollowers ShrIdent (KeyHashid TicketAuthorLocal)
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent | LocalPersonCollectionProjectTeam ShrIdent PrjIdent
| LocalPersonCollectionProjectFollowers ShrIdent PrjIdent | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent
@ -116,7 +116,7 @@ data LocalPersonCollection
| LocalPersonCollectionRepoTeam ShrIdent RpIdent | LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent | LocalPersonCollectionRepoFollowers ShrIdent RpIdent
| LocalPersonCollectionRepoPatchFollowers ShrIdent RpIdent (KeyHashid LocalTicket) | LocalPersonCollectionRepoProposalFollowers ShrIdent RpIdent (KeyHashid LocalTicket)
deriving (Eq, Ord) deriving (Eq, Ord)
parseLocalPersonCollection parseLocalPersonCollection
@ -127,8 +127,8 @@ parseLocalPersonCollection (SharerTicketTeamR shr talkhid) =
Just $ LocalPersonCollectionSharerTicketTeam shr talkhid Just $ LocalPersonCollectionSharerTicketTeam shr talkhid
parseLocalPersonCollection (SharerTicketFollowersR shr talkhid) = parseLocalPersonCollection (SharerTicketFollowersR shr talkhid) =
Just $ LocalPersonCollectionSharerTicketFollowers shr talkhid Just $ LocalPersonCollectionSharerTicketFollowers shr talkhid
parseLocalPersonCollection (SharerPatchFollowersR shr talkhid) = parseLocalPersonCollection (SharerProposalFollowersR shr talkhid) =
Just $ LocalPersonCollectionSharerPatchFollowers shr talkhid Just $ LocalPersonCollectionSharerProposalFollowers shr talkhid
parseLocalPersonCollection (ProjectTeamR shr prj) = parseLocalPersonCollection (ProjectTeamR shr prj) =
Just $ LocalPersonCollectionProjectTeam shr prj Just $ LocalPersonCollectionProjectTeam shr prj
parseLocalPersonCollection (ProjectFollowersR shr prj) = parseLocalPersonCollection (ProjectFollowersR shr prj) =
@ -141,22 +141,22 @@ parseLocalPersonCollection (RepoTeamR shr rp) =
Just $ LocalPersonCollectionRepoTeam shr rp Just $ LocalPersonCollectionRepoTeam shr rp
parseLocalPersonCollection (RepoFollowersR shr rp) = parseLocalPersonCollection (RepoFollowersR shr rp) =
Just $ LocalPersonCollectionRepoFollowers shr rp Just $ LocalPersonCollectionRepoFollowers shr rp
parseLocalPersonCollection (RepoPatchFollowersR shr rp ltkhid) = parseLocalPersonCollection (RepoProposalFollowersR shr rp ltkhid) =
Just $ LocalPersonCollectionRepoPatchFollowers shr rp ltkhid Just $ LocalPersonCollectionRepoProposalFollowers shr rp ltkhid
parseLocalPersonCollection _ = Nothing parseLocalPersonCollection _ = Nothing
renderLocalPersonCollection :: LocalPersonCollection -> Route App renderLocalPersonCollection :: LocalPersonCollection -> Route App
renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr
renderLocalPersonCollection (LocalPersonCollectionSharerTicketTeam shr talkhid) = SharerTicketTeamR shr talkhid renderLocalPersonCollection (LocalPersonCollectionSharerTicketTeam shr talkhid) = SharerTicketTeamR shr talkhid
renderLocalPersonCollection (LocalPersonCollectionSharerTicketFollowers shr talkhid) = SharerTicketFollowersR 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 (LocalPersonCollectionProjectTeam shr prj) = ProjectTeamR shr prj
renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj
renderLocalPersonCollection (LocalPersonCollectionProjectTicketTeam shr prj ltkhid) = ProjectTicketTeamR shr prj ltkhid renderLocalPersonCollection (LocalPersonCollectionProjectTicketTeam shr prj ltkhid) = ProjectTicketTeamR shr prj ltkhid
renderLocalPersonCollection (LocalPersonCollectionProjectTicketFollowers shr prj ltkhid) = ProjectTicketParticipantsR shr prj ltkhid renderLocalPersonCollection (LocalPersonCollectionProjectTicketFollowers shr prj ltkhid) = ProjectTicketParticipantsR shr prj ltkhid
renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp
renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp) = RepoFollowersR 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 parseLocalRecipient
:: Route App -> Maybe (Either LocalActor LocalPersonCollection) :: Route App -> Maybe (Either LocalActor LocalPersonCollection)
@ -195,7 +195,7 @@ data LocalRepoRecipientDirect
data LocalRepoRecipient data LocalRepoRecipient
= LocalRepoDirect LocalRepoRecipientDirect = LocalRepoDirect LocalRepoRecipientDirect
| LocalRepoPatchRelated (KeyHashid LocalTicket) LocalPatchRecipientDirect | LocalRepoProposalRelated (KeyHashid LocalTicket) LocalPatchRecipientDirect
deriving (Eq, Ord) deriving (Eq, Ord)
data LocalSharerRecipientDirect data LocalSharerRecipientDirect
@ -206,7 +206,7 @@ data LocalSharerRecipientDirect
data LocalSharerRecipient data LocalSharerRecipient
= LocalSharerDirect LocalSharerRecipientDirect = LocalSharerDirect LocalSharerRecipientDirect
| LocalSharerTicketRelated (KeyHashid TicketAuthorLocal) LocalTicketRecipientDirect | LocalSharerTicketRelated (KeyHashid TicketAuthorLocal) LocalTicketRecipientDirect
| LocalSharerPatchRelated (KeyHashid TicketAuthorLocal) LocalPatchRecipientDirect | LocalSharerProposalRelated (KeyHashid TicketAuthorLocal) LocalPatchRecipientDirect
| LocalProjectRelated PrjIdent LocalProjectRecipient | LocalProjectRelated PrjIdent LocalProjectRecipient
| LocalRepoRelated RpIdent LocalRepoRecipient | LocalRepoRelated RpIdent LocalRepoRecipient
deriving (Eq, Ord) deriving (Eq, Ord)
@ -237,9 +237,9 @@ groupedRecipientFromCollection
LocalSharerRelated shr $ LocalSharerRelated shr $
LocalSharerTicketRelated talkhid LocalTicketFollowerz LocalSharerTicketRelated talkhid LocalTicketFollowerz
groupedRecipientFromCollection groupedRecipientFromCollection
(LocalPersonCollectionSharerPatchFollowers shr talkhid) = (LocalPersonCollectionSharerProposalFollowers shr talkhid) =
LocalSharerRelated shr $ LocalSharerRelated shr $
LocalSharerPatchRelated talkhid LocalPatchFollowers LocalSharerProposalRelated talkhid LocalPatchFollowers
groupedRecipientFromCollection groupedRecipientFromCollection
(LocalPersonCollectionProjectTeam shr prj) = (LocalPersonCollectionProjectTeam shr prj) =
LocalSharerRelated shr $ LocalProjectRelated prj $ LocalSharerRelated shr $ LocalProjectRelated prj $
@ -265,9 +265,9 @@ groupedRecipientFromCollection
LocalSharerRelated shr $ LocalRepoRelated rp $ LocalSharerRelated shr $ LocalRepoRelated rp $
LocalRepoDirect LocalRepoFollowers LocalRepoDirect LocalRepoFollowers
groupedRecipientFromCollection groupedRecipientFromCollection
(LocalPersonCollectionRepoPatchFollowers shr rp ltkhid) = (LocalPersonCollectionRepoProposalFollowers shr rp ltkhid) =
LocalSharerRelated shr $ LocalRepoRelated rp $ LocalSharerRelated shr $ LocalRepoRelated rp $
LocalRepoPatchRelated ltkhid LocalPatchFollowers LocalRepoProposalRelated ltkhid LocalPatchFollowers
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Recipient set types -- Recipient set types
@ -314,7 +314,7 @@ data LocalRepoDirectSet = LocalRepoDirectSet
data LocalRepoRelatedSet = LocalRepoRelatedSet data LocalRepoRelatedSet = LocalRepoRelatedSet
{ localRecipRepoDirect { localRecipRepoDirect
:: LocalRepoDirectSet :: LocalRepoDirectSet
, localRecipRepoPatchRelated , localRecipRepoProposalRelated
:: [(KeyHashid LocalTicket, LocalPatchDirectSet)] :: [(KeyHashid LocalTicket, LocalPatchDirectSet)]
} }
deriving Eq deriving Eq
@ -330,7 +330,7 @@ data LocalSharerRelatedSet = LocalSharerRelatedSet
:: LocalSharerDirectSet :: LocalSharerDirectSet
, localRecipSharerTicketRelated , localRecipSharerTicketRelated
:: [(KeyHashid TicketAuthorLocal, LocalTicketDirectSet)] :: [(KeyHashid TicketAuthorLocal, LocalTicketDirectSet)]
, localRecipSharerPatchRelated , localRecipSharerProposalRelated
:: [(KeyHashid TicketAuthorLocal, LocalPatchDirectSet)] :: [(KeyHashid TicketAuthorLocal, LocalPatchDirectSet)]
, localRecipProjectRelated , localRecipProjectRelated
:: [(PrjIdent, LocalProjectRelatedSet)] :: [(PrjIdent, LocalProjectRelatedSet)]
@ -358,7 +358,7 @@ groupLocalRecipients
(d:ds, ts, ps, js, rs) (d:ds, ts, ps, js, rs)
LocalSharerTicketRelated talkhid ltr -> LocalSharerTicketRelated talkhid ltr ->
(ds, (talkhid, ltr):ts, ps, js, rs) (ds, (talkhid, ltr):ts, ps, js, rs)
LocalSharerPatchRelated talkhid lpr -> LocalSharerProposalRelated talkhid lpr ->
(ds, ts, (talkhid, lpr):ps, js, rs) (ds, ts, (talkhid, lpr):ps, js, rs)
LocalProjectRelated prj ljr -> LocalProjectRelated prj ljr ->
(ds, ts, ps, (prj, ljr):js, rs) (ds, ts, ps, (prj, ljr):js, rs)
@ -411,7 +411,7 @@ groupLocalRecipients
lrr2set = uncurry mk . partitionEithers . map lrr2e . NE.toList lrr2set = uncurry mk . partitionEithers . map lrr2e . NE.toList
where where
lrr2e (LocalRepoDirect d) = Left d lrr2e (LocalRepoDirect d) = Left d
lrr2e (LocalRepoPatchRelated num ltrs) = Right (num, ltrs) lrr2e (LocalRepoProposalRelated num ltrs) = Right (num, ltrs)
mk ds ps = mk ds ps =
LocalRepoRelatedSet LocalRepoRelatedSet
(lrrs2set ds) (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 if patch
then do then do
(Entity _ tal, Entity _ lt, _, _, _, _) <- do (Entity _ tal, Entity _ lt, _, _, _, _) <- do
mticket <- lift $ getSharerPatch shr talid mticket <- lift $ getSharerProposal shr talid
fromMaybeE mticket "Context: No such sharer-patch" fromMaybeE mticket "Context: No such sharer-patch"
return (tal, lt, LocalPersonCollectionSharerPatchFollowers) return (tal, lt, LocalPersonCollectionSharerProposalFollowers)
else do else do
(Entity _ tal, Entity _ lt, _, _, _) <- do (Entity _ tal, Entity _ lt, _, _, _) <- do
mticket <- lift $ getSharerTicket shr talid mticket <- lift $ getSharerTicket shr talid
@ -297,12 +297,12 @@ sharerCreateNoteF now shrRecip author body mfwd luCreate note = do
case mractid of case mractid of
Nothing -> "I already have this activity in my inbox, doing nothing" Nothing -> "I already have this activity in my inbox, doing nothing"
Just _ -> "Context is a project-ticket, so just inserting to my inbox" 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 personRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid getValBy404 $ UniquePersonIdent sid
(_, _, _, Entity _ lt, _, _, _, _, _) <- do (_, _, _, Entity _ lt, _, _, _, _, _) <- do
mticket <- lift $ getRepoPatch shr rp ltid mticket <- lift $ getRepoProposal shr rp ltid
fromMaybeE mticket "Context: No such repo-patch" fromMaybeE mticket "Context: No such repo-patch"
let did = localTicketDiscuss lt let did = localTicketDiscuss lt
_ <- traverse (getParent did) mparent _ <- traverse (getParent did) mparent
@ -429,7 +429,7 @@ projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate note = do
Right (sig, remotesHttp) -> do Right (sig, remotesHttp) -> do
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp 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" 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 where
getProjectRecip404 = do getProjectRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
@ -456,7 +456,7 @@ repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(rid, ibid) <- lift getRepoRecip404 (rid, ibid) <- lift getRepoRecip404
(_, _, _, repo, _, _) <- do (_, _, _, repo, _, _) <- do
mticket <- lift $ getSharerPatch shr talid mticket <- lift $ getSharerProposal shr talid
fromMaybeE mticket "Context: No such sharer-ticket" fromMaybeE mticket "Context: No such sharer-ticket"
case repo of case repo of
Left (_, Entity _ trl) 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" return "Stored to inbox and did inbox forwarding"
Left (NoteContextProjectTicket _ _ _) -> Left (NoteContextProjectTicket _ _ _) ->
return "Context is a project-ticket, ignoring activity" return "Context is a project-ticket, ignoring activity"
Left (NoteContextRepoPatch shr rp ltid) -> do Left (NoteContextRepoProposal shr rp ltid) -> do
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(rid, ibid) <- lift getRepoRecip404 (rid, ibid) <- lift getRepoRecip404
(_, _, _, Entity _ lt, _, Entity _ trl, _, _, _) <- do (_, _, _, Entity _ lt, _, Entity _ trl, _, _, _) <- do
mticket <- lift $ getRepoPatch shr rp ltid mticket <- lift $ getRepoProposal shr rp ltid
fromMaybeE mticket "Context: No such repo-patch" fromMaybeE mticket "Context: No such repo-patch"
if ticketRepoLocalRepo trl == rid if ticketRepoLocalRepo trl == rid
then do then do
@ -518,7 +518,7 @@ repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do
[] []
[ LocalPersonCollectionRepoFollowers shrRecip rpRecip [ LocalPersonCollectionRepoFollowers shrRecip rpRecip
, LocalPersonCollectionRepoTeam shrRecip rpRecip , LocalPersonCollectionRepoTeam shrRecip rpRecip
, LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid , LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
--, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
] ]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips 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 collections =
[ let coll = [ let coll =
if patch if patch
then LocalPersonCollectionSharerPatchFollowers then LocalPersonCollectionSharerProposalFollowers
else LocalPersonCollectionSharerTicketFollowers else LocalPersonCollectionSharerTicketFollowers
in coll shr talkhid in coll shr talkhid
] ]
@ -425,7 +425,7 @@ sharerFollowF shr =
| shr == shr' = Just Nothing | shr == shr' = Just Nothing
objRoute (SharerTicketR shr' talkhid) objRoute (SharerTicketR shr' talkhid)
| shr == shr' = Just $ Just (talkhid, False) | shr == shr' = Just $ Just (talkhid, False)
objRoute (SharerPatchR shr' talkhid) objRoute (SharerProposalR shr' talkhid)
| shr == shr' = Just $ Just (talkhid, True) | shr == shr' = Just $ Just (talkhid, True)
objRoute _ = Nothing objRoute _ = Nothing
@ -436,7 +436,7 @@ sharerFollowF shr =
talid <- decodeKeyHashidM talkhid talid <- decodeKeyHashidM talkhid
if patch if patch
then do then do
(_, Entity _ lt, _, _, _, _) <- MaybeT $ getSharerPatch shr talid (_, Entity _ lt, _, _, _, _) <- MaybeT $ getSharerProposal shr talid
return lt return lt
else do else do
(_, Entity _ lt, _, _, _) <- MaybeT $ getSharerTicket shr talid (_, Entity _ lt, _, _, _) <- MaybeT $ getSharerTicket shr talid
@ -514,7 +514,7 @@ repoFollowF shr rp =
where where
objRoute (RepoR shr' rp') objRoute (RepoR shr' rp')
| shr == shr' && rp == rp' = Just Nothing | shr == shr' && rp == rp' = Just Nothing
objRoute (RepoPatchR shr' rp' ltkhid) objRoute (RepoProposalR shr' rp' ltkhid)
| shr == shr' && rp == rp' = Just $ Just ltkhid | shr == shr' && rp == rp' = Just $ Just ltkhid
objRoute _ = Nothing objRoute _ = Nothing
@ -523,7 +523,7 @@ repoFollowF shr rp =
r <- getValBy404 $ UniqueRepo rp sid r <- getValBy404 $ UniqueRepo rp sid
mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do
ltid <- decodeKeyHashidM ltkhid ltid <- decodeKeyHashidM ltkhid
(_, _, _, Entity _ lt, _, _, _, _, _) <- MaybeT $ getRepoPatch shr rp ltid (_, _, _, Entity _ lt, _, _, _, _, _) <- MaybeT $ getRepoProposal shr rp ltid
return lt return lt
return $ return $
case mmt of case mmt of
@ -692,7 +692,7 @@ sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do
let ObjURI hAuthor luAuthor = remoteAuthorURI author let ObjURI hAuthor luAuthor = remoteAuthorURI author
ticketFollowers = ticketFollowers =
if patch if patch
then LocalPersonCollectionSharerPatchFollowers shrRecip talkhid then LocalPersonCollectionSharerProposalFollowers shrRecip talkhid
else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
audAuthor = audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
@ -866,7 +866,7 @@ repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do
Just _ -> "Sent Accept" Just _ -> "Sent Accept"
return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
where where
myWorkItem (WorkItemRepoPatch shr rp ltid) myWorkItem (WorkItemRepoProposal shr rp ltid)
| shr == shrRecip && rp == rpRecip = Just ltid | shr == shrRecip && rp == rpRecip = Just ltid
myWorkItem _ = Nothing myWorkItem _ = Nothing
@ -875,7 +875,7 @@ repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do
ra <- getJust $ remoteAuthorId author ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author let ObjURI hAuthor luAuthor = remoteAuthorURI author
ticketFollowers = ticketFollowers =
LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
audAuthor = audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
audTicket = audTicket =

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

@ -102,7 +102,7 @@ checkOfferTicket
-> ExceptT -> ExceptT
Text Text
Handler Handler
( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
, TextHtml , TextHtml
, TextHtml , TextHtml
, TextPandocMarkdown , TextPandocMarkdown
@ -147,14 +147,14 @@ checkOfferTicket author ticket uTarget = do
return (muContext, summary, content, source, mmr') return (muContext, summary, content, source, mmr')
where where
checkMR h (MergeRequest muOrigin luTarget epatch) = do checkMR h (MergeRequest muOrigin luTarget ebundle) = do
verifyNothingE muOrigin "MR with 'origin'" verifyNothingE muOrigin "MR with 'origin'"
branch <- checkBranch h luTarget branch <- checkBranch h luTarget
(typ, content) <- (typ, diffs) <-
case epatch of case ebundle of
Left _ -> throwE "MR patch specified as a URI" Left _ -> throwE "MR bundle specified as a URI"
Right (hPatch, patch) -> checkPatch hPatch patch Right (hBundle, bundle) -> checkBundle hBundle bundle
return (branch, typ, content) return (branch, typ, diffs)
where where
checkBranch h lu = do checkBranch h lu = do
hl <- hostIsLocal h hl <- hostIsLocal h
@ -172,17 +172,25 @@ checkOfferTicket author ticket uTarget = do
"MR target is a valid local route, but isn't a \ "MR target is a valid local route, but isn't a \
\repo or branch route" \repo or branch route"
else return $ Right $ ObjURI h lu else return $ Right $ ObjURI h lu
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do checkBundle _ (AP.BundleHosted _ _) =
verifyNothingE mlocal "Patch with 'id'" throwE "Patches specified as URIs"
unless (ObjURI h attrib == remoteAuthorURI author) $ checkBundle h (AP.BundleOffer mlocal patches) = do
throwE "Ticket and Patch attrib mismatch" verifyNothingE mlocal "Bundle with 'id'"
verifyNothingE mpub "Patch has 'published'" (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches
return (typ, content) unless (all (== typ) typs) $ throwE "Different patch types"
return (typ, diffs)
where
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
verifyNothingE mlocal "Patch with 'id'"
unless (ObjURI h attrib == remoteAuthorURI author) $
throwE "Ticket and Patch attrib mismatch"
verifyNothingE mpub "Patch has 'published'"
return (typ, content)
matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj
matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" matchTargetAndMR (Left (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))) 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' <- branch' <-
case branch of case branch of
Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
@ -195,21 +203,21 @@ checkOfferTicket author ticket uTarget = do
VCSGit -> VCSGit ->
unless (isJust branch') $ unless (isJust branch') $
throwE "Git MR doesn't specify the 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 where
typ2vcs PatchTypeDarcs = VCSDarcs typ2vcs PatchTypeDarcs = VCSDarcs
matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) 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 <- luBranch <-
case branch of case branch of
Right (ObjURI h' lu') | h == h' -> return lu Right (ObjURI h' lu') | h == h' -> return lu
_ -> throwE "MR target repo/branch and Offer target repo mismatch" _ -> throwE "MR target repo/branch and Offer target repo mismatch"
let patch = let bundle =
( if lu == luBranch then Nothing else Just luBranch ( if lu == luBranch then Nothing else Just luBranch
, typ , typ
, content , diffs
) )
return $ Right (h, lu, Just patch) return $ Right (h, lu, Just bundle)
sharerOfferTicketF sharerOfferTicketF
:: UTCTime :: UTCTime
@ -228,12 +236,12 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
personInbox <$> getValBy404 (UniquePersonIdent sid) personInbox <$> getValBy404 (UniquePersonIdent sid)
case target of case target of
Left (WTTProject shr prj) -> do Left (WITProject shr prj) -> do
mjid <- lift $ runMaybeT $ do mjid <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniqueProject prj sid MaybeT $ getKeyBy $ UniqueProject prj sid
void $ fromMaybeE mjid "Offer target: No such local project" void $ fromMaybeE mjid "Offer target: No such local project"
Left (WTTRepo shr rp _ _ _) -> do Left (WITRepo shr rp _ _ _) -> do
mrid <- lift $ runMaybeT $ do mrid <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniqueRepo rp sid 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" Nothing -> "Accepted new ticket, no inbox-forwarding to do"
Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer" Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer"
where where
targetRelevance (Left (WTTProject shr prj)) targetRelevance (Left (WITProject shr prj))
| shr == shrRecip && prj == prjRecip = Just () | shr == shrRecip && prj == prjRecip = Just ()
targetRelevance _ = Nothing targetRelevance _ = Nothing
insertAccept shr prj author luOffer ltid obiidAccept = do insertAccept shr prj author luOffer ltid obiidAccept = do
@ -394,7 +402,7 @@ repoOfferTicketF
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = do repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = do
(target, summary, content, source) <- checkOfferTicket author ticket uTarget (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 Entity rid r <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueRepo rpRecip sid getBy404 $ UniqueRepo rpRecip sid
@ -418,7 +426,8 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =
obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
let makeTRL tclid = TicketRepoLocal tclid rid mb let makeTRL tclid = TicketRepoLocal tclid rid mb
(tid, ltid) <- insertLocalTicket now author makeTRL summary content source ractid obiidAccept (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) <- (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept shrRecip rpRecip author luOffer ltid obiidAccept insertAccept shrRecip rpRecip author luOffer ltid obiidAccept
knownRemoteRecipsAccept <- knownRemoteRecipsAccept <-
@ -447,8 +456,8 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =
Nothing -> "Accepted new patch, no inbox-forwarding to do" Nothing -> "Accepted new patch, no inbox-forwarding to do"
Just _ -> "Accepted new patch and ran inbox-forwarding of the Offer" Just _ -> "Accepted new patch and ran inbox-forwarding of the Offer"
where where
targetRelevance (Left (WTTRepo shr rp mb vcs diff)) targetRelevance (Left (WITRepo shr rp mb vcs diffs))
| shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff) | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diffs)
targetRelevance _ = Nothing targetRelevance _ = Nothing
insertAccept shr rp author luOffer ltid obiidAccept = do insertAccept shr rp author luOffer ltid obiidAccept = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -485,29 +494,29 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =
, activitySpecific = AcceptActivity Accept , activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hAuthor luOffer { acceptObject = ObjURI hAuthor luOffer
, acceptResult = , acceptResult =
Just $ encodeRouteLocal $ RepoPatchR shr rp ltkhid Just $ encodeRouteLocal $ RepoProposalR shr rp ltkhid
} }
} }
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts) return (doc, recipientSet, remoteActors, fwdHosts)
data RemotePatch = RemotePatch data RemoteBundle = RemoteBundle
{ rpBranch :: Maybe LocalURI { rpBranch :: Maybe LocalURI
, rpType :: PatchType , rpType :: PatchType
, rpContent :: Text , rpDiffs :: NonEmpty Text
} }
data RemoteWorkItem = RemoteWorkItem data RemoteWorkItem = RemoteWorkItem
{ rwiHost :: Host { rwiHost :: Host
, rwiTarget :: Maybe LocalURI , rwiTarget :: Maybe LocalURI
, rwiContext :: LocalURI , rwiContext :: LocalURI
, rwiPatch :: Maybe RemotePatch , rwiBundle :: Maybe RemoteBundle
} }
data RemoteWorkItem' = RemoteWorkItem' data RemoteWorkItem' = RemoteWorkItem'
{ rwiHost' :: Host { rwiHost' :: Host
, rwiContext' :: LocalURI , rwiContext' :: LocalURI
, rwiPatch' :: Maybe RemotePatch , rwiBundle' :: Maybe RemoteBundle
} }
data ParsedCreateTicket = ParsedCreateTicket data ParsedCreateTicket = ParsedCreateTicket
@ -559,7 +568,7 @@ checkCreateTicket author ticket muTarget = do
checkTicket checkTicket
:: AP.Ticket URIMode :: AP.Ticket URIMode
-> ExceptT Text Handler -> ExceptT Text Handler
( Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch) ( Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle)
, TicketLocal , TicketLocal
, UTCTime , UTCTime
, TextHtml , TextHtml
@ -583,29 +592,28 @@ checkCreateTicket author ticket muTarget = do
verifyNothingE muAssigned "Ticket has 'assignedTo'" verifyNothingE muAssigned "Ticket has 'assignedTo'"
when (isJust mresolved) $ throwE "Ticket is resolved" 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' context' <- matchTicketAndMR (AP.ticketId tlocal) pub context mmr'
return (context', tlocal, pub, summary, content, source) return (context', tlocal, pub, summary, content, source)
where where
checkMR checkMR
:: Host :: LocalURI
-> Host
-> MergeRequest URIMode -> MergeRequest URIMode
-> ExceptT Text Handler -> ExceptT Text Handler
( Either (ShrIdent, RpIdent, Maybe Text) FedURI ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, Maybe (LocalURI, LocalURI)
, Maybe UTCTime
, PatchType , 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'" verifyNothingE muOrigin "MR with 'origin'"
branch <- checkBranch h luTarget branch <- checkBranch h luTarget
(mlocal, mpub, typ, content) <- (typ, patches) <-
case epatch of case ebundle of
Left _ -> throwE "MR patch specified as a URI" Left _ -> throwE "MR bundle specified as a URI"
Right (hPatch, patch) -> checkPatch hPatch patch Right (hBundle, bundle) -> checkBundle hBundle bundle
return (branch, mlocal, mpub, typ, content) return (branch, typ, patches)
where where
checkBranch checkBranch
:: Host :: Host
@ -628,29 +636,48 @@ checkCreateTicket author ticket muTarget = do
"MR target is a valid local route, but isn't a \ "MR target is a valid local route, but isn't a \
\repo or branch route" \repo or branch route"
else return $ Right $ ObjURI h lu else return $ Right $ ObjURI h lu
checkPatch checkBundle _ (AP.BundleHosted _ _) =
:: Host throwE "Patches specified as URIs"
-> AP.Patch URIMode checkBundle h (AP.BundleOffer mblocal patches) = do
-> ExceptT Text Handler for_ mblocal $ \ (h', BundleLocal _luId luCtx prevs mcurr) -> do
( Maybe (LocalURI, LocalURI) unless (h == h') $
, Maybe UTCTime throwE "Bundle and author hosts differ"
, PatchType unless (luCtx == luTicket) $
, Text throwE "Bundle 'context' doesn't match Ticket 'id'"
) unless (null prevs) $
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do throwE "Bundle has previous versions"
mlocal' <- unless (isNothing mcurr) $
for mlocal $ throwE "Bundle has a more recent version"
\ (h', PatchLocal luId luContext versions mcurr) -> do (mlocal, mpub, typ, diff) :| patches' <- traverse (checkPatch h) patches
unless (h == h') $ patches'' <- for patches' $ \ (mlocal', mpub', typ', diff') -> do
throwE "Patch & its author on different hosts" mluId <- for mlocal' $ \ (luId', luContext') -> do
unless (null versions) $ for_ mlocal $ \ (_, luContext) ->
throwE "Patch has versions" unless (luContext == luContext') $
unless (isNothing mcurr) $ throwE "Patches have different context"
throwE "Patch has 'currentVersion'" return luId'
return (luId, luContext) unless (typ == typ') $ throwE "Different patch types"
unless (ObjURI h attrib == remoteAuthorURI author) $ return (mluId, mpub', diff')
throwE "Ticket & Patch attrib mismatch" return (typ, (fst <$> mlocal, mpub, diff) :| patches'')
return (mlocal', mpub, typ, content) where
checkPatch
:: Host
-> AP.Patch URIMode
-> ExceptT Text Handler
( Maybe (LocalURI, LocalURI)
, Maybe UTCTime
, PatchType
, Text
)
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
mlocal' <-
for mlocal $
\ (h', PatchLocal luId luContext) -> do
unless (h == h') $
throwE "Patch & its author on different hosts"
return (luId, luContext)
unless (ObjURI h attrib == remoteAuthorURI author) $
throwE "Ticket & Patch attrib mismatch"
return (mlocal', mpub, typ, content)
matchTicketAndMR matchTicketAndMR
:: LocalURI :: LocalURI
-> UTCTime -> UTCTime
@ -659,27 +686,18 @@ checkCreateTicket author ticket muTarget = do
FedURI FedURI
-> Maybe -> Maybe
( Either (ShrIdent, RpIdent, Maybe Text) FedURI ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, Maybe (LocalURI, LocalURI)
, Maybe UTCTime
, PatchType , PatchType
, Text , NonEmpty (Maybe LocalURI, Maybe UTCTime, Text)
) )
-> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch)) -> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle))
matchTicketAndMR _ _ (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj matchTicketAndMR _ _ (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj
matchTicketAndMR _ _ (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" matchTicketAndMR _ _ (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
matchTicketAndMR _ _ (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" 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' <- branch' <-
case branch of case branch of
Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
_ -> throwE "MR target repo/branch and Offer target repo mismatch" _ -> 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 let vcs = typ2vcs typ
case vcs of case vcs of
VCSDarcs -> VCSDarcs ->
@ -688,58 +706,61 @@ checkCreateTicket author ticket muTarget = do
VCSGit -> VCSGit ->
unless (isJust branch') $ unless (isJust branch') $
throwE "Git MR doesn't specify the 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 where
typ2vcs PatchTypeDarcs = VCSDarcs typ2vcs PatchTypeDarcs = VCSDarcs
matchTicketAndMR _ _ (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) 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 <- luBranch <-
case branch of case branch of
Right (ObjURI h' lu') | h == h' -> return lu Right (ObjURI h' lu') | h == h' -> return lu
_ -> throwE "MR target repo/branch and Offer target repo mismatch" _ -> throwE "MR target repo/branch and Offer target repo mismatch"
_mluPatch <- for mlocal $ \ (luPatch, luPatchContext) -> do diffs <- for patches $ \ (_mluId, mpub, diff) -> do
unless (luPatchContext == luTicket) $ for_ mpub $ \ pub' ->
throwE "Patch 'context' != Ticket 'id'" unless (pub == pub') $
return luPatch throwE "Ticket & Patch 'published' differ"
for_ mpub $ \ pub' -> return diff
unless (pub == pub') $ let bundle =
throwE "Ticket & Patch 'published' differ" RemoteBundle
let patch =
RemotePatch
(if lu == luBranch then Nothing else Just luBranch) (if lu == luBranch then Nothing else Just luBranch)
typ typ
content diffs
return $ Right (h, lu, Just patch) return $ Right (h, lu, Just bundle)
checkTargetAndContext checkTargetAndContext
:: Maybe :: Maybe
( Either ( Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI FedURI
) )
-> Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch) -> Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle)
-> ExceptT Text Handler (Either (Bool, WorkItemTarget) RemoteWorkItem) -> ExceptT Text Handler (Either (Bool, WorkItemTarget) RemoteWorkItem)
checkTargetAndContext Nothing context = checkTargetAndContext Nothing context =
return $ return $
case context of case context of
Left wit -> Left (False, wit) 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 = checkTargetAndContext (Just target) context =
case (target, context) of case (target, context) of
(Left _, Right _) -> (Left _, Right _) ->
throwE "Create target is local but ticket context is remote" throwE "Create target is local but ticket context is remote"
(Right _, Left _) -> (Right _, Left _) ->
throwE "Create target is remote but ticket context is local" 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 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 \ else throwE "Create target and ticket context on \
\different remote hosts" \different remote hosts"
(Left proj, Left wit) -> (Left proj, Left wit) ->
case (proj, wit) of case (proj, wit) of
(Left (shr, prj), WTTProject shr' prj') (Left (shr, prj), WITProject shr' prj')
| shr == shr' && prj == prj' -> | shr == shr' && prj == prj' ->
return $ Left (True, wit) return $ Left (True, wit)
(Right (shr, rp), WTTRepo shr' rp' _ _ _) (Right (shr, rp), WITRepo shr' rp' _ _ _)
| shr == shr' && rp == rp' -> | shr == shr' && rp == rp' ->
return $ Left (True, wit) return $ Left (True, wit)
_ -> throwE _ -> throwE
@ -769,12 +790,12 @@ sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
Nothing -> "Activity already exists in my inbox" Nothing -> "Activity already exists in my inbox"
Just _ -> "Activity inserted to my inbox" Just _ -> "Activity inserted to my inbox"
where where
checkTargetAndContextDB (Left (_, WTTProject shr prj)) = do checkTargetAndContextDB (Left (_, WITProject shr prj)) = do
mj <- lift $ runMaybeT $ do mj <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid MaybeT $ getBy $ UniqueProject prj sid
unless (isJust mj) $ throwE "Local context: No such project" 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 mr <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueRepo rp sid 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" Nothing -> "Accepted and listed ticket, no inbox-forwarding to do"
Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create" Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create"
where where
targetRelevance (Left (_, WTTProject shr prj)) targetRelevance (Left (_, WITProject shr prj))
| shr == shrRecip && prj == prjRecip = Just () | shr == shrRecip && prj == prjRecip = Just ()
targetRelevance _ = Nothing targetRelevance _ = Nothing
@ -984,7 +1005,7 @@ repoCreateTicketF
repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do
ParsedCreateTicket targetAndContext tlocal published title desc src <- ParsedCreateTicket targetAndContext tlocal published title desc src <-
checkCreateTicket author ticket muTarget 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 Entity rid r <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueRepo rpRecip sid 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 result <- insertRemoteTicket mkTRL author (AP.ticketId tlocal) published title desc src ractid obiidAccept
unless (isRight result) $ delete obiidAccept unless (isRight result) $ delete obiidAccept
for result $ \ tid -> do 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 mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
let sieve = let sieve =
makeRecipientSet 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" Nothing -> "Accepted and listed MR, no inbox-forwarding to do"
Just _ -> "Accepted and listed MR and ran inbox-forwarding of the Create" Just _ -> "Accepted and listed MR and ran inbox-forwarding of the Create"
where where
targetRelevance (Left (_, WTTRepo shr rp mb vcs diff)) targetRelevance (Left (_, WITRepo shr rp mb vcs diffs))
| shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff) | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diffs)
targetRelevance _ = Nothing targetRelevance _ = Nothing
sharerOfferDepF sharerOfferDepF
@ -1076,7 +1098,7 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do
if patch if patch
then do then do
(_, Entity ltid _, _, context, _, _) <- do (_, Entity ltid _, _, context, _, _) <- do
mticket <- lift $ getSharerPatch shrRecip talid mticket <- lift $ getSharerProposal shrRecip talid
fromMaybeE mticket $ "Parent" <> ": No such sharer-patch" fromMaybeE mticket $ "Parent" <> ": No such sharer-patch"
context' <- context' <-
lift $ lift $
@ -1170,7 +1192,7 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do
if patch if patch
then do then do
(_, Entity ltid _, _, _, _, _) <- do (_, Entity ltid _, _, _, _, _) <- do
mticket <- lift $ getSharerPatch shrRecip talid mticket <- lift $ getSharerProposal shrRecip talid
fromMaybeE mticket $ "Child" <> ": No such sharer-patch" fromMaybeE mticket $ "Child" <> ": No such sharer-patch"
return ltid return ltid
else do else do
@ -1189,7 +1211,7 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do
followers hashTALID (talid, patch) = followers hashTALID (talid, patch) =
let coll = let coll =
if patch if patch
then LocalPersonCollectionSharerPatchFollowers then LocalPersonCollectionSharerProposalFollowers
else LocalPersonCollectionSharerTicketFollowers else LocalPersonCollectionSharerTicketFollowers
in coll shrRecip (hashTALID talid) in coll shrRecip (hashTALID talid)
insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, WorkItemDetail childId childCtx childAuthor) = do 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 -> return $ \ talid patch ->
let coll = let coll =
if patch if patch
then LocalPersonCollectionSharerPatchFollowers then LocalPersonCollectionSharerProposalFollowers
else LocalPersonCollectionSharerTicketFollowers else LocalPersonCollectionSharerTicketFollowers
in coll shrRecip (hashTALID talid) 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 for (ticketRelevance shrRecip rpRecip parent) $ \ parentLtid -> do
parentAuthor <- runSiteDBExcept $ do parentAuthor <- runSiteDBExcept $ do
(_, _, _, _, _, _, author, _, _) <- do (_, _, _, _, _, _, author, _, _) <- do
mticket <- lift $ getRepoPatch shrRecip rpRecip parentLtid mticket <- lift $ getRepoProposal shrRecip rpRecip parentLtid
fromMaybeE mticket $ "Parent" <> ": No such repo-patch" fromMaybeE mticket $ "Parent" <> ": No such repo-patch"
lift $ getWorkItemAuthorDetail author lift $ getWorkItemAuthorDetail author
childDetail <- getWorkItemDetail "Child" child 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 _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do"
(Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer" (Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer"
where where
ticketRelevance shr rp (Left (WorkItemRepoPatch shr' rp' ltid)) ticketRelevance shr rp (Left (WorkItemRepoProposal shr' rp' ltid))
| shr == shr' && rp == rp' = Just ltid | shr == shr' && rp == rp' = Just ltid
ticketRelevance _ _ _ = Nothing ticketRelevance _ _ _ = Nothing
insertDepOffer _ (Left _) _ = return () insertDepOffer _ (Left _) _ = return ()
insertDepOffer ibiidOffer (Right _) child = insertDepOffer ibiidOffer (Right _) child =
for_ (ticketRelevance shrRecip rpRecip child) $ \ ltid -> do for_ (ticketRelevance shrRecip rpRecip child) $ \ ltid -> do
_ <- do _ <- do
mticket <- lift $ getRepoPatch shrRecip rpRecip ltid mticket <- lift $ getRepoProposal shrRecip rpRecip ltid
fromMaybeE mticket $ "Child" <> ": No such repo-patch" fromMaybeE mticket $ "Child" <> ": No such repo-patch"
lift $ insert_ TicketDependencyOffer lift $ insert_ TicketDependencyOffer
{ ticketDependencyOfferOffer = ibiidOffer { 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 \ shr rp wi -> followers hashLTID <$> ticketRelevance shr rp wi
where where
followers hashLTID ltid = followers hashLTID ltid =
LocalPersonCollectionRepoPatchFollowers LocalPersonCollectionRepoProposalFollowers
shrRecip rpRecip (hashLTID ltid) shrRecip rpRecip (hashLTID ltid)
insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -1606,20 +1628,20 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do
hashLTID <- getEncodeKeyHashid hashLTID <- getEncodeKeyHashid
return $ return $
\ ltid -> \ ltid ->
LocalPersonCollectionRepoPatchFollowers LocalPersonCollectionRepoProposalFollowers
shrRecip rpRecip (hashLTID ltid) shrRecip rpRecip (hashLTID ltid)
verifyWorkItemExists (WorkItemSharerTicket shr talid False) = do verifyWorkItemExists (WorkItemSharerTicket shr talid False) = do
mticket <- lift $ getSharerTicket shr talid mticket <- lift $ getSharerTicket shr talid
verifyNothingE mticket $ "Object" <> ": No such sharer-ticket" verifyNothingE mticket $ "Object" <> ": No such sharer-ticket"
verifyWorkItemExists (WorkItemSharerTicket shr talid True) = do verifyWorkItemExists (WorkItemSharerTicket shr talid True) = do
mticket <- lift $ getSharerPatch shr talid mticket <- lift $ getSharerProposal shr talid
verifyNothingE mticket $ "Object" <> ": No such sharer-patch" verifyNothingE mticket $ "Object" <> ": No such sharer-patch"
verifyWorkItemExists (WorkItemProjectTicket shr prj ltid) = do verifyWorkItemExists (WorkItemProjectTicket shr prj ltid) = do
mticket <- lift $ getProjectTicket shr prj ltid mticket <- lift $ getProjectTicket shr prj ltid
verifyNothingE mticket $ "Object" <> ": No such project-ticket" verifyNothingE mticket $ "Object" <> ": No such project-ticket"
verifyWorkItemExists (WorkItemRepoPatch shr rp ltid) = do verifyWorkItemExists (WorkItemRepoProposal shr rp ltid) = do
mticket <- lift $ getRepoPatch shr rp ltid mticket <- lift $ getRepoProposal shr rp ltid
verifyNothingE mticket $ "Object" <> ": No such repo-patch" verifyNothingE mticket $ "Object" <> ": No such repo-patch"
insertResolve author ltid ractid obiidAccept = do insertResolve author ltid ractid obiidAccept = do
@ -1665,7 +1687,7 @@ sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do
let followers = let followers =
let collection = let collection =
if patch if patch
then LocalPersonCollectionSharerPatchFollowers then LocalPersonCollectionSharerProposalFollowers
else LocalPersonCollectionSharerTicketFollowers else LocalPersonCollectionSharerTicketFollowers
in collection shrRecip $ hashTALID talid in collection shrRecip $ hashTALID talid
sieve = sieve =
@ -1725,7 +1747,7 @@ sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do
getObjectLtid talid True = do getObjectLtid talid True = do
(_, Entity ltid _, Entity tid _, _, _, _) <- do (_, Entity ltid _, Entity tid _, _, _, _) <- do
mticket <- lift $ getSharerPatch shrRecip talid mticket <- lift $ getSharerProposal shrRecip talid
fromMaybeE mticket $ "Object" <> ": No such sharer-patch" fromMaybeE mticket $ "Object" <> ": No such sharer-patch"
return (ltid, tid) return (ltid, tid)
getObjectLtid talid False = do getObjectLtid talid False = do
@ -1749,7 +1771,7 @@ sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do
audTicket = audTicket =
let followers = let followers =
if patch if patch
then LocalPersonCollectionSharerPatchFollowers then LocalPersonCollectionSharerProposalFollowers
else LocalPersonCollectionSharerTicketFollowers else LocalPersonCollectionSharerTicketFollowers
in AudLocal [] [followers shrRecip talkhid] in AudLocal [] [followers shrRecip talkhid]
@ -1932,7 +1954,7 @@ repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) =
let sieve = let sieve =
makeRecipientSet makeRecipientSet
[] []
[ LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
, LocalPersonCollectionRepoTeam shrRecip rpRecip , LocalPersonCollectionRepoTeam shrRecip rpRecip
, LocalPersonCollectionRepoFollowers 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" then "Ticket is mine, now resolved, did inbox-forwarding"
else "Ticket is mine, now resolved, no inbox-forwarding to do" else "Ticket is mine, now resolved, no inbox-forwarding to do"
where where
relevantObject (Left (WorkItemRepoPatch shr rp ltid)) relevantObject (Left (WorkItemRepoProposal shr rp ltid))
| shr == shrRecip && rp == rpRecip = Just ltid | shr == shrRecip && rp == rpRecip = Just ltid
relevantObject _ = Nothing relevantObject _ = Nothing
getObjectLtid ltid = do getObjectLtid ltid = do
(_, _, Entity tid _, _, _, _, _, _, _) <- do (_, _, Entity tid _, _, _, _, _, _, _) <- do
mticket <- lift $ getRepoPatch shrRecip rpRecip ltid mticket <- lift $ getRepoProposal shrRecip rpRecip ltid
fromMaybeE mticket $ "Object" <> ": No such repo-patch" fromMaybeE mticket $ "Object" <> ": No such repo-patch"
return tid return tid
@ -2006,7 +2028,7 @@ repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) =
audTicket = audTicket =
AudLocal AudLocal
[] []
[ LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
, LocalPersonCollectionRepoTeam shrRecip rpRecip , LocalPersonCollectionRepoTeam shrRecip rpRecip
, LocalPersonCollectionRepoFollowers 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 Crypto.PublicVerifKey
import Network.FedURI import Network.FedURI
import Web.ActivityAccess import Web.ActivityAccess
import Web.ActivityPub hiding (Ticket, TicketDependency, Patch) import Web.ActivityPub hiding (Ticket, TicketDependency, Bundle, Patch)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -133,6 +133,7 @@ type LocalMessageKeyHashid = KeyHashid LocalMessage
type LocalTicketKeyHashid = KeyHashid LocalTicket type LocalTicketKeyHashid = KeyHashid LocalTicket
type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal
type TicketDepKeyHashid = KeyHashid LocalTicketDependency type TicketDepKeyHashid = KeyHashid LocalTicketDependency
type BundleKeyHashid = KeyHashid Bundle
type PatchKeyHashid = KeyHashid Patch type PatchKeyHashid = KeyHashid Patch
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full

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

@ -14,23 +14,25 @@
-} -}
module Vervis.Handler.Patch module Vervis.Handler.Patch
( getSharerPatchesR ( getSharerProposalsR
, getSharerPatchR , getSharerProposalR
, getSharerPatchDiscussionR , getSharerProposalDiscussionR
, getSharerPatchDepsR , getSharerProposalDepsR
, getSharerPatchReverseDepsR , getSharerProposalReverseDepsR
, getSharerPatchFollowersR , getSharerProposalFollowersR
, getSharerPatchEventsR , getSharerProposalEventsR
, getSharerPatchVersionR , getSharerProposalBundleR
, getSharerProposalBundlePatchR
, getRepoPatchesR , getRepoProposalsR
, getRepoPatchR , getRepoProposalR
, getRepoPatchDiscussionR , getRepoProposalDiscussionR
, getRepoPatchDepsR , getRepoProposalDepsR
, getRepoPatchReverseDepsR , getRepoProposalReverseDepsR
, getRepoPatchFollowersR , getRepoProposalFollowersR
, getRepoPatchEventsR , getRepoProposalEventsR
, getRepoPatchVersionR , getRepoProposalBundleR
, getRepoProposalBundlePatchR
) )
where where
@ -38,7 +40,7 @@ import Control.Monad
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.Function import Data.Function
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
@ -50,7 +52,7 @@ import qualified Data.List.Ordered as LO
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Ticket (..), Patch (..)) import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -73,9 +75,9 @@ import Vervis.Paginate
import Vervis.Patch import Vervis.Patch
import Vervis.Ticket import Vervis.Ticket
getSharerPatchesR :: ShrIdent -> Handler TypedContent getSharerProposalsR :: ShrIdent -> Handler TypedContent
getSharerPatchesR = getSharerProposalsR =
getSharerWorkItems SharerPatchesR SharerPatchR countPatches selectPatches getSharerWorkItems SharerProposalsR SharerProposalR countPatches selectPatches
where where
countPatches pid = fmap toOne $ countPatches pid = fmap toOne $
E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do 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.&&. tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
E.isNothing (tup E.?. TicketUnderProjectId) E.&&. E.isNothing (tup E.?. TicketUnderProjectId) E.&&.
E.exists E.exists
(E.from $ \ pt -> (E.from $ \ bn ->
E.where_ $ lt E.^. LocalTicketTicket E.==. pt E.^. PatchTicket E.where_ $ lt E.^. LocalTicketTicket E.==. bn E.^. BundleTicket
) )
return $ E.count $ tal E.^. TicketAuthorLocalId return $ E.count $ tal E.^. TicketAuthorLocalId
where where
@ -101,20 +103,20 @@ getSharerPatchesR =
tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
E.isNothing (tup E.?. TicketUnderProjectId) E.&&. E.isNothing (tup E.?. TicketUnderProjectId) E.&&.
E.exists E.exists
(E.from $ \ pt -> (E.from $ \ bn ->
E.where_ $ lt E.^. LocalTicketTicket E.==. pt E.^. PatchTicket E.where_ $ lt E.^. LocalTicketTicket E.==. bn E.^. BundleTicket
) )
E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId] E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId]
E.offset $ fromIntegral off E.offset $ fromIntegral off
E.limit $ fromIntegral lim E.limit $ fromIntegral lim
return $ tal E.^. TicketAuthorLocalId return $ tal E.^. TicketAuthorLocalId
getSharerPatchR getSharerProposalR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchR shr talkhid = do getSharerProposalR shr talkhid = do
(ticket, ptid, repo, massignee) <- runDB $ do (ticket, bnid, repo, massignee) <- runDB $ do
(_, _, Entity tid t, tp, _, ptid :| _) <- getSharerPatch404 shr talkhid (_, _, Entity tid t, tp, _, bnid :| _) <- getSharerProposal404 shr talkhid
(,,,) t ptid (,,,) t bnid
<$> bitraverse <$> bitraverse
(\ (_, Entity _ trl) -> do (\ (_, Entity _ trl) -> do
r <- getJust $ ticketRepoLocalRepo trl r <- getJust $ ticketRepoLocalRepo trl
@ -140,24 +142,24 @@ getSharerPatchR shr talkhid = do
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodePatchId <- getEncodeKeyHashid encodeBundleId <- getEncodeKeyHashid
let patchAP = AP.Ticket let ticketAP = AP.Ticket
{ AP.ticketLocal = Just { AP.ticketLocal = Just
( hLocal ( hLocal
, AP.TicketLocal , AP.TicketLocal
{ AP.ticketId = { AP.ticketId =
encodeRouteLocal $ SharerPatchR shr talkhid encodeRouteLocal $ SharerProposalR shr talkhid
, AP.ticketReplies = , AP.ticketReplies =
encodeRouteLocal $ SharerPatchDiscussionR shr talkhid encodeRouteLocal $ SharerProposalDiscussionR shr talkhid
, AP.ticketParticipants = , AP.ticketParticipants =
encodeRouteLocal $ SharerPatchFollowersR shr talkhid encodeRouteLocal $ SharerProposalFollowersR shr talkhid
, AP.ticketTeam = Nothing , AP.ticketTeam = Nothing
, AP.ticketEvents = , AP.ticketEvents =
encodeRouteLocal $ SharerPatchEventsR shr talkhid encodeRouteLocal $ SharerProposalEventsR shr talkhid
, AP.ticketDeps = , AP.ticketDeps =
encodeRouteLocal $ SharerPatchDepsR shr talkhid encodeRouteLocal $ SharerProposalDepsR shr talkhid
, AP.ticketReverseDeps = , AP.ticketReverseDeps =
encodeRouteLocal $ SharerPatchReverseDepsR shr talkhid encodeRouteLocal $ SharerProposalReverseDepsR shr talkhid
} }
) )
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr
@ -196,95 +198,143 @@ getSharerPatchR shr talkhid = do
RepoBranchR (sharerIdent s) (repoIdent r) b RepoBranchR (sharerIdent s) (repoIdent r) b
Right (_, ro) -> Right (_, ro) ->
remoteObjectIdent ro remoteObjectIdent ro
, mrPatch = , mrBundle =
Left $ encodeRouteHome $ Left $ encodeRouteHome $
SharerPatchVersionR shr talkhid $ SharerProposalBundleR shr talkhid $
encodePatchId ptid encodeBundleId bnid
} }
) )
} }
provideHtmlAndAP patchAP $ redirectToPrettyJSON here provideHtmlAndAP ticketAP $ redirectToPrettyJSON here
where where
here = SharerPatchR shr talkhid here = SharerProposalR shr talkhid
getSharerPatchDiscussionR getSharerProposalDiscussionR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchDiscussionR shr talkhid = getSharerProposalDiscussionR shr talkhid =
getRepliesCollection (SharerPatchDiscussionR shr talkhid) $ do getRepliesCollection (SharerProposalDiscussionR shr talkhid) $ do
(_, Entity _ lt, _, _, _, _) <- getSharerPatch404 shr talkhid (_, Entity _ lt, _, _, _, _) <- getSharerProposal404 shr talkhid
return $ localTicketDiscuss lt return $ localTicketDiscuss lt
getSharerPatchDepsR getSharerProposalDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchDepsR shr talkhid = getSharerProposalDepsR shr talkhid =
getDependencyCollection here getTicket404 getDependencyCollection here getTicket404
where where
here = SharerPatchDepsR shr talkhid here = SharerProposalDepsR shr talkhid
getTicket404 = do getTicket404 = do
(_, Entity ltid _, _, _, _, _) <- getSharerPatch404 shr talkhid (_, Entity ltid _, _, _, _, _) <- getSharerProposal404 shr talkhid
return ltid return ltid
getSharerPatchReverseDepsR getSharerProposalReverseDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchReverseDepsR shr talkhid = getSharerProposalReverseDepsR shr talkhid =
getReverseDependencyCollection here getTicket404 getReverseDependencyCollection here getTicket404
where where
here = SharerPatchDepsR shr talkhid here = SharerProposalDepsR shr talkhid
getTicket404 = do getTicket404 = do
(_, Entity ltid _, _, _, _, _) <- getSharerPatch404 shr talkhid (_, Entity ltid _, _, _, _, _) <- getSharerProposal404 shr talkhid
return ltid return ltid
getSharerPatchFollowersR getSharerProposalFollowersR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchFollowersR shr talkhid = getFollowersCollection here getFsid getSharerProposalFollowersR shr talkhid = getFollowersCollection here getFsid
where where
here = SharerPatchFollowersR shr talkhid here = SharerProposalFollowersR shr talkhid
getFsid = do getFsid = do
(_, Entity _ lt, _, _, _, _) <- getSharerPatch404 shr talkhid (_, Entity _ lt, _, _, _, _) <- getSharerProposal404 shr talkhid
return $ localTicketFollowers lt return $ localTicketFollowers lt
getSharerPatchEventsR getSharerProposalEventsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchEventsR shr talkhid = do getSharerProposalEventsR shr talkhid = do
_ <- runDB $ getSharerPatch404 shr talkhid _ <- runDB $ getSharerProposal404 shr talkhid
provideEmptyCollection provideEmptyCollection
CollectionTypeOrdered CollectionTypeOrdered
(SharerPatchEventsR shr talkhid) (SharerProposalEventsR shr talkhid)
getSharerPatchVersionR getSharerProposalBundleR
:: ShrIdent :: ShrIdent
-> KeyHashid TicketAuthorLocal -> 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 -> KeyHashid Patch
-> Handler TypedContent -> Handler TypedContent
getSharerPatchVersionR shr talkhid ptkhid = do getSharerProposalBundlePatchR shr talkhid bnkhid ptkhid = do
(vcs, patch, (versions, mcurr)) <- runDB $ do (vcs, patch) <- runDB $ do
(_, _, Entity tid _, repo, _, v :| vs) <- getSharerPatch404 shr talkhid (_, _, _, repo, _, vers) <- getSharerProposal404 shr talkhid
bnid <- decodeKeyHashid404 bnkhid
unless (bnid `elem` vers) notFound
ptid <- decodeKeyHashid404 ptkhid ptid <- decodeKeyHashid404 ptkhid
(,,) <$> case repo of pt <- get404 ptid
Left (_, Entity _ trl) -> unless (patchBundle pt == bnid) notFound
repoVcs <$> getJust (ticketRepoLocalRepo trl) vcs <-
Right _ -> case repo of
error "TODO determine mediaType of patch of remote repo" Left (_, Entity _ trl) ->
<*> do pt <- get404 ptid repoVcs <$> getJust (ticketRepoLocalRepo trl)
unless (patchTicket pt == tid) notFound Right _ ->
return pt error "TODO determine mediaType of patch of remote repo"
<*> pure (if ptid == v then (vs, Nothing) else ([], Just v)) return (vcs, pt)
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodePatchId <- getEncodeKeyHashid
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
let versionUrl = SharerPatchVersionR shr talkhid . encodePatchId
versionAP = AP.Patch let patchAP = AP.Patch
{ AP.patchLocal = Just { AP.patchLocal = Just
( hLocal ( hLocal
, AP.PatchLocal , AP.PatchLocal
{ AP.patchId = encodeRouteLocal here { AP.patchId = encodeRouteLocal here
, AP.patchContext = , AP.patchContext =
encodeRouteLocal $ SharerPatchR shr talkhid encodeRouteLocal $
, AP.patchPrevVersions = SharerProposalBundleR shr talkhid bnkhid
map (encodeRouteLocal . versionUrl) versions
, AP.patchCurrentVersion =
encodeRouteLocal . versionUrl <$> mcurr
} }
) )
, AP.patchAttributedTo = encodeRouteLocal $ SharerR shr , AP.patchAttributedTo = encodeRouteLocal $ SharerR shr
@ -295,12 +345,12 @@ getSharerPatchVersionR shr talkhid ptkhid = do
VCSGit -> error "TODO add PatchType for git patches" VCSGit -> error "TODO add PatchType for git patches"
, AP.patchContent = patchContent patch , AP.patchContent = patchContent patch
} }
provideHtmlAndAP versionAP $ redirectToPrettyJSON here provideHtmlAndAP patchAP $ redirectToPrettyJSON here
where where
here = SharerPatchVersionR shr talkhid ptkhid here = SharerProposalBundlePatchR shr talkhid bnkhid ptkhid
getRepoPatchesR :: ShrIdent -> RpIdent -> Handler TypedContent getRepoProposalsR :: ShrIdent -> RpIdent -> Handler TypedContent
getRepoPatchesR shr rp = do getRepoProposalsR shr rp = do
(total, pages, mpage) <- runDB $ do (total, pages, mpage) <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
rid <- getKeyBy404 $ UniqueRepo rp sid rid <- getKeyBy404 $ UniqueRepo rp sid
@ -309,16 +359,16 @@ getRepoPatchesR shr rp = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRoutePageLocal <- getEncodeRoutePageLocal encodeRoutePageLocal <- getEncodeRoutePageLocal
let here = RepoPatchesR shr rp let here = RepoProposalsR shr rp
pageUrl = encodeRoutePageLocal here pageUrl = encodeRoutePageLocal here
encodeLT <- getEncodeKeyHashid encodeLT <- getEncodeKeyHashid
encodeTAL <- getEncodeKeyHashid encodeTAL <- getEncodeKeyHashid
let patchUrl (Left (E.Value ltid, E.Value mtalid, E.Value mshr, E.Value mtupid)) = let patchUrl (Left (E.Value ltid, E.Value mtalid, E.Value mshr, E.Value mtupid)) =
encodeRouteHome $ encodeRouteHome $
case (mtalid, mshr, mtupid) of case (mtalid, mshr, mtupid) of
(Nothing, Nothing, Nothing) -> RepoPatchR shr rp $ encodeLT ltid (Nothing, Nothing, Nothing) -> RepoProposalR shr rp $ encodeLT ltid
(Just talid, Just shrA, Nothing) -> SharerPatchR shrA $ encodeTAL talid (Just talid, Just shrA, Nothing) -> SharerProposalR shrA $ encodeTAL talid
(Just _, Just _, Just _) -> RepoPatchR shr rp $ encodeLT ltid (Just _, Just _, Just _) -> RepoProposalR shr rp $ encodeLT ltid
_ -> error "Impossible" _ -> error "Impossible"
patchUrl (Right (E.Value h, E.Value lu)) = ObjURI h lu 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 Left) locals)
(map (second Right) remotes) (map (second Right) remotes)
getRepoPatchR getRepoProposalR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchR shr rp ltkhid = do getRepoProposalR shr rp ltkhid = do
(ticket, ptid, trl, author, massignee, mresolved) <- runDB $ do (ticket, bnid, trl, author, massignee, mresolved) <- runDB $ do
(_, _, Entity tid t, _, _, Entity _ trl, ta, tr, ptid :| _) <- getRepoPatch404 shr rp ltkhid (_, _, Entity tid t, _, _, Entity _ trl, ta, tr, bnid :| _) <- getRepoProposal404 shr rp ltkhid
(,,,,,) t ptid trl (,,,,,) t bnid trl
<$> bitraverse <$> bitraverse
(\ (Entity _ tal, _) -> do (\ (Entity _ tal, _) -> do
p <- getJust $ ticketAuthorLocalAuthor tal p <- getJust $ ticketAuthorLocalAuthor tal
@ -445,29 +495,29 @@ getRepoPatchR shr rp ltkhid = do
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodePatchId <- getEncodeKeyHashid encodeBundleId <- getEncodeKeyHashid
encodeObiid <- getEncodeKeyHashid encodeObiid <- getEncodeKeyHashid
let host = let host =
case author of case author of
Left _ -> hLocal Left _ -> hLocal
Right (i, _) -> instanceHost i Right (i, _) -> instanceHost i
patchAP = AP.Ticket ticketAP = AP.Ticket
{ AP.ticketLocal = Just { AP.ticketLocal = Just
( hLocal ( hLocal
, AP.TicketLocal , AP.TicketLocal
{ AP.ticketId = { AP.ticketId =
encodeRouteLocal $ RepoPatchR shr rp ltkhid encodeRouteLocal $ RepoProposalR shr rp ltkhid
, AP.ticketReplies = , AP.ticketReplies =
encodeRouteLocal $ RepoPatchDiscussionR shr rp ltkhid encodeRouteLocal $ RepoProposalDiscussionR shr rp ltkhid
, AP.ticketParticipants = , AP.ticketParticipants =
encodeRouteLocal $ RepoPatchFollowersR shr rp ltkhid encodeRouteLocal $ RepoProposalFollowersR shr rp ltkhid
, AP.ticketTeam = Nothing , AP.ticketTeam = Nothing
, AP.ticketEvents = , AP.ticketEvents =
encodeRouteLocal $ RepoPatchEventsR shr rp ltkhid encodeRouteLocal $ RepoProposalEventsR shr rp ltkhid
, AP.ticketDeps = , AP.ticketDeps =
encodeRouteLocal $ RepoPatchDepsR shr rp ltkhid encodeRouteLocal $ RepoProposalDepsR shr rp ltkhid
, AP.ticketReverseDeps = , AP.ticketReverseDeps =
encodeRouteLocal $ RepoPatchReverseDepsR shr rp ltkhid encodeRouteLocal $ RepoProposalReverseDepsR shr rp ltkhid
} }
) )
, AP.ticketAttributedTo = , AP.ticketAttributedTo =
@ -500,74 +550,128 @@ getRepoPatchR shr rp ltkhid = do
case ticketRepoLocalBranch trl of case ticketRepoLocalBranch trl of
Nothing -> RepoR shr rp Nothing -> RepoR shr rp
Just b -> RepoBranchR shr rp b Just b -> RepoBranchR shr rp b
, mrPatch = , mrBundle =
Left $ encodeRouteHome $ Left $ encodeRouteHome $
RepoPatchVersionR shr rp ltkhid $ RepoProposalBundleR shr rp ltkhid $
encodePatchId ptid encodeBundleId bnid
} }
) )
} }
provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here provideHtmlAndAP' host ticketAP $ redirectToPrettyJSON here
where where
here = RepoPatchR shr rp ltkhid here = RepoProposalR shr rp ltkhid
getRepoPatchDiscussionR getRepoProposalDiscussionR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchDiscussionR shr rp ltkhid = getRepoProposalDiscussionR shr rp ltkhid =
getRepliesCollection (RepoPatchDiscussionR shr rp ltkhid) $ do getRepliesCollection (RepoProposalDiscussionR shr rp ltkhid) $ do
(_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid
return $ localTicketDiscuss lt return $ localTicketDiscuss lt
getRepoPatchDepsR getRepoProposalDepsR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchDepsR shr rp ltkhid = getRepoProposalDepsR shr rp ltkhid =
getDependencyCollection here getTicketId404 getDependencyCollection here getTicketId404
where where
here = RepoPatchDepsR shr rp ltkhid here = RepoProposalDepsR shr rp ltkhid
getTicketId404 = do getTicketId404 = do
(_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid (_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid
return ltid return ltid
getRepoPatchReverseDepsR getRepoProposalReverseDepsR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchReverseDepsR shr rp ltkhid = getRepoProposalReverseDepsR shr rp ltkhid =
getReverseDependencyCollection here getTicketId404 getReverseDependencyCollection here getTicketId404
where where
here = RepoPatchReverseDepsR shr rp ltkhid here = RepoProposalReverseDepsR shr rp ltkhid
getTicketId404 = do getTicketId404 = do
(_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid (_, _, _, Entity ltid _, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid
return ltid return ltid
getRepoPatchFollowersR getRepoProposalFollowersR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchFollowersR shr rp ltkhid = getFollowersCollection here getFsid getRepoProposalFollowersR shr rp ltkhid = getFollowersCollection here getFsid
where where
here = RepoPatchFollowersR shr rp ltkhid here = RepoProposalFollowersR shr rp ltkhid
getFsid = do getFsid = do
(_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid
return $ localTicketFollowers lt return $ localTicketFollowers lt
getRepoPatchEventsR getRepoProposalEventsR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchEventsR shr rp ltkhid = do getRepoProposalEventsR shr rp ltkhid = do
_ <- runDB $ getRepoPatch404 shr rp ltkhid _ <- runDB $ getRepoProposal404 shr rp ltkhid
provideEmptyCollection provideEmptyCollection
CollectionTypeOrdered CollectionTypeOrdered
(RepoPatchEventsR shr rp ltkhid) (RepoProposalEventsR shr rp ltkhid)
getRepoPatchVersionR getRepoProposalBundleR
:: ShrIdent :: ShrIdent
-> RpIdent -> RpIdent
-> KeyHashid LocalTicket -> 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 -> KeyHashid Patch
-> Handler TypedContent -> Handler TypedContent
getRepoPatchVersionR shr rp ltkhid ptkhid = do getRepoProposalBundlePatchR shr rp ltkhid bnkhid ptkhid = do
(vcs, patch, author, (versions, mcurr)) <- runDB $ do (vcs, patch, author) <- runDB $ do
(_, Entity _ repo, Entity tid _, _, _, _, ta, _, v :| vs) <- getRepoPatch404 shr rp ltkhid (_, Entity _ repo, _, _, _, _, ta, _, vers) <- getRepoProposal404 shr rp ltkhid
ptid <- decodeKeyHashid404 ptkhid (,,)
(repoVcs repo,,,) <$> pure (repoVcs repo)
<$> do pt <- get404 ptid <*> do bnid <- decodeKeyHashid404 bnkhid
unless (patchTicket pt == tid) notFound unless (bnid `elem` vers) notFound
ptid <- decodeKeyHashid404 ptkhid
pt <- get404 ptid
unless (patchBundle pt == bnid) notFound
return pt return pt
<*> bitraverse <*> bitraverse
(\ (Entity _ tal, _) -> do (\ (Entity _ tal, _) -> do
@ -581,27 +685,22 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do
return (i, ro) return (i, ro)
) )
ta ta
<*> pure (if ptid == v then (vs, Nothing) else ([], Just v))
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodePatchId <- getEncodeKeyHashid
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
let versionUrl = RepoPatchVersionR shr rp ltkhid . encodePatchId
host = let host =
case author of case author of
Left _ -> hLocal Left _ -> hLocal
Right (i, _) -> instanceHost i Right (i, _) -> instanceHost i
versionAP = AP.Patch patchAP = AP.Patch
{ AP.patchLocal = Just { AP.patchLocal = Just
( hLocal ( hLocal
, AP.PatchLocal , AP.PatchLocal
{ AP.patchId = encodeRouteLocal here { AP.patchId = encodeRouteLocal here
, AP.patchContext = , AP.patchContext =
encodeRouteLocal $ RepoPatchR shr rp ltkhid encodeRouteLocal $
, AP.patchPrevVersions = RepoProposalBundleR shr rp ltkhid bnkhid
map (encodeRouteLocal . versionUrl) versions
, AP.patchCurrentVersion =
encodeRouteLocal . versionUrl <$> mcurr
} }
) )
, AP.patchAttributedTo = , AP.patchAttributedTo =
@ -616,6 +715,6 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do
VCSGit -> error "TODO add PatchType for git patches" VCSGit -> error "TODO add PatchType for git patches"
, AP.patchContent = patchContent patch , AP.patchContent = patchContent patch
} }
provideHtmlAndAP' host versionAP $ redirectToPrettyJSON here provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here
where 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 getSharerWorkItems SharerTicketsR SharerTicketR countTickets selectTickets
where where
countTickets pid = fmap toOne $ countTickets pid = fmap toOne $
E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` pt) -> do E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` bn) -> do
E.on $ E.just (lt E.^. LocalTicketTicket) E.==. pt E.?. PatchTicket E.on $ E.just (lt E.^. LocalTicketTicket) E.==. bn E.?. BundleTicket
E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId
E.where_ $ E.where_ $
tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
E.isNothing (tup E.?. TicketUnderProjectId) E.&&. E.isNothing (tup E.?. TicketUnderProjectId) E.&&.
E.isNothing (pt E.?. PatchId) E.isNothing (bn E.?. BundleId)
return $ E.count $ tal E.^. TicketAuthorLocalId return $ E.count $ tal E.^. TicketAuthorLocalId
where where
toOne [x] = E.unValue x toOne [x] = E.unValue x
toOne [] = error "toOne = 0" toOne [] = error "toOne = 0"
toOne _ = error "toOne > 1" toOne _ = error "toOne > 1"
selectTickets pid off lim = selectTickets pid off lim =
E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` pt) -> do E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` bn) -> do
E.on $ E.just (lt E.^. LocalTicketTicket) E.==. pt E.?. PatchTicket E.on $ E.just (lt E.^. LocalTicketTicket) E.==. bn E.?. BundleTicket
E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId
E.where_ $ E.where_ $
tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
E.isNothing (tup E.?. TicketUnderProjectId) 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.orderBy [E.desc $ tal E.^. TicketAuthorLocalId]
E.offset $ fromIntegral off E.offset $ fromIntegral off
E.limit $ fromIntegral lim E.limit $ fromIntegral lim

21
src/Vervis/Migration.hs
View file

@ -1752,6 +1752,27 @@ changes hLocal ctx =
, removeField "Ticket" "closed" , removeField "Ticket" "closed"
-- 278 -- 278
, removeField "Ticket" "closer" , 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 migrateDB

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

@ -238,6 +238,11 @@ module Vervis.Migration.Model
, OutboxItem276Generic (..) , OutboxItem276Generic (..)
, TicketProjectLocal276Generic (..) , TicketProjectLocal276Generic (..)
, Project276Generic (..) , Project276Generic (..)
, model_2020_08_10
, Ticket280Generic (..)
, Bundle280Generic (..)
, Patch280
, Patch280Generic (..)
) )
where where
@ -465,3 +470,9 @@ model_2020_07_27 = $(schema "2020_07_27_ticket_resolve")
makeEntitiesMigration "276" makeEntitiesMigration "276"
$(modelFile "migrations/2020_07_27_ticket_resolve_mig.model") $(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 module Vervis.Patch
( getSharerPatch ( getSharerProposal
, getSharerPatch404 , getSharerProposal404
, getRepoPatch , getRepoProposal
, getRepoPatch404 , getRepoProposal404
) )
where where
@ -61,7 +61,7 @@ getResolved ltid = do
"No TRX" "No TRX"
"Both TRL and TRR" "Both TRL and TRR"
getSharerPatch getSharerProposal
:: MonadIO m :: MonadIO m
=> ShrIdent => ShrIdent
-> TicketAuthorLocalId -> TicketAuthorLocalId
@ -83,10 +83,10 @@ getSharerPatch
(Entity TicketResolveLocal) (Entity TicketResolveLocal)
(Entity TicketResolveRemote) (Entity TicketResolveRemote)
) )
, NonEmpty PatchId , NonEmpty BundleId
) )
) )
getSharerPatch shr talid = runMaybeT $ do getSharerProposal shr talid = runMaybeT $ do
pid <- do pid <- do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniquePersonIdent sid MaybeT $ getKeyBy $ UniquePersonIdent sid
@ -96,9 +96,9 @@ getSharerPatch shr talid = runMaybeT $ do
lt <- lift $ getJust ltid lt <- lift $ getJust ltid
let tid = localTicketTicket lt let tid = localTicketTicket lt
t <- lift $ getJust tid t <- lift $ getJust tid
ptids <- bnids <-
MaybeT $ MaybeT $
nonEmpty <$> selectKeysList [PatchTicket ==. tid] [Desc PatchId] nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId]
repo <- repo <-
requireEitherAlt requireEitherAlt
(do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
@ -118,9 +118,9 @@ getSharerPatch shr talid = runMaybeT $ do
"MR doesn't have context" "MR doesn't have context"
"MR has both local and remote context" "MR has both local and remote context"
mresolved <- lift $ getResolved ltid 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 :: ShrIdent
-> KeyHashid TicketAuthorLocal -> KeyHashid TicketAuthorLocal
-> AppDB -> AppDB
@ -140,16 +140,16 @@ getSharerPatch404
(Entity TicketResolveLocal) (Entity TicketResolveLocal)
(Entity TicketResolveRemote) (Entity TicketResolveRemote)
) )
, NonEmpty PatchId , NonEmpty BundleId
) )
getSharerPatch404 shr talkhid = do getSharerProposal404 shr talkhid = do
talid <- decodeKeyHashid404 talkhid talid <- decodeKeyHashid404 talkhid
mpatch <- getSharerPatch shr talid mpatch <- getSharerProposal shr talid
case mpatch of case mpatch of
Nothing -> notFound Nothing -> notFound
Just patch -> return patch Just patch -> return patch
getRepoPatch getRepoProposal
:: MonadIO m :: MonadIO m
=> ShrIdent => ShrIdent
-> RpIdent -> RpIdent
@ -171,10 +171,10 @@ getRepoPatch
(Entity TicketResolveLocal) (Entity TicketResolveLocal)
(Entity TicketResolveRemote) (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 es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr
er@(Entity rid _) <- MaybeT $ getBy $ UniqueRepo rp sid er@(Entity rid _) <- MaybeT $ getBy $ UniqueRepo rp sid
lt <- MaybeT $ get ltid lt <- MaybeT $ get ltid
@ -183,9 +183,9 @@ getRepoPatch shr rp ltid = runMaybeT $ do
etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid
etrl@(Entity _ trl) <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid etrl@(Entity _ trl) <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid
guard $ ticketRepoLocalRepo trl == rid guard $ ticketRepoLocalRepo trl == rid
ptids <- bnids <-
MaybeT $ MaybeT $
nonEmpty <$> selectKeysList [PatchTicket ==. tid] [Desc PatchId] nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId]
author <- author <-
requireEitherAlt requireEitherAlt
(do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
@ -200,9 +200,9 @@ getRepoPatch shr rp ltid = runMaybeT $ do
"MR doesn't have author" "MR doesn't have author"
"MR has both local and remote author" "MR has both local and remote author"
mresolved <- lift $ getResolved ltid 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 :: ShrIdent
-> RpIdent -> RpIdent
-> KeyHashid LocalTicket -> KeyHashid LocalTicket
@ -222,11 +222,11 @@ getRepoPatch404
(Entity TicketResolveLocal) (Entity TicketResolveLocal)
(Entity TicketResolveRemote) (Entity TicketResolveRemote)
) )
, NonEmpty PatchId , NonEmpty BundleId
) )
getRepoPatch404 shr rp ltkhid = do getRepoProposal404 shr rp ltkhid = do
ltid <- decodeKeyHashid404 ltkhid ltid <- decodeKeyHashid404 ltkhid
mpatch <- getRepoPatch shr rp ltid mpatch <- getRepoProposal shr rp ltid
case mpatch of case mpatch of
Nothing -> notFound Nothing -> notFound
Just patch -> return patch 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 Control.Monad.Trans.Reader
import Data.Either import Data.Either
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.Maybe (isJust) import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
@ -496,8 +496,8 @@ getSharerTicket shr talid = runMaybeT $ do
lt <- lift $ getJust ltid lt <- lift $ getJust ltid
let tid = localTicketTicket lt let tid = localTicketTicket lt
t <- lift $ getJust tid t <- lift $ getJust tid
npatches <- lift $ count [PatchTicket ==. tid] mbn <- lift $ selectFirst [BundleTicket ==. tid] []
guard $ npatches <= 0 guard $ isNothing mbn
project <- project <-
requireEitherAlt requireEitherAlt
(do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
@ -599,8 +599,8 @@ getProjectTicket shr prj ltid = runMaybeT $ do
etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid
etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid
guard $ ticketProjectLocalProject tpl == jid guard $ ticketProjectLocalProject tpl == jid
npatches <- lift $ count [PatchTicket ==. tid] mbn <- lift $ selectFirst [BundleTicket ==. tid] []
guard $ npatches <= 0 guard $ isNothing mbn
author <- author <-
requireEitherAlt requireEitherAlt
(do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
@ -760,7 +760,7 @@ getReverseDependencyCollection here getLocalTicketId404 = do
data WorkItem data WorkItem
= WorkItemSharerTicket ShrIdent TicketAuthorLocalId Bool = WorkItemSharerTicket ShrIdent TicketAuthorLocalId Bool
| WorkItemProjectTicket ShrIdent PrjIdent LocalTicketId | WorkItemProjectTicket ShrIdent PrjIdent LocalTicketId
| WorkItemRepoPatch ShrIdent RpIdent LocalTicketId | WorkItemRepoProposal ShrIdent RpIdent LocalTicketId
deriving Eq deriving Eq
getWorkItemRoute getWorkItemRoute
@ -773,9 +773,9 @@ askWorkItemRoute = do
hashTALID <- getEncodeKeyHashid hashTALID <- getEncodeKeyHashid
hashLTID <- getEncodeKeyHashid hashLTID <- getEncodeKeyHashid
let route (WorkItemSharerTicket shr talid False) = SharerTicketR shr (hashTALID talid) 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 (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 return route
getWorkItem :: MonadIO m => LocalTicketId -> ReaderT SqlBackend m WorkItem getWorkItem :: MonadIO m => LocalTicketId -> ReaderT SqlBackend m WorkItem
@ -790,20 +790,20 @@ getWorkItem ltid = (either error return =<<) $ runExceptT $ do
Just (Entity talid _) -> lift $ do Just (Entity talid _) -> lift $ do
metcr <- getBy (UniqueTicketProjectRemote talid) metcr <- getBy (UniqueTicketProjectRemote talid)
for metcr $ \ etcr -> for metcr $ \ etcr ->
(etcr,) . (> 0) <$> count [PatchTicket ==. tid] (etcr,) . (> 0) <$> count [BundleTicket ==. tid]
mlocalContext <- do mlocalContext <- do
metcl <- lift $ getBy $ UniqueTicketContextLocal tid metcl <- lift $ getBy $ UniqueTicketContextLocal tid
for metcl $ \ etcl@(Entity tclid _) -> do for metcl $ \ etcl@(Entity tclid _) -> do
npatches <- lift $ count [PatchTicket ==. tid] mbn <- lift $ selectFirst [BundleTicket ==. tid] []
metpl <- lift $ getBy $ UniqueTicketProjectLocal tclid metpl <- lift $ getBy $ UniqueTicketProjectLocal tclid
metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid
case (metpl, metrl) of case (metpl, metrl) of
(Nothing, Nothing) -> throwE "TCL but no TPL and no TRL" (Nothing, Nothing) -> throwE "TCL but no TPL and no TRL"
(Just etpl, Nothing) -> do (Just etpl, Nothing) -> do
when (npatches > 0) $ throwE "TPL but patches attached" when (isJust mbn) $ throwE "TPL but patches attached"
return (etcl, Left etpl) return (etcl, Left etpl)
(Nothing, Just etrl) -> do (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) return (etcl, Right etrl)
(Just _, Just _) -> throwE "Both TPL and TRL" (Just _, Just _) -> throwE "Both TPL and TRL"
metar <- metar <-
@ -858,7 +858,7 @@ getWorkItem ltid = (either error return =<<) $ runExceptT $ do
contextHosted (Right (Entity _ trl)) = do contextHosted (Right (Entity _ trl)) = do
r <- getJust $ ticketRepoLocalRepo trl r <- getJust $ ticketRepoLocalRepo trl
s <- getJust $ repoSharer r s <- getJust $ repoSharer r
return $ WorkItemRepoPatch (sharerIdent s) (repoIdent r) ltid return $ WorkItemRepoProposal (sharerIdent s) (repoIdent r) ltid
authorHosted (Entity talid tal) patch = do authorHosted (Entity talid tal) patch = do
p <- getJust $ ticketAuthorLocalAuthor tal p <- getJust $ ticketAuthorLocalAuthor tal
s <- getJust $ personIdent p s <- getJust $ personIdent p
@ -875,15 +875,15 @@ parseWorkItem name u@(ObjURI h lu) = do
SharerTicketR shr talkhid -> do SharerTicketR shr talkhid -> do
talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid" talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
return $ WorkItemSharerTicket shr talid False return $ WorkItemSharerTicket shr talid False
SharerPatchR shr talkhid -> do SharerProposalR shr talkhid -> do
talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid" talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
return $ WorkItemSharerTicket shr talid True return $ WorkItemSharerTicket shr talid True
ProjectTicketR shr prj ltkhid -> do ProjectTicketR shr prj ltkhid -> do
ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid" ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
return $ WorkItemProjectTicket shr prj ltid return $ WorkItemProjectTicket shr prj ltid
RepoPatchR shr rp ltkhid -> do RepoProposalR shr rp ltkhid -> do
ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid" ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
return $ WorkItemRepoPatch shr rp ltid return $ WorkItemRepoProposal shr rp ltid
_ -> throwE $ name <> ": not a work item route" _ -> throwE $ name <> ": not a work item route"
else return $ Right u else return $ Right u
@ -923,7 +923,7 @@ checkDepAndTarget
where where
workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj 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 (Left _) (Right _) = throwE "Local parent but remote target"
checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent" checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
checkParentAndTarget (Right _) (Right _) = return () 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.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
-- import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
-- import Data.Either import Data.List.NonEmpty (NonEmpty)
-- import Data.Foldable (for_)
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
-- import Data.Traversable
import Database.Persist import Database.Persist
import Database.Persist.Sql 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 qualified Data.Text as T
import Network.FedURI import Network.FedURI
@ -56,10 +49,6 @@ import Yesod.MonadSite
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local 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.ActivityPub.Recipient
import Vervis.FedURI import Vervis.FedURI
@ -67,11 +56,8 @@ import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
-- import Vervis.Model.Workflow
-- import Vervis.Paginate
import Vervis.Patch import Vervis.Patch
import Vervis.Ticket import Vervis.Ticket
-- import Vervis.Widget.Ticket (TicketSummary (..))
data WorkItemDetail = WorkItemDetail data WorkItemDetail = WorkItemDetail
{ widIdent :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI) { widIdent :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI)
@ -105,9 +91,9 @@ askWorkItemFollowers = do
hashTALID <- getEncodeKeyHashid hashTALID <- getEncodeKeyHashid
hashLTID <- getEncodeKeyHashid hashLTID <- getEncodeKeyHashid
let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid 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 (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 return workItemFollowers
contextAudience contextAudience
@ -198,7 +184,7 @@ getWorkItemDetail name v = do
return (ltid, context', Left shr) return (ltid, context', Left shr)
getWorkItem name (WorkItemSharerTicket shr talid True) = do getWorkItem name (WorkItemSharerTicket shr talid True) = do
(_, Entity ltid _, _, context, _, _) <- do (_, Entity ltid _, _, context, _, _) <- do
mticket <- lift $ getSharerPatch shr talid mticket <- lift $ getSharerProposal shr talid
fromMaybeE mticket $ name <> ": No such sharer-patch" fromMaybeE mticket $ name <> ": No such sharer-patch"
context' <- context' <-
lift $ lift $
@ -227,8 +213,8 @@ getWorkItemDetail name v = do
fromMaybeE mticket $ name <> ": No such project-ticket" fromMaybeE mticket $ name <> ": No such project-ticket"
author' <- lift $ getWorkItemAuthorDetail author author' <- lift $ getWorkItemAuthorDetail author
return (ltid, Left $ Left (sharerIdent s, projectIdent j), author') return (ltid, Left $ Left (sharerIdent s, projectIdent j), author')
getWorkItem name (WorkItemRepoPatch shr rp ltid) = do getWorkItem name (WorkItemRepoProposal shr rp ltid) = do
mticket <- lift $ getRepoPatch shr rp ltid mticket <- lift $ getRepoProposal shr rp ltid
(Entity _ s, Entity _ r, _, _, _, _, author, _, _) <- (Entity _ s, Entity _ r, _, _, _, _, author, _, _) <-
fromMaybeE mticket $ name <> ": No such repo-patch" fromMaybeE mticket $ name <> ": No such repo-patch"
author' <- lift $ getWorkItemAuthorDetail author author' <- lift $ getWorkItemAuthorDetail author
@ -255,5 +241,5 @@ getWorkItemDetail name v = do
mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro) mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
data WorkItemTarget data WorkItemTarget
= WTTProject ShrIdent PrjIdent = WITProject ShrIdent PrjIdent
| WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text | WITRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem (NonEmpty Text)

107
src/Web/ActivityPub.hs
View file

@ -49,6 +49,8 @@ module Web.ActivityPub
, PatchType (..) , PatchType (..)
, PatchLocal (..) , PatchLocal (..)
, Patch (..) , Patch (..)
, BundleLocal (..)
, Bundle (..)
, TicketLocal (..) , TicketLocal (..)
, MergeRequest (..) , MergeRequest (..)
, Ticket (..) , Ticket (..)
@ -826,7 +828,7 @@ newtype TextPandocMarkdown = TextPandocMarkdown
} }
deriving (FromJSON, ToJSON) deriving (FromJSON, ToJSON)
data PatchType = PatchTypeDarcs data PatchType = PatchTypeDarcs deriving Eq
instance FromJSON PatchType where instance FromJSON PatchType where
parseJSON = withText "PatchType" parse parseJSON = withText "PatchType" parse
@ -841,10 +843,8 @@ instance ToJSON PatchType where
render PatchTypeDarcs = "application/x-darcs-patch" :: Text render PatchTypeDarcs = "application/x-darcs-patch" :: Text
data PatchLocal = PatchLocal data PatchLocal = PatchLocal
{ patchId :: LocalURI { patchId :: LocalURI
, patchContext :: LocalURI , patchContext :: LocalURI
, patchPrevVersions :: [LocalURI]
, patchCurrentVersion :: Maybe LocalURI
} }
parsePatchLocal parsePatchLocal
@ -854,16 +854,12 @@ parsePatchLocal o = do
case mid of case mid of
Nothing -> do Nothing -> do
verifyNothing "context" verifyNothing "context"
verifyNothing "previousVersions"
verifyNothing "currentVersion"
return Nothing return Nothing
Just (ObjURI a id_) -> Just (ObjURI a id_) ->
fmap (Just . (a,)) $ fmap (Just . (a,)) $
PatchLocal PatchLocal
<$> pure id_ <$> pure id_
<*> withAuthorityO a (o .: "context") <*> withAuthorityO a (o .: "context")
<*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= [])
<*> withAuthorityMaybeO a (o .:? "currentVersion")
where where
verifyNothing t = verifyNothing t =
if t `M.member` o if t `M.member` o
@ -871,11 +867,9 @@ parsePatchLocal o = do
else return () else return ()
encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series
encodePatchLocal a (PatchLocal id_ context versions mcurrent) encodePatchLocal a (PatchLocal id_ context)
= "id" .= ObjURI a id_ = "id" .= ObjURI a id_
<> "context" .= ObjURI a context <> "context" .= ObjURI a context
<> "previousVersions" .= map (ObjURI a) versions
<> "currentVersion" .=? (ObjURI a <$> mcurrent)
data Patch u = Patch data Patch u = Patch
{ patchLocal :: Maybe (Authority u, PatchLocal) { patchLocal :: Maybe (Authority u, PatchLocal)
@ -911,6 +905,89 @@ instance ActivityPub Patch where
<> "mediaType" .= typ <> "mediaType" .= typ
<> "content" .= content <> "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 data TicketLocal = TicketLocal
{ ticketId :: LocalURI { ticketId :: LocalURI
, ticketReplies :: LocalURI , ticketReplies :: LocalURI
@ -964,7 +1041,7 @@ encodeTicketLocal
data MergeRequest u = MergeRequest data MergeRequest u = MergeRequest
{ mrOrigin :: Maybe (ObjURI u) { mrOrigin :: Maybe (ObjURI u)
, mrTarget :: LocalURI , mrTarget :: LocalURI
, mrPatch :: Either (ObjURI u) (Authority u, Patch u) , mrBundle :: Either (ObjURI u) (Authority u, Bundle u)
} }
instance ActivityPub MergeRequest where instance ActivityPub MergeRequest where
@ -985,11 +1062,11 @@ instance ActivityPub MergeRequest where
where where
fromDoc (Doc h v) = (h, v) fromDoc (Doc h v) = (h, v)
toSeries h (MergeRequest morigin target patch) toSeries h (MergeRequest morigin target bundle)
= "type" .= ("Offer" :: Text) = "type" .= ("Offer" :: Text)
<> "origin" .=? morigin <> "origin" .=? morigin
<> "target" .= ObjURI h target <> "target" .= ObjURI h target
<> "object" .= fromEither (second (uncurry Doc) patch) <> "object" .= fromEither (second (uncurry Doc) bundle)
data Ticket u = Ticket data Ticket u = Ticket
{ ticketLocal :: Maybe (Authority u, TicketLocal) { ticketLocal :: Maybe (Authority u, TicketLocal)