C2S: createTicketC: Allow to submit MRs i.e. Ticket with a Patch attached
This commit is contained in:
fr33domlover
parent
fd8405e741
commit
c1f0722c21
2 changed files with 404 additions and 121 deletions
|
|
@ -415,6 +415,8 @@ TicketProjectRemote
|
|||
ticket TicketAuthorLocalId
|
||||
tracker RemoteActorId
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -489,15 +489,6 @@ checkFederation remoteRecips = do
|
|||
unless (federation || null remoteRecips) $
|
||||
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 (Left (WTTProject shr prj)) localRecips =
|
||||
fromMaybeE verify "Local context project isn't listed as a recipient"
|
||||
|
|
@ -527,24 +518,23 @@ createTicketC
|
|||
-> ExceptT Text Handler OutboxItemId
|
||||
createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
|
||||
context <- parseTicketContext uContext
|
||||
(context, title, desc, source) <- checkCreateTicket shrUser ticket muTarget
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Create Ticket with no recipients"
|
||||
checkFederation remoteRecips
|
||||
verifyProjectRecipOld context localRecips
|
||||
tracker <- fetchTracker context uTarget
|
||||
verifyProjectRecip context localRecips
|
||||
tracker <- bitraverse pure fetchTracker context
|
||||
now <- liftIO getCurrentTime
|
||||
(_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
|
||||
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
|
||||
project <- prepareProject now tracker
|
||||
talid <- lift $ insertTicket now pidUser title desc source obiidCreate project
|
||||
docCreate <- lift $ insertCreateToOutbox shrUser blinded ticketData now obiidCreate talid
|
||||
(talid, mptid) <- lift $ insertTicket now pidUser title desc source obiidCreate project
|
||||
docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid
|
||||
remoteRecipsHttpCreate <- do
|
||||
let sieve =
|
||||
case tracker of
|
||||
Left (shr, prj) ->
|
||||
case context of
|
||||
Left (WTTProject shr prj) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorProject shr prj
|
||||
]
|
||||
|
|
@ -552,27 +542,55 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
, LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
Left (WTTRepo shr rp _ _ _) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorRepo shr rp
|
||||
]
|
||||
[ LocalPersonCollectionSharerFollowers shrUser
|
||||
, LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
Right _ ->
|
||||
makeRecipientSet
|
||||
[]
|
||||
[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
|
||||
lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
|
||||
maccept <-
|
||||
case project of
|
||||
Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do
|
||||
let prj = projectIdent j
|
||||
recipsA =
|
||||
Left proj@(shr, ent, obiidAccept) -> Just <$> do
|
||||
let recipsA =
|
||||
[ LocalActorSharer shrUser
|
||||
]
|
||||
recipsC =
|
||||
[ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
, LocalPersonCollectionSharerFollowers shrUser
|
||||
]
|
||||
(recipsC, ibid, actor) =
|
||||
case ent of
|
||||
Left (Entity _ j) ->
|
||||
let prj = projectIdent j
|
||||
in ( [ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
, 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
|
||||
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
|
||||
lift $ (obiidAccept,doc,) <$> deliverRemoteDB'' [] obiidAccept [] recips
|
||||
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
|
||||
return obiidCreate
|
||||
where
|
||||
checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do
|
||||
verifyNothingE mlocal "Ticket with 'id'"
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
unless (encodeRouteLocal (SharerR shr) == luAttrib) $
|
||||
throwE "Ticket attributed to someone else"
|
||||
verifyNothingE mpublished "Ticket with 'published'"
|
||||
verifyNothingE mupdated "Ticket with 'updated'"
|
||||
context <- fromMaybeE mcontext "Ticket without 'context'"
|
||||
verifyNothingE massigned "Ticket with 'assignedTo'"
|
||||
when resolved $ throwE "Ticket resolved"
|
||||
target <- fromMaybeE mtarget "Create Ticket without 'target'"
|
||||
verifyNothingE mmr "Ticket with 'attachment'"
|
||||
return (context, summary, content, source, target)
|
||||
checkCreateTicket
|
||||
:: ShrIdent
|
||||
-> AP.Ticket URIMode
|
||||
-> Maybe FedURI
|
||||
-> ExceptT Text Handler
|
||||
( Either
|
||||
WorkItemTarget
|
||||
( Host
|
||||
, LocalURI
|
||||
, LocalURI
|
||||
, Maybe (Maybe LocalURI, PatchType, Text)
|
||||
)
|
||||
, TextHtml
|
||||
, TextHtml
|
||||
, TextPandocMarkdown
|
||||
)
|
||||
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
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal lu)
|
||||
(name <> " is local but isn't a valid route")
|
||||
case route of
|
||||
ProjectR shr prj -> return $ Left (shr, prj)
|
||||
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
|
||||
checkTicket
|
||||
:: AP.Ticket URIMode
|
||||
-> ExceptT Text Handler
|
||||
( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text))
|
||||
, 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
|
||||
unless (encodeRouteLocal (SharerR shr) == attrib) $
|
||||
throwE "Ticket attributed to someone else"
|
||||
verifyNothingE mpublished "Ticket with 'published'"
|
||||
verifyNothingE mupdated "Ticket with 'updated'"
|
||||
uContext <- fromMaybeE muContext "Ticket without 'context'"
|
||||
context <- checkTracker "Ticket context" uContext
|
||||
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"
|
||||
|
||||
parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI)
|
||||
parseTicketContext u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Ticket context isn't a valid route"
|
||||
case route of
|
||||
ProjectR shr prj -> return (shr, prj)
|
||||
_ -> throwE "Ticket context isn't a project route"
|
||||
else return $ Right u
|
||||
fetchTracker (h, luTarget, luContext, mpatch) = do
|
||||
(iid, era) <- do
|
||||
iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <- lift $ fetchRemoteActor iid h luTarget
|
||||
case result of
|
||||
Left e -> throwE $ T.pack $ displayException e
|
||||
Right (Left e) -> throwE $ T.pack $ show e
|
||||
Right (Right mera) -> do
|
||||
era <- fromMaybeE mera "target found to be a collection, not an actor"
|
||||
return (iid, era)
|
||||
return (iid, era, if luTarget == luContext then Nothing else Just luContext, mpatch)
|
||||
|
||||
fetchTracker c u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
case (hl, c) of
|
||||
(True, Left (shr, prj)) -> Left <$> do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
unless (encodeRouteLocal (ProjectR shr prj) == lu) $
|
||||
throwE "Local context and target mismatch"
|
||||
return (shr, prj)
|
||||
(True, Right _) -> throwE "context and target different host"
|
||||
(False, Left _) -> throwE "context and target different host"
|
||||
(False, Right (ObjURI h' lu')) -> Right <$> do
|
||||
unless (h == h') $ throwE "context and target different host"
|
||||
(iid, era) <- do
|
||||
iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <- lift $ fetchRemoteActor iid h lu
|
||||
case result of
|
||||
Left e -> throwE $ T.pack $ displayException e
|
||||
Right (Left e) -> throwE $ T.pack $ show e
|
||||
Right (Right mera) -> do
|
||||
era <- fromMaybeE mera "target found to be a collection, not an actor"
|
||||
return (iid, era)
|
||||
return (iid, era, if lu == lu' then Nothing else Just lu')
|
||||
|
||||
prepareProject now (Left (shr, prj)) = Left <$> do
|
||||
prepareProject now (Left (WTTProject shr prj)) = Left <$> do
|
||||
mej <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
MaybeT $ getBy $ UniqueProject prj sid
|
||||
ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
|
||||
obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
|
||||
return (shr, ej, obiidAccept)
|
||||
prepareProject _ (Right (iid, era, mlu)) = lift $ Right <$> do
|
||||
mroid <- for mlu $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu)
|
||||
return (era, mroid)
|
||||
return (shr, Left ej, obiidAccept)
|
||||
prepareProject now (Left (WTTRepo shr rp mb vcs diff)) = Left <$> do
|
||||
mer <- lift $ runMaybeT $ do
|
||||
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
|
||||
did <- insert Discussion
|
||||
|
|
@ -666,35 +868,122 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
, ticketAuthorLocalAuthor = pidUser
|
||||
, ticketAuthorLocalOpen = obiidCreate
|
||||
}
|
||||
case project of
|
||||
Left (_shr, Entity jid _j, obiidAccept) -> do
|
||||
tclid <- insert TicketContextLocal
|
||||
{ ticketContextLocalTicket = tid
|
||||
, ticketContextLocalAccept = obiidAccept
|
||||
}
|
||||
insert_ TicketProjectLocal
|
||||
{ ticketProjectLocalContext = tclid
|
||||
, ticketProjectLocalProject = jid
|
||||
}
|
||||
Right (Entity raid _ra, mroid) ->
|
||||
insert_ TicketProjectRemote
|
||||
{ ticketProjectRemoteTicket = talid
|
||||
, ticketProjectRemoteTracker = raid
|
||||
, ticketProjectRemoteProject = mroid
|
||||
}
|
||||
return talid
|
||||
mptid <-
|
||||
case project of
|
||||
Left (_shr, ent, obiidAccept) -> do
|
||||
tclid <- insert TicketContextLocal
|
||||
{ ticketContextLocalTicket = tid
|
||||
, ticketContextLocalAccept = obiidAccept
|
||||
}
|
||||
case ent of
|
||||
Left (Entity jid _) -> do
|
||||
insert_ TicketProjectLocal
|
||||
{ ticketProjectLocalContext = tclid
|
||||
, ticketProjectLocalProject = jid
|
||||
}
|
||||
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
|
||||
{ ticketProjectRemoteTicket = talid
|
||||
, ticketProjectRemoteTracker = raid
|
||||
, ticketProjectRemoteProject = mroid
|
||||
}
|
||||
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
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
talkhid <- encodeKeyHashid talid
|
||||
mptkhid <- traverse encodeKeyHashid mptid
|
||||
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
|
||||
{ ticketId = encodeRouteLocal $ SharerTicketR shrUser talkhid
|
||||
{ ticketId = luTicket
|
||||
, ticketReplies = encodeRouteLocal $ SharerTicketDiscussionR 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
|
||||
, ticketDeps = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid
|
||||
, ticketReverseDeps = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid
|
||||
|
|
@ -716,7 +1005,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
, AP.ticketSource = source
|
||||
, AP.ticketAssignedTo = Nothing
|
||||
, AP.ticketIsResolved = False
|
||||
, AP.ticketAttachment = Nothing
|
||||
, AP.ticketAttachment = mmr
|
||||
}
|
||||
, createTarget = Just uTarget
|
||||
}
|
||||
|
|
@ -724,34 +1013,26 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc 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
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
obikhidCreate <- encodeKeyHashid obiidCreate
|
||||
talkhid <- encodeKeyHashid talid
|
||||
let prjJ = projectIdent j
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
Project #
|
||||
<a href=@{ProjectR shrJ prjJ}>
|
||||
#{prj2text prjJ}
|
||||
\ accepted #
|
||||
<a href=@{SharerTicketR shrU talkhid}>
|
||||
ticket
|
||||
\ by #
|
||||
<a href=@{SharerR shrU}>
|
||||
#{shr2text shrU}
|
||||
|]
|
||||
let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
|
||||
let (outboxItemRoute, actorRoute) =
|
||||
case ent of
|
||||
Left (Entity _ j) ->
|
||||
let prj = projectIdent j
|
||||
in (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj)
|
||||
Right (Entity _ r, _, _) ->
|
||||
let rp = repoIdent r
|
||||
in (RepoOutboxItemR shrJ rp, RepoR shrJ rp)
|
||||
recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
|
||||
accept = Doc hLocal Activity
|
||||
{ activityId = Just $ encodeRouteLocal $ ProjectOutboxItemR shrJ prjJ obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ ProjectR shrJ prjJ
|
||||
, activitySummary = Just summary
|
||||
{ activityId = Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept
|
||||
, activityActor = encodeRouteLocal actorRoute
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate
|
||||
|
|
|
|||
Loading…
Reference in a new issue