diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index 41dc9d7..4971bed 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -377,6 +377,8 @@ handleRepoInbox shrRecip rpRecip now auth body = do
(,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
OfferActivity (Offer obj target) ->
case obj of
+ OfferTicket ticket ->
+ (,Nothing) <$> repoOfferTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket target
OfferDep dep ->
repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
_ -> return ("Unsupported offer object type for repos", Nothing)
diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index ca4f934..1dbfb2b 100644
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@@ -16,6 +16,7 @@
module Vervis.Federation.Ticket
( sharerOfferTicketF
, projectOfferTicketF
+ , repoOfferTicketF
, sharerCreateTicketF
, projectCreateTicketF
@@ -62,7 +63,7 @@ import qualified Data.Text.Lazy as TL
import Database.Persist.JSON
import Network.FedURI
-import Web.ActivityPub hiding (Ticket (..))
+import Web.ActivityPub hiding (Patch, Ticket (..))
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
@@ -185,7 +186,15 @@ checkOfferTicket author ticket uTarget = do
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
+ 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
matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
@@ -235,6 +244,37 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do
Nothing -> "Activity already exists in my inbox"
Just _ -> "Activity inserted to my inbox"
+insertLocalTicket now author txl summary content source ractidOffer obiidAccept = do
+ did <- insert Discussion
+ fsid <- insert FollowerSet
+ tid <- insert Ticket
+ { ticketNumber = Nothing
+ , ticketCreated = now
+ , ticketTitle = unTextHtml summary
+ , ticketSource = unTextPandocMarkdown source
+ , ticketDescription = unTextHtml content
+ , ticketAssignee = Nothing
+ , ticketStatus = TSNew
+ , ticketClosed = UTCTime (ModifiedJulianDay 0) 0
+ , ticketCloser = Nothing
+ }
+ ltid <- insert LocalTicket
+ { localTicketTicket = tid
+ , localTicketDiscuss = did
+ , localTicketFollowers = fsid
+ }
+ tclid <- insert TicketContextLocal
+ { ticketContextLocalTicket = tid
+ , ticketContextLocalAccept = obiidAccept
+ }
+ insert_ $ txl tclid
+ insert_ TicketAuthorRemote
+ { ticketAuthorRemoteTicket = tclid
+ , ticketAuthorRemoteAuthor = remoteAuthorId author
+ , ticketAuthorRemoteOpen = ractidOffer
+ }
+ return (tid, ltid)
+
projectOfferTicketF
:: UTCTime
-> ShrIdent
@@ -269,7 +309,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
(obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
- ltid <- insertTicket now author jid summary content source ractid obiidAccept
+ (_, ltid) <- insertLocalTicket now author (flip TicketProjectLocal jid) summary content source ractid obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept shrRecip prjRecip author luOffer ltid obiidAccept
knownRemoteRecipsAccept <-
@@ -301,39 +341,6 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
targetRelevance (Left (WTTProject shr prj))
| shr == shrRecip && prj == prjRecip = Just ()
targetRelevance _ = Nothing
- insertTicket now author jid summary content source ractidOffer obiidAccept = do
- did <- insert Discussion
- fsid <- insert FollowerSet
- tid <- insert Ticket
- { ticketNumber = Nothing
- , ticketCreated = now
- , ticketTitle = unTextHtml summary
- , ticketSource = unTextPandocMarkdown source
- , ticketDescription = unTextHtml content
- , ticketAssignee = Nothing
- , ticketStatus = TSNew
- , ticketClosed = UTCTime (ModifiedJulianDay 0) 0
- , ticketCloser = Nothing
- }
- ltid <- insert LocalTicket
- { localTicketTicket = tid
- , localTicketDiscuss = did
- , localTicketFollowers = fsid
- }
- tclid <- insert TicketContextLocal
- { ticketContextLocalTicket = tid
- , ticketContextLocalAccept = obiidAccept
- }
- insert_ TicketProjectLocal
- { ticketProjectLocalContext = tclid
- , ticketProjectLocalProject = jid
- }
- insert_ TicketAuthorRemote
- { ticketAuthorRemoteTicket = tclid
- , ticketAuthorRemoteAuthor = remoteAuthorId author
- , ticketAuthorRemoteOpen = ractidOffer
- }
- return ltid
insertAccept shr prj author luOffer ltid obiidAccept = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
@@ -375,6 +382,116 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
+repoOfferTicketF
+ :: UTCTime
+ -> ShrIdent
+ -> RpIdent
+ -> RemoteAuthor
+ -> ActivityBody
+ -> Maybe (LocalRecipientSet, ByteString)
+ -> LocalURI
+ -> AP.Ticket URIMode
+ -> FedURI
+ -> ExceptT Text Handler Text
+repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = do
+ (target, summary, content, source) <- checkOfferTicket author ticket uTarget
+ mmhttp <- for (targetRelevance target) $ \ (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) luOffer False
+ lift $ for mractid $ \ ractid -> 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
+ (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
+ obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
+ let makeTRL tclid = TicketRepoLocal tclid rid mb
+ (tid, ltid) <- insertLocalTicket now author makeTRL summary content source ractid obiidAccept
+ insert_ $ Patch tid now diff
+ (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+ insertAccept shrRecip rpRecip author luOffer ltid obiidAccept
+ knownRemoteRecipsAccept <-
+ deliverLocal'
+ False
+ (LocalActorRepo shrRecip rpRecip)
+ (repoInbox r)
+ obiidAccept
+ localRecipsAccept
+ (obiidAccept,docAccept,fwdHostsAccept,) <$>
+ deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+ return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept)
+ case mmhttp of
+ Nothing -> return "Offer target isn't me, not using"
+ Just mhttp ->
+ case mhttp of
+ Nothing -> return "Activity already in my inbox, doing nothing"
+ Just (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do
+ for_ mremotesHttpFwd $ \ (sig, remotes) ->
+ forkWorker "repoOfferTicketF inbox-forwarding" $
+ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
+ forkWorker "repoOfferTicketF Accept HTTP delivery" $
+ deliverRemoteHttp' fwdHosts obiid doc remotes
+ return $
+ case mremotesHttpFwd of
+ Nothing -> "Accepted new patch, no inbox-forwarding to do"
+ Just _ -> "Accepted new patch and ran inbox-forwarding of the Offer"
+ where
+ targetRelevance (Left (WTTRepo shr rp mb vcs diff))
+ | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff)
+ targetRelevance _ = Nothing
+ insertAccept shr rp author luOffer ltid obiidAccept = do
+ encodeRouteLocal <- getEncodeRouteLocal
+ encodeRouteHome <- getEncodeRouteHome
+
+ hLocal <- asksSite siteInstanceHost
+
+ obikhidAccept <- encodeKeyHashid obiidAccept
+ ltkhid <- encodeKeyHashid ltid
+
+ ra <- getJust $ remoteAuthorId author
+
+ let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+ audAuthor =
+ AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+ audProject =
+ AudLocal []
+ [ LocalPersonCollectionRepoTeam shr rp
+ , LocalPersonCollectionRepoFollowers shr rp
+ ]
+
+ (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+ collectAudience [audAuthor, audProject]
+
+ recips = map encodeRouteHome audLocal ++ audRemote
+ doc = Doc hLocal Activity
+ { activityId =
+ Just $ encodeRouteLocal $
+ RepoOutboxItemR shr rp obikhidAccept
+ , activityActor = encodeRouteLocal $ RepoR shr rp
+ , activitySummary = Nothing
+ , activityAudience = Audience recips [] [] [] [] []
+ , activitySpecific = AcceptActivity Accept
+ { acceptObject = ObjURI hAuthor luOffer
+ , acceptResult =
+ Just $ encodeRouteLocal $ RepoPatchR shr rp ltkhid
+ }
+ }
+ update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+ return (doc, recipientSet, remoteActors, fwdHosts)
+
checkCreateTicket
:: RemoteAuthor
-> AP.Ticket URIMode