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