sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-28 11:24:51 +09:00
Code Issues Activity

C2S: Reimplement offerTicketC using the new tools

Browse source
This commit is contained in:
fr33domlover 2020-07-07 07:26:51 +00:00
parent 511c3c60db
commit 2a6bba89d5
2 changed files with 191 additions and 306 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

486
src/Vervis/API.hs
View file

@ -115,33 +115,6 @@ import Vervis.Settings
import Vervis.Patch import Vervis.Patch
import Vervis.Ticket 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 :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
parseComment luParent = do parseComment luParent = do
route <- case decodeRouteLocal luParent of route <- case decodeRouteLocal luParent of
@ -508,6 +481,20 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
return 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 -- | 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 -- context project may be local or remote. Return an error message if the
-- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'. -- 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" _ -> throwE "Ticket context isn't a project route"
else return $ Right u 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 fetchTracker c u@(ObjURI h lu) = do
hl <- hostIsLocal h hl <- hostIsLocal h
case (hl, c) of case (hl, c) of
@ -639,14 +612,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
return (iid, era) return (iid, era)
return (iid, era, if lu == lu' then Nothing else Just lu') 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 prepareProject now (Left (shr, prj)) = Left <$> do
mej <- lift $ runMaybeT $ do mej <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr 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 insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
offerTicketC offerTicketC
:: ShrIdent :: Entity Person
-> Sharer
-> Maybe TextHtml -> Maybe TextHtml
-> Audience URIMode -> Audience URIMode
-> AP.Ticket URIMode -> AP.Ticket URIMode
-> FedURI -> FedURI
-> ExceptT Text Handler OutboxItemId -> ExceptT Text Handler OutboxItemId
offerTicketC shrUser summary audience ticket uTarget = do offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do
(hProject, shrProject, prjProject) <- parseTarget uTarget let shrUser = sharerIdent sharerUser
{-deps <- -} (title, desc, source, target) <- checkTicket shrUser ticket uTarget
checkOffer hProject shrProject prjProject
(localRecips, remoteRecips) <- do (localRecips, remoteRecips) <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
fromMaybeE mrecips "Offer with no recipients" fromMaybeE mrecips "Offer Ticket with no recipients"
federation <- asksSite $ appFederation . appSettings federation <- asksSite $ appFederation . appSettings
unless (federation || null remoteRecips) $ unless (federation || null remoteRecips) $
throwE "Federation disabled, but remote recipients specified" throwE "Federation disabled, but remote recipients specified"
checkRecips hProject shrProject prjProject localRecips verifyProjectRecip target localRecips
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
(obiid, doc, remotesHttp) <- runDBExcept $ do (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do
(pidAuthor, obidAuthor) <- mproject <-
verifyAuthor case target of
shrUser Left (shr, prj) -> Just <$> do
(AP.ticketAttributedTo ticket) mproj <- lift $ runMaybeT $ do
"Ticket attributed to different actor" Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
mprojAndDeps <- do ej <- MaybeT $ getBy $ UniqueProject prj sid
targetIsLocal <- hostIsLocal hProject return (s, ej)
if targetIsLocal fromMaybeE mproj "Offer target no such local project in DB"
then Just <$> getProjectAndDeps shrProject prjProject {-deps-} Right _ -> return Nothing
else return Nothing (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser)
(obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor remotesHttpOffer <- do
moreRemotes <- let sieve =
lift $ deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer localRecips case target of
unless (federation || null moreRemotes) $ Left (shr, prj) ->
throwE "Federation disabled but remote collection members found" makeRecipientSet
remotesHttp <- lift $ deliverRemoteDB' hProject obiid remoteRecips moreRemotes [ LocalActorProject shr prj
return (obiid, doc, remotesHttp) ]
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp hProject obiid doc remotesHttp [ LocalPersonCollectionSharerFollowers shrUser
return obiid , 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 where
checkOffer hProject shrProject prjProject = do checkTicket
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'" shrUser
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" (AP.Ticket mlocal attrib mpublished mupdated muContext summary
verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" content source muAssigned resolved mmr)
-- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'" uTarget = do
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'" verifyNothingE mlocal "Ticket with 'id'"
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved" shrAttrib <- do
checkRecips hProject shrProject prjProject localRecips = do route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route"
local <- hostIsLocal hProject case route of
if local SharerR shr -> return shr
then traverse (verifyOfferRecips shrProject prjProject) localRecips _ -> throwE "Ticket attrib not a sharer route"
else traverse (verifyOnlySharer . snd) localRecips 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 where
verifyOfferRecips shr prj (shr', lsrSet) = parseTarget u@(ObjURI h lu) = do
if shr == shr' hl <- hostIsLocal h
then unless (lsrSet == offerRecips prj) $ if hl
throwE "Unexpected offer target recipient set" then Left <$> do
else verifyOnlySharer lsrSet route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route"
where case route of
offerRecips prj = LocalSharerRelatedSet ProjectR shr prj -> return (shr, prj)
{ localRecipSharerDirect = LocalSharerDirectSet False False RepoR _ _ -> throwE "Offering patch to repo not implemented yet"
, localRecipSharerTicketRelated = [] _ -> throwE "Offer target is local but isn't a project/repo route"
, localRecipProjectRelated = else return $ Right u
[ ( prj insertOfferToOutbox shrUser now obid = do
, 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
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
let activity mluAct = Doc hLocal Activity obiid <- insertEmptyOutboxItem obid now
{ activityId = mluAct encodeRouteLocal <- getEncodeRouteLocal
, activityActor = AP.ticketAttributedTo ticket obikhid <- encodeKeyHashid obiid
, activitySummary = Just summary let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
doc = Doc hLocal Activity
{ activityId = Just luAct
, activityActor = encodeRouteLocal $ SharerR shrUser
, activitySummary = summary
, activityAudience = audience , activityAudience = audience
, activitySpecific = , activitySpecific =
OfferActivity $ Offer (OfferTicket ticket) uTarget 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] update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc, luAct) return (obiid, doc, luAct)
deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do insertTicket pidAuthor now title desc source jid obiid obiidAccept = do
(pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer _ _ projects _) -> do did <- insert Discussion
(pids, remotes) <- fsid <- insert FollowerSet
traverseCollect (uncurry $ deliverLocalProject shr) projects tid <- insert Ticket
pids' <- do { ticketNumber = Nothing
mpid <- , ticketCreated = now
if localRecipSharer sharer , ticketTitle = unTextHtml title
then runMaybeT $ do , ticketSource = unTextPandocMarkdown source
sid <- MaybeT $ getKeyBy $ UniqueSharer shr , ticketDescription = unTextHtml desc
MaybeT $ getKeyBy $ UniquePersonIdent sid , ticketAssignee = Nothing
else return Nothing , ticketStatus = TSNew
return $ , ticketClosed = UTCTime (ModifiedJulianDay 0) 0
case mpid of , ticketCloser = Nothing
Nothing -> pids }
Just pid -> LO.insertSet pid pids ltid <- insert LocalTicket
return (pids', remotes) { localTicketTicket = tid
for_ (L.delete pidAuthor pids) $ \ pid -> do , localTicketDiscuss = did
ibid <- personInbox <$> getJust pid , localTicketFollowers = fsid
ibiid <- insert $ InboxItem True }
insert_ $ InboxItemLocal ibid obiid ibiid tclid <- insert TicketContextLocal
return remotes { ticketContextLocalTicket = tid
where , ticketContextLocalAccept = obiidAccept
traverseCollect action values = }
bimap collectPids collectRemotes . unzip <$> traverse action values insert_ TicketProjectLocal
where { ticketProjectLocalContext = tclid
collectPids = foldl' LO.union [] , ticketProjectLocalProject = jid
collectRemotes = foldl' unionRemotes [] }
forCollect = flip traverseCollect talid <- insert TicketAuthorLocal
deliverLocalProject shr prj (LocalProjectRelatedSet project _) = { ticketAuthorLocalTicket = ltid
case mprojAndDeps of , ticketAuthorLocalAuthor = pidAuthor
Just (sid, jid, ibid, fsid{-, tids-}) , ticketAuthorLocalOpen = obiid
| shr == shrProject && }
prj == prjProject && insert_ TicketUnderProject
localRecipProject project -> do { ticketUnderProjectProject = tclid
insertToInbox ibid , ticketUnderProjectAuthor = talid
{- }
num <- return ltid
((subtract 1) . projectNextTicket) <$> insertAccept shrUser luOffer shrJ prj obiidAccept ltid = do
updateGet jid [ProjectNextTicket +=. 1] encodeRouteLocal <- getEncodeRouteLocal
-} encodeRouteHome <- getEncodeRouteHome
obiidAccept <- do hLocal <- asksSite siteInstanceHost
obidProject <- projectOutbox <$> getJust jid obikhidAccept <- encodeKeyHashid obiidAccept
now <- liftIO getCurrentTime ltkhid <- encodeKeyHashid ltid
hLocal <- asksSite siteInstanceHost let actors = [LocalActorSharer shrUser]
insert OutboxItem collections =
{ outboxItemOutbox = obidProject [ LocalPersonCollectionProjectTeam shrJ prj
, outboxItemActivity = , LocalPersonCollectionProjectFollowers shrJ prj
persistJSONObjectFromDoc $ Doc hLocal emptyActivity ]
, outboxItemPublished = now recips =
} map encodeRouteHome $
ltid <- insertTicket jid {-tids-} {-num-} obiidAccept map renderLocalActor actors ++
docAccept <- insertAccept pidAuthor sid jid fsid luOffer obiidAccept ltid map renderLocalPersonCollection collections
publishAccept pidAuthor sid jid fsid luOffer {-num-} obiidAccept docAccept doc = Doc hLocal Activity
(pidsTeam, remotesTeam) <- { activityId =
if localRecipProjectTeam project Just $ encodeRouteLocal $
then getProjectTeam sid ProjectOutboxItemR shrJ prj obikhidAccept
else return ([], []) , activityActor = encodeRouteLocal $ ProjectR shrJ prj
(pidsFollowers, remotesFollowers) <- , activitySummary = Nothing
if localRecipProjectFollowers project , activityAudience = Audience recips [] [] [] [] []
then getFollowers fsid , activitySpecific = AcceptActivity Accept
else return ([], []) { acceptObject = ObjURI hLocal luOffer
return , acceptResult =
( LO.union pidsTeam pidsFollowers Just $ encodeRouteLocal $ ProjectTicketR shrJ prj ltkhid
, 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
} }
ltid <- insert LocalTicket }
{ localTicketTicket = tid update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
, localTicketDiscuss = did return (doc, makeRecipientSet actors collections)
, 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
undoC undoC
:: ShrIdent :: ShrIdent

11
src/Vervis/Handler/Client.hs
View file

@ -301,7 +301,7 @@ postSharerOutboxR shr = do
OfferActivity (Offer obj target) -> OfferActivity (Offer obj target) ->
case obj of case obj of
OfferTicket ticket -> OfferTicket ticket ->
offerTicketC shr summary audience ticket target offerTicketC eperson sharer summary audience ticket target
_ -> throwE "Unsupported Offer 'object' type" _ -> throwE "Unsupported Offer 'object' type"
UndoActivity undo -> UndoActivity undo ->
undoC shr summary audience undo undoC shr summary audience undo
@ -336,7 +336,7 @@ postPublishR = do
FormMissing -> throwE "Field(s) missing" FormMissing -> throwE "Field(s) missing"
FormFailure _l -> throwE "Invalid input, see below" FormFailure _l -> throwE "Invalid input, see below"
FormSuccess r -> return r 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 case eid of
Left err -> setMessage $ toHtml err Left err -> setMessage $ toHtml err
Right id_ -> Right id_ ->
@ -412,11 +412,12 @@ postPublishR = do
_ -> error "Create object isn't a ticket" _ -> error "Create object isn't a ticket"
target = createTarget create target = createTarget create
createTicketC eperson sharer (Just summary) audience ticket target 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 encodeRouteLocal <- getEncodeRouteLocal
encodeRouteFed <- getEncodeRouteFed encodeRouteFed <- getEncodeRouteFed
local <- hostIsLocal h local <- hostIsLocal h
descHtml <- ExceptT . pure $ renderPandocMarkdown desc descHtml <- ExceptT . pure $ renderPandocMarkdown desc
let shrAuthor = sharerIdent sharer
summary <- summary <-
TextHtml . TL.toStrict . renderHtml <$> TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer withUrlRenderer
@ -459,7 +460,7 @@ postPublishR = do
, audienceGeneral = [] , audienceGeneral = []
, audienceNonActors = map (encodeRouteFed h) recipsC , 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 follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do
(summary, audience, followAP) <- (summary, audience, followAP) <-
C.follow shrAuthor uObject uRecip False C.follow shrAuthor uObject uRecip False
@ -788,7 +789,7 @@ postProjectTicketsR shr prj = do
then Right <$> do then Right <$> do
(summary, audience, ticket, target) <- (summary, audience, ticket, target) <-
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj 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 ExceptT $ runDB $ do
mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
return $ return $