diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index e2e1282..ca4f934 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -83,11 +83,16 @@ import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Model.Repo import Vervis.Model.Ticket import Vervis.Patch import Vervis.Ticket import Vervis.WorkItem +data WorkItemTarget + = WTTProject ShrIdent PrjIdent + | WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text + checkOfferTicket :: RemoteAuthor -> AP.Ticket URIMode @@ -95,17 +100,18 @@ checkOfferTicket -> ExceptT Text Handler - ( Either (ShrIdent, PrjIdent) FedURI + ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) , TextHtml , TextHtml , TextPandocMarkdown ) checkOfferTicket author ticket uTarget = do target <- checkProject uTarget - (muContext, summary, content, source) <- checkTicket ticket + (muContext, summary, content, source, mmr) <- checkTicket ticket for_ muContext $ \ u -> unless (u == uTarget) $ throwE "Offer target != Ticket context" - return (target, summary, content, source) + target' <- matchTargetAndMR target mmr + return (target', summary, content, source) where checkProject u@(ObjURI h lu) = do hl <- hostIsLocal h @@ -116,11 +122,12 @@ checkOfferTicket author ticket uTarget = do (decodeRouteLocal lu) "Offer target 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 "Offer target is a valid local route, but isn't a \ - \project route" + \project or repo route" else return $ Right u checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary @@ -133,9 +140,66 @@ checkOfferTicket author ticket uTarget = do verifyNothingE mupdated "Ticket has 'updated'" verifyNothingE muAssigned "Ticket has 'assignedTo'" when resolved $ throwE "Ticket is resolved" - verifyNothingE mmr "Ticket has 'attachment'" - return (muContext, summary, content, source) + mmr' <- traverse (uncurry checkMR) mmr + + return (muContext, summary, content, source, mmr') + where + checkMR h (MergeRequest muOrigin luTarget epatch) = do + verifyNothingE muOrigin "MR with 'origin'" + branch <- checkBranch h luTarget + (typ, content) <- + case epatch of + Left _ -> throwE "MR patch specified as a URI" + Right (hPatch, patch) -> checkPatch hPatch patch + return (branch, typ, content) + where + 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 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))) (Just _) = throwE "Patch offered to project" + matchTargetAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" + matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, content)) = do + branch' <- + case branch of + Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb + _ -> throwE "MR target repo/branch and Offer target repo mismatch" + return $ Left $ WTTRepo shr rp branch' (typ2vcs typ) content + where + typ2vcs PatchTypeDarcs = VCSDarcs + matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) + matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, content)) = do + luBranch <- + case branch of + Right (ObjURI h' lu') | h == h' -> return lu + _ -> throwE "MR target repo/branch and Offer target repo mismatch" + let patch = + ( if lu == luBranch then Nothing else Just luBranch + , typ + , content + ) + return $ Right (h, lu, Just patch) sharerOfferTicketF :: UTCTime @@ -154,11 +218,16 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do sid <- getKeyBy404 $ UniqueSharer shrRecip personInbox <$> getValBy404 (UniquePersonIdent sid) case target of - Left (shr, prj) -> do + Left (WTTProject shr prj) -> do mjid <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getKeyBy $ UniqueProject prj sid void $ fromMaybeE mjid "Offer target: No such local project" + Left (WTTRepo shr rp _ _ _) -> do + mrid <- lift $ runMaybeT $ do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + MaybeT $ getKeyBy $ UniqueRepo rp sid + void $ fromMaybeE mrid "Offer target: No such local repo" Right _ -> return () lift $ insertToInbox now author body ibidRecip luOffer True return $ @@ -229,7 +298,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge Nothing -> "Accepted new ticket, no inbox-forwarding to do" Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer" where - targetRelevance (Left (shr, prj)) + targetRelevance (Left (WTTProject shr prj)) | shr == shrRecip && prj == prjRecip = Just () targetRelevance _ = Nothing insertTicket now author jid summary content source ractidOffer obiidAccept = do diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 213a0fa..7d00c20 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -283,7 +283,7 @@ getSharerPatchVersionR shr talkhid ptkhid = do } ) , AP.patchAttributedTo = encodeRouteLocal $ SharerR shr - , AP.patchPublished = patchCreated patch + , AP.patchPublished = Just $ patchCreated patch , AP.patchType = case vcs of VCSDarcs -> PatchTypeDarcs @@ -576,7 +576,7 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do Left sharer -> encodeRouteLocal $ SharerR $ sharerIdent sharer Right (_, object) -> remoteObjectIdent object - , AP.patchPublished = patchCreated patch + , AP.patchPublished = Just $ patchCreated patch , AP.patchType = case vcs of VCSDarcs -> PatchTypeDarcs diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 8cae27e..826e265 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -875,7 +875,7 @@ encodePatchLocal a (PatchLocal id_ context versions) data Patch u = Patch { patchLocal :: Maybe (Authority u, PatchLocal) , patchAttributedTo :: LocalURI - , patchPublished :: UTCTime + , patchPublished :: Maybe UTCTime , patchType :: PatchType , patchContent :: Text } @@ -894,7 +894,7 @@ instance ActivityPub Patch where Patch <$> parsePatchLocal o <*> pure attrib - <*> o .: "published" + <*> o .:? "published" <*> o .: "mediaType" <*> o .: "content" @@ -902,7 +902,7 @@ instance ActivityPub Patch where = maybe mempty (uncurry encodePatchLocal) local <> "type" .= ("Patch" :: Text) <> "attributedTo" .= ObjURI a attrib - <> "published" .= published + <> "published" .=? published <> "mediaType" .= typ <> "content" .= content