S2S: Add repo patch support to checkCreateTicket
This commit is contained in:
parent
f7c0807775
commit
f286f35a87
1 changed files with 212 additions and 33 deletions
|
@ -488,26 +488,54 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =
|
||||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
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
|
checkCreateTicket
|
||||||
:: RemoteAuthor
|
:: RemoteAuthor
|
||||||
-> AP.Ticket URIMode
|
-> AP.Ticket URIMode
|
||||||
-> Maybe FedURI
|
-> Maybe FedURI
|
||||||
-> ExceptT
|
-> ExceptT Text Handler ParsedCreateTicket
|
||||||
Text
|
|
||||||
Handler
|
|
||||||
( (Either (Bool, ShrIdent, PrjIdent) (Host, Maybe LocalURI, LocalURI))
|
|
||||||
, TicketLocal
|
|
||||||
, UTCTime
|
|
||||||
, TextHtml
|
|
||||||
, TextHtml
|
|
||||||
, TextPandocMarkdown
|
|
||||||
)
|
|
||||||
checkCreateTicket author ticket muTarget = do
|
checkCreateTicket author ticket muTarget = do
|
||||||
mtarget <- traverse (checkTracker "Create target") muTarget
|
mtarget <- traverse (checkTracker "Create target") muTarget
|
||||||
(context, ticketData, published, title, desc, src) <- checkTicket ticket
|
(context, tlocal, published, summary, content, source) <-
|
||||||
(, ticketData, published, title, desc, src) <$>
|
checkTicket ticket
|
||||||
checkTargetAndContext mtarget context
|
item <- checkTargetAndContext mtarget context
|
||||||
|
return $ ParsedCreateTicket item tlocal published summary content source
|
||||||
where
|
where
|
||||||
|
checkTracker
|
||||||
|
:: Text
|
||||||
|
-> FedURI
|
||||||
|
-> ExceptT Text Handler
|
||||||
|
(Either
|
||||||
|
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
|
||||||
|
FedURI
|
||||||
|
)
|
||||||
checkTracker name u@(ObjURI h lu) = do
|
checkTracker name u@(ObjURI h lu) = do
|
||||||
hl <- hostIsLocal h
|
hl <- hostIsLocal h
|
||||||
if hl
|
if hl
|
||||||
|
@ -517,14 +545,24 @@ checkCreateTicket author ticket muTarget = do
|
||||||
(decodeRouteLocal lu)
|
(decodeRouteLocal lu)
|
||||||
(name <> " is local but isn't a valid route")
|
(name <> " is local but isn't a valid route")
|
||||||
case route of
|
case route of
|
||||||
ProjectR shr prj -> return (shr, prj)
|
ProjectR shr prj -> return $ Left (shr, prj)
|
||||||
|
RepoR shr rp -> return $ Right (shr, rp)
|
||||||
_ ->
|
_ ->
|
||||||
throwE $
|
throwE $
|
||||||
name <>
|
name <>
|
||||||
" is a valid local route, but isn't a project \
|
" is a valid local route, but isn't a \
|
||||||
\route"
|
\project/repo route"
|
||||||
else return $ Right u
|
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
|
checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
|
||||||
content source muAssigned resolved mmr) = do
|
content source muAssigned resolved mmr) = do
|
||||||
(hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'"
|
(hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'"
|
||||||
|
@ -541,31 +579,167 @@ checkCreateTicket author ticket muTarget = do
|
||||||
verifyNothingE mupdated "Ticket has 'updated'"
|
verifyNothingE mupdated "Ticket has 'updated'"
|
||||||
verifyNothingE muAssigned "Ticket has 'assignedTo'"
|
verifyNothingE muAssigned "Ticket has 'assignedTo'"
|
||||||
when resolved $ throwE "Ticket is resolved"
|
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 =
|
checkTargetAndContext Nothing context =
|
||||||
return $
|
return $
|
||||||
case context of
|
case context of
|
||||||
Left (shr, prj) -> Left (False, shr, prj)
|
Left wit -> Left (False, wit)
|
||||||
Right (ObjURI h lu) -> Right (h, Nothing, lu)
|
Right (h, luCtx, mpatch) -> Right $ RemoteWorkItem h Nothing luCtx mpatch
|
||||||
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 (ObjURI hContext luContext)) ->
|
(Right (ObjURI hTarget luTarget), Right (hContext, luContext, mpatch)) ->
|
||||||
if hTarget == hContext
|
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 \
|
else throwE "Create target and ticket context on \
|
||||||
\different remote hosts"
|
\different remote hosts"
|
||||||
(Left (shr, prj), Left (shr', prj')) ->
|
(Left proj, Left wit) ->
|
||||||
if shr == shr' && prj == prj'
|
case (proj, wit) of
|
||||||
then return $ Left (True, shr, prj)
|
(Left (shr, prj), WTTProject shr' prj')
|
||||||
else throwE "Create target and ticket context are \
|
| shr == shr' && prj == prj' ->
|
||||||
\different local projects"
|
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
|
sharerCreateTicketF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -578,8 +752,7 @@ sharerCreateTicketF
|
||||||
-> Maybe FedURI
|
-> Maybe FedURI
|
||||||
-> ExceptT Text Handler Text
|
-> ExceptT Text Handler Text
|
||||||
sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
|
sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
|
||||||
(targetAndContext, _, _, _, _, _) <-
|
targetAndContext <- pctItem <$> checkCreateTicket author ticket muTarget
|
||||||
checkCreateTicket author ticket muTarget
|
|
||||||
mractid <- runDBExcept $ do
|
mractid <- runDBExcept $ do
|
||||||
ibidRecip <- lift $ do
|
ibidRecip <- lift $ do
|
||||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
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"
|
Nothing -> "Activity already exists in my inbox"
|
||||||
Just _ -> "Activity inserted to my inbox"
|
Just _ -> "Activity inserted to my inbox"
|
||||||
where
|
where
|
||||||
checkTargetAndContextDB (Left (_, shr, prj)) = do
|
checkTargetAndContextDB (Left (_, WTTProject 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
|
||||||
|
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 ()
|
checkTargetAndContextDB (Right _) = return ()
|
||||||
|
|
||||||
projectCreateTicketF
|
projectCreateTicketF
|
||||||
|
@ -610,7 +788,8 @@ projectCreateTicketF
|
||||||
-> Maybe FedURI
|
-> Maybe FedURI
|
||||||
-> ExceptT Text Handler Text
|
-> ExceptT Text Handler Text
|
||||||
projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do
|
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
|
mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do
|
||||||
Entity jid j <- do
|
Entity jid j <- do
|
||||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
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"
|
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 (_, shr, prj))
|
targetRelevance (Left (_, WTTProject shr prj))
|
||||||
| shr == shrRecip && prj == prjRecip = Just ()
|
| shr == shrRecip && prj == prjRecip = Just ()
|
||||||
targetRelevance _ = Nothing
|
targetRelevance _ = Nothing
|
||||||
insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do
|
insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do
|
||||||
|
|
Loading…
Reference in a new issue