mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 18:34:52 +09:00
C2S: Reimplement offerTicketC using the new tools
This commit is contained in:
fr33domlover
parent
511c3c60db
commit
2a6bba89d5
2 changed files with 191 additions and 306 deletions
|
|
@ -115,33 +115,6 @@ import Vervis.Settings
|
|||
import Vervis.Patch
|
||||
import Vervis.Ticket
|
||||
|
||||
verifyIsLoggedInUser
|
||||
:: LocalURI
|
||||
-> Text
|
||||
-> ExceptT Text AppDB (PersonId, OutboxId, ShrIdent)
|
||||
verifyIsLoggedInUser lu t = do
|
||||
Entity pid p <- requireVerifiedAuth
|
||||
s <- lift $ getJust $ personIdent p
|
||||
route2local <- getEncodeRouteLocal
|
||||
let shr = sharerIdent s
|
||||
if route2local (SharerR shr) == lu
|
||||
then return (pid, personOutbox p, shr)
|
||||
else throwE t
|
||||
|
||||
verifyAuthor
|
||||
:: ShrIdent
|
||||
-> LocalURI
|
||||
-> Text
|
||||
-> ExceptT Text AppDB (PersonId, OutboxId)
|
||||
verifyAuthor shr lu t = ExceptT $ do
|
||||
Entity sid s <- getBy404 $ UniqueSharer shr
|
||||
Entity pid p <- getBy404 $ UniquePersonIdent sid
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
return $
|
||||
if encodeRouteLocal (SharerR shr) == lu
|
||||
then Right (pid, personOutbox p)
|
||||
else Left t
|
||||
|
||||
parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
|
||||
parseComment luParent = do
|
||||
route <- case decodeRouteLocal luParent of
|
||||
|
|
@ -508,6 +481,20 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
|
|||
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
|
||||
return create
|
||||
|
||||
checkFederation remoteRecips = do
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients found"
|
||||
|
||||
verifyProjectRecip (Right _) _ = return ()
|
||||
verifyProjectRecip (Left (shr, prj)) localRecips =
|
||||
fromMaybeE verify "Local context project isn't listed as a recipient"
|
||||
where
|
||||
verify = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
|
||||
guard $ localRecipProject $ localRecipProjectDirect projectSet
|
||||
|
||||
-- | Handle a Ticket submitted by a local user to their outbox. The ticket's
|
||||
-- context project may be local or remote. Return an error message if the
|
||||
-- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'.
|
||||
|
|
@ -602,20 +589,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
_ -> throwE "Ticket context isn't a project route"
|
||||
else return $ Right u
|
||||
|
||||
checkFederation remoteRecips = do
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients found"
|
||||
|
||||
verifyProjectRecip (Right _) _ = return ()
|
||||
verifyProjectRecip (Left (shr, prj)) localRecips =
|
||||
fromMaybeE verify "Local context project isn't listed as a recipient"
|
||||
where
|
||||
verify = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
|
||||
guard $ localRecipProject $ localRecipProjectDirect projectSet
|
||||
|
||||
fetchTracker c u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
case (hl, c) of
|
||||
|
|
@ -639,14 +612,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
return (iid, era)
|
||||
return (iid, era, if lu == lu' then Nothing else Just lu')
|
||||
|
||||
insertEmptyOutboxItem obid now = do
|
||||
h <- asksSite siteInstanceHost
|
||||
insert OutboxItem
|
||||
{ outboxItemOutbox = obid
|
||||
, outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
|
||||
prepareProject now (Left (shr, prj)) = Left <$> do
|
||||
mej <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
|
|
@ -997,279 +962,198 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
|
|||
insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
|
||||
|
||||
offerTicketC
|
||||
:: ShrIdent
|
||||
:: Entity Person
|
||||
-> Sharer
|
||||
-> Maybe TextHtml
|
||||
-> Audience URIMode
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
offerTicketC shrUser summary audience ticket uTarget = do
|
||||
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
||||
{-deps <- -}
|
||||
checkOffer hProject shrProject prjProject
|
||||
offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
(title, desc, source, target) <- checkTicket shrUser ticket uTarget
|
||||
(localRecips, remoteRecips) <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Offer with no recipients"
|
||||
fromMaybeE mrecips "Offer Ticket with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
checkRecips hProject shrProject prjProject localRecips
|
||||
verifyProjectRecip target localRecips
|
||||
now <- liftIO getCurrentTime
|
||||
(obiid, doc, remotesHttp) <- runDBExcept $ do
|
||||
(pidAuthor, obidAuthor) <-
|
||||
verifyAuthor
|
||||
shrUser
|
||||
(AP.ticketAttributedTo ticket)
|
||||
"Ticket attributed to different actor"
|
||||
mprojAndDeps <- do
|
||||
targetIsLocal <- hostIsLocal hProject
|
||||
if targetIsLocal
|
||||
then Just <$> getProjectAndDeps shrProject prjProject {-deps-}
|
||||
else return Nothing
|
||||
(obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor
|
||||
moreRemotes <-
|
||||
lift $ deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer localRecips
|
||||
unless (federation || null moreRemotes) $
|
||||
throwE "Federation disabled but remote collection members found"
|
||||
remotesHttp <- lift $ deliverRemoteDB' hProject obiid remoteRecips moreRemotes
|
||||
return (obiid, doc, remotesHttp)
|
||||
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp hProject obiid doc remotesHttp
|
||||
return obiid
|
||||
(obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do
|
||||
mproject <-
|
||||
case target of
|
||||
Left (shr, prj) -> Just <$> do
|
||||
mproj <- lift $ runMaybeT $ do
|
||||
Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
|
||||
ej <- MaybeT $ getBy $ UniqueProject prj sid
|
||||
return (s, ej)
|
||||
fromMaybeE mproj "Offer target no such local project in DB"
|
||||
Right _ -> return Nothing
|
||||
(obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser)
|
||||
remotesHttpOffer <- do
|
||||
let sieve =
|
||||
case target of
|
||||
Left (shr, prj) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorProject shr prj
|
||||
]
|
||||
[ LocalPersonCollectionSharerFollowers shrUser
|
||||
, LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
Right _ ->
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
moreRemoteRecips <-
|
||||
lift $
|
||||
deliverLocal'
|
||||
True
|
||||
(LocalActorSharer shrUser)
|
||||
(personInbox personUser)
|
||||
obiid
|
||||
(localRecipSieve sieve False localRecips)
|
||||
unless (federation || null moreRemoteRecips) $
|
||||
throwE "Federation disabled, but recipient collection remote members found"
|
||||
lift $ deliverRemoteDB' (objUriAuthority uTarget) obiid remoteRecips moreRemoteRecips
|
||||
maccept <- lift $ for mproject $ \ (s, Entity jid j) -> do
|
||||
let shrJ = sharerIdent s
|
||||
prj = projectIdent j
|
||||
obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
|
||||
ltid <- insertTicket pidUser now title desc source jid obiid obiidAccept
|
||||
(docAccept, localRecipsAccept) <- insertAccept shrUser luOffer shrJ prj obiidAccept ltid
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorProject shrJ prj)
|
||||
(projectInbox j)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept
|
||||
return (obiid, doc, remotesHttpOffer, maccept)
|
||||
lift $ do
|
||||
forkWorker "offerTicketC: async HTTP Offer delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidOffer docOffer remotesHttpOffer
|
||||
for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
|
||||
forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
|
||||
return obiidOffer
|
||||
where
|
||||
checkOffer 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"
|
||||
checkRecips hProject shrProject prjProject localRecips = do
|
||||
local <- hostIsLocal hProject
|
||||
if local
|
||||
then traverse (verifyOfferRecips shrProject prjProject) localRecips
|
||||
else traverse (verifyOnlySharer . snd) localRecips
|
||||
checkTicket
|
||||
shrUser
|
||||
(AP.Ticket mlocal attrib mpublished mupdated muContext summary
|
||||
content source muAssigned resolved mmr)
|
||||
uTarget = do
|
||||
verifyNothingE mlocal "Ticket with 'id'"
|
||||
shrAttrib <- do
|
||||
route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route"
|
||||
case route of
|
||||
SharerR shr -> return shr
|
||||
_ -> throwE "Ticket attrib not a sharer route"
|
||||
unless (shrAttrib == shrUser) $
|
||||
throwE "Ticket attibuted to someone else"
|
||||
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
|
||||
verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
|
||||
for_ muContext $ \ uContext ->
|
||||
unless (uContext == uTarget) $ throwE "Offer target != ticket context"
|
||||
verifyNothingE muAssigned "Ticket has 'assignedTo'"
|
||||
when resolved $ throwE "Ticket is resolved"
|
||||
verifyNothingE mmr "Ticket has 'attachment'"
|
||||
target <- parseTarget uTarget
|
||||
return (summary, content, source, target)
|
||||
where
|
||||
verifyOfferRecips shr prj (shr', lsrSet) =
|
||||
if shr == shr'
|
||||
then unless (lsrSet == offerRecips prj) $
|
||||
throwE "Unexpected offer target recipient set"
|
||||
else verifyOnlySharer lsrSet
|
||||
where
|
||||
offerRecips prj = LocalSharerRelatedSet
|
||||
{ localRecipSharerDirect = LocalSharerDirectSet False False
|
||||
, localRecipSharerTicketRelated = []
|
||||
, localRecipProjectRelated =
|
||||
[ ( prj
|
||||
, LocalProjectRelatedSet
|
||||
{ localRecipProjectDirect =
|
||||
LocalProjectDirectSet True True True
|
||||
, localRecipProjectTicketRelated = []
|
||||
}
|
||||
)
|
||||
]
|
||||
, localRecipRepoRelated = []
|
||||
}
|
||||
verifyOnlySharer lsrSet = do
|
||||
unless (null $ localRecipProjectRelated lsrSet) $
|
||||
throwE "Unexpected recipients unrelated to offer target"
|
||||
unless (null $ localRecipRepoRelated lsrSet) $
|
||||
throwE "Unexpected recipients unrelated to offer target"
|
||||
insertToOutbox now obid = do
|
||||
parseTarget u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route"
|
||||
case route of
|
||||
ProjectR shr prj -> return (shr, prj)
|
||||
RepoR _ _ -> throwE "Offering patch to repo not implemented yet"
|
||||
_ -> throwE "Offer target is local but isn't a project/repo route"
|
||||
else return $ Right u
|
||||
insertOfferToOutbox shrUser now obid = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
let activity mluAct = Doc hLocal Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = AP.ticketAttributedTo ticket
|
||||
, activitySummary = Just summary
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activitySummary = summary
|
||||
, activityAudience = audience
|
||||
, activitySpecific =
|
||||
OfferActivity $ Offer (OfferTicket ticket) uTarget
|
||||
}
|
||||
obiid <- insert OutboxItem
|
||||
{ outboxItemOutbox = obid
|
||||
, outboxItemActivity =
|
||||
persistJSONObjectFromDoc $ activity Nothing
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = activity $ Just luAct
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do
|
||||
(pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer _ _ projects _) -> do
|
||||
(pids, remotes) <-
|
||||
traverseCollect (uncurry $ deliverLocalProject shr) projects
|
||||
pids' <- do
|
||||
mpid <-
|
||||
if localRecipSharer sharer
|
||||
then runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
MaybeT $ getKeyBy $ UniquePersonIdent sid
|
||||
else return Nothing
|
||||
return $
|
||||
case mpid of
|
||||
Nothing -> pids
|
||||
Just pid -> LO.insertSet pid pids
|
||||
return (pids', remotes)
|
||||
for_ (L.delete pidAuthor pids) $ \ pid -> do
|
||||
ibid <- personInbox <$> getJust pid
|
||||
ibiid <- insert $ InboxItem True
|
||||
insert_ $ InboxItemLocal ibid obiid ibiid
|
||||
return remotes
|
||||
where
|
||||
traverseCollect action values =
|
||||
bimap collectPids collectRemotes . unzip <$> traverse action values
|
||||
where
|
||||
collectPids = foldl' LO.union []
|
||||
collectRemotes = foldl' unionRemotes []
|
||||
forCollect = flip traverseCollect
|
||||
deliverLocalProject shr prj (LocalProjectRelatedSet project _) =
|
||||
case mprojAndDeps of
|
||||
Just (sid, jid, ibid, fsid{-, tids-})
|
||||
| shr == shrProject &&
|
||||
prj == prjProject &&
|
||||
localRecipProject project -> do
|
||||
insertToInbox ibid
|
||||
{-
|
||||
num <-
|
||||
((subtract 1) . projectNextTicket) <$>
|
||||
updateGet jid [ProjectNextTicket +=. 1]
|
||||
-}
|
||||
obiidAccept <- do
|
||||
obidProject <- projectOutbox <$> getJust jid
|
||||
now <- liftIO getCurrentTime
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
insert OutboxItem
|
||||
{ outboxItemOutbox = obidProject
|
||||
, outboxItemActivity =
|
||||
persistJSONObjectFromDoc $ Doc hLocal emptyActivity
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
ltid <- insertTicket jid {-tids-} {-num-} obiidAccept
|
||||
docAccept <- insertAccept pidAuthor sid jid fsid luOffer obiidAccept ltid
|
||||
publishAccept pidAuthor sid jid fsid luOffer {-num-} obiidAccept docAccept
|
||||
(pidsTeam, remotesTeam) <-
|
||||
if localRecipProjectTeam project
|
||||
then getProjectTeam sid
|
||||
else return ([], [])
|
||||
(pidsFollowers, remotesFollowers) <-
|
||||
if localRecipProjectFollowers project
|
||||
then getFollowers fsid
|
||||
else return ([], [])
|
||||
return
|
||||
( LO.union pidsTeam pidsFollowers
|
||||
, unionRemotes remotesTeam remotesFollowers
|
||||
)
|
||||
_ -> return ([], [])
|
||||
where
|
||||
insertToInbox ibid = do
|
||||
ibiid <- insert $ InboxItem False
|
||||
insert_ $ InboxItemLocal ibid obiid ibiid
|
||||
insertAccept pidAuthor sid jid fsid luOffer obiid ltid = do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{SharerR shrUser}>
|
||||
#{shr2text shrUser}
|
||||
's ticket accepted by project #
|
||||
<a href=@{ProjectR shrProject prjProject}>
|
||||
./s/#{shr2text shrProject}/p/#{prj2text prjProject}
|
||||
: #
|
||||
<a href=@{ProjectTicketR shrProject prjProject ltkhid}>
|
||||
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
|
||||
|]
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let recips =
|
||||
map encodeRouteHome
|
||||
[ SharerR shrUser
|
||||
, ProjectTeamR shrProject prjProject
|
||||
, ProjectFollowersR shrProject prjProject
|
||||
]
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
ProjectOutboxItemR shrProject prjProject obikhid
|
||||
, activityActor =
|
||||
encodeRouteLocal $ ProjectR shrProject prjProject
|
||||
, activitySummary = Just summary
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luOffer
|
||||
, acceptResult =
|
||||
Just $ encodeRouteLocal $
|
||||
ProjectTicketR shrProject prjProject ltkhid
|
||||
}
|
||||
}
|
||||
update
|
||||
obiid
|
||||
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return doc
|
||||
insertTicket jid {-tidsDeps-} {-next-} obiidAccept = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = unTextHtml $ AP.ticketSummary ticket
|
||||
, ticketSource =
|
||||
unTextPandocMarkdown $ AP.ticketSource ticket
|
||||
, ticketDescription = unTextHtml $ AP.ticketContent ticket
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
insertTicket pidAuthor now title desc source jid obiid obiidAccept = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = unTextHtml title
|
||||
, ticketSource = unTextPandocMarkdown source
|
||||
, ticketDescription = unTextHtml desc
|
||||
, 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
|
||||
}
|
||||
talid <- insert TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = ltid
|
||||
, ticketAuthorLocalAuthor = pidAuthor
|
||||
, ticketAuthorLocalOpen = obiid
|
||||
}
|
||||
insert_ TicketUnderProject
|
||||
{ ticketUnderProjectProject = tclid
|
||||
, ticketUnderProjectAuthor = talid
|
||||
}
|
||||
return ltid
|
||||
insertAccept shrUser luOffer shrJ prj obiidAccept ltid = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
let actors = [LocalActorSharer shrUser]
|
||||
collections =
|
||||
[ LocalPersonCollectionProjectTeam shrJ prj
|
||||
, LocalPersonCollectionProjectFollowers shrJ prj
|
||||
]
|
||||
recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalPersonCollection collections
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
ProjectOutboxItemR shrJ prj obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ ProjectR shrJ prj
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luOffer
|
||||
, acceptResult =
|
||||
Just $ encodeRouteLocal $ ProjectTicketR shrJ prj ltkhid
|
||||
}
|
||||
ltid <- insert LocalTicket
|
||||
{ localTicketTicket = tid
|
||||
, localTicketDiscuss = did
|
||||
, localTicketFollowers = fsid
|
||||
}
|
||||
tclid <- insert TicketContextLocal
|
||||
{ ticketContextLocalTicket = tid
|
||||
, ticketContextLocalAccept = obiidAccept
|
||||
}
|
||||
insert_ TicketProjectLocal
|
||||
{ ticketProjectLocalContext = tclid
|
||||
, ticketProjectLocalProject = jid
|
||||
}
|
||||
talid <- insert TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = ltid
|
||||
, ticketAuthorLocalAuthor = pidAuthor
|
||||
, ticketAuthorLocalOpen = obiid
|
||||
}
|
||||
insert_ TicketUnderProject
|
||||
{ ticketUnderProjectProject = tclid
|
||||
, ticketUnderProjectAuthor = talid
|
||||
}
|
||||
--insertMany_ $ map (TicketDependency tid) tidsDeps
|
||||
-- insert_ $ Follow pidAuthor fsid False True
|
||||
return ltid
|
||||
publishAccept pidAuthor sid jid fsid luOffer {-num-} obiid doc = do
|
||||
now <- liftIO getCurrentTime
|
||||
let dont = Authority "dont-do.any-forwarding" Nothing
|
||||
remotesHttp <- do
|
||||
moreRemotes <- deliverLocal now sid fsid obiid
|
||||
deliverRemoteDB' dont obiid [] moreRemotes
|
||||
site <- askSite
|
||||
liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site
|
||||
where
|
||||
deliverLocal now sid fsid obiid = do
|
||||
(pidsTeam, remotesTeam) <- getProjectTeam sid
|
||||
(pidsFollowers, remotesFollowers) <- getFollowers fsid
|
||||
let pids = LO.insertSet pidAuthor $ LO.union pidsTeam pidsFollowers
|
||||
remotes = unionRemotes remotesTeam remotesFollowers
|
||||
for_ pids $ \ pid -> do
|
||||
ibid <- personInbox <$> getJust pid
|
||||
ibiid <- insert $ InboxItem True
|
||||
insert_ $ InboxItemLocal ibid obiid ibiid
|
||||
return remotes
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, makeRecipientSet actors collections)
|
||||
|
||||
undoC
|
||||
:: ShrIdent
|
||||
|
|
|
|||
|
|
@ -301,7 +301,7 @@ postSharerOutboxR shr = do
|
|||
OfferActivity (Offer obj target) ->
|
||||
case obj of
|
||||
OfferTicket ticket ->
|
||||
offerTicketC shr summary audience ticket target
|
||||
offerTicketC eperson sharer summary audience ticket target
|
||||
_ -> throwE "Unsupported Offer 'object' type"
|
||||
UndoActivity undo ->
|
||||
undoC shr summary audience undo
|
||||
|
|
@ -336,7 +336,7 @@ postPublishR = do
|
|||
FormMissing -> throwE "Field(s) missing"
|
||||
FormFailure _l -> throwE "Invalid input, see below"
|
||||
FormSuccess r -> return r
|
||||
bitraverse (bitraverse (publishComment ep s) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
|
||||
bitraverse (bitraverse (publishComment ep s) (publishTicket ep s)) (bitraverse (openTicket ep s) (follow shrAuthor)) input
|
||||
case eid of
|
||||
Left err -> setMessage $ toHtml err
|
||||
Right id_ ->
|
||||
|
|
@ -412,11 +412,12 @@ postPublishR = do
|
|||
_ -> error "Create object isn't a ticket"
|
||||
target = createTarget create
|
||||
createTicketC eperson sharer (Just summary) audience ticket target
|
||||
openTicket shrAuthor ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
|
||||
openTicket eperson sharer ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteFed <- getEncodeRouteFed
|
||||
local <- hostIsLocal h
|
||||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||
let shrAuthor = sharerIdent sharer
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
|
|
@ -459,7 +460,7 @@ postPublishR = do
|
|||
, audienceGeneral = []
|
||||
, audienceNonActors = map (encodeRouteFed h) recipsC
|
||||
}
|
||||
offerTicketC shrAuthor (Just summary) audience ticketAP target
|
||||
offerTicketC eperson sharer (Just summary) audience ticketAP target
|
||||
follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do
|
||||
(summary, audience, followAP) <-
|
||||
C.follow shrAuthor uObject uRecip False
|
||||
|
|
@ -788,7 +789,7 @@ postProjectTicketsR shr prj = do
|
|||
then Right <$> do
|
||||
(summary, audience, ticket, target) <-
|
||||
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
|
||||
obiid <- offerTicketC shrAuthor (Just summary) audience ticket target
|
||||
obiid <- offerTicketC eperson sharer (Just summary) audience ticket target
|
||||
ExceptT $ runDB $ do
|
||||
mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
|
||||
return $
|
||||
|
|
|
|||
Loading…
Reference in a new issue