C2S: offerTicketC: Support offering a patch to a repo

This commit is contained in:
fr33domlover 2020-07-16 11:30:22 +00:00
parent 3e7e885300
commit f7c0807775
3 changed files with 214 additions and 64 deletions

View file

@ -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,28 +1086,23 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
return obiidOffer
where
checkTicket
shrUser
(AP.Ticket mlocal attrib mpublished mupdated muContext summary
content source muAssigned resolved mmr)
uTarget = do
verifyNothingE mlocal "Ticket with 'id'"
shrAttrib <- do
route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route"
case route of
SharerR shr -> return shr
_ -> throwE "Ticket attrib not a sharer route"
unless (shrAttrib == shrUser) $
throwE "Ticket attibuted to someone else"
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
for_ muContext $ \ uContext ->
unless (uContext == uTarget) $ throwE "Offer target != ticket context"
verifyNothingE muAssigned "Ticket has 'assignedTo'"
when resolved $ throwE "Ticket is resolved"
verifyNothingE mmr "Ticket has 'attachment'"
target <- parseTarget uTarget
return (summary, content, source, target)
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
@ -1066,10 +1110,100 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
then Left <$> do
route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route"
case route of
ProjectR shr prj -> return (shr, prj)
RepoR _ _ -> throwE "Offering patch to repo not implemented yet"
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) = do
verifyNothingE mlocal "Ticket with 'id'"
shrAttrib <- do
route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route"
case route of
SharerR shr -> return shr
_ -> throwE "Ticket attrib not a sharer route"
unless (shrAttrib == shrUser) $
throwE "Ticket attibuted to someone else"
verifyNothingE mpublished "Ticket with 'published'"
verifyNothingE mupdated "Ticket with 'updated'"
verifyNothingE muAssigned "Ticket has 'assignedTo'"
when resolved $ throwE "Ticket is resolved"
mmr' <- traverse (uncurry checkMR) mmr
return (muContext, summary, content, source, mmr')
where
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)
"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 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]

View file

@ -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

View file

@ -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