S2S: Implement loomApplyF (remote person asking to apply bundle on local loom)
This commit is contained in:
parent
40e2dd9666
commit
ba6f22b94b
7 changed files with 378 additions and 613 deletions
|
@ -115,6 +115,7 @@ import Vervis.Model.Ticket
|
||||||
import Vervis.Path
|
import Vervis.Path
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
import Vervis.Persist.Collab
|
import Vervis.Persist.Collab
|
||||||
|
import Vervis.Persist.Ticket
|
||||||
import Vervis.Recipient
|
import Vervis.Recipient
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
|
@ -597,24 +598,10 @@ applyC
|
||||||
-> Audience URIMode
|
-> Audience URIMode
|
||||||
-> Apply URIMode
|
-> Apply URIMode
|
||||||
-> ExceptT Text Handler OutboxItemId
|
-> ExceptT Text Handler OutboxItemId
|
||||||
applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (AP.Apply uObject target) = do
|
applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience apply = do
|
||||||
|
|
||||||
-- Check input
|
-- Check input
|
||||||
maybeLocalTarget <- do
|
maybeLocalTarget <- checkApplyLocalLoom apply
|
||||||
bundle <- parseProposalBundle "Apply object" uObject
|
|
||||||
targetTip <- nameExceptT "Apply target" $ checkTip target
|
|
||||||
let maybeLocal =
|
|
||||||
case targetTip of
|
|
||||||
TipLocalRepo repoID -> Just (repoID, Nothing)
|
|
||||||
TipLocalBranch repoID branch -> Just (repoID, Just branch)
|
|
||||||
TipRemote _ -> Nothing
|
|
||||||
TipRemoteBranch _ _ -> Nothing
|
|
||||||
for maybeLocal $ \ (repoID, maybeBranch) -> do
|
|
||||||
(loomID, clothID, bundleID) <-
|
|
||||||
case bundle of
|
|
||||||
Left b -> pure b
|
|
||||||
Right _ -> throwE "Applying a remote bundle on local loom"
|
|
||||||
return (repoID, maybeBranch, loomID, clothID, bundleID)
|
|
||||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||||
mrecips <- parseAudience audience
|
mrecips <- parseAudience audience
|
||||||
fromMaybeE mrecips "Apply with no recipients"
|
fromMaybeE mrecips "Apply with no recipients"
|
||||||
|
@ -636,89 +623,23 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (
|
||||||
maybeLocalTargetDB <- for maybeLocalTarget $
|
maybeLocalTargetDB <- for maybeLocalTarget $
|
||||||
\ (repoID, maybeBranch, loomID, clothID, bundleID) -> runDBExcept $ do
|
\ (repoID, maybeBranch, loomID, clothID, bundleID) -> runDBExcept $ do
|
||||||
|
|
||||||
-- Find the bundle and its loom in DB
|
-- Find the repo and the bundle in our DB, and verify that the loom
|
||||||
(loom, clothBranch, ticketID, maybeResolve, latest) <- do
|
-- hosting the bundle is willing to accept the request from sender
|
||||||
maybeBundle <- lift $ runMaybeT $ do
|
-- to apply this specific bundle to this repo/branch
|
||||||
(Entity _ loom, Entity _ cloth, Entity ticketID _, _author, resolve, proposal) <-
|
(loom, ticketID, diffs) <-
|
||||||
MaybeT $ getCloth loomID clothID
|
checkApplyDB
|
||||||
bundle <- MaybeT $ get bundleID
|
(Left senderPersonID)
|
||||||
guard $ bundleTicket bundle == clothID
|
capID
|
||||||
latest :| _prevs <-
|
(repoID, maybeBranch)
|
||||||
case justHere proposal of
|
(loomID, clothID, bundleID)
|
||||||
Nothing ->
|
|
||||||
error "Why didn't getCloth find any bundles"
|
|
||||||
Just bundles -> return bundles
|
|
||||||
return (loom, ticketLoomBranch cloth, ticketID, resolve, latest)
|
|
||||||
fromMaybeE maybeBundle ""
|
|
||||||
|
|
||||||
-- Verify the target repo/branch iof the Apply is identical to the
|
|
||||||
-- target repo/branch of the MR
|
|
||||||
unless (maybeBranch == clothBranch) $
|
|
||||||
throwE "Apply target != MR target"
|
|
||||||
|
|
||||||
-- Find target repo in DB and verify it consents to being served by
|
|
||||||
-- the loom
|
|
||||||
unless (repoID == loomRepo loom) $
|
|
||||||
throwE "MR target repo isn't the one served by the Apply object bundle's loom"
|
|
||||||
repo <- getE repoID "Apply target: No such local repo in DB"
|
|
||||||
unless (repoLoom repo == Just loomID) $
|
|
||||||
throwE "Apply object bunde's loom doesn't have repo's consent to serve it"
|
|
||||||
|
|
||||||
-- Verify that VCS type matches the presence of a branch:
|
|
||||||
-- Branch specified for Git, isn't specified for Darcs
|
|
||||||
case (repoVcs repo, maybeBranch) of
|
|
||||||
(VCSDarcs, Nothing) -> pure ()
|
|
||||||
(VCSGit, Just _) -> pure ()
|
|
||||||
_ -> throwE "VCS type and branch presence mismatch"
|
|
||||||
|
|
||||||
-- Verify the MR isn't already resolved and the bundle is the
|
|
||||||
-- latest version
|
|
||||||
unless (isNothing maybeResolve) $
|
|
||||||
throwE "MR is already resolved"
|
|
||||||
unless (bundleID == latest) $
|
|
||||||
throwE "Bundle isn't the latest version"
|
|
||||||
|
|
||||||
-- Verify the sender is authorized by the loom to apply a patch
|
|
||||||
capability <-
|
|
||||||
case capID of
|
|
||||||
Left (actor, _, item) -> return (actor, item)
|
|
||||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
|
|
||||||
verifyCapability capability (Left senderPersonID) (GrantResourceLoom loomID)
|
|
||||||
|
|
||||||
-- Get the patches from DB, verify VCS match just in case
|
|
||||||
diffs <- do
|
|
||||||
ps <-
|
|
||||||
lift $ map entityVal <$>
|
|
||||||
selectList [PatchBundle ==. bundleID] [Asc PatchId]
|
|
||||||
let patchVCS = patchMediaTypeVCS . patchType
|
|
||||||
case NE.nonEmpty ps of
|
|
||||||
Nothing -> error "Bundle without patches"
|
|
||||||
Just ne ->
|
|
||||||
if all ((== repoVcs repo) . patchVCS) ne
|
|
||||||
then return $ NE.map patchContent ne
|
|
||||||
else throwE "Patch type mismatch with repo VCS type"
|
|
||||||
|
|
||||||
return
|
return
|
||||||
(Entity loomID loom, clothID, ticketID, repoID, maybeBranch, diffs)
|
(Entity loomID loom, clothID, ticketID, repoID, maybeBranch, diffs)
|
||||||
|
|
||||||
-- Apply patches
|
-- Apply patches
|
||||||
for_ maybeLocalTargetDB $ \ (_, _, _, repoID, maybeBranch, diffs) -> do
|
for_ maybeLocalTargetDB $
|
||||||
repoPath <- do
|
\ (_, _, _, repoID, maybeBranch, diffs) ->
|
||||||
repoHash <- encodeKeyHashid repoID
|
applyPatches repoID maybeBranch diffs
|
||||||
repoDir <- askRepoDir repoHash
|
|
||||||
liftIO $ makeAbsolute repoDir
|
|
||||||
case maybeBranch of
|
|
||||||
Just branch -> do
|
|
||||||
ExceptT $ liftIO $ runExceptT $
|
|
||||||
withSystemTempDirectory "vervis-applyC" $
|
|
||||||
applyGitPatches repoPath (T.unpack branch) diffs
|
|
||||||
Nothing -> do
|
|
||||||
patch <-
|
|
||||||
case diffs of
|
|
||||||
t :| [] -> return t
|
|
||||||
_ :| (_ : _) ->
|
|
||||||
throwE "Darcs repo given multiple patch bundles"
|
|
||||||
applyDarcsPatch repoPath patch
|
|
||||||
|
|
||||||
senderHash <- encodeKeyHashid senderPersonID
|
senderHash <- encodeKeyHashid senderPersonID
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
|
@ -824,7 +745,7 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (
|
||||||
, activitySummary = summary
|
, activitySummary = summary
|
||||||
, activityAudience = blinded
|
, activityAudience = blinded
|
||||||
, activityFulfills = []
|
, activityFulfills = []
|
||||||
, activitySpecific = ApplyActivity $ Apply uObject target
|
, activitySpecific = ApplyActivity apply
|
||||||
}
|
}
|
||||||
update applyID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
update applyID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
return (luApply, doc)
|
return (luApply, doc)
|
||||||
|
|
|
@ -19,8 +19,8 @@ module Vervis.Data.Ticket
|
||||||
, Merge (..)
|
, Merge (..)
|
||||||
, TrackerAndMerge (..)
|
, TrackerAndMerge (..)
|
||||||
, WorkItemOffer (..)
|
, WorkItemOffer (..)
|
||||||
, checkTip
|
|
||||||
, checkOfferTicket
|
, checkOfferTicket
|
||||||
|
, checkApplyLocalLoom
|
||||||
|
|
||||||
-- These are exported only for Vervis.Client
|
-- These are exported only for Vervis.Client
|
||||||
, Tracker (..)
|
, Tracker (..)
|
||||||
|
@ -50,6 +50,7 @@ import Control.Monad.Trans.Except.Local
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
import Vervis.Ticket
|
||||||
|
|
||||||
data Tip
|
data Tip
|
||||||
= TipLocalRepo RepoId
|
= TipLocalRepo RepoId
|
||||||
|
@ -199,3 +200,30 @@ checkOfferTicket host ticket uTarget = do
|
||||||
unless (tracker == target) $ throwE "Offer target != ticket context"
|
unless (tracker == target) $ throwE "Offer target != ticket context"
|
||||||
tam <- checkTrackerAndMerge target maybeBundle
|
tam <- checkTrackerAndMerge target maybeBundle
|
||||||
return $ WorkItemOffer author title desc source tam
|
return $ WorkItemOffer author title desc source tam
|
||||||
|
|
||||||
|
checkApply
|
||||||
|
:: AP.Apply URIMode
|
||||||
|
-> ExceptT Text Handler
|
||||||
|
(Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
|
||||||
|
checkApply (AP.Apply uObject target) =
|
||||||
|
(,) <$> parseProposalBundle "Apply object" uObject
|
||||||
|
<*> nameExceptT "Apply target" (checkTip target)
|
||||||
|
|
||||||
|
checkApplyLocalLoom
|
||||||
|
:: AP.Apply URIMode
|
||||||
|
-> ExceptT Text Handler
|
||||||
|
(Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
|
||||||
|
checkApplyLocalLoom apply = do
|
||||||
|
(bundle, targetTip) <- checkApply apply
|
||||||
|
let maybeLocal =
|
||||||
|
case targetTip of
|
||||||
|
TipLocalRepo repoID -> Just (repoID, Nothing)
|
||||||
|
TipLocalBranch repoID branch -> Just (repoID, Just branch)
|
||||||
|
TipRemote _ -> Nothing
|
||||||
|
TipRemoteBranch _ _ -> Nothing
|
||||||
|
for maybeLocal $ \ (repoID, maybeBranch) -> do
|
||||||
|
(loomID, clothID, bundleID) <-
|
||||||
|
case bundle of
|
||||||
|
Left b -> pure b
|
||||||
|
Right _ -> throwE "Applying a remote bundle on local loom"
|
||||||
|
return (repoID, maybeBranch, loomID, clothID, bundleID)
|
||||||
|
|
|
@ -20,8 +20,7 @@ module Vervis.Federation.Ticket
|
||||||
|
|
||||||
--, repoAddBundleF
|
--, repoAddBundleF
|
||||||
|
|
||||||
--, repoApplyF
|
, loomApplyF
|
||||||
--, loomApplyF
|
|
||||||
|
|
||||||
--, deckOfferDepF
|
--, deckOfferDepF
|
||||||
--, repoOfferDepF
|
--, repoOfferDepF
|
||||||
|
@ -94,6 +93,7 @@ import Development.PatchMediaType
|
||||||
|
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
import Vervis.Cloth
|
import Vervis.Cloth
|
||||||
|
import Vervis.Data.Actor
|
||||||
import Vervis.Data.Ticket
|
import Vervis.Data.Ticket
|
||||||
import Vervis.Darcs
|
import Vervis.Darcs
|
||||||
import Vervis.Delivery
|
import Vervis.Delivery
|
||||||
|
@ -107,6 +107,7 @@ import Vervis.Model
|
||||||
import Vervis.Model.Role
|
import Vervis.Model.Role
|
||||||
import Vervis.Model.Ticket
|
import Vervis.Model.Ticket
|
||||||
import Vervis.Path
|
import Vervis.Path
|
||||||
|
import Vervis.Persist.Ticket
|
||||||
import Vervis.Query
|
import Vervis.Query
|
||||||
import Vervis.Recipient
|
import Vervis.Recipient
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
|
@ -499,6 +500,12 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
||||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
|
||||||
|
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
|
||||||
|
remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luAct
|
||||||
|
remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
|
||||||
|
MaybeT $ getBy $ UniqueInboxItemRemote inboxID remoteActivityID
|
||||||
|
|
||||||
loomOfferTicketF
|
loomOfferTicketF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> KeyHashid Loom
|
-> KeyHashid Loom
|
||||||
|
@ -577,13 +584,11 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
||||||
|
|
||||||
-- Has the loom already received this activity to its inbox? If yes, we
|
-- Has the loom already received this activity to its inbox? If yes, we
|
||||||
-- won't process it again
|
-- won't process it again
|
||||||
maybeAlreadyInInbox <- runMaybeT $ do
|
alreadyInInbox <- do
|
||||||
instanceID <- MaybeT $ getKeyBy $ UniqueInstance $ objUriAuthority $ remoteAuthorURI author
|
let hOffer = objUriAuthority $ remoteAuthorURI author
|
||||||
remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luOffer
|
activityAlreadyInInbox hOffer luOffer (actorInbox actor)
|
||||||
remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
|
|
||||||
MaybeT $ getBy $ UniqueInboxItemRemote (actorInbox actor) remoteActivityID
|
|
||||||
|
|
||||||
return (recipLoomRepoID, recipLoomActor, isJust maybeAlreadyInInbox)
|
return (recipLoomRepoID, recipLoomActor, alreadyInInbox)
|
||||||
|
|
||||||
if alreadyInInbox
|
if alreadyInInbox
|
||||||
then return ("I already have this activity in my inbox, ignoring", Nothing)
|
then return ("I already have this activity in my inbox, ignoring", Nothing)
|
||||||
|
@ -1169,564 +1174,204 @@ repoAddBundleF now recipHash author body mfwd luAdd patches uTarget = do
|
||||||
shrRecip rpRecip (hashLTID ltid)
|
shrRecip rpRecip (hashLTID ltid)
|
||||||
-}
|
-}
|
||||||
|
|
||||||
repoApplyF
|
loomApplyF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> KeyHashid Repo
|
-> KeyHashid Loom
|
||||||
-> RemoteAuthor
|
-> RemoteAuthor
|
||||||
-> ActivityBody
|
-> ActivityBody
|
||||||
-> Maybe (RecipientRoutes, ByteString)
|
-> Maybe (RecipientRoutes, ByteString)
|
||||||
-> LocalURI
|
-> LocalURI
|
||||||
-> FedURI
|
-> AP.Apply URIMode
|
||||||
-> FedURI
|
|
||||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||||
repoApplyF now recipHash author body mfwd luApply uObject uTarget = do
|
loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
||||||
error "repoApplyF temporarily disabled"
|
|
||||||
|
|
||||||
|
-- Check input
|
||||||
{-
|
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||||
|
(repoID, maybeBranch, clothID, bundleID) <- do
|
||||||
|
maybeLocalTarget <- checkApplyLocalLoom apply
|
||||||
-- Verify the patch bundle URI is one of:
|
(repoID, maybeBranch, loomID, clothID, bundleID) <-
|
||||||
-- * A local sharer-hosted bundle
|
fromMaybeE
|
||||||
-- * A local repo-hosted bundle under the receiving repo
|
maybeLocalTarget
|
||||||
-- * A remote URI
|
"Bundle doesn't belong to a local loom, in particular not to \
|
||||||
bundle <- do
|
\me, so I won't apply it. Was I supposed to receive it?"
|
||||||
b <- parseProposalBundle "repoApplyF Apply object, a URI" uObject
|
unless (loomID == recipLoomID) $
|
||||||
case b of
|
throwE
|
||||||
Left (Right (shr, rp, ltid, bnid)) ->
|
"Bundle belongs to some other local loom, so I won't apply \
|
||||||
if shr == shrRecip && rp == rpRecip
|
\it. Was I supposed to receive it?"
|
||||||
then return $ Left $ Right (ltid, bnid)
|
return (repoID, maybeBranch, clothID, bundleID)
|
||||||
else throwE "Bundle is some other local repo's repo-hosted bundle"
|
|
||||||
Left (Left x) -> return $ Left $ Left x
|
|
||||||
Right u -> return $ Right u
|
|
||||||
|
|
||||||
-- Verify the apply's target is one of:
|
|
||||||
-- * The URI of the receiving repo
|
|
||||||
-- * A local branch URI under the receiving repo
|
|
||||||
-- * A remote URI
|
|
||||||
mbranch <- do
|
|
||||||
target <- checkBranch' uTarget
|
|
||||||
case target of
|
|
||||||
Left (shr, rp, mb) | shr == shrRecip && rp == rpRecip -> return mb
|
|
||||||
_ -> throwE "Apply target isn't me, so, ignoring this activity"
|
|
||||||
|
|
||||||
-- Verify the capability URI is one of:
|
-- Verify the capability URI is one of:
|
||||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||||
-- * A remote URI
|
-- * A remote URI
|
||||||
capID <- do
|
uCap <- do
|
||||||
let muCap = activityCapability $ actbActivity body
|
let muCap = activityCapability $ actbActivity body
|
||||||
uCap <- fromMaybeE muCap "Asking to apply patch but no capability provided"
|
fromMaybeE muCap "Asking to apply patch but no capability provided"
|
||||||
parseActivityURI "Apply capability" uCap
|
capID <- nameExceptT "Apply capability" $ parseActivityURI uCap
|
||||||
|
|
||||||
-- Make sure receiving repo exists in DB, otherwise its inbox doesn't exist
|
maybeNewApply <- runDBExcept $ do
|
||||||
-- either thus we return 404
|
|
||||||
Entity ridRecip repoRecip <- lift $ runDB $ do
|
|
||||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
|
||||||
getBy404 $ UniqueRepo rpRecip sid
|
|
||||||
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
|
|
||||||
|
|
||||||
-- Check in DB whether the provided capability matches a DB
|
-- Find recipient loom in DB, returning 404 if doesn't exist because
|
||||||
-- record we have, and that it includes permission to apply MRs
|
-- we're in the loom's inbox post handler
|
||||||
runSiteDBExcept $ do
|
recipLoom <- lift $ get404 recipLoomID
|
||||||
-- Find the activity itself by URI in the DB
|
let recipLoomActorID = loomActor recipLoom
|
||||||
act <- do
|
recipLoomActor <- lift $ getJust recipLoomActorID
|
||||||
mact <- getActivity capID
|
|
||||||
fromMaybeE mact "Capability activity not known to me"
|
|
||||||
-- Find the Collab record for that activity
|
|
||||||
cid <-
|
|
||||||
case act of
|
|
||||||
Left (_actor, obiid) -> do
|
|
||||||
mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
|
|
||||||
collabSenderLocalCollab <$>
|
|
||||||
fromMaybeE mcsl "Capability is a local activity but no matching capability"
|
|
||||||
Right ractid -> do
|
|
||||||
mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
|
|
||||||
collabSenderRemoteCollab <$>
|
|
||||||
fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
|
|
||||||
-- Find the recipient of that Collab
|
|
||||||
raidCollab <- do
|
|
||||||
mcrr <- lift $ getValBy $ UniqueCollabRecipRemote cid
|
|
||||||
crr <- fromMaybeE mcrr "No remote recip for capability"
|
|
||||||
mcrl <- lift $ getBy $ UniqueCollabRecipLocal cid
|
|
||||||
verifyNothingE mcrl "Both local & remote recip for capability!"
|
|
||||||
return $ collabRecipRemoteActor crr
|
|
||||||
-- Verify the recipient is the author of the Apply activity
|
|
||||||
unless (raidCollab == remoteAuthorId author) $
|
|
||||||
throwE "Collab recipient isn't the Apply author"
|
|
||||||
-- Find the repo to which this Collab gives access
|
|
||||||
ridCap <- do
|
|
||||||
mctlr <- lift $ getValBy $ UniqueCollabTopicLocalRepo cid
|
|
||||||
rid <-
|
|
||||||
collabTopicLocalRepoRepo <$>
|
|
||||||
fromMaybeE mctlr "Collab isn't for a repo"
|
|
||||||
mctlj <- lift $ getBy $ UniqueCollabTopicLocalProject cid
|
|
||||||
verifyNothingE mctlj "Collab topic duplicate, found project"
|
|
||||||
mctr <- lift $ getBy $ UniqueCollabTopicRemote cid
|
|
||||||
verifyNothingE mctr "Collab topic duplicate, found remote"
|
|
||||||
return rid
|
|
||||||
-- Verify that repo is us
|
|
||||||
unless (ridCap == ridRecip) $
|
|
||||||
throwE "Capability topic is some other local repo"
|
|
||||||
-- Find the collaborator's role in the repo
|
|
||||||
mrlid <-
|
|
||||||
lift $ fmap collabRoleLocalRole <$>
|
|
||||||
getValBy (UniqueCollabRoleLocal cid)
|
|
||||||
-- If no role specified, that means Developer role with
|
|
||||||
-- access to apply changes to repo source code, otherwise
|
|
||||||
-- make sure the specified role (or an ancestor of it) has
|
|
||||||
-- access to the relevant operation
|
|
||||||
for_ mrlid $ \ rlid -> do
|
|
||||||
let roleHas role op = getBy $ UniqueRoleAccess role op
|
|
||||||
ancestorHas = flip getProjectRoleAncestorWithOpQ
|
|
||||||
roleHasAccess role op =
|
|
||||||
fmap isJust . runMaybeT $
|
|
||||||
MaybeT (roleHas role op) <|>
|
|
||||||
MaybeT (ancestorHas role op)
|
|
||||||
has <- lift $ roleHasAccess rlid ProjOpApplyPatch
|
|
||||||
unless has $
|
|
||||||
throwE
|
|
||||||
"Apply author's role in repo doesn't have \
|
|
||||||
\ApplyPatch access"
|
|
||||||
|
|
||||||
-- We verified apply permission, now let's examine the bundle itself
|
-- Has the loom already received this activity to its inbox? If yes, we
|
||||||
case bundle of
|
-- won't process it again
|
||||||
Left (Left (shr, talid, bnid)) -> do
|
alreadyInInbox <- lift $ do
|
||||||
-- Verify we have this ticket and bundle in the DB
|
let hOffer = objUriAuthority $ remoteAuthorURI author
|
||||||
-- Verify the ticket is listed under the repo
|
activityAlreadyInInbox hOffer luApply (actorInbox recipLoomActor)
|
||||||
-- Verify the bundle is the latest version
|
|
||||||
mticket <- lift $ runSiteDB $ getSharerProposal shr talid
|
|
||||||
(_, Entity ltid _, _, context, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket"
|
|
||||||
case context of
|
|
||||||
Left (_, Entity _ trl) ->
|
|
||||||
unless (ticketRepoLocalRepo trl == ridRecip) $
|
|
||||||
throwE "Apply object: Ticket under some other local repo"
|
|
||||||
Right _ -> throwE "Apply object: Ticket not under a local repo"
|
|
||||||
_ <- fromMaybeE mresolved "Apply object: Proposal already applied"
|
|
||||||
unless (bnid == bnid') $
|
|
||||||
throwE "Apply object: Bundle isn't the latest version"
|
|
||||||
|
|
||||||
-- Grab the bundle's patches from DB and apply them
|
-- Find the repo and the bundle in our DB, and verify that the loom is
|
||||||
patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
|
-- willing to accept the request from sender to apply this specific
|
||||||
case repoVcs repoRecip of
|
-- bundle to this repo/branch
|
||||||
VCSGit -> do
|
if alreadyInInbox
|
||||||
branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
|
then pure Nothing
|
||||||
patches' <-
|
else Just <$> do
|
||||||
case NE.nonEmpty patches of
|
(_, ticketID, diffs) <-
|
||||||
Nothing -> error "No patches found in DB"
|
checkApplyDB
|
||||||
Just ps -> return ps
|
(Right $ remoteAuthorId author) capID
|
||||||
let essence (Patch _ _ typ t) = (typ, t)
|
(repoID, maybeBranch) (recipLoomID, clothID, bundleID)
|
||||||
patches'' = NE.map (essence . entityVal) patches'
|
return (Entity recipLoomActorID recipLoomActor, ticketID, diffs)
|
||||||
unless (all ((== PatchMediaTypeGit) . fst) patches'') $
|
|
||||||
throwE "Trying to apply non-Git patch to a Git repo"
|
|
||||||
applyGitPatches shrRecip rpRecip branch $ NE.map snd patches''
|
|
||||||
VCSDarcs -> do
|
|
||||||
verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
|
|
||||||
patch <-
|
|
||||||
case patches of
|
|
||||||
[] -> error "Local repo-bundle without any patches found"
|
|
||||||
_ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
|
|
||||||
(Entity _ (Patch _ _ typ t)) : [] ->
|
|
||||||
case typ of
|
|
||||||
PatchMediaTypeDarcs -> return t
|
|
||||||
_ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
|
|
||||||
applyDarcsPatch shrRecip rpRecip patch
|
|
||||||
|
|
||||||
-- Insert Apply activity to repo's inbox
|
case maybeNewApply of
|
||||||
-- Produce an Accept activity and deliver locally
|
Nothing ->
|
||||||
-- Mark the ticket as resolved
|
return "I already have this activity in my inbox, doing nothing"
|
||||||
mhttp <- lift $ runSiteDB $ do
|
Just (Entity recipLoomActorID recipLoomActor, ticketID, diffs) -> do
|
||||||
mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False
|
|
||||||
for mractid $ \ ractid -> do
|
|
||||||
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
|
||||||
talkhid <- encodeKeyHashid talid
|
|
||||||
let sieve =
|
|
||||||
makeRecipientSet
|
|
||||||
[]
|
|
||||||
[ LocalPersonCollectionSharerProposalFollowers shrRecip talkhid
|
|
||||||
, LocalPersonCollectionRepoTeam shrRecip rpRecip
|
|
||||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
|
||||||
]
|
|
||||||
remoteRecips <-
|
|
||||||
insertRemoteActivityToLocalInboxes
|
|
||||||
False ractid $
|
|
||||||
localRecipSieve'
|
|
||||||
sieve False False localRecips
|
|
||||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
|
|
||||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
|
|
||||||
|
|
||||||
_ <- insertResolve author ltid ractid obiidAccept
|
-- Apply patches
|
||||||
|
applyPatches repoID maybeBranch diffs
|
||||||
|
|
||||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
maybeHttp <- lift $ runDB $ do
|
||||||
insertAcceptLocalSharer luApply shr talid obiidAccept
|
|
||||||
|
|
||||||
knownRemoteRecipsAccept <-
|
-- Insert the Apply to loom's inbox
|
||||||
deliverLocal'
|
mractid <- insertToInbox now author body (actorInbox recipLoomActor) luApply False
|
||||||
False
|
for mractid $ \ applyID -> do
|
||||||
(LocalActorRepo shrRecip rpRecip)
|
|
||||||
(repoInbox repoRecip)
|
|
||||||
obiidAccept
|
|
||||||
localRecipsAccept
|
|
||||||
(mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept,) <$>
|
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
|
||||||
|
|
||||||
-- Run inbox-forwarding on the Apply activity
|
-- Forward the Apply activity to relevant local stages, and
|
||||||
-- Deliver Accept activity to remote recipients via HTTP
|
-- schedule delivery for unavailable remote members of them
|
||||||
case mhttp of
|
maybeHttpFwdApply <- for mfwd $ \ (localRecips, sig) -> do
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
clothHash <- encodeKeyHashid clothID
|
||||||
Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
|
let sieve =
|
||||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
makeRecipientSet
|
||||||
forkWorker "repoApplyF inbox-forwarding" $
|
[]
|
||||||
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
|
[ LocalStageLoomFollowers recipLoomHash
|
||||||
forkWorker "repoApplyF Accept HTTP delivery" $
|
, LocalStageClothFollowers recipLoomHash clothHash
|
||||||
deliverRemoteHttp' fwdHosts obiid doc recips
|
]
|
||||||
|
remoteRecips <-
|
||||||
|
insertRemoteActivityToLocalInboxes False applyID $
|
||||||
|
localRecipSieve' sieve False False localRecips
|
||||||
|
remoteRecipsHttp <-
|
||||||
|
deliverRemoteDB_L
|
||||||
|
(actbBL body) applyID recipLoomID sig remoteRecips
|
||||||
return $
|
return $
|
||||||
if isJust mremotesHttpFwd
|
deliverRemoteHTTP_L
|
||||||
then "Applied patches, did inbox-forwarding"
|
now recipLoomHash (actbBL body) sig remoteRecipsHttp
|
||||||
else "Applied patches, no inbox-forwarding to do"
|
|
||||||
|
|
||||||
Left (Right (ltid, bnid)) -> do
|
-- Mark ticket in DB as resolved by the Apply
|
||||||
-- Verify we have this ticket and bundle in the DB, and that
|
acceptID <-
|
||||||
-- the bundle is the latest version
|
insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||||
mticket <- lift $ runSiteDB $ getRepoProposal shrRecip rpRecip ltid
|
insertResolve ticketID applyID acceptID
|
||||||
(_, _, _, _, _, _, _, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket"
|
|
||||||
_ <- fromMaybeE mresolved "Apply object: Proposal already applied"
|
|
||||||
unless (bnid == bnid') $
|
|
||||||
throwE "Apply object: Bundle isn't the latest version"
|
|
||||||
|
|
||||||
-- Grab the bundle's patches from DB and apply them
|
-- Prepare an Accept activity and insert to loom's outbox
|
||||||
patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
|
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||||
case repoVcs repoRecip of
|
insertAcceptToOutbox uCap clothID acceptID
|
||||||
VCSGit -> do
|
|
||||||
branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
|
|
||||||
patches' <-
|
|
||||||
case NE.nonEmpty patches of
|
|
||||||
Nothing -> error "No patches found in DB"
|
|
||||||
Just ps -> return ps
|
|
||||||
let essence (Patch _ _ typ t) = (typ, t)
|
|
||||||
patches'' = NE.map (essence . entityVal) patches'
|
|
||||||
unless (all ((== PatchMediaTypeGit) . fst) patches'') $
|
|
||||||
throwE "Trying to apply non-Git patch to a Git repo"
|
|
||||||
applyGitPatches shrRecip rpRecip branch $ NE.map snd patches''
|
|
||||||
VCSDarcs -> do
|
|
||||||
verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
|
|
||||||
patch <-
|
|
||||||
case patches of
|
|
||||||
[] -> error "Local repo-bundle without any patches found"
|
|
||||||
_ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
|
|
||||||
(Entity _ (Patch _ _ typ t)) : [] ->
|
|
||||||
case typ of
|
|
||||||
PatchMediaTypeDarcs -> return t
|
|
||||||
_ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
|
|
||||||
applyDarcsPatch shrRecip rpRecip patch
|
|
||||||
|
|
||||||
-- Insert Apply activity to repo's inbox
|
-- Deliver the Accept to local recipients, and schedule delivery
|
||||||
-- Produce an Accept activity and deliver locally
|
-- for unavailable remote recipients
|
||||||
-- Mark the ticket as resolved
|
knownRemoteRecipsAccept <-
|
||||||
mhttp <- lift $ runSiteDB $ do
|
deliverLocal'
|
||||||
mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False
|
False (LocalActorLoom recipLoomHash) recipLoomActorID
|
||||||
for mractid $ \ ractid -> do
|
acceptID localRecipsAccept
|
||||||
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
remoteRecipsHttpAccept <-
|
||||||
ltkhid <- encodeKeyHashid ltid
|
deliverRemoteDB''
|
||||||
let sieve =
|
fwdHostsAccept acceptID remoteRecipsAccept
|
||||||
makeRecipientSet
|
knownRemoteRecipsAccept
|
||||||
[]
|
|
||||||
[ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
|
|
||||||
, LocalPersonCollectionRepoTeam shrRecip rpRecip
|
|
||||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
|
||||||
]
|
|
||||||
remoteRecips <-
|
|
||||||
insertRemoteActivityToLocalInboxes
|
|
||||||
False ractid $
|
|
||||||
localRecipSieve'
|
|
||||||
sieve False False localRecips
|
|
||||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
|
|
||||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
|
|
||||||
|
|
||||||
_ <- insertResolve author ltid ractid obiidAccept
|
-- Return instructions for HTTP inbox-forwarding of the Apply
|
||||||
|
-- activity, and for HTTP delivery of the Accept activity to
|
||||||
|
-- remote recipients
|
||||||
|
return
|
||||||
|
( maybeHttpFwdApply
|
||||||
|
, deliverRemoteHttp'
|
||||||
|
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
||||||
|
)
|
||||||
|
|
||||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
-- Launch asynchronous HTTP forwarding of the Apply activity and HTTP
|
||||||
insertAcceptLocalRepo luApply ltid obiidAccept
|
-- delivery of the Accept activity
|
||||||
|
case maybeHttp of
|
||||||
knownRemoteRecipsAccept <-
|
Nothing ->
|
||||||
deliverLocal'
|
return
|
||||||
False
|
"When I started serving this activity, I didn't have it in my inbox, \
|
||||||
(LocalActorRepo shrRecip rpRecip)
|
\but now suddenly it seems I already do, so ignoring"
|
||||||
(repoInbox repoRecip)
|
Just (maybeHttpFwdApply, deliverHttpAccept) -> do
|
||||||
obiidAccept
|
forkWorker "loomApplyF Accept HTTP delivery" deliverHttpAccept
|
||||||
localRecipsAccept
|
case maybeHttpFwdApply of
|
||||||
(mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept,) <$>
|
Nothing -> return "Applied the patch(es), no inbox-forwarding to do"
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
Just forwardHttpApply -> do
|
||||||
|
forkWorker "loomApplyF inbox-forwarding" forwardHttpApply
|
||||||
-- Run inbox-forwarding on the Apply activity
|
return "Applied the patch(es) and ran inbox-forwarding of the Apply"
|
||||||
-- Deliver Accept activity to remote recipients via HTTP
|
|
||||||
case mhttp of
|
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
|
||||||
Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
|
|
||||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
|
||||||
forkWorker "repoApplyF inbox-forwarding" $
|
|
||||||
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
|
|
||||||
forkWorker "repoApplyF Accept HTTP delivery" $
|
|
||||||
deliverRemoteHttp' fwdHosts obiid doc recips
|
|
||||||
return $
|
|
||||||
if isJust mremotesHttpFwd
|
|
||||||
then "Applied patches, did inbox-forwarding"
|
|
||||||
else "Applied patches, no inbox-forwarding to do"
|
|
||||||
|
|
||||||
Right uBundle@(ObjURI hBundle luBundle) -> do
|
|
||||||
|
|
||||||
-- Verify it's a latest-version bundle pointed by a ticket we
|
|
||||||
-- have listed under the receiving repo
|
|
||||||
manager <- asksSite appHttpManager
|
|
||||||
Doc h b <- withExceptT T.pack $ AP.fetchAP manager $ Left uBundle
|
|
||||||
(BundleLocal bid ctx _prevs mcurr, lus) <-
|
|
||||||
case b of
|
|
||||||
BundleHosted Nothing _ -> throwE "No bundle @id"
|
|
||||||
BundleHosted (Just l) ps -> return (l, ps)
|
|
||||||
BundleOffer _ _ -> throwE "Why does bundle contain patch objects"
|
|
||||||
unless (h == hBundle && bid == luBundle) $
|
|
||||||
throwE "Bundle 'id' differs from the URI we fetched"
|
|
||||||
for_ mcurr $ \ curr ->
|
|
||||||
throwE $
|
|
||||||
if curr == bid
|
|
||||||
then "Bundle currentVersion points to itself"
|
|
||||||
else "Bundle isn't the latest version"
|
|
||||||
let uTicket = ObjURI h ctx
|
|
||||||
Doc _ ticket <- withExceptT T.pack $ AP.fetchAP manager $ Left uTicket
|
|
||||||
(_, tlocal) <- fromMaybeE (AP.ticketLocal ticket) "Ticket has no @id"
|
|
||||||
(h', mr) <- fromMaybeE (AP.ticketAttachment ticket) "Ticket has no 'attachment'"
|
|
||||||
unless (ObjURI h' (mrTarget mr) == uTarget) $
|
|
||||||
throwE "Ticket MR target isn't me / branch"
|
|
||||||
case mrBundle mr of
|
|
||||||
Left u ->
|
|
||||||
if u == uBundle
|
|
||||||
then pure ()
|
|
||||||
else throwE "Bundle isn't the one pointed by ticket"
|
|
||||||
Right _ -> throwE "Ticket has bundle object instead of just URI"
|
|
||||||
e <- runSiteDBExcept $ getRemoteTicketByURI uTicket
|
|
||||||
case e of
|
|
||||||
Right (_, _, _, _, _, Right (Entity _ trl))
|
|
||||||
| ticketRepoLocalRepo trl == ridRecip -> pure ()
|
|
||||||
_ -> throwE "I don't have the ticket listed under me"
|
|
||||||
|
|
||||||
-- HTTP GET all the patches, examine and apply them
|
|
||||||
patches <- for lus $ \ luPatch -> do
|
|
||||||
Doc _ (AP.Patch mlocal _luAttrib _mpub typ content) <-
|
|
||||||
withExceptT T.pack $ AP.fetchAP manager $ Left $ ObjURI hBundle luPatch
|
|
||||||
(h, PatchLocal luP luC) <- fromMaybeE mlocal "No patch @id"
|
|
||||||
unless (ObjURI h luP == ObjURI hBundle luPatch) $
|
|
||||||
throwE "Patch @id doesn't match the URI we fetched"
|
|
||||||
unless (luC == luBundle) $
|
|
||||||
throwE "Patch doesn't point back to the bundle"
|
|
||||||
unless (patchMediaTypeVCS typ == repoVcs repoRecip) $
|
|
||||||
throwE "Patch type and repo VCS mismatch"
|
|
||||||
return (typ, content)
|
|
||||||
case repoVcs repoRecip of
|
|
||||||
VCSGit -> do
|
|
||||||
branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
|
|
||||||
unless (all ((== PatchMediaTypeGit) . fst) patches) $
|
|
||||||
throwE "Trying to apply non-Git patch to a Git repo"
|
|
||||||
applyGitPatches shrRecip rpRecip branch $ NE.map snd patches
|
|
||||||
VCSDarcs -> do
|
|
||||||
verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
|
|
||||||
patch <-
|
|
||||||
case patches of
|
|
||||||
_ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
|
|
||||||
(typ, t) :| [] ->
|
|
||||||
case typ of
|
|
||||||
PatchMediaTypeDarcs -> return t
|
|
||||||
_ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
|
|
||||||
applyDarcsPatch shrRecip rpRecip patch
|
|
||||||
|
|
||||||
-- Insert Apply activity to repo's inbox
|
|
||||||
-- Produce an Accept activity and deliver locally
|
|
||||||
mhttp <- lift $ runSiteDB $ do
|
|
||||||
mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False
|
|
||||||
for mractid $ \ ractid -> do
|
|
||||||
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
|
||||||
let sieve =
|
|
||||||
makeRecipientSet
|
|
||||||
[]
|
|
||||||
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
|
|
||||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
|
||||||
]
|
|
||||||
remoteRecips <-
|
|
||||||
insertRemoteActivityToLocalInboxes
|
|
||||||
False ractid $
|
|
||||||
localRecipSieve'
|
|
||||||
sieve False False localRecips
|
|
||||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
|
|
||||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
|
|
||||||
|
|
||||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
|
||||||
insertAcceptRemote luApply hBundle tlocal obiidAccept
|
|
||||||
|
|
||||||
knownRemoteRecipsAccept <-
|
|
||||||
deliverLocal'
|
|
||||||
False
|
|
||||||
(LocalActorRepo shrRecip rpRecip)
|
|
||||||
(repoInbox repoRecip)
|
|
||||||
obiidAccept
|
|
||||||
localRecipsAccept
|
|
||||||
(mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept,) <$>
|
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
|
||||||
|
|
||||||
-- Run inbox-forwarding on the Apply activity
|
|
||||||
-- Deliver Accept activity to remote recipients via HTTP
|
|
||||||
case mhttp of
|
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
|
||||||
Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
|
|
||||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
|
||||||
forkWorker "repoApplyF inbox-forwarding" $
|
|
||||||
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
|
|
||||||
forkWorker "repoApplyF Accept HTTP delivery" $
|
|
||||||
deliverRemoteHttp' fwdHosts obiid doc recips
|
|
||||||
return $
|
|
||||||
if isJust mremotesHttpFwd
|
|
||||||
then "Applied patches, did inbox-forwarding"
|
|
||||||
else "Applied patches, no inbox-forwarding to do"
|
|
||||||
|
|
||||||
{-
|
|
||||||
TODO to be clear: When a repo receives a Ticket, does it store the whole
|
|
||||||
ticket and bundle and patches in DB?
|
|
||||||
ANSWER: Yes, it does
|
|
||||||
|
|
||||||
And when a repo is notified on a new bundle version for such a
|
|
||||||
remotely hosted Ticket, does it store this new bundle and its patches
|
|
||||||
in the local DB?
|
|
||||||
ANSWER: No, it stores only for a repo-hosted own Ticket
|
|
||||||
|
|
||||||
TODO if I'm the target, am I a darcs repo?
|
|
||||||
|
|
||||||
TODO if a branch of mine is the target, am I a git repo?
|
|
||||||
-}
|
|
||||||
|
|
||||||
where
|
where
|
||||||
insertAcceptRemote luApply hTicket tlocal obiidAccept = do
|
|
||||||
|
insertResolve ticketID applyID acceptID = do
|
||||||
|
trid <- insert TicketResolve
|
||||||
|
{ ticketResolveTicket = ticketID
|
||||||
|
, ticketResolveAccept = acceptID
|
||||||
|
}
|
||||||
|
insert_ TicketResolveRemote
|
||||||
|
{ ticketResolveRemoteTicket = trid
|
||||||
|
, ticketResolveRemoteActivity = applyID
|
||||||
|
, ticketResolveRemoteActor = remoteAuthorId author
|
||||||
|
}
|
||||||
|
update ticketID [TicketStatus =. TSClosed]
|
||||||
|
|
||||||
|
insertAcceptToOutbox uCap clothID acceptID = do
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
hLocal <- asksSite siteInstanceHost
|
hLocal <- asksSite siteInstanceHost
|
||||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
|
||||||
|
clothHash <- encodeKeyHashid clothID
|
||||||
|
acceptHash <- encodeKeyHashid acceptID
|
||||||
|
|
||||||
ra <- getJust $ remoteAuthorId author
|
ra <- getJust $ remoteAuthorId author
|
||||||
|
|
||||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||||
|
|
||||||
audAuthor =
|
audSender =
|
||||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
AudRemote hAuthor
|
||||||
|
[luAuthor]
|
||||||
audTicket =
|
(maybeToList $ remoteActorFollowers ra)
|
||||||
AudRemote hTicket [] [AP.ticketParticipants tlocal]
|
audTracker =
|
||||||
|
|
||||||
audRepo =
|
|
||||||
AudLocal
|
AudLocal
|
||||||
[]
|
[]
|
||||||
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
|
[ LocalStageLoomFollowers recipLoomHash
|
||||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
, LocalStageClothFollowers recipLoomHash clothHash
|
||||||
]
|
]
|
||||||
|
|
||||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
collectAudience [audAuthor, audTicket, audRepo]
|
collectAudience [audSender, audTracker]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
doc = Doc hLocal Activity
|
doc = AP.Doc hLocal AP.Activity
|
||||||
{ activityId =
|
{ AP.activityId =
|
||||||
Just $ encodeRouteLocal $
|
Just $ encodeRouteLocal $
|
||||||
RepoOutboxItemR shrRecip rpRecip obikhidAccept
|
LoomOutboxItemR recipLoomHash acceptHash
|
||||||
, activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip
|
, AP.activityActor =
|
||||||
, activityCapability = Nothing
|
encodeRouteLocal $ LoomR recipLoomHash
|
||||||
, activitySummary = Nothing
|
, AP.activityCapability = Just uCap
|
||||||
, activityAudience = Audience recips [] [] [] [] []
|
, AP.activitySummary = Nothing
|
||||||
, activitySpecific = AcceptActivity Accept
|
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.activityFulfills = []
|
||||||
|
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
||||||
{ acceptObject = ObjURI hAuthor luApply
|
{ acceptObject = ObjURI hAuthor luApply
|
||||||
, acceptResult = Nothing
|
, acceptResult = Nothing
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
|
||||||
|
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
insertAcceptLocalRepo luApply ltid obiidAccept = do
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
hLocal <- asksSite siteInstanceHost
|
|
||||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
|
||||||
ltkhid <- encodeKeyHashid ltid
|
|
||||||
ra <- getJust $ remoteAuthorId author
|
|
||||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
|
||||||
|
|
||||||
audAuthor =
|
|
||||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
|
||||||
|
|
||||||
audTicket =
|
|
||||||
AudLocal [] [LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid]
|
|
||||||
|
|
||||||
audRepo =
|
|
||||||
AudLocal
|
|
||||||
[]
|
|
||||||
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
|
|
||||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
|
||||||
]
|
|
||||||
|
|
||||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
|
||||||
collectAudience [audAuthor, audTicket, audRepo]
|
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
doc = Doc hLocal Activity
|
|
||||||
{ activityId =
|
|
||||||
Just $ encodeRouteLocal $
|
|
||||||
RepoOutboxItemR shrRecip rpRecip obikhidAccept
|
|
||||||
, activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip
|
|
||||||
, activityCapability = Nothing
|
|
||||||
, activitySummary = Nothing
|
|
||||||
, activityAudience = Audience recips [] [] [] [] []
|
|
||||||
, activitySpecific = AcceptActivity Accept
|
|
||||||
{ acceptObject = ObjURI hAuthor luApply
|
|
||||||
, acceptResult = Nothing
|
|
||||||
}
|
|
||||||
}
|
|
||||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
insertAcceptLocalSharer luApply shr talid obiidAccept = do
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
hLocal <- asksSite siteInstanceHost
|
|
||||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
|
||||||
talkhid <- encodeKeyHashid talid
|
|
||||||
ra <- getJust $ remoteAuthorId author
|
|
||||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
|
||||||
|
|
||||||
audAuthor =
|
|
||||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
|
||||||
|
|
||||||
audTicket =
|
|
||||||
AudLocal [] [LocalPersonCollectionSharerProposalFollowers shr talkhid]
|
|
||||||
|
|
||||||
audRepo =
|
|
||||||
AudLocal
|
|
||||||
[]
|
|
||||||
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
|
|
||||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
|
||||||
]
|
|
||||||
|
|
||||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
|
||||||
collectAudience [audAuthor, audTicket, audRepo]
|
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
doc = Doc hLocal Activity
|
|
||||||
{ activityId =
|
|
||||||
Just $ encodeRouteLocal $
|
|
||||||
RepoOutboxItemR shrRecip rpRecip obikhidAccept
|
|
||||||
, activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip
|
|
||||||
, activityCapability = Nothing
|
|
||||||
, activitySummary = Nothing
|
|
||||||
, activityAudience = Audience recips [] [] [] [] []
|
|
||||||
, activitySpecific = AcceptActivity Accept
|
|
||||||
{ acceptObject = ObjURI hAuthor luApply
|
|
||||||
, acceptResult = Nothing
|
|
||||||
}
|
|
||||||
}
|
|
||||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
|
||||||
-}
|
|
||||||
|
|
||||||
personOfferDepF
|
personOfferDepF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> KeyHashid Person
|
-> KeyHashid Person
|
||||||
|
|
|
@ -142,6 +142,8 @@ postLoomInboxR recipLoomHash =
|
||||||
case specific of
|
case specific of
|
||||||
AP.AcceptActivity accept ->
|
AP.AcceptActivity accept ->
|
||||||
loomAcceptF now recipLoomHash author body mfwd luActivity accept
|
loomAcceptF now recipLoomHash author body mfwd luActivity accept
|
||||||
|
AP.ApplyActivity apply->
|
||||||
|
loomApplyF now recipLoomHash author body mfwd luActivity apply
|
||||||
AP.InviteActivity invite ->
|
AP.InviteActivity invite ->
|
||||||
topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
|
topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
|
||||||
AP.OfferActivity (AP.Offer obj target) ->
|
AP.OfferActivity (AP.Offer obj target) ->
|
||||||
|
|
144
src/Vervis/Persist/Ticket.hs
Normal file
144
src/Vervis/Persist/Ticket.hs
Normal file
|
@ -0,0 +1,144 @@
|
||||||
|
{- This file is part of Vervis.
|
||||||
|
-
|
||||||
|
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||||
|
-
|
||||||
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
|
-
|
||||||
|
- The author(s) have dedicated all copyright and related and neighboring
|
||||||
|
- rights to this software to the public domain worldwide. This software is
|
||||||
|
- distributed without any warranty.
|
||||||
|
-
|
||||||
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||||
|
- with this software. If not, see
|
||||||
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
-}
|
||||||
|
|
||||||
|
module Vervis.Persist.Ticket
|
||||||
|
( checkApplyDB
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Trans.Class
|
||||||
|
import Control.Monad.Trans.Except
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.These
|
||||||
|
import Database.Persist
|
||||||
|
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
|
||||||
|
import Development.PatchMediaType
|
||||||
|
import Yesod.Hashids
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Except.Local
|
||||||
|
import Database.Persist.Local
|
||||||
|
|
||||||
|
import Vervis.Access
|
||||||
|
import Vervis.Cloth
|
||||||
|
import Vervis.FedURI
|
||||||
|
import Vervis.Foundation
|
||||||
|
import Vervis.Model
|
||||||
|
import Vervis.Recipient
|
||||||
|
|
||||||
|
-- | Given:
|
||||||
|
--
|
||||||
|
-- * A local tip (i.e. a repository or a branch), parsed from a URI
|
||||||
|
-- * A local bundle to apply to it, parsed from a URI
|
||||||
|
-- * A local or remote actor requesting to apply the bundle to the tip, already
|
||||||
|
-- known to be in our DB
|
||||||
|
-- * An activity URI provided by that actor as a capability, parsed from URI
|
||||||
|
--
|
||||||
|
-- Find the tip and the bundle in our DB, and verify that the loom hosting the
|
||||||
|
-- bundle is willing to accept the request from that specific actor to apply
|
||||||
|
-- that bundle to that repo. More specifically:
|
||||||
|
--
|
||||||
|
-- * Verify the tip matches the MR target
|
||||||
|
-- * Verify that the loom and the repo are linked
|
||||||
|
-- * Verify that a branch is specified if repo is Git, isn't specified if Darcs
|
||||||
|
-- * Verify the MR isn't already resolved
|
||||||
|
-- * Verify bundle is the latest version of the MR
|
||||||
|
-- * Verify the requester actor is authorized to apply
|
||||||
|
-- * Verify that patch type matches repo VCS type
|
||||||
|
--
|
||||||
|
-- Returns:
|
||||||
|
--
|
||||||
|
-- * The loom (so it can send an Accept after applying)
|
||||||
|
-- * The MR's ticket ID (so it can be marked as resolved after applying)
|
||||||
|
-- * The actual patch diffs, in first-to-last order
|
||||||
|
checkApplyDB
|
||||||
|
:: Either PersonId RemoteActorId -- ^ Actor requesting to apply
|
||||||
|
-> (Either
|
||||||
|
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
|
||||||
|
FedURI
|
||||||
|
) -- ^ Capability specified by the actor
|
||||||
|
-> (RepoId, Maybe Text) -- ^ Repository (or branch) to apply to
|
||||||
|
-> (LoomId, TicketLoomId, BundleId) -- ^ Parsed bundle URI to apply
|
||||||
|
-> ExceptT Text AppDB (Loom, TicketId, NonEmpty Text)
|
||||||
|
checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
|
||||||
|
|
||||||
|
-- Find the bundle and its loom in DB
|
||||||
|
(loom, clothBranch, ticketID, maybeResolve, latest) <- do
|
||||||
|
maybeBundle <- lift $ runMaybeT $ do
|
||||||
|
(Entity _ loom, Entity _ cloth, Entity ticketID _, _author, resolve, proposal) <-
|
||||||
|
MaybeT $ getCloth loomID clothID
|
||||||
|
bundle <- MaybeT $ get bundleID
|
||||||
|
guard $ bundleTicket bundle == clothID
|
||||||
|
latest :| _prevs <-
|
||||||
|
case justHere proposal of
|
||||||
|
Nothing ->
|
||||||
|
error "Why didn't getCloth find any bundles"
|
||||||
|
Just bundles -> return bundles
|
||||||
|
return (loom, ticketLoomBranch cloth, ticketID, resolve, latest)
|
||||||
|
fromMaybeE maybeBundle "Apply object bundle not found in DB"
|
||||||
|
|
||||||
|
-- Verify the target repo/branch of the Apply is identical to the
|
||||||
|
-- target repo/branch of the MR
|
||||||
|
unless (maybeBranch == clothBranch) $
|
||||||
|
throwE "Apply target != MR target"
|
||||||
|
|
||||||
|
-- Find target repo in DB and verify it consents to being served by
|
||||||
|
-- the loom
|
||||||
|
unless (repoID == loomRepo loom) $
|
||||||
|
throwE "MR target repo isn't the one served by the Apply object bundle's loom"
|
||||||
|
repo <- getE repoID "Apply target: No such local repo in DB"
|
||||||
|
unless (repoLoom repo == Just loomID) $
|
||||||
|
throwE "Apply object bunde's loom doesn't have repo's consent to serve it"
|
||||||
|
|
||||||
|
-- Verify that VCS type matches the presence of a branch:
|
||||||
|
-- Branch specified for Git, isn't specified for Darcs
|
||||||
|
case (repoVcs repo, maybeBranch) of
|
||||||
|
(VCSDarcs, Nothing) -> pure ()
|
||||||
|
(VCSGit, Just _) -> pure ()
|
||||||
|
_ -> throwE "VCS type and branch presence mismatch"
|
||||||
|
|
||||||
|
-- Verify the MR isn't already resolved and the bundle is the
|
||||||
|
-- latest version
|
||||||
|
unless (isNothing maybeResolve) $
|
||||||
|
throwE "MR is already resolved"
|
||||||
|
unless (bundleID == latest) $
|
||||||
|
throwE "Bundle isn't the latest version"
|
||||||
|
|
||||||
|
-- Verify the sender is authorized by the loom to apply a patch
|
||||||
|
capability <-
|
||||||
|
case capID of
|
||||||
|
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||||
|
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
|
||||||
|
verifyCapability capability actor (GrantResourceLoom loomID)
|
||||||
|
|
||||||
|
-- Get the patches from DB, verify VCS match just in case
|
||||||
|
diffs <- do
|
||||||
|
ps <-
|
||||||
|
lift $ map entityVal <$>
|
||||||
|
selectList [PatchBundle ==. bundleID] [Asc PatchId]
|
||||||
|
let patchVCS = patchMediaTypeVCS . patchType
|
||||||
|
case NE.nonEmpty ps of
|
||||||
|
Nothing -> error "Bundle without patches"
|
||||||
|
Just ne ->
|
||||||
|
if all ((== repoVcs repo) . patchVCS) ne
|
||||||
|
then return $ NE.map patchContent ne
|
||||||
|
else throwE "Patch type mismatch with repo VCS type"
|
||||||
|
|
||||||
|
return (loom, ticketID, diffs)
|
|
@ -16,11 +16,13 @@
|
||||||
module Vervis.Web.Repo
|
module Vervis.Web.Repo
|
||||||
( serveCommit
|
( serveCommit
|
||||||
, generatePatches
|
, generatePatches
|
||||||
|
, applyPatches
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding
|
import Data.Text.Encoding
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
|
@ -47,6 +49,7 @@ import Data.Patch.Local hiding (Patch)
|
||||||
|
|
||||||
import qualified Data.Patch.Local as P
|
import qualified Data.Patch.Local as P
|
||||||
|
|
||||||
|
import Vervis.Darcs
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Git
|
import Vervis.Git
|
||||||
|
@ -138,3 +141,24 @@ generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $
|
||||||
lift $ runSiteDB $ do
|
lift $ runSiteDB $ do
|
||||||
bundleID <- insert $ Bundle clothID True
|
bundleID <- insert $ Bundle clothID True
|
||||||
insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
|
insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
|
||||||
|
|
||||||
|
applyPatches
|
||||||
|
:: (MonadSite m, SiteEnv m ~ App)
|
||||||
|
=> RepoId -> Maybe Text -> NonEmpty Text -> ExceptT Text m ()
|
||||||
|
applyPatches repoID maybeBranch diffs = do
|
||||||
|
repoPath <- do
|
||||||
|
repoHash <- encodeKeyHashid repoID
|
||||||
|
repoDir <- askRepoDir repoHash
|
||||||
|
liftIO $ makeAbsolute repoDir
|
||||||
|
case maybeBranch of
|
||||||
|
Just branch -> do
|
||||||
|
ExceptT $ liftIO $ runExceptT $
|
||||||
|
withSystemTempDirectory "vervis-applyPatches" $
|
||||||
|
applyGitPatches repoPath (T.unpack branch) diffs
|
||||||
|
Nothing -> do
|
||||||
|
patch <-
|
||||||
|
case diffs of
|
||||||
|
t :| [] -> return t
|
||||||
|
_ :| (_ : _) ->
|
||||||
|
throwE "Darcs repo given multiple patch bundles"
|
||||||
|
applyDarcsPatch repoPath patch
|
||||||
|
|
|
@ -210,6 +210,7 @@ library
|
||||||
|
|
||||||
Vervis.Persist.Actor
|
Vervis.Persist.Actor
|
||||||
Vervis.Persist.Collab
|
Vervis.Persist.Collab
|
||||||
|
Vervis.Persist.Ticket
|
||||||
|
|
||||||
Vervis.Query
|
Vervis.Query
|
||||||
Vervis.Readme
|
Vervis.Readme
|
||||||
|
|
Loading…
Reference in a new issue