forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Add repo patch support to checkCreateTicket

Browse source
This commit is contained in:
fr33domlover 2020-07-19 12:48:39 +00:00
parent f7c0807775
commit f286f35a87
1 changed files with 212 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -488,26 +488,54 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
data RemotePatch = RemotePatch
{ rpBranch :: Maybe LocalURI
, rpType :: PatchType
, rpContent :: Text
}
data RemoteWorkItem = RemoteWorkItem
{ rwiHost :: Host
, rwiTarget :: Maybe LocalURI
, rwiContext :: LocalURI
, rwiPatch :: Maybe RemotePatch
}
data RemoteWorkItem' = RemoteWorkItem'
{ rwiHost' :: Host
, rwiContext' :: LocalURI
, rwiPatch' :: Maybe RemotePatch
}
data ParsedCreateTicket = ParsedCreateTicket
{ pctItem :: Either (Bool, WorkItemTarget) RemoteWorkItem
, pctLocal :: TicketLocal
, pctPublished :: UTCTime
, pctTitle :: TextHtml
, pctDesc :: TextHtml
, pctSource :: TextPandocMarkdown
}
checkCreateTicket
:: RemoteAuthor
-> AP.Ticket URIMode
-> Maybe FedURI
-> ExceptT
Text
Handler
( (Either (Bool, ShrIdent, PrjIdent) (Host, Maybe LocalURI, LocalURI))
, TicketLocal
, UTCTime
, TextHtml
, TextHtml
, TextPandocMarkdown
)
-> ExceptT Text Handler ParsedCreateTicket
checkCreateTicket author ticket muTarget = do
mtarget <- traverse (checkTracker "Create target") muTarget
(context, ticketData, published, title, desc, src) <- checkTicket ticket
(, ticketData, published, title, desc, src) <$>
checkTargetAndContext mtarget context
(context, tlocal, published, summary, content, source) <-
checkTicket ticket
item <- checkTargetAndContext mtarget context
return $ ParsedCreateTicket item tlocal published summary content source
where
checkTracker
:: Text
-> FedURI
-> ExceptT Text Handler
(Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI
)
checkTracker name u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
@ -517,14 +545,24 @@ checkCreateTicket author ticket muTarget = do
(decodeRouteLocal lu)
(name <> " is local but isn't a valid route")
case route of
ProjectR shr prj -> return (shr, prj)
ProjectR shr prj -> return $ Left (shr, prj)
RepoR shr rp -> return $ Right (shr, rp)
_ ->
throwE $
name <>
" is a valid local route, but isn't a project \
\route"
" is a valid local route, but isn't a \
\project/repo route"
else return $ Right u
checkTicket
:: AP.Ticket URIMode
-> ExceptT Text Handler
( Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch)
, TicketLocal
, UTCTime
, TextHtml
, TextHtml
, TextPandocMarkdown
)
checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
content source muAssigned resolved mmr) = do
(hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'"
@ -541,31 +579,167 @@ checkCreateTicket author ticket muTarget = do
verifyNothingE mupdated "Ticket has 'updated'"
verifyNothingE muAssigned "Ticket has 'assignedTo'"
when resolved $ throwE "Ticket is resolved"
verifyNothingE mmr "Ticket has 'attachment'"
return (context, tlocal, pub, summary, content, source)
mmr' <- traverse (uncurry checkMR) mmr
context' <- matchTicketAndMR (AP.ticketId tlocal) pub context mmr'
return (context', tlocal, pub, summary, content, source)
where
checkMR
:: Host
-> MergeRequest URIMode
-> ExceptT Text Handler
( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, Maybe (LocalURI, LocalURI)
, Maybe UTCTime
, PatchType
, Text
)
checkMR h (MergeRequest muOrigin luTarget epatch) = do
verifyNothingE muOrigin "MR with 'origin'"
branch <- checkBranch h luTarget
(mlocal, mpub, typ, content) <-
case epatch of
Left _ -> throwE "MR patch specified as a URI"
Right (hPatch, patch) -> checkPatch hPatch patch
return (branch, mlocal, mpub, typ, content)
where
checkBranch
:: Host
-> LocalURI
-> ExceptT Text Handler
(Either (ShrIdent, RpIdent, Maybe Text) FedURI)
checkBranch h lu = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE
(decodeRouteLocal lu)
"MR target is local but isn't a valid route"
case route of
RepoR shr rp -> return (shr, rp, Nothing)
RepoBranchR shr rp b -> return (shr, rp, Just b)
_ ->
throwE
"MR target is a valid local route, but isn't a \
\repo or branch route"
else return $ Right $ ObjURI h lu
checkPatch
:: Host
-> AP.Patch URIMode
-> ExceptT Text Handler
( Maybe (LocalURI, LocalURI)
, Maybe UTCTime
, PatchType
, Text
)
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
mlocal' <-
for mlocal $
\ (h', PatchLocal luId luContext versions) -> do
unless (h == h') $
throwE "Patch & its author on different hosts"
unless (null versions) $
throwE "Patch has versions"
return (luId, luContext)
unless (ObjURI h attrib == remoteAuthorURI author) $
throwE "Ticket & Patch attrib mismatch"
return (mlocal', mpub, typ, content)
matchTicketAndMR
:: LocalURI
-> UTCTime
-> Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI
-> Maybe
( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, Maybe (LocalURI, LocalURI)
, Maybe UTCTime
, PatchType
, Text
)
-> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch))
matchTicketAndMR _ _ (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj
matchTicketAndMR _ _ (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
matchTicketAndMR _ _ (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo"
matchTicketAndMR luTicket pub (Left (Right (shr, rp))) (Just (branch, mlocal, mpub, typ, content)) = do
branch' <-
case branch of
Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
_ -> throwE "MR target repo/branch and Offer target repo mismatch"
_mluPatch <- for mlocal $ \ (luPatch, luPatchContext) -> do
unless (luPatchContext == luTicket) $
throwE "Patch 'context' != Ticket 'id'"
return luPatch
for_ mpub $ \ pub' ->
unless (pub == pub') $
throwE "Ticket & Patch 'published' differ"
let vcs = typ2vcs typ
case vcs of
VCSDarcs ->
unless (isNothing branch') $
throwE "Darcs MR specifies a branch"
VCSGit ->
unless (isJust branch') $
throwE "Git MR doesn't specify the branch"
return $ Left $ WTTRepo shr rp branch' vcs content
where
typ2vcs PatchTypeDarcs = VCSDarcs
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
luBranch <-
case branch of
Right (ObjURI h' lu') | h == h' -> return lu
_ -> throwE "MR target repo/branch and Offer target repo mismatch"
_mluPatch <- for mlocal $ \ (luPatch, luPatchContext) -> do
unless (luPatchContext == luTicket) $
throwE "Patch 'context' != Ticket 'id'"
return luPatch
for_ mpub $ \ pub' ->
unless (pub == pub') $
throwE "Ticket & Patch 'published' differ"
let patch =
RemotePatch
(if lu == luBranch then Nothing else Just luBranch)
typ
content
return $ Right (h, lu, Just patch)
checkTargetAndContext
:: Maybe
( Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI
)
-> Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch)
-> ExceptT Text Handler (Either (Bool, WorkItemTarget) RemoteWorkItem)
checkTargetAndContext Nothing context =
return $
case context of
Left (shr, prj) -> Left (False, shr, prj)
Right (ObjURI h lu) -> Right (h, Nothing, lu)
Left wit -> Left (False, wit)
Right (h, luCtx, mpatch) -> Right $ RemoteWorkItem h Nothing luCtx mpatch
checkTargetAndContext (Just target) context =
case (target, context) of
(Left _, Right _) ->
throwE "Create target is local but ticket context is remote"
(Right _, Left _) ->
throwE "Create target is remote but ticket context is local"
(Right (ObjURI hTarget luTarget), Right (ObjURI hContext luContext)) ->
(Right (ObjURI hTarget luTarget), Right (hContext, luContext, mpatch)) ->
if hTarget == hContext
then return $ Right (hTarget, Just luTarget, luContext)
then return $ Right $ RemoteWorkItem hTarget (Just luTarget) luContext mpatch
else throwE "Create target and ticket context on \
\different remote hosts"
(Left (shr, prj), Left (shr', prj')) ->
if shr == shr' && prj == prj'
then return $ Left (True, shr, prj)
else throwE "Create target and ticket context are \
\different local projects"
(Left proj, Left wit) ->
case (proj, wit) of
(Left (shr, prj), WTTProject shr' prj')
| shr == shr' && prj == prj' ->
return $ Left (True, wit)
(Right (shr, rp), WTTRepo shr' rp' _ _ _)
| shr == shr' && rp == rp' ->
return $ Left (True, wit)
_ -> throwE
"Create target and ticket context are \
\different local projects"
sharerCreateTicketF
:: UTCTime
@ -578,8 +752,7 @@ sharerCreateTicketF
-> Maybe FedURI
-> ExceptT Text Handler Text
sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
(targetAndContext, _, _, _, _, _) <-
checkCreateTicket author ticket muTarget
targetAndContext <- pctItem <$> checkCreateTicket author ticket muTarget
mractid <- runDBExcept $ do
ibidRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
@ -591,11 +764,16 @@ sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
Nothing -> "Activity already exists in my inbox"
Just _ -> "Activity inserted to my inbox"
where
checkTargetAndContextDB (Left (_, shr, prj)) = do
checkTargetAndContextDB (Left (_, WTTProject shr prj)) = do
mj <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid
unless (isJust mj) $ throwE "Local context: No such project"
checkTargetAndContextDB (Left (_, WTTRepo shr rp _ _ _)) = do
mr <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueRepo rp sid
unless (isJust mr) $ throwE "Local context: No such repo"
checkTargetAndContextDB (Right _) = return ()
projectCreateTicketF
@ -610,7 +788,8 @@ projectCreateTicketF
-> Maybe FedURI
-> ExceptT Text Handler Text
projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do
(targetAndContext, tlocal, published, title, desc, src) <- checkCreateTicket author ticket muTarget
ParsedCreateTicket targetAndContext tlocal published title desc src <-
checkCreateTicket author ticket muTarget
mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do
Entity jid j <- do
sid <- getKeyBy404 $ UniqueSharer shrRecip
@ -665,7 +844,7 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
Nothing -> "Accepted and listed ticket, no inbox-forwarding to do"
Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create"
where
targetRelevance (Left (_, shr, prj))
targetRelevance (Left (_, WTTProject shr prj))
| shr == shrRecip && prj == prjRecip = Just ()
targetRelevance _ = Nothing
insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do