diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 4444905..5d07d67 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -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