mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 18:04:53 +09:00
S2S: Repos now accept remotely hosted patches via Create/Ticket
This commit is contained in:
fr33domlover
parent
f286f35a87
commit
029fce58a4
2 changed files with 197 additions and 97 deletions
|
|
@ -372,6 +372,8 @@ handleRepoInbox shrRecip rpRecip now auth body = do
|
|||
case obj of
|
||||
CreateNote note ->
|
||||
(,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity note
|
||||
CreateTicket ticket ->
|
||||
(,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget
|
||||
_ -> error "Unsupported create object type for repos"
|
||||
FollowActivity follow ->
|
||||
(,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ module Vervis.Federation.Ticket
|
|||
|
||||
, sharerCreateTicketF
|
||||
, projectCreateTicketF
|
||||
, repoCreateTicketF
|
||||
|
||||
, sharerOfferDepF
|
||||
, projectOfferDepF
|
||||
|
|
@ -776,6 +777,124 @@ sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
|
|||
unless (isJust mr) $ throwE "Local context: No such repo"
|
||||
checkTargetAndContextDB (Right _) = return ()
|
||||
|
||||
insertRemoteTicket
|
||||
:: (MonadIO m, PersistRecordBackend txl SqlBackend)
|
||||
=> (TicketContextLocalId -> txl)
|
||||
-> RemoteAuthor
|
||||
-> LocalURI
|
||||
-> UTCTime
|
||||
-> TextHtml
|
||||
-> TextHtml
|
||||
-> TextPandocMarkdown
|
||||
-> RemoteActivityId
|
||||
-> OutboxItemId
|
||||
-> ReaderT SqlBackend m (Either Bool ())
|
||||
insertRemoteTicket mktxl author luTicket published summary content source ractidCreate obiidAccept = do
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = published
|
||||
, ticketTitle = unTextHtml summary
|
||||
, ticketSource = unTextPandocMarkdown source
|
||||
, ticketDescription = unTextHtml content
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
}
|
||||
tclid <- insert TicketContextLocal
|
||||
{ ticketContextLocalTicket = tid
|
||||
, ticketContextLocalAccept = obiidAccept
|
||||
}
|
||||
txlid <- insert $ mktxl tclid
|
||||
mtarid <- insertUnique TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tclid
|
||||
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketAuthorRemoteOpen = ractidCreate
|
||||
}
|
||||
case mtarid of
|
||||
Nothing -> do
|
||||
delete txlid
|
||||
delete tclid
|
||||
delete tid
|
||||
return $ Left False
|
||||
Just tarid -> do
|
||||
roid <- either entityKey id <$> insertBy' RemoteObject
|
||||
{ remoteObjectInstance = remoteAuthorInstance author
|
||||
, remoteObjectIdent = luTicket
|
||||
}
|
||||
did <- insert Discussion
|
||||
(rdid, rdnew) <- idAndNew <$> insertBy' RemoteDiscussion
|
||||
{ remoteDiscussionIdent = roid
|
||||
, remoteDiscussionDiscuss = did
|
||||
}
|
||||
unless rdnew $ delete did
|
||||
mrtid <- insertUnique RemoteTicket
|
||||
{ remoteTicketTicket = tarid
|
||||
, remoteTicketIdent = roid
|
||||
, remoteTicketDiscuss = rdid
|
||||
}
|
||||
case mrtid of
|
||||
Nothing -> do
|
||||
delete tarid
|
||||
delete txlid
|
||||
delete tclid
|
||||
delete tid
|
||||
return $ Left True
|
||||
Just _rtid -> return $ Right ()
|
||||
|
||||
insertAcceptOnCreate collections outboxItemRoute actorRoute author luCreate tlocal obiidAccept = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audAuthorAndTicket =
|
||||
AudRemote hAuthor [luAuthor] $ catMaybes
|
||||
[ remoteActorFollowers ra
|
||||
, Just $ AP.ticketParticipants tlocal
|
||||
]
|
||||
audProject = AudLocal [] collections
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAuthorAndTicket, audProject]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept
|
||||
, activityActor = encodeRouteLocal actorRoute
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hAuthor luCreate
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
insertAcceptOnCreate_J shr prj =
|
||||
insertAcceptOnCreate
|
||||
[ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
(ProjectOutboxItemR shr prj)
|
||||
(ProjectR shr prj)
|
||||
|
||||
insertAcceptOnCreate_R shr rp =
|
||||
insertAcceptOnCreate
|
||||
[ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
(RepoOutboxItemR shr rp)
|
||||
(RepoR shr rp)
|
||||
|
||||
projectCreateTicketF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
|
|
@ -797,7 +916,8 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
|
|||
mractid <- insertToInbox now author body (projectInbox j) luCreate False
|
||||
for mractid $ \ ractid -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
|
||||
result <- insertTicket jid author (AP.ticketId tlocal) published title desc src ractid obiidAccept
|
||||
let makeTPL tclid = TicketProjectLocal tclid jid
|
||||
result <- insertRemoteTicket makeTPL author (AP.ticketId tlocal) published title desc src ractid obiidAccept
|
||||
unless (isRight result) $ delete obiidAccept
|
||||
for result $ \ () -> do
|
||||
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
||||
|
|
@ -814,7 +934,7 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
|
|||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAccept shrRecip prjRecip author luCreate tlocal obiidAccept
|
||||
insertAcceptOnCreate_J shrRecip prjRecip author luCreate tlocal obiidAccept
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
|
|
@ -847,102 +967,80 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
|
|||
targetRelevance (Left (_, WTTProject shr prj))
|
||||
| shr == shrRecip && prj == prjRecip = Just ()
|
||||
targetRelevance _ = Nothing
|
||||
insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = published
|
||||
, ticketTitle = unTextHtml summary
|
||||
, ticketSource = unTextPandocMarkdown source
|
||||
, ticketDescription = unTextHtml content
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
}
|
||||
tclid <- insert TicketContextLocal
|
||||
{ ticketContextLocalTicket = tid
|
||||
, ticketContextLocalAccept = obiidAccept
|
||||
}
|
||||
tplid <- insert TicketProjectLocal
|
||||
{ ticketProjectLocalContext = tclid
|
||||
, ticketProjectLocalProject = jid
|
||||
}
|
||||
mtarid <- insertUnique TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tclid
|
||||
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketAuthorRemoteOpen = ractidCreate
|
||||
}
|
||||
case mtarid of
|
||||
Nothing -> do
|
||||
delete tplid
|
||||
delete tclid
|
||||
delete tid
|
||||
return $ Left False
|
||||
Just tarid -> do
|
||||
roid <- either entityKey id <$> insertBy' RemoteObject
|
||||
{ remoteObjectInstance = remoteAuthorInstance author
|
||||
, remoteObjectIdent = luTicket
|
||||
}
|
||||
did <- insert Discussion
|
||||
(rdid, rdnew) <- idAndNew <$> insertBy' RemoteDiscussion
|
||||
{ remoteDiscussionIdent = roid
|
||||
, remoteDiscussionDiscuss = did
|
||||
}
|
||||
unless rdnew $ delete did
|
||||
mrtid <- insertUnique RemoteTicket
|
||||
{ remoteTicketTicket = tarid
|
||||
, remoteTicketIdent = roid
|
||||
, remoteTicketDiscuss = rdid
|
||||
}
|
||||
case mrtid of
|
||||
Nothing -> do
|
||||
delete tarid
|
||||
delete tplid
|
||||
delete tclid
|
||||
delete tid
|
||||
return $ Left True
|
||||
Just _rtid -> return $ Right ()
|
||||
insertAccept shr prj author luCreate tlocal obiidAccept = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audAuthorAndTicket =
|
||||
AudRemote hAuthor [luAuthor] $ catMaybes
|
||||
[ remoteActorFollowers ra
|
||||
, Just $ AP.ticketParticipants tlocal
|
||||
]
|
||||
audProject =
|
||||
AudLocal []
|
||||
[ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAuthorAndTicket, audProject]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
ProjectOutboxItemR shr prj obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ ProjectR shr prj
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hAuthor luCreate
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
repoCreateTicketF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> RpIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> Maybe FedURI
|
||||
-> ExceptT Text Handler Text
|
||||
repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do
|
||||
ParsedCreateTicket targetAndContext tlocal published title desc src <-
|
||||
checkCreateTicket author ticket muTarget
|
||||
mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, vcs, _diff) -> runDBExcept $ do
|
||||
Entity rid r <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
getBy404 $ UniqueRepo rpRecip sid
|
||||
unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
|
||||
mractid <- lift $ insertToInbox now author body (repoInbox r) luCreate False
|
||||
lift $ for mractid $ \ ractid -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
|
||||
let mkTRL tclid = TicketRepoLocal tclid rid mb
|
||||
result <- insertRemoteTicket mkTRL author (AP.ticketId tlocal) published title desc src ractid obiidAccept
|
||||
unless (isRight result) $ delete obiidAccept
|
||||
for result $ \ () -> do
|
||||
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
|
||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
||||
]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False ractid $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptOnCreate_R shrRecip rpRecip author luCreate tlocal obiidAccept
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorRepo shrRecip rpRecip)
|
||||
(repoInbox r)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
case mmhttp of
|
||||
Nothing -> return "Create/MR against different repo, not using"
|
||||
Just mhttp ->
|
||||
case mhttp of
|
||||
Nothing -> return "Activity already in my inbox, doing nothing"
|
||||
Just e ->
|
||||
case e of
|
||||
Left False -> return "Already have a MR opened by this activity, ignoring"
|
||||
Left True -> return "Already have this MR, ignoring"
|
||||
Right (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "repoCreateTicketF inbox-forwarding" $
|
||||
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
|
||||
forkWorker "repoCreateTicketF Accept HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc remotes
|
||||
return $
|
||||
case mremotesHttpFwd of
|
||||
Nothing -> "Accepted and listed MR, no inbox-forwarding to do"
|
||||
Just _ -> "Accepted and listed MR and ran inbox-forwarding of the Create"
|
||||
where
|
||||
targetRelevance (Left (_, WTTRepo shr rp mb vcs diff))
|
||||
| shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff)
|
||||
targetRelevance _ = Nothing
|
||||
|
||||
sharerOfferDepF
|
||||
:: UTCTime
|
||||
|
|
|
|||
Loading…
Reference in a new issue