mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-01-10 18:06:45 +09:00
S2S: projectCreateTicketF: Refactor to use new utils
This commit is contained in:
fr33domlover
parent
e46bcac559
commit
c78becaf5e
1 changed files with 114 additions and 210 deletions
|
|
@ -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"
|
||||
where
|
||||
getProject = do
|
||||
(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
|
||||
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 =
|
||||
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
|
||||
]
|
||||
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
|
||||
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
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue