C2S: createTicketC: Allow to submit MRs i.e. Ticket with a Patch attached

This commit is contained in:
fr33domlover 2020-07-22 13:00:48 +00:00
parent fd8405e741
commit c1f0722c21
2 changed files with 404 additions and 121 deletions

View file

@ -415,6 +415,8 @@ TicketProjectRemote
ticket TicketAuthorLocalId ticket TicketAuthorLocalId
tracker RemoteActorId tracker RemoteActorId
project RemoteObjectId Maybe -- specify if not same as tracker project RemoteObjectId Maybe -- specify if not same as tracker
-- For MRs it may be either a remote repo or
-- a branch of it
UniqueTicketProjectRemote ticket UniqueTicketProjectRemote ticket

View file

@ -489,15 +489,6 @@ checkFederation remoteRecips = do
unless (federation || null remoteRecips) $ unless (federation || null remoteRecips) $
throwE "Federation disabled, but remote recipients found" throwE "Federation disabled, but remote recipients found"
verifyProjectRecipOld (Right _) _ = return ()
verifyProjectRecipOld (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
verifyProjectRecip (Right _) _ = return () verifyProjectRecip (Right _) _ = return ()
verifyProjectRecip (Left (WTTProject shr prj)) localRecips = verifyProjectRecip (Left (WTTProject shr prj)) localRecips =
fromMaybeE verify "Local context project isn't listed as a recipient" fromMaybeE verify "Local context project isn't listed as a recipient"
@ -527,24 +518,23 @@ createTicketC
-> ExceptT Text Handler OutboxItemId -> ExceptT Text Handler OutboxItemId
createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = do createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = do
let shrUser = sharerIdent sharerUser let shrUser = sharerIdent sharerUser
ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget (context, title, desc, source) <- checkCreateTicket shrUser ticket muTarget
context <- parseTicketContext uContext
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
fromMaybeE mrecips "Create Ticket with no recipients" fromMaybeE mrecips "Create Ticket with no recipients"
checkFederation remoteRecips checkFederation remoteRecips
verifyProjectRecipOld context localRecips verifyProjectRecip context localRecips
tracker <- fetchTracker context uTarget tracker <- bitraverse pure fetchTracker context
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
(_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do (_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
project <- prepareProject now tracker project <- prepareProject now tracker
talid <- lift $ insertTicket now pidUser title desc source obiidCreate project (talid, mptid) <- lift $ insertTicket now pidUser title desc source obiidCreate project
docCreate <- lift $ insertCreateToOutbox shrUser blinded ticketData now obiidCreate talid docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid
remoteRecipsHttpCreate <- do remoteRecipsHttpCreate <- do
let sieve = let sieve =
case tracker of case context of
Left (shr, prj) -> Left (WTTProject shr prj) ->
makeRecipientSet makeRecipientSet
[ LocalActorProject shr prj [ LocalActorProject shr prj
] ]
@ -552,27 +542,55 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj , LocalPersonCollectionProjectFollowers shr prj
] ]
Left (WTTRepo shr rp _ _ _) ->
makeRecipientSet
[ LocalActorRepo shr rp
]
[ LocalPersonCollectionSharerFollowers shrUser
, LocalPersonCollectionRepoTeam shr rp
, LocalPersonCollectionRepoFollowers shr rp
]
Right _ -> Right _ ->
makeRecipientSet makeRecipientSet
[] []
[LocalPersonCollectionSharerFollowers shrUser] [LocalPersonCollectionSharerFollowers shrUser]
moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips moreRemoteRecips <-
lift $
deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $
localRecipSieve sieve False localRecips
checkFederation moreRemoteRecips checkFederation moreRemoteRecips
lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
maccept <- maccept <-
case project of case project of
Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do Left proj@(shr, ent, obiidAccept) -> Just <$> do
let prj = projectIdent j let recipsA =
recipsA =
[ LocalActorSharer shrUser [ LocalActorSharer shrUser
] ]
recipsC = (recipsC, ibid, actor) =
[ LocalPersonCollectionProjectTeam shr prj case ent of
Left (Entity _ j) ->
let prj = projectIdent j
in ( [ LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj , LocalPersonCollectionProjectFollowers shr prj
, LocalPersonCollectionSharerFollowers shrUser , LocalPersonCollectionSharerFollowers shrUser
] ]
, projectInbox j
, LocalActorProject shr prj
)
Right (Entity _ r, _, _) ->
let rp = repoIdent r
in ( [ LocalPersonCollectionRepoTeam shr rp
, LocalPersonCollectionRepoFollowers shr rp
, LocalPersonCollectionSharerFollowers shrUser
]
, repoInbox r
, LocalActorRepo shr rp
)
doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC
recips <- lift $ deliverLocal' True (LocalActorProject shr prj) (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC recips <-
lift $
deliverLocal' True actor ibid obiidAccept $
makeRecipientSet recipsA recipsC
checkFederation recips checkFederation recips
lift $ (obiidAccept,doc,) <$> deliverRemoteDB'' [] obiidAccept [] recips lift $ (obiidAccept,doc,) <$> deliverRemoteDB'' [] obiidAccept [] recips
Right _ -> return Nothing Right _ -> return Nothing
@ -583,64 +601,248 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
return obiidCreate return obiidCreate
where where
checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do checkCreateTicket
verifyNothingE mlocal "Ticket with 'id'" :: ShrIdent
encodeRouteLocal <- getEncodeRouteLocal -> AP.Ticket URIMode
unless (encodeRouteLocal (SharerR shr) == luAttrib) $ -> Maybe FedURI
throwE "Ticket attributed to someone else" -> ExceptT Text Handler
verifyNothingE mpublished "Ticket with 'published'" ( Either
verifyNothingE mupdated "Ticket with 'updated'" WorkItemTarget
context <- fromMaybeE mcontext "Ticket without 'context'" ( Host
verifyNothingE massigned "Ticket with 'assignedTo'" , LocalURI
when resolved $ throwE "Ticket resolved" , LocalURI
target <- fromMaybeE mtarget "Create Ticket without 'target'" , Maybe (Maybe LocalURI, PatchType, Text)
verifyNothingE mmr "Ticket with 'attachment'" )
return (context, summary, content, source, target) , TextHtml
, TextHtml
parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI) , TextPandocMarkdown
parseTicketContext u@(ObjURI h lu) = do )
checkCreateTicket shr ticket muTarget = do
uTarget <- fromMaybeE muTarget "Create Ticket without 'target'"
target <- checkTracker "Create target" uTarget
(context, summary, content, source) <- checkTicket ticket
item <- checkTargetAndContext target context
return (item, summary, content, source)
where
checkTracker
:: Text
-> FedURI
-> ExceptT Text Handler
(Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI
)
checkTracker name u@(ObjURI h lu) = do
hl <- hostIsLocal h hl <- hostIsLocal h
if hl if hl
then Left <$> do then Left <$> do
route <- fromMaybeE (decodeRouteLocal lu) "Ticket context isn't a valid route" route <-
fromMaybeE
(decodeRouteLocal lu)
(name <> " is local but isn't a valid route")
case route of case route of
ProjectR shr prj -> return (shr, prj) ProjectR shr prj -> return $ Left (shr, prj)
_ -> throwE "Ticket context isn't a project route" RepoR shr rp -> return $ Right (shr, rp)
_ ->
throwE $
name <>
" is a valid local route, but isn't a \
\project/repo route"
else return $ Right u else return $ Right u
checkTicket
fetchTracker c u@(ObjURI h lu) = do :: AP.Ticket URIMode
hl <- hostIsLocal h -> ExceptT Text Handler
case (hl, c) of ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text))
(True, Left (shr, prj)) -> Left <$> do , TextHtml
, TextHtml
, TextPandocMarkdown
)
checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
content source muAssigned resolved mmr) = do
verifyNothingE mlocal "Ticket with 'id'"
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
unless (encodeRouteLocal (ProjectR shr prj) == lu) $ unless (encodeRouteLocal (SharerR shr) == attrib) $
throwE "Local context and target mismatch" throwE "Ticket attributed to someone else"
return (shr, prj) verifyNothingE mpublished "Ticket with 'published'"
(True, Right _) -> throwE "context and target different host" verifyNothingE mupdated "Ticket with 'updated'"
(False, Left _) -> throwE "context and target different host" uContext <- fromMaybeE muContext "Ticket without 'context'"
(False, Right (ObjURI h' lu')) -> Right <$> do context <- checkTracker "Ticket context" uContext
unless (h == h') $ throwE "context and target different host" verifyNothingE muAssigned "Ticket with 'assignedTo'"
when resolved $ throwE "Ticket resolved"
mmr' <- traverse (uncurry checkMR) mmr
context' <- matchContextAndMR context mmr'
return (context', summary, content, source)
where
checkMR
:: Host
-> MergeRequest URIMode
-> ExceptT Text Handler
( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, PatchType
, Text
)
checkMR h (MergeRequest muOrigin luTarget epatch) = do
verifyNothingE muOrigin "MR with 'origin'"
branch <- checkBranch h luTarget
(typ, content) <-
case epatch of
Left _ -> throwE "MR patch specified as a URI"
Right (hPatch, patch) -> checkPatch hPatch patch
return (branch, typ, content)
where
checkBranch
:: Host
-> LocalURI
-> ExceptT Text Handler
(Either (ShrIdent, RpIdent, Maybe Text) FedURI)
checkBranch h lu = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE
(decodeRouteLocal lu)
"MR target is local but isn't a valid route"
case route of
RepoR shr rp -> return (shr, rp, Nothing)
RepoBranchR shr rp b -> return (shr, rp, Just b)
_ ->
throwE
"MR target is a valid local route, but isn't a \
\repo or branch route"
else return $ Right $ ObjURI h lu
checkPatch
:: Host
-> AP.Patch URIMode
-> ExceptT Text Handler
( PatchType
, Text
)
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
encodeRouteLocal <- getEncodeRouteLocal
verifyHostLocal h "Patch attributed to remote user"
verifyNothingE mlocal "Patch with 'id'"
unless (encodeRouteLocal (SharerR shr) == attrib) $
throwE "Ticket and Patch attrib mismatch"
verifyNothingE mpub "Patch has 'published'"
return (typ, content)
matchContextAndMR
:: Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI
-> Maybe
( Either (ShrIdent, RpIdent, Maybe Text) FedURI
, PatchType
, Text
)
-> ExceptT Text Handler
(Either
WorkItemTarget
( Host
, LocalURI
, Maybe (Maybe LocalURI, PatchType, Text)
)
)
matchContextAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj
matchContextAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
matchContextAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo"
matchContextAndMR (Left (Right (shr, rp))) (Just (branch, typ, content)) = do
branch' <-
case branch of
Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
_ -> throwE "MR target repo/branch and Ticket context repo mismatch"
let vcs = typ2vcs typ
case vcs of
VCSDarcs ->
unless (isNothing branch') $
throwE "Darcs MR specifies a branch"
VCSGit ->
unless (isJust branch') $
throwE "Git MR doesn't specify the branch"
return $ Left $ WTTRepo shr rp branch' vcs content
where
typ2vcs PatchTypeDarcs = VCSDarcs
matchContextAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
matchContextAndMR (Right (ObjURI h lu)) (Just (branch, typ, content)) = do
luBranch <-
case branch of
Right (ObjURI h' lu') | h == h' -> return lu
_ -> throwE "MR target repo/branch and Ticket context repo mismatch"
let patch =
( if lu == luBranch then Nothing else Just luBranch
, typ
, content
)
return $ Right (h, lu, Just patch)
checkTargetAndContext
:: Either
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
FedURI
-> Either
WorkItemTarget
(Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text))
-> ExceptT Text Handler
(Either
WorkItemTarget
( Host
, LocalURI
, LocalURI
, Maybe (Maybe LocalURI, PatchType, Text)
)
)
checkTargetAndContext (Left _) (Right _) =
throwE "Create target is local but ticket context is remote"
checkTargetAndContext (Right _) (Left _) =
throwE "Create target is remote but ticket context is local"
checkTargetAndContext (Right (ObjURI hTarget luTarget)) (Right (hContext, luContext, mpatch)) =
if hTarget == hContext
then return $ Right (hContext, luTarget, luContext, mpatch)
else throwE "Create target and ticket context on different \
\remote hosts"
checkTargetAndContext (Left proj) (Left wit) =
case (proj, wit) of
(Left (shr, prj), WTTProject shr' prj')
| shr == shr' && prj == prj' -> return $ Left wit
(Right (shr, rp), WTTRepo shr' rp' _ _ _)
| shr == shr' && rp == rp' -> return $ Left wit
_ -> throwE "Create target and ticket context are different \
\local projects"
fetchTracker (h, luTarget, luContext, mpatch) = do
(iid, era) <- do (iid, era) <- do
iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
result <- lift $ fetchRemoteActor iid h lu result <- lift $ fetchRemoteActor iid h luTarget
case result of case result of
Left e -> throwE $ T.pack $ displayException e Left e -> throwE $ T.pack $ displayException e
Right (Left e) -> throwE $ T.pack $ show e Right (Left e) -> throwE $ T.pack $ show e
Right (Right mera) -> do Right (Right mera) -> do
era <- fromMaybeE mera "target found to be a collection, not an actor" era <- fromMaybeE mera "target found to be a collection, not an actor"
return (iid, era) return (iid, era)
return (iid, era, if lu == lu' then Nothing else Just lu') return (iid, era, if luTarget == luContext then Nothing else Just luContext, mpatch)
prepareProject now (Left (shr, prj)) = Left <$> do prepareProject now (Left (WTTProject shr prj)) = Left <$> do
mej <- lift $ runMaybeT $ do mej <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid MaybeT $ getBy $ UniqueProject prj sid
ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project" ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
return (shr, ej, obiidAccept) return (shr, Left ej, obiidAccept)
prepareProject _ (Right (iid, era, mlu)) = lift $ Right <$> do prepareProject now (Left (WTTRepo shr rp mb vcs diff)) = Left <$> do
mroid <- for mlu $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu) mer <- lift $ runMaybeT $ do
return (era, mroid) sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueRepo rp sid
er@(Entity _ r) <- fromMaybeE mer "Local context: no such repo"
unless (repoVcs r == vcs) $ throwE "Repo VCS and patch VCS mismatch"
obiidAccept <- lift $ insertEmptyOutboxItem (repoOutbox r) now
return (shr, Right (er, mb, diff), obiidAccept)
prepareProject _ (Right (iid, era, mlu, mpatch)) = lift $ Right <$> do
let mlu' =
case mpatch of
Just (Just luBranch, _, _) -> Just luBranch
Nothing -> mlu
mroid <- for mlu' $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu)
let removeBranch (mb, typ, diff) = (typ, diff)
return (era, mroid, removeBranch <$> mpatch)
insertTicket now pidUser title desc source obiidCreate project = do insertTicket now pidUser title desc source obiidCreate project = do
did <- insert Discussion did <- insert Discussion
@ -666,35 +868,122 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, ticketAuthorLocalAuthor = pidUser , ticketAuthorLocalAuthor = pidUser
, ticketAuthorLocalOpen = obiidCreate , ticketAuthorLocalOpen = obiidCreate
} }
mptid <-
case project of case project of
Left (_shr, Entity jid _j, obiidAccept) -> do Left (_shr, ent, obiidAccept) -> do
tclid <- insert TicketContextLocal tclid <- insert TicketContextLocal
{ ticketContextLocalTicket = tid { ticketContextLocalTicket = tid
, ticketContextLocalAccept = obiidAccept , ticketContextLocalAccept = obiidAccept
} }
case ent of
Left (Entity jid _) -> do
insert_ TicketProjectLocal insert_ TicketProjectLocal
{ ticketProjectLocalContext = tclid { ticketProjectLocalContext = tclid
, ticketProjectLocalProject = jid , ticketProjectLocalProject = jid
} }
Right (Entity raid _ra, mroid) -> return Nothing
Right (Entity rid _, mb, diff) -> Just <$> do
insert_ TicketRepoLocal
{ ticketRepoLocalContext = tclid
, ticketRepoLocalRepo = rid
, ticketRepoLocalBranch = mb
}
insert $ Patch tid now diff
Right (Entity raid _, mroid, mpatch) -> do
insert_ TicketProjectRemote insert_ TicketProjectRemote
{ ticketProjectRemoteTicket = talid { ticketProjectRemoteTicket = talid
, ticketProjectRemoteTracker = raid , ticketProjectRemoteTracker = raid
, ticketProjectRemoteProject = mroid , ticketProjectRemoteProject = mroid
} }
return talid for mpatch $ \ (_typ, diff) -> insert $ Patch tid now diff
return (talid, mptid)
insertCreateToOutbox shrUser blinded (uContext, title, desc, source, uTarget) now obiidCreate talid = do insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
talkhid <- encodeKeyHashid talid talkhid <- encodeKeyHashid talid
mptkhid <- traverse encodeKeyHashid mptid
obikhid <- encodeKeyHashid obiidCreate obikhid <- encodeKeyHashid obiidCreate
let luAttrib = encodeRouteLocal $ SharerR shrUser let luTicket = encodeRouteLocal $ SharerTicketR shrUser talkhid
luAttrib = encodeRouteLocal $ SharerR shrUser
(uTarget, uContext, mmr) =
case context of
Left (WTTProject shr prj) ->
let uProject = encodeRouteHome $ ProjectR shr prj
in (uProject, uProject, Nothing)
Left (WTTRepo shr rp mb vcs diff) ->
let uRepo = encodeRouteHome $ RepoR shr rp
mr = MergeRequest
{ mrOrigin = Nothing
, mrTarget =
encodeRouteLocal $
case mb of
Nothing -> RepoR shr rp
Just b -> RepoBranchR shr rp b
, mrPatch = Right
( hLocal
, AP.Patch
{ AP.patchLocal = Just
( hLocal
, PatchLocal
{ patchId =
case mptkhid of
Nothing -> error "mptkhid is Nothing"
Just ptkhid ->
encodeRouteLocal $
SharerPatchVersionR shrUser talkhid ptkhid
, patchContext = luTicket
, patchPrevVersions = []
}
)
, AP.patchAttributedTo = luAttrib
, AP.patchPublished = Just now
, AP.patchType =
case vcs of
VCSDarcs -> PatchTypeDarcs
VCSGit -> error "createTicketC VCSGit"
, AP.patchContent = diff
}
)
}
in (uRepo, uRepo, Just (hLocal, mr))
Right (hContext, luTarget, luContext, mpatch) ->
let mr (mluBranch, typ, diff) = MergeRequest
{ mrOrigin = Nothing
, mrTarget = fromMaybe luContext mluBranch
, mrPatch = Right
( hLocal
, AP.Patch
{ AP.patchLocal = Just
( hLocal
, PatchLocal
{ patchId =
case mptkhid of
Nothing -> error "mptkhid is Nothing"
Just ptkhid ->
encodeRouteLocal $
SharerPatchVersionR shrUser talkhid ptkhid
, patchContext = luTicket
, patchPrevVersions = []
}
)
, AP.patchAttributedTo = luAttrib
, AP.patchPublished = Just now
, AP.patchType = typ
, AP.patchContent = diff
}
)
}
in ( ObjURI hContext luTarget
, ObjURI hContext luContext
, (hContext,) . mr <$> mpatch
)
tlocal = TicketLocal tlocal = TicketLocal
{ ticketId = encodeRouteLocal $ SharerTicketR shrUser talkhid { ticketId = luTicket
, ticketReplies = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid , ticketReplies = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid
, ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid , ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid
, ticketTeam = Just $ encodeRouteLocal $ SharerTicketTeamR shrUser talkhid , ticketTeam = Nothing -- Just $ encodeRouteLocal $ SharerTicketTeamR shrUser talkhid
, ticketEvents = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid , ticketEvents = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid
, ticketDeps = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid , ticketDeps = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid
, ticketReverseDeps = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid , ticketReverseDeps = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid
@ -716,7 +1005,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, AP.ticketSource = source , AP.ticketSource = source
, AP.ticketAssignedTo = Nothing , AP.ticketAssignedTo = Nothing
, AP.ticketIsResolved = False , AP.ticketIsResolved = False
, AP.ticketAttachment = Nothing , AP.ticketAttachment = mmr
} }
, createTarget = Just uTarget , createTarget = Just uTarget
} }
@ -724,34 +1013,26 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
return create return create
insertAcceptToOutbox (shrJ, Entity _ j, obiidAccept) shrU obiidCreate talid actors colls = do insertAcceptToOutbox (shrJ, ent, obiidAccept) shrU obiidCreate talid actors colls = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept obikhidAccept <- encodeKeyHashid obiidAccept
obikhidCreate <- encodeKeyHashid obiidCreate obikhidCreate <- encodeKeyHashid obiidCreate
talkhid <- encodeKeyHashid talid talkhid <- encodeKeyHashid talid
let prjJ = projectIdent j let (outboxItemRoute, actorRoute) =
summary <- case ent of
TextHtml . TL.toStrict . renderHtml <$> Left (Entity _ j) ->
withUrlRenderer let prj = projectIdent j
[hamlet| in (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj)
<p> Right (Entity _ r, _, _) ->
Project # let rp = repoIdent r
<a href=@{ProjectR shrJ prjJ}> in (RepoOutboxItemR shrJ rp, RepoR shrJ rp)
#{prj2text prjJ} recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
\ accepted #
<a href=@{SharerTicketR shrU talkhid}>
ticket
\ by #
<a href=@{SharerR shrU}>
#{shr2text shrU}
|]
let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
accept = Doc hLocal Activity accept = Doc hLocal Activity
{ activityId = Just $ encodeRouteLocal $ ProjectOutboxItemR shrJ prjJ obikhidAccept { activityId = Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept
, activityActor = encodeRouteLocal $ ProjectR shrJ prjJ , activityActor = encodeRouteLocal actorRoute
, activitySummary = Just summary , activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] [] , activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept , activitySpecific = AcceptActivity Accept
{ acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate { acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate