NOTE: Federation is disabled on this instance!

• forge.angeley.es
• code.angeley.es

• Edit file src/Vervis/Federation/Ticket.hs 0 → 0

  +		40	import Data.Either
  …	…	…	…
  -	91		checkOffer
  -	92		:: AP.Ticket URIMode
  -	93		-> Host
  -	94		-> ShrIdent
  -	95		-> PrjIdent
  -	96		-> ExceptT Text Handler ()
  -	97		checkOffer ticket hProject shrProject prjProject = do
  -	98		verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
  -	99		verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
  -	100		verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
  -	101		-- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
  -	102		verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
  -	103		when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
  -	104		verifyNothingE (AP.ticketAttachment ticket) "Ticket with 'attachment'"
  -	105
  …	…	…	…
  -	169		data OfferTicketRecipColl
  -	170		= OfferTicketRecipProjectFollowers
  -	171		| OfferTicketRecipProjectTeam
  -	172		deriving Eq
  -	173
  -	174		findRelevantCollections shrRecip prjRecip hLocal = nub . mapMaybe decide . concatRecipients
  -	175		where
  -	176		decide u = do
  -	177		let ObjURI h lu = u
  -	178		guard $ h == hLocal
  -	179		route <- decodeRouteLocal lu
  -	180		case route of
  -	181		ProjectTeamR shr prj
  -	182		| shr == shrRecip && prj == prjRecip
  -	183		-> Just OfferTicketRecipProjectTeam
  -	184		ProjectFollowersR shr prj
  -	185		| shr == shrRecip && prj == prjRecip
  -	186		-> Just OfferTicketRecipProjectFollowers
  -	187		_ -> Nothing
  -	188
  -	189		-- | Perform inbox forwarding, delivering a remote activity we received to
  -	190		-- local inboxes
  -	191		deliverFwdLocal
  -	192		:: RemoteActivityId
  -	193		-> [OfferTicketRecipColl]
  -	194		-> SharerId
  -	195		-> FollowerSetId
  -	196		-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
  -	197		deliverFwdLocal ractid recips sid fsid = do
  -	198		(teamPids, teamRemotes) <-
  -	199		if OfferTicketRecipProjectTeam `elem` recips
  -	200		then getTicketTeam sid
  -	201		else return ([], [])
  -	202		(fsPids, fsRemotes) <-
  -	203		if OfferTicketRecipProjectFollowers `elem` recips
  -	204		then getFollowers fsid
  -	205		else return ([], [])
  -	206		let pids = union teamPids fsPids
  -	207		remotes = unionRemotes teamRemotes fsRemotes
  -	208		for_ pids $ \ pid -> do
  -	209		ibid <- personInbox <$> getJust pid
  -	210		ibiid <- insert $ InboxItem True
  -	211		mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
  -	212		when (isNothing mibrid) $
  -	213		delete ibiid
  -	214		return remotes
  -	215
  …	…	…	…
  +		258	, TextHtml
  +		259	, TextHtml
  +		260	, TextPandocMarkdown
  -	325		(context, ticketData, published) <- checkTicket ticket
  -	326		(, ticketData, published) <$> checkTargetAndContext mtarget context
  +		267	(context, ticketData, published, title, desc, src) <- checkTicket ticket
  +		268	(, ticketData, published, title, desc, src) <$>
  +		269	checkTargetAndContext mtarget context
  …	…	…	…
  -	346		checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary
  -	347		_content _source muAssigned resolved mmr) = do
  +		289	checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
  +		290	content source muAssigned resolved mmr) = do
  …	…	…	…
  -	364		return (context, tlocal, pub)
  +		307	return (context, tlocal, pub, summary, content, source)
  …	…	…	…
  -	399		(targetAndContext, _, _) <- checkCreateTicket author ticket muTarget
  +		342	(targetAndContext, _, _, _, _, _) <-
  +		343	checkCreateTicket author ticket muTarget
  …	…	…	…
  -	431		(targetAndContext, tlocal, published) <- checkCreateTicket author ticket muTarget
  -	432		case targetAndContext of
  -	433		Left (_, shrContext, prjContext)
  -	434		| shrRecip == shrContext && prjRecip == prjContext -> do
  -	435		msgOrRecips <- lift $ runDB $ do
  -	436		(sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
  -	437		mractidCreate <- insertCreate luCreate ibidProject
  -	438		case mractidCreate of
  -	439		Nothing -> return $ Left "Already have this activity in project inbox, ignoring"
  -	440		Just ractidCreate -> do
  -	441		(obiidAccept, docAccept, localRecipsAccept, remoteRecipsAccept, fwdAccept) <- insertAccept obidProject luCreate tlocal
  -	442		result <- insertTicket jid (AP.ticketId tlocal) published ractidCreate obiidAccept
  -	443		case result of
  -	444		Left False -> do
  -	445		delete obiidAccept
  -	446		return $ Left "Already have a ticket opened by this activity, ignoring"
  -	447		Left True -> do
  -	448		delete obiidAccept
  -	449		return $ Left "Already have this ticket, ignoring"
  -	450		Right () -> do
  -	451		hLocal <- getsYesod siteInstanceHost
  -	452		let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body
  -	453		mremoteRecipsHttpCreateFwd <- for mfwd $ \ (_, sig) -> do
  -	454		remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject
  -	455		(sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
  -	456		remoteRecipsHttpAccept <- do
  -	457		moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept
  -	458		deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept
  -	459		return $ Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept)
  -	460		case msgOrRecips of
  -	461		Left msg -> return msg
  -	462		Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do
  -	463		for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig recips
  -	464		forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept
  -	465		return "Accepting and listing new remote author hosted ticket"
  -	466		_ -> return "Create/Ticket against different project, ignoring"
  +		375	(targetAndContext, tlocal, published, title, desc, src) <- checkCreateTicket author ticket muTarget
  +		376	mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do
  +		377	Entity jid j <- do
  +		378	sid <- getKeyBy404 $ UniqueSharer shrRecip
  +		379	getBy404 $ UniqueProject prjRecip sid
  +		380	mractid <- insertToInbox now author body (projectInbox j) luCreate False
  +		381	for mractid $ \ ractid -> do
  +		382	obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
  +		383	result <- insertTicket jid author (AP.ticketId tlocal) published title desc src ractid obiidAccept
  +		384	unless (isRight result) $ delete obiidAccept
  +		385	for result $ \ () -> do
  +		386	mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
  +		387	let sieve =
  +		388	makeRecipientSet
  +		389	[]
  +		390	[ LocalPersonCollectionProjectTeam shrRecip prjRecip
  +		391	, LocalPersonCollectionProjectFollowers shrRecip prjRecip
  +		392	]
  +		393	remoteRecips <-
  +		394	insertRemoteActivityToLocalInboxes
  +		395	False ractid $
  +		396	localRecipSieve'
  +		397	sieve False False localRecips
  +		398	(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
  +		399	(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
  +		400	insertAccept shrRecip prjRecip author luCreate tlocal obiidAccept
  +		401	knownRemoteRecipsAccept <-
  +		402	deliverLocal'
  +		403	False
  +		404	(LocalActorProject shrRecip prjRecip)
  +		405	(projectInbox j)
  +		406	obiidAccept
  +		407	localRecipsAccept
  +		408	(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
  +		409	deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
  +		410	case mmhttp of
  +		411	Nothing -> return "Create/Ticket against different project, not using"
  +		412	Just mhttp ->
  +		413	case mhttp of
  +		414	Nothing -> return "Activity already in my inbox, doing nothing"
  +		415	Just e ->
  +		416	case e of
  +		417	Left False -> return "Already have a ticket opened by this activity, ignoring"
  +		418	Left True -> return "Already have this ticket, ignoring"
  +		419	Right (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do
  +		420	for_ mremotesHttpFwd $ \ (sig, remotes) ->
  +		421	forkWorker "projectCreateTicketF inbox-forwarding" $
  +		422	deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
  +		423	forkWorker "projectCreateTicketF Accept HTTP delivery" $
  +		424	deliverRemoteHttp' fwdHosts obiid doc remotes
  +		425	return $
  +		426	case mremotesHttpFwd of
  +		427	Nothing -> "Accepted and listed ticket, no inbox-forwarding to do"
  +		428	Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create"
  …	…	…	…
  -	486		getProject = do
  -	487		sid <- getKeyBy404 $ UniqueSharer shrRecip
  -	488		Entity jid j <- getBy404 $ UniqueProject prjRecip sid
  -	489		return (sid, jid, projectOutbox j, projectInbox j, projectFollowers j)
  -	490
  -	491		insertCreate luCreate ibidProject = do
  -	492		roid <- either entityKey id <$> insertBy' RemoteObject
  -	493		{ remoteObjectInstance = remoteAuthorInstance author
  -	494		, remoteObjectIdent = luCreate
  -	495		}
  -	496		let raidAuthor = remoteAuthorId author
  -	497		ractidCreate <- either entityKey id <$> insertBy' RemoteActivity
  -	498		{ remoteActivityIdent = roid
  -	499		, remoteActivityContent = persistJSONFromBL $ actbBL body
  -	500		, remoteActivityReceived = now
  -	501		}
  -	502		ibiid <- insert $ InboxItem False
  -	503		mibirid <-
  -	504		insertUnique $ InboxItemRemote ibidProject ractidCreate ibiid
  -	505		case mibirid of
  -	506		Nothing -> do
  -	507		delete ibiid
  -	508		return Nothing
  -	509		Just _ -> return $ Just ractidCreate
  -	510
  -	511		insertAccept obidProject luCreate tlocal = do
  -	512		encodeRouteLocal <- getEncodeRouteLocal
  -	513		encodeRouteHome <- getEncodeRouteHome
  -	514		hLocal <- asksSite siteInstanceHost
  -	515		obiidAccept <- insert OutboxItem
  -	516		{ outboxItemOutbox = obidProject
  -	517		, outboxItemActivity =
  -	518		persistJSONObjectFromDoc $ Doc hLocal emptyActivity
  -	519		, outboxItemPublished = now
  -	520		}
  -	521		obikhidAccept <- encodeKeyHashid obiidAccept
  -	522		ra <- getJust $ remoteAuthorId author
  -	523		summary <- do
  -	524		let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author
  -	525		TextHtml . TL.toStrict . renderHtml <$>
  -	526		withUrlRenderer
  -	527		[hamlet|
  -	528		<p>
  -	529		<a href="#{renderObjURI uAuthor}">
  -	530		$maybe name <- remoteActorName ra
  -	531		#{name}
  -	532		$nothing
  -	533		#{renderAuthority hAuthor}#{localUriPath luAuthor}
  -	534		\'s ticket accepted and listed by project #
  -	535		<a href=@{ProjectR shrRecip prjRecip}>
  -	536		./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
  -	537		\: #
  -	538		<a href="#{renderObjURI $ ObjURI hAuthor $ AP.ticketId tlocal}">
  -	539		#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
  -	540		|]
  -	541		let localRecipsA =
  -	542		[
  -	543		]
  -	544		localRecipsC =
  -	545		[ LocalPersonCollectionProjectTeam shrRecip prjRecip
  -	546		, LocalPersonCollectionProjectFollowers shrRecip prjRecip
  -	547		]
  -	548		remoteRecipsA =
  -	549		objUriLocal (remoteAuthorURI author) :| []
  -	550		remoteRecipsC = catMaybes
  -	551		[ remoteActorFollowers ra
  -	552		, Just $ AP.ticketParticipants tlocal
  -	553		, AP.ticketTeam tlocal
  -	554		]
  -	555		localRecips =
  -	556		map encodeRouteHome $
  -	557		map renderLocalActor localRecipsA ++
  -	558		map renderLocalPersonCollection localRecipsC
  -	559		remoteRecips =
  -	560		map (ObjURI $ objUriAuthority $ remoteAuthorURI author) $
  -	561		NE.toList remoteRecipsA ++ remoteRecipsC
  -	562		recips = localRecips ++ remoteRecips
  -	563		doc = Doc hLocal Activity
  -	564		{ activityId =
  -	565		Just $ encodeRouteLocal $
  -	566		ProjectOutboxItemR shrRecip prjRecip obikhidAccept
  -	567		, activityActor =
  -	568		encodeRouteLocal $ ProjectR shrRecip prjRecip
  -	569		, activitySummary = Just summary
  -	570		, activityAudience = Audience recips [] [] [] [] []
  -	571		, activitySpecific = AcceptActivity Accept
  -	572		{ acceptObject =
  -	573		ObjURI
  -	574		(objUriAuthority $ remoteAuthorURI author)
  -	575		luCreate
  -	576		, acceptResult = Nothing
  -	577		}
  -	578		}
  -	579		update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
  -	580		return
  -	581		( obiidAccept
  -	582		, doc
  -	583		, makeRecipientSet localRecipsA localRecipsC
  -	584		, [(objUriAuthority $ remoteAuthorURI author, remoteRecipsA)]
  -	585		, objUriAuthority $ remoteAuthorURI author
  -	586		)
  -	587
  -	588		insertTicket jid luTicket published ractidCreate obiidAccept = do
  +		448	targetRelevance (Left (_, shr, prj))
  +		449	| shr == shrRecip && prj == prjRecip = Just ()
  +		450	targetRelevance _ = Nothing
  +		451	insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do
  -	493		, ticketTitle = unTextHtml $ AP.ticketSummary ticket
  -	494		, ticketSource = unTextPandocMarkdown $ AP.ticketSource ticket
  -	495		, ticketDescription = unTextHtml $ AP.ticketContent ticket
  +		356	, ticketTitle = unTextHtml summary
  +		357	, ticketSource = unTextPandocMarkdown source
  +		358	, ticketDescription = unTextHtml content
  …	…	…	…
  +		407	insertAccept shr prj author luCreate tlocal obiidAccept = do
  +		408	encodeRouteLocal <- getEncodeRouteLocal
  +		409	encodeRouteHome <- getEncodeRouteHome
  +		410
  +		411	hLocal <- asksSite siteInstanceHost
  +		412
  +		413	obikhidAccept <- encodeKeyHashid obiidAccept
  +		414
  +		415	ra <- getJust $ remoteAuthorId author
  +		416
  +		417	let ObjURI hAuthor luAuthor = remoteAuthorURI author
  +		418
  +		419	audAuthorAndTicket =
  +		420	AudRemote hAuthor [luAuthor] $ catMaybes
  +		421	[ remoteActorFollowers ra
  +		422	, Just $ AP.ticketParticipants tlocal
  +		423	]
  +		424	audProject =
  +		425	AudLocal []
  +		426	[ LocalPersonCollectionProjectTeam shr prj
  +		427	, LocalPersonCollectionProjectFollowers shr prj
  +		428	]
  +		429
  +		430	(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
  +		431	collectAudience [audAuthorAndTicket, audProject]
  +		432
  +		433	recips = map encodeRouteHome audLocal ++ audRemote
  +		434	doc = Doc hLocal Activity
  +		435	{ activityId =
  +		436	Just $ encodeRouteLocal $
  +		437	ProjectOutboxItemR shr prj obikhidAccept
  +		438	, activityActor = encodeRouteLocal $ ProjectR shr prj
  +		439	, activitySummary = Nothing
  +		440	, activityAudience = Audience recips [] [] [] [] []
  +		441	, activitySpecific = AcceptActivity Accept
  +		442	{ acceptObject = ObjURI hAuthor luCreate
  +		443	, acceptResult = Nothing
  +		444	}
  +		445	}
  +		446	update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
  +		447	return (doc, recipientSet, remoteActors, fwdHosts)
  …	…	…	…