C2S: offerTicketC: Support offering a patch to a repo
This commit is contained in:
fr33domlover
parent
3e7e885300
commit
f7c0807775
3 changed files with 214 additions and 64 deletions
|
|
@ -84,7 +84,7 @@ import Crypto.PublicVerifKey
|
|||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Network.HTTP.Digest
|
||||
import Web.ActivityPub hiding (Follow, Ticket)
|
||||
import Web.ActivityPub hiding (Patch, Ticket, Follow)
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.FedURI
|
||||
|
|
@ -110,6 +110,7 @@ import Vervis.FedURI
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Repo
|
||||
import Vervis.Model.Ticket
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
|
|
@ -488,8 +489,8 @@ checkFederation remoteRecips = do
|
|||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients found"
|
||||
|
||||
verifyProjectRecip (Right _) _ = return ()
|
||||
verifyProjectRecip (Left (shr, prj)) localRecips =
|
||||
verifyProjectRecipOld (Right _) _ = return ()
|
||||
verifyProjectRecipOld (Left (shr, prj)) localRecips =
|
||||
fromMaybeE verify "Local context project isn't listed as a recipient"
|
||||
where
|
||||
verify = do
|
||||
|
|
@ -497,6 +498,22 @@ verifyProjectRecip (Left (shr, prj)) 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"
|
||||
where
|
||||
verify = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
|
||||
guard $ localRecipProject $ localRecipProjectDirect projectSet
|
||||
verifyProjectRecip (Left (WTTRepo shr rp _ _ _)) localRecips =
|
||||
fromMaybeE verify "Local context repo isn't listed as a recipient"
|
||||
where
|
||||
verify = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
repoSet <- lookup rp $ localRecipRepoRelated sharerSet
|
||||
guard $ localRecipRepo $ localRecipRepoDirect repoSet
|
||||
|
||||
-- | 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'.
|
||||
|
|
@ -516,7 +533,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Create Ticket with no recipients"
|
||||
checkFederation remoteRecips
|
||||
verifyProjectRecip context localRecips
|
||||
verifyProjectRecipOld context localRecips
|
||||
tracker <- fetchTracker context uTarget
|
||||
now <- liftIO getCurrentTime
|
||||
(_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
|
||||
|
|
@ -970,7 +987,7 @@ offerTicketC
|
|||
-> ExceptT Text Handler OutboxItemId
|
||||
offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
(title, desc, source, target) <- checkTicket shrUser ticket uTarget
|
||||
(target, title, desc, source) <- checkOfferTicket shrUser ticket uTarget
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Offer Ticket with no recipients"
|
||||
|
|
@ -982,18 +999,26 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
(obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do
|
||||
mproject <-
|
||||
case target of
|
||||
Left (shr, prj) -> Just <$> do
|
||||
Left (WTTProject shr prj) -> Just . Left <$> 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"
|
||||
Left (WTTRepo shr rp mb vcs diff) -> Just . Right <$> do
|
||||
mproj <- lift $ runMaybeT $ do
|
||||
Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
|
||||
er <- MaybeT $ getBy $ UniqueRepo rp sid
|
||||
return (s, er)
|
||||
(s, er@(Entity _ r)) <- fromMaybeE mproj "Offer target no such local repo in DB"
|
||||
unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
|
||||
return (s, er, mb, diff)
|
||||
Right _ -> return Nothing
|
||||
(obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded
|
||||
remotesHttpOffer <- do
|
||||
let sieve =
|
||||
case target of
|
||||
Left (shr, prj) ->
|
||||
Left (WTTProject shr prj) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorProject shr prj
|
||||
]
|
||||
|
|
@ -1001,6 +1026,14 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
, LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
Left (WTTRepo shr rp _ _ _) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorRepo shr rp
|
||||
]
|
||||
[ LocalPersonCollectionSharerFollowers shrUser
|
||||
, LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
Right _ ->
|
||||
makeRecipientSet
|
||||
[]
|
||||
|
|
@ -1016,19 +1049,35 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
unless (federation || null moreRemoteRecips) $
|
||||
throwE "Federation disabled, but recipient collection remote members found"
|
||||
lift $ deliverRemoteDB'' fwdHosts 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
|
||||
maccept <- lift $ for mproject $ \ project -> do
|
||||
let obid =
|
||||
case project of
|
||||
Left (_, Entity _ j) -> projectOutbox j
|
||||
Right (_, Entity _ r, _, _) -> repoOutbox r
|
||||
obiidAccept <- insertEmptyOutboxItem obid now
|
||||
let insertTXL =
|
||||
case project of
|
||||
Left (_, Entity jid _) ->
|
||||
\ tclid -> insert_ $ TicketProjectLocal tclid jid
|
||||
Right (_, Entity rid _, mb, _) ->
|
||||
\ tclid -> insert_ $ TicketRepoLocal tclid rid mb
|
||||
(tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept
|
||||
case project of
|
||||
Left _ -> return ()
|
||||
Right (_, _, _, diff) -> insert_ $ Patch tid now diff
|
||||
(docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid
|
||||
let (actor, ibid) =
|
||||
case project of
|
||||
Left (s, Entity _ j) ->
|
||||
( LocalActorProject (sharerIdent s) (projectIdent j)
|
||||
, projectInbox j
|
||||
)
|
||||
Right (s, Entity _ r, _, _) ->
|
||||
( LocalActorRepo (sharerIdent s) (repoIdent r)
|
||||
, repoInbox r
|
||||
)
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorProject shrJ prj)
|
||||
(projectInbox j)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
deliverLocal' False actor ibid obiidAccept localRecipsAccept
|
||||
(obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept
|
||||
return (obiid, doc, remotesHttpOffer, maccept)
|
||||
lift $ do
|
||||
|
|
@ -1037,11 +1086,38 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
|
||||
return obiidOffer
|
||||
where
|
||||
checkOfferTicket
|
||||
:: ShrIdent
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler
|
||||
( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text))
|
||||
, TextHtml
|
||||
, TextHtml
|
||||
, TextPandocMarkdown
|
||||
)
|
||||
checkOfferTicket shrUser ticket uTarget = do
|
||||
target <- parseTarget uTarget
|
||||
(muContext, summary, content, source, mmr) <- checkTicket shrUser ticket
|
||||
for_ muContext $
|
||||
\ u -> unless (u == uTarget) $ throwE "Offer target != ticket context"
|
||||
target' <- matchTargetAndMR target mmr
|
||||
return (target', summary, content, source)
|
||||
where
|
||||
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 $ Left (shr, prj)
|
||||
RepoR shr rp -> return $ Right (shr, rp)
|
||||
_ -> throwE "Offer target is local but isn't a project/repo route"
|
||||
else return $ Right u
|
||||
checkTicket
|
||||
shrUser
|
||||
(AP.Ticket mlocal attrib mpublished mupdated muContext summary
|
||||
content source muAssigned resolved mmr)
|
||||
uTarget = do
|
||||
content source muAssigned resolved mmr) = do
|
||||
verifyNothingE mlocal "Ticket with 'id'"
|
||||
shrAttrib <- do
|
||||
route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route"
|
||||
|
|
@ -1050,26 +1126,84 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
_ -> 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 mpublished "Ticket with 'published'"
|
||||
verifyNothingE mupdated "Ticket with 'updated'"
|
||||
verifyNothingE muAssigned "Ticket has 'assignedTo'"
|
||||
when resolved $ throwE "Ticket is resolved"
|
||||
verifyNothingE mmr "Ticket has 'attachment'"
|
||||
target <- parseTarget uTarget
|
||||
return (summary, content, source, target)
|
||||
|
||||
mmr' <- traverse (uncurry checkMR) mmr
|
||||
|
||||
return (muContext, summary, content, source, mmr')
|
||||
where
|
||||
parseTarget u@(ObjURI h lu) = do
|
||||
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 h lu = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route"
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal lu)
|
||||
"MR target is local but isn't 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
|
||||
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 h (AP.Patch mlocal attrib mpub typ content) = do
|
||||
verifyNothingE mlocal "Patch with 'id'"
|
||||
hl <- hostIsLocal h
|
||||
shrAttrib <- do
|
||||
route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route"
|
||||
case route of
|
||||
SharerR shr -> return shr
|
||||
_ -> throwE "Patch attrib not a sharer route"
|
||||
unless (hl && shrAttrib == shrUser) $
|
||||
throwE "Ticket and Patch attrib mismatch"
|
||||
verifyNothingE mpub "Patch has 'published'"
|
||||
return (typ, content)
|
||||
matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj
|
||||
matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
|
||||
matchTargetAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo"
|
||||
matchTargetAndMR (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 Offer target 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
|
||||
matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
|
||||
matchTargetAndMR (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 Offer target repo mismatch"
|
||||
let patch =
|
||||
( if lu == luBranch then Nothing else Just luBranch
|
||||
, typ
|
||||
, content
|
||||
)
|
||||
return $ Right (h, lu, Just patch)
|
||||
insertOfferToOutbox shrUser now obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
|
|
@ -1086,7 +1220,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
insertTicket pidAuthor now title desc source jid obiid obiidAccept = do
|
||||
insertTicket pidAuthor now title desc source insertTXL obiid obiidAccept = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
|
|
@ -1109,10 +1243,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
{ ticketContextLocalTicket = tid
|
||||
, ticketContextLocalAccept = obiidAccept
|
||||
}
|
||||
insert_ TicketProjectLocal
|
||||
{ ticketProjectLocalContext = tclid
|
||||
, ticketProjectLocalProject = jid
|
||||
}
|
||||
insertTXL tclid
|
||||
talid <- insert TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = ltid
|
||||
, ticketAuthorLocalAuthor = pidAuthor
|
||||
|
|
@ -1122,33 +1253,50 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
{ ticketUnderProjectProject = tclid
|
||||
, ticketUnderProjectAuthor = talid
|
||||
}
|
||||
return ltid
|
||||
insertAccept shrUser luOffer shrJ prj obiidAccept ltid = do
|
||||
return (tid, ltid)
|
||||
insertAccept shrUser luOffer project obiidAccept ltid = do
|
||||
let (collections, outboxItemRoute, projectRoute, ticketRoute) =
|
||||
case project of
|
||||
Left (s, Entity _ j) ->
|
||||
let shr = sharerIdent s
|
||||
prj = projectIdent j
|
||||
in ( [ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
, ProjectOutboxItemR shr prj
|
||||
, ProjectR shr prj
|
||||
, ProjectTicketR shr prj
|
||||
)
|
||||
Right (s, Entity _ r, _, _) ->
|
||||
let shr = sharerIdent s
|
||||
rp = repoIdent r
|
||||
in ( [ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
, RepoOutboxItemR shr rp
|
||||
, RepoR shr rp
|
||||
, RepoPatchR shr rp
|
||||
)
|
||||
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
|
||||
Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept
|
||||
, activityActor = encodeRouteLocal projectRoute
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luOffer
|
||||
, acceptResult =
|
||||
Just $ encodeRouteLocal $ ProjectTicketR shrJ prj ltkhid
|
||||
Just $ encodeRouteLocal $ ticketRoute ltkhid
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
|
|
|
|||
|
|
@ -90,10 +90,6 @@ import Vervis.Patch
|
|||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
|
||||
data WorkItemTarget
|
||||
= WTTProject ShrIdent PrjIdent
|
||||
| WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text
|
||||
|
||||
checkOfferTicket
|
||||
:: RemoteAuthor
|
||||
-> AP.Ticket URIMode
|
||||
|
|
@ -107,14 +103,14 @@ checkOfferTicket
|
|||
, TextPandocMarkdown
|
||||
)
|
||||
checkOfferTicket author ticket uTarget = do
|
||||
target <- checkProject uTarget
|
||||
target <- parseTarget uTarget
|
||||
(muContext, summary, content, source, mmr) <- checkTicket ticket
|
||||
for_ muContext $
|
||||
\ u -> unless (u == uTarget) $ throwE "Offer target != Ticket context"
|
||||
target' <- matchTargetAndMR target mmr
|
||||
return (target', summary, content, source)
|
||||
where
|
||||
checkProject u@(ObjURI h lu) = do
|
||||
parseTarget u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ module Vervis.WorkItem
|
|||
, askWorkItemFollowers
|
||||
, contextAudience
|
||||
, getWorkItemDetail
|
||||
, WorkItemTarget (..)
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -64,6 +65,7 @@ import Vervis.FedURI
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Repo
|
||||
-- import Vervis.Model.Workflow
|
||||
-- import Vervis.Paginate
|
||||
import Vervis.Patch
|
||||
|
|
@ -247,3 +249,7 @@ getWorkItemDetail name v = do
|
|||
_ -> throwE "Not a ticket author route"
|
||||
else return $ Right u
|
||||
mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
|
||||
data WorkItemTarget
|
||||
= WTTProject ShrIdent PrjIdent
|
||||
| WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text
|
||||
|
|
|
|||
Loading…
Reference in a new issue