diff --git a/config/models b/config/models index b96c7f2..74f83d8 100644 --- a/config/models +++ b/config/models @@ -401,6 +401,7 @@ TicketProjectLocal TicketRepoLocal context TicketContextLocalId repo RepoId + branch Text Maybe UniqueTicketRepoLocal context diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 6cd4bf1..821b705 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -523,7 +523,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept return talid where - checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved) mtarget = do + checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do verifyNothingE mlocal "Ticket with 'id'" encodeRouteLocal <- getEncodeRouteLocal unless (encodeRouteLocal (SharerR shr) == luAttrib) $ @@ -534,6 +534,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT verifyNothingE massigned "Ticket with 'assignedTo'" when resolved $ throwE "Ticket resolved" target <- fromMaybeE mtarget "Create Ticket without 'target'" + verifyNothingE mmr "Ticket with 'attachment'" return (context, summary, content, source, target) parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI) @@ -677,6 +678,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , AP.ticketSource = source , AP.ticketAssignedTo = Nothing , AP.ticketIsResolved = False + , AP.ticketAttachment = Nothing } , createTarget = Just uTarget } diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index f4b80d5..74883c4 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -241,6 +241,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx , AP.ticketSource = TextPandocMarkdown desc , AP.ticketAssignedTo = Nothing , AP.ticketIsResolved = False + , AP.ticketAttachment = Nothing } offer = Offer { offerObject = ticket @@ -308,6 +309,7 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context , AP.ticketSource = TextPandocMarkdown desc , AP.ticketAssignedTo = Nothing , AP.ticketIsResolved = False + , AP.ticketAttachment = Nothing } create = Create { createObject = CreateTicket ticket diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 9793a05..79d0a7a 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -88,6 +88,7 @@ checkOffer ticket hProject shrProject prjProject = do -- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'" verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'" when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved" + verifyNothingE (AP.ticketAttachment ticket) "Ticket with 'attachment'" sharerOfferTicketF :: UTCTime @@ -445,7 +446,7 @@ checkCreateTicket author ticket muTarget = do else return $ Right u checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary - _content _source muAssigned resolved) = do + _content _source muAssigned resolved mmr) = do (hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'" hl <- hostIsLocal hTicket when hl $ throwE "Remote author claims to create local ticket" @@ -460,6 +461,7 @@ 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) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 511351f..bf05aa6 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -399,6 +399,7 @@ postPublishR = do , ticketSource = TextPandocMarkdown desc , ticketAssignedTo = Nothing , ticketIsResolved = False + , ticketAttachment = Nothing } offer = Offer { offerObject = ticketAP diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index d66f991..3e26b8b 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -34,6 +34,7 @@ import Database.Persist import Yesod.Core import Yesod.Persist.Core +import qualified Data.List.NonEmpty as NE import qualified Database.Esqueleto as E import Network.FedURI @@ -99,14 +100,14 @@ getSharerPatchesR = getSharerPatchR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent getSharerPatchR shr talkhid = do - (ticket, repo, massignee) <- runDB $ do - (_, _, Entity _ t, tp) <- getSharerPatch404 shr talkhid - (,,) t + (ticket, repo, massignee, ptids') <- runDB $ do + (_, _, Entity tid t, tp) <- getSharerPatch404 shr talkhid + (,,,) t <$> bitraverse (\ (_, Entity _ trl) -> do r <- getJust $ ticketRepoLocalRepo trl s <- getJust $ repoSharer r - return (s, r) + return (s, r, ticketRepoLocalBranch trl) ) (\ (Entity _ tpr, _) -> do roid <- @@ -124,10 +125,17 @@ getSharerPatchR shr talkhid = do p <- getJust pidAssignee getJust $ personIdent p ) + <*> selectKeysList [PatchTicket ==. tid] [Desc PatchId] + let ptids = + case NE.nonEmpty ptids' of + Nothing -> error "No patches found!" + Just ne -> ne hLocal <- getsYesod siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - let patchAP = AP.Ticket + encodePatchId <- getEncodeKeyHashid + let versionUrl = SharerPatchVersionR shr talkhid . encodePatchId + patchAP = AP.Ticket { AP.ticketLocal = Just ( hLocal , AP.TicketLocal @@ -152,7 +160,7 @@ getSharerPatchR shr talkhid = do , AP.ticketContext = Just $ case repo of - Left (s, r) -> + Left (s, r, _) -> encodeRouteHome $ RepoR (sharerIdent s) (repoIdent r) Right (i, ro) -> @@ -163,6 +171,23 @@ getSharerPatchR shr talkhid = do , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee , AP.ticketIsResolved = ticketStatus ticket == TSClosed + , AP.ticketAttachment = Just + ( hLocal + , MergeRequest + { mrOrigin = Nothing + , mrTarget = + case repo of + Left (s, r, Nothing) -> + encodeRouteHome $ + RepoR (sharerIdent s) (repoIdent r) + Left (s, r, Just b) -> + encodeRouteHome $ + RepoBranchR (sharerIdent s) (repoIdent r) b + Right (i, ro) -> + ObjURI (instanceHost i) (remoteObjectIdent ro) + , mrPatch = NE.map (encodeRouteLocal . versionUrl) ptids + } + ) } provideHtmlAndAP patchAP $ redirectToPrettyJSON here where diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 7c32779..efda708 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -418,6 +418,7 @@ getProjectTicketR shar proj ltkhid = do , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent . fst <$> massignee , AP.ticketIsResolved = ticketStatus ticket == TSClosed + , AP.ticketAttachment = Nothing } provideHtmlAndAP' host ticketAP $ let followButton = @@ -1230,6 +1231,7 @@ getSharerTicketR shr talkhid = do , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee , AP.ticketIsResolved = ticketStatus ticket == TSClosed + , AP.ticketAttachment = Nothing } provideHtmlAndAP ticketAP $ redirectToPrettyJSON here where diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index f82b2a0..f86e7c3 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -766,6 +766,7 @@ changes hLocal ctx = TextPandocMarkdown $ ticket20190612Source ticket , ticketAssignedTo = Nothing , ticketIsResolved = False + , ticketAttachment = Nothing } summary = [hamlet| @@ -1582,6 +1583,8 @@ changes hLocal ctx = , addEntities model_2020_05_17 -- 250 , addFieldPrimRequired "Patch" defaultTime "created" + -- 251 + , addFieldPrimOptional "TicketRepoLocal" (Nothing :: Maybe Text) "branch" ] migrateDB diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 5911faa..d00f629 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -49,6 +49,7 @@ module Web.ActivityPub , PatchType (..) , Patch (..) , TicketLocal (..) + , MergeRequest (..) , Ticket (..) , Author (..) , Hash (..) @@ -924,6 +925,44 @@ encodeTicketLocal <> "dependencies" .= ObjURI a deps <> "dependants" .= ObjURI a rdeps +data MergeRequest u = MergeRequest + { mrOrigin :: Maybe (ObjURI u) + , mrTarget :: ObjURI u + , mrPatch :: NonEmpty LocalURI + } + +instance ActivityPub MergeRequest where + jsonldContext _ = [as2Context, forgeContext] + + parseObject o = do + typ <- o .: "type" + unless (typ == ("Offer" :: Text)) $ + fail "type isn't Offer" + (hPatch, patches) <- do + c <- o .: "object" + ctyp <- c .: "type" + unless (ctyp == ("OrderedCollection" :: Text)) $ + fail "type isn't OrderedCollection" + ObjURI h lu :| us <- c .: "items" <|> c .: "orderedItems" + let (hs, lus) = unzip $ map (\ (ObjURI h lu) -> (h, lu)) us + unless (all (== h) hs) $ fail "Version hosts differ" + return (h, lu :| lus) + fmap (hPatch,) $ + MergeRequest + <$> o .:? "origin" + <*> o .: "target" + <*> pure patches + + toSeries hPatch (MergeRequest morigin target patches) + = "type" .= ("Offer" :: Text) + <> "origin" .=? morigin + <> "target" .= target + <> "object" .= object + [ "type" .= ("OrderedCollection" :: Text) + , "totalItems" .= length patches + , "orderedItems" .= NE.map (ObjURI hPatch) patches + ] + data Ticket u = Ticket { ticketLocal :: Maybe (Authority u, TicketLocal) , ticketAttributedTo :: LocalURI @@ -936,6 +975,7 @@ data Ticket u = Ticket , ticketSource :: TextPandocMarkdown , ticketAssignedTo :: Maybe (ObjURI u) , ticketIsResolved :: Bool + , ticketAttachment :: Maybe (Authority u, MergeRequest u) } instance ActivityPub Ticket where @@ -969,10 +1009,11 @@ instance ActivityPub Ticket where <*> source .: "content" <*> o .:? "assignedTo" <*> o .: "isResolved" + <*> (traverse parseObject =<< o .:? "attachment") toSeries authority (Ticket local attributedTo published updated context {-name-} - summary content source assignedTo isResolved) + summary content source assignedTo isResolved mmr) = maybe mempty (uncurry encodeTicketLocal) local <> "type" .= ("Ticket" :: Text) @@ -990,6 +1031,10 @@ instance ActivityPub Ticket where ] <> "assignedTo" .=? assignedTo <> "isResolved" .= isResolved + <> maybe + mempty + (\ (h, mr) -> "attachment" `pair` pairs (toSeries h mr)) + mmr data Author = Author { authorName :: Text