diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index 026c501..e2e1282 100644
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@@ -37,6 +37,7 @@ import Data.Aeson
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
+import Data.Either
import Data.Foldable
import Data.Function
import Data.List (nub, union)
@@ -87,21 +88,6 @@ import Vervis.Patch
import Vervis.Ticket
import Vervis.WorkItem
-checkOffer
- :: AP.Ticket URIMode
- -> Host
- -> ShrIdent
- -> PrjIdent
- -> ExceptT Text Handler ()
-checkOffer ticket hProject shrProject prjProject = do
- verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
- verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
- verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
- -- 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'"
-
checkOfferTicket
:: RemoteAuthor
-> AP.Ticket URIMode
@@ -180,53 +166,6 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do
Nothing -> "Activity already exists in my inbox"
Just _ -> "Activity inserted to my inbox"
-data OfferTicketRecipColl
- = OfferTicketRecipProjectFollowers
- | OfferTicketRecipProjectTeam
- deriving Eq
-
-findRelevantCollections shrRecip prjRecip hLocal = nub . mapMaybe decide . concatRecipients
- where
- decide u = do
- let ObjURI h lu = u
- guard $ h == hLocal
- route <- decodeRouteLocal lu
- case route of
- ProjectTeamR shr prj
- | shr == shrRecip && prj == prjRecip
- -> Just OfferTicketRecipProjectTeam
- ProjectFollowersR shr prj
- | shr == shrRecip && prj == prjRecip
- -> Just OfferTicketRecipProjectFollowers
- _ -> Nothing
-
--- | Perform inbox forwarding, delivering a remote activity we received to
--- local inboxes
-deliverFwdLocal
- :: RemoteActivityId
- -> [OfferTicketRecipColl]
- -> SharerId
- -> FollowerSetId
- -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
-deliverFwdLocal ractid recips sid fsid = do
- (teamPids, teamRemotes) <-
- if OfferTicketRecipProjectTeam `elem` recips
- then getTicketTeam sid
- else return ([], [])
- (fsPids, fsRemotes) <-
- if OfferTicketRecipProjectFollowers `elem` recips
- then getFollowers fsid
- else return ([], [])
- let pids = union teamPids fsPids
- remotes = unionRemotes teamRemotes fsRemotes
- for_ pids $ \ pid -> do
- ibid <- personInbox <$> getJust pid
- ibiid <- insert $ InboxItem True
- mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
- when (isNothing mibrid) $
- delete ibiid
- return remotes
-
projectOfferTicketF
:: UTCTime
-> ShrIdent
@@ -377,11 +316,15 @@ checkCreateTicket
( (Either (Bool, ShrIdent, PrjIdent) (Host, Maybe LocalURI, LocalURI))
, TicketLocal
, UTCTime
+ , TextHtml
+ , TextHtml
+ , TextPandocMarkdown
)
checkCreateTicket author ticket muTarget = do
mtarget <- traverse (checkTracker "Create target") muTarget
- (context, ticketData, published) <- checkTicket ticket
- (, ticketData, published) <$> checkTargetAndContext mtarget context
+ (context, ticketData, published, title, desc, src) <- checkTicket ticket
+ (, ticketData, published, title, desc, src) <$>
+ checkTargetAndContext mtarget context
where
checkTracker name u@(ObjURI h lu) = do
hl <- hostIsLocal h
@@ -400,8 +343,8 @@ checkCreateTicket author ticket muTarget = do
\route"
else return $ Right u
- checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary
- _content _source muAssigned resolved mmr) = do
+ checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
+ 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"
@@ -418,7 +361,7 @@ checkCreateTicket author ticket muTarget = do
when resolved $ throwE "Ticket is resolved"
verifyNothingE mmr "Ticket has 'attachment'"
- return (context, tlocal, pub)
+ return (context, tlocal, pub, summary, content, source)
checkTargetAndContext Nothing context =
return $
@@ -453,7 +396,8 @@ sharerCreateTicketF
-> Maybe FedURI
-> ExceptT Text Handler Text
sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
- (targetAndContext, _, _) <- checkCreateTicket author ticket muTarget
+ (targetAndContext, _, _, _, _, _) <-
+ checkCreateTicket author ticket muTarget
mractid <- runDBExcept $ do
ibidRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
@@ -484,152 +428,71 @@ projectCreateTicketF
-> Maybe FedURI
-> ExceptT Text Handler Text
projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do
- (targetAndContext, tlocal, published) <- checkCreateTicket author ticket muTarget
- case targetAndContext of
- Left (_, shrContext, prjContext)
- | shrRecip == shrContext && prjRecip == prjContext -> do
- msgOrRecips <- lift $ runDB $ do
- (sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
- mractidCreate <- insertCreate luCreate ibidProject
- case mractidCreate of
- Nothing -> return $ Left "Already have this activity in project inbox, ignoring"
- Just ractidCreate -> do
- (obiidAccept, docAccept, localRecipsAccept, remoteRecipsAccept, fwdAccept) <- insertAccept obidProject luCreate tlocal
- result <- insertTicket jid (AP.ticketId tlocal) published ractidCreate obiidAccept
- case result of
- Left False -> do
- delete obiidAccept
- return $ Left "Already have a ticket opened by this activity, ignoring"
- Left True -> do
- delete obiidAccept
- return $ Left "Already have this ticket, ignoring"
- Right () -> do
- hLocal <- getsYesod siteInstanceHost
- let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body
- mremoteRecipsHttpCreateFwd <- for mfwd $ \ (_, sig) -> do
- remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject
- (sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
- remoteRecipsHttpAccept <- do
- moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept
- deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept
- return $ Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept)
- case msgOrRecips of
- Left msg -> return msg
- Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do
- for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig recips
- forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept
- return "Accepting and listing new remote author hosted ticket"
- _ -> return "Create/Ticket against different project, ignoring"
+ (targetAndContext, tlocal, published, title, desc, src) <- checkCreateTicket author ticket muTarget
+ mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do
+ Entity jid j <- do
+ sid <- getKeyBy404 $ UniqueSharer shrRecip
+ getBy404 $ UniqueProject prjRecip sid
+ 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
+ unless (isRight result) $ delete obiidAccept
+ for result $ \ () -> do
+ mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+ let sieve =
+ makeRecipientSet
+ []
+ [ LocalPersonCollectionProjectTeam shrRecip prjRecip
+ , LocalPersonCollectionProjectFollowers shrRecip prjRecip
+ ]
+ remoteRecips <-
+ insertRemoteActivityToLocalInboxes
+ False ractid $
+ localRecipSieve'
+ sieve False False localRecips
+ (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
+ (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+ insertAccept shrRecip prjRecip author luCreate tlocal obiidAccept
+ knownRemoteRecipsAccept <-
+ deliverLocal'
+ False
+ (LocalActorProject shrRecip prjRecip)
+ (projectInbox j)
+ obiidAccept
+ localRecipsAccept
+ (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
+ deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+ case mmhttp of
+ Nothing -> return "Create/Ticket against different project, 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 ticket opened by this activity, ignoring"
+ Left True -> return "Already have this ticket, ignoring"
+ Right (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do
+ for_ mremotesHttpFwd $ \ (sig, remotes) ->
+ forkWorker "projectCreateTicketF inbox-forwarding" $
+ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
+ forkWorker "projectCreateTicketF Accept HTTP delivery" $
+ deliverRemoteHttp' fwdHosts obiid doc remotes
+ return $
+ case mremotesHttpFwd of
+ Nothing -> "Accepted and listed ticket, no inbox-forwarding to do"
+ Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create"
where
- getProject = do
- sid <- getKeyBy404 $ UniqueSharer shrRecip
- Entity jid j <- getBy404 $ UniqueProject prjRecip sid
- return (sid, jid, projectOutbox j, projectInbox j, projectFollowers j)
-
- insertCreate luCreate ibidProject = do
- roid <- either entityKey id <$> insertBy' RemoteObject
- { remoteObjectInstance = remoteAuthorInstance author
- , remoteObjectIdent = luCreate
- }
- let raidAuthor = remoteAuthorId author
- ractidCreate <- either entityKey id <$> insertBy' RemoteActivity
- { remoteActivityIdent = roid
- , remoteActivityContent = persistJSONFromBL $ actbBL body
- , remoteActivityReceived = now
- }
- ibiid <- insert $ InboxItem False
- mibirid <-
- insertUnique $ InboxItemRemote ibidProject ractidCreate ibiid
- case mibirid of
- Nothing -> do
- delete ibiid
- return Nothing
- Just _ -> return $ Just ractidCreate
-
- insertAccept obidProject luCreate tlocal = do
- encodeRouteLocal <- getEncodeRouteLocal
- encodeRouteHome <- getEncodeRouteHome
- hLocal <- asksSite siteInstanceHost
- obiidAccept <- insert OutboxItem
- { outboxItemOutbox = obidProject
- , outboxItemActivity =
- persistJSONObjectFromDoc $ Doc hLocal emptyActivity
- , outboxItemPublished = now
- }
- obikhidAccept <- encodeKeyHashid obiidAccept
- ra <- getJust $ remoteAuthorId author
- summary <- do
- let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author
- TextHtml . TL.toStrict . renderHtml <$>
- withUrlRenderer
- [hamlet|
- <p>
- <a href="#{renderObjURI uAuthor}">
- $maybe name <- remoteActorName ra
- #{name}
- $nothing
- #{renderAuthority hAuthor}#{localUriPath luAuthor}
- \'s ticket accepted and listed by project #
- <a href=@{ProjectR shrRecip prjRecip}>
- ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
- \: #
- <a href="#{renderObjURI $ ObjURI hAuthor $ AP.ticketId tlocal}">
- #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
- |]
- let localRecipsA =
- [
- ]
- localRecipsC =
- [ LocalPersonCollectionProjectTeam shrRecip prjRecip
- , LocalPersonCollectionProjectFollowers shrRecip prjRecip
- ]
- remoteRecipsA =
- objUriLocal (remoteAuthorURI author) :| []
- remoteRecipsC = catMaybes
- [ remoteActorFollowers ra
- , Just $ AP.ticketParticipants tlocal
- , AP.ticketTeam tlocal
- ]
- localRecips =
- map encodeRouteHome $
- map renderLocalActor localRecipsA ++
- map renderLocalPersonCollection localRecipsC
- remoteRecips =
- map (ObjURI $ objUriAuthority $ remoteAuthorURI author) $
- NE.toList remoteRecipsA ++ remoteRecipsC
- recips = localRecips ++ remoteRecips
- doc = Doc hLocal Activity
- { activityId =
- Just $ encodeRouteLocal $
- ProjectOutboxItemR shrRecip prjRecip obikhidAccept
- , activityActor =
- encodeRouteLocal $ ProjectR shrRecip prjRecip
- , activitySummary = Just summary
- , activityAudience = Audience recips [] [] [] [] []
- , activitySpecific = AcceptActivity Accept
- { acceptObject =
- ObjURI
- (objUriAuthority $ remoteAuthorURI author)
- luCreate
- , acceptResult = Nothing
- }
- }
- update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
- return
- ( obiidAccept
- , doc
- , makeRecipientSet localRecipsA localRecipsC
- , [(objUriAuthority $ remoteAuthorURI author, remoteRecipsA)]
- , objUriAuthority $ remoteAuthorURI author
- )
-
- insertTicket jid luTicket published ractidCreate obiidAccept = do
+ targetRelevance (Left (_, 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 $ AP.ticketSummary ticket
- , ticketSource = unTextPandocMarkdown $ AP.ticketSource ticket
- , ticketDescription = unTextHtml $ AP.ticketContent ticket
+ , ticketTitle = unTextHtml summary
+ , ticketSource = unTextPandocMarkdown source
+ , ticketDescription = unTextHtml content
, ticketAssignee = Nothing
, ticketStatus = TSNew
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
@@ -678,6 +541,47 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
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)
sharerOfferDepF
:: UTCTime