S2S: Implement loomApplyF (remote person asking to apply bundle on local loom)
This commit is contained in:
fr33domlover
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.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Recipient
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
|
|
@ -597,24 +598,10 @@ applyC
|
|||
-> Audience URIMode
|
||||
-> Apply URIMode
|
||||
-> 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
|
||||
maybeLocalTarget <- do
|
||||
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)
|
||||
maybeLocalTarget <- checkApplyLocalLoom apply
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Apply with no recipients"
|
||||
|
|
@ -636,89 +623,23 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (
|
|||
maybeLocalTargetDB <- for maybeLocalTarget $
|
||||
\ (repoID, maybeBranch, loomID, clothID, bundleID) -> runDBExcept $ 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 ""
|
||||
|
||||
-- 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"
|
||||
-- Find the repo and the bundle in our DB, and verify that the loom
|
||||
-- hosting the bundle is willing to accept the request from sender
|
||||
-- to apply this specific bundle to this repo/branch
|
||||
(loom, ticketID, diffs) <-
|
||||
checkApplyDB
|
||||
(Left senderPersonID)
|
||||
capID
|
||||
(repoID, maybeBranch)
|
||||
(loomID, clothID, bundleID)
|
||||
|
||||
return
|
||||
(Entity loomID loom, clothID, ticketID, repoID, maybeBranch, diffs)
|
||||
|
||||
-- Apply patches
|
||||
for_ maybeLocalTargetDB $ \ (_, _, _, 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-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
|
||||
for_ maybeLocalTargetDB $
|
||||
\ (_, _, _, repoID, maybeBranch, diffs) ->
|
||||
applyPatches repoID maybeBranch diffs
|
||||
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
now <- liftIO getCurrentTime
|
||||
|
|
@ -824,7 +745,7 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (
|
|||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activityFulfills = []
|
||||
, activitySpecific = ApplyActivity $ Apply uObject target
|
||||
, activitySpecific = ApplyActivity apply
|
||||
}
|
||||
update applyID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (luApply, doc)
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@ module Vervis.Data.Ticket
|
|||
, Merge (..)
|
||||
, TrackerAndMerge (..)
|
||||
, WorkItemOffer (..)
|
||||
, checkTip
|
||||
, checkOfferTicket
|
||||
, checkApplyLocalLoom
|
||||
|
||||
-- These are exported only for Vervis.Client
|
||||
, Tracker (..)
|
||||
|
|
@ -50,6 +50,7 @@ import Control.Monad.Trans.Except.Local
|
|||
import Vervis.Foundation
|
||||
import Vervis.FedURI
|
||||
import Vervis.Model
|
||||
import Vervis.Ticket
|
||||
|
||||
data Tip
|
||||
= TipLocalRepo RepoId
|
||||
|
|
@ -199,3 +200,30 @@ checkOfferTicket host ticket uTarget = do
|
|||
unless (tracker == target) $ throwE "Offer target != ticket context"
|
||||
tam <- checkTrackerAndMerge target maybeBundle
|
||||
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
|
||||
|
||||
--, repoApplyF
|
||||
--, loomApplyF
|
||||
, loomApplyF
|
||||
|
||||
--, deckOfferDepF
|
||||
--, repoOfferDepF
|
||||
|
|
@ -94,6 +93,7 @@ import Development.PatchMediaType
|
|||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.Darcs
|
||||
import Vervis.Delivery
|
||||
|
|
@ -107,6 +107,7 @@ import Vervis.Model
|
|||
import Vervis.Model.Role
|
||||
import Vervis.Model.Ticket
|
||||
import Vervis.Path
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Query
|
||||
import Vervis.Recipient
|
||||
import Vervis.Ticket
|
||||
|
|
@ -499,6 +500,12 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
|||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
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
|
||||
:: UTCTime
|
||||
-> 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
|
||||
-- won't process it again
|
||||
maybeAlreadyInInbox <- runMaybeT $ do
|
||||
instanceID <- MaybeT $ getKeyBy $ UniqueInstance $ objUriAuthority $ remoteAuthorURI author
|
||||
remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luOffer
|
||||
remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
|
||||
MaybeT $ getBy $ UniqueInboxItemRemote (actorInbox actor) remoteActivityID
|
||||
alreadyInInbox <- do
|
||||
let hOffer = objUriAuthority $ remoteAuthorURI author
|
||||
activityAlreadyInInbox hOffer luOffer (actorInbox actor)
|
||||
|
||||
return (recipLoomRepoID, recipLoomActor, isJust maybeAlreadyInInbox)
|
||||
return (recipLoomRepoID, recipLoomActor, alreadyInInbox)
|
||||
|
||||
if alreadyInInbox
|
||||
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)
|
||||
-}
|
||||
|
||||
repoApplyF
|
||||
loomApplyF
|
||||
:: UTCTime
|
||||
-> KeyHashid Repo
|
||||
-> KeyHashid Loom
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> FedURI
|
||||
-> FedURI
|
||||
-> AP.Apply URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
repoApplyF now recipHash author body mfwd luApply uObject uTarget = do
|
||||
error "repoApplyF temporarily disabled"
|
||||
loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
||||
|
||||
|
||||
{-
|
||||
|
||||
|
||||
-- Verify the patch bundle URI is one of:
|
||||
-- * A local sharer-hosted bundle
|
||||
-- * A local repo-hosted bundle under the receiving repo
|
||||
-- * A remote URI
|
||||
bundle <- do
|
||||
b <- parseProposalBundle "repoApplyF Apply object, a URI" uObject
|
||||
case b of
|
||||
Left (Right (shr, rp, ltid, bnid)) ->
|
||||
if shr == shrRecip && rp == rpRecip
|
||||
then return $ Left $ Right (ltid, bnid)
|
||||
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"
|
||||
-- Check input
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
(repoID, maybeBranch, clothID, bundleID) <- do
|
||||
maybeLocalTarget <- checkApplyLocalLoom apply
|
||||
(repoID, maybeBranch, loomID, clothID, bundleID) <-
|
||||
fromMaybeE
|
||||
maybeLocalTarget
|
||||
"Bundle doesn't belong to a local loom, in particular not to \
|
||||
\me, so I won't apply it. Was I supposed to receive it?"
|
||||
unless (loomID == recipLoomID) $
|
||||
throwE
|
||||
"Bundle belongs to some other local loom, so I won't apply \
|
||||
\it. Was I supposed to receive it?"
|
||||
return (repoID, maybeBranch, clothID, bundleID)
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
capID <- do
|
||||
uCap <- do
|
||||
let muCap = activityCapability $ actbActivity body
|
||||
uCap <- fromMaybeE muCap "Asking to apply patch but no capability provided"
|
||||
parseActivityURI "Apply capability" uCap
|
||||
fromMaybeE muCap "Asking to apply patch but no capability provided"
|
||||
capID <- nameExceptT "Apply capability" $ parseActivityURI uCap
|
||||
|
||||
-- Make sure receiving repo exists in DB, otherwise its inbox doesn't exist
|
||||
-- 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
|
||||
maybeNewApply <- runDBExcept $ do
|
||||
|
||||
-- Check in DB whether the provided capability matches a DB
|
||||
-- record we have, and that it includes permission to apply MRs
|
||||
runSiteDBExcept $ do
|
||||
-- Find the activity itself by URI in the DB
|
||||
act <- do
|
||||
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"
|
||||
-- Find recipient loom in DB, returning 404 if doesn't exist because
|
||||
-- we're in the loom's inbox post handler
|
||||
recipLoom <- lift $ get404 recipLoomID
|
||||
let recipLoomActorID = loomActor recipLoom
|
||||
recipLoomActor <- lift $ getJust recipLoomActorID
|
||||
|
||||
-- We verified apply permission, now let's examine the bundle itself
|
||||
case bundle of
|
||||
Left (Left (shr, talid, bnid)) -> do
|
||||
-- Verify we have this ticket and bundle in the DB
|
||||
-- Verify the ticket is listed under the repo
|
||||
-- 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"
|
||||
-- Has the loom already received this activity to its inbox? If yes, we
|
||||
-- won't process it again
|
||||
alreadyInInbox <- lift $ do
|
||||
let hOffer = objUriAuthority $ remoteAuthorURI author
|
||||
activityAlreadyInInbox hOffer luApply (actorInbox recipLoomActor)
|
||||
|
||||
-- Grab the bundle's patches from DB and apply them
|
||||
patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
|
||||
case repoVcs repoRecip of
|
||||
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
|
||||
-- Find the repo and the bundle in our DB, and verify that the loom is
|
||||
-- willing to accept the request from sender to apply this specific
|
||||
-- bundle to this repo/branch
|
||||
if alreadyInInbox
|
||||
then pure Nothing
|
||||
else Just <$> do
|
||||
(_, ticketID, diffs) <-
|
||||
checkApplyDB
|
||||
(Right $ remoteAuthorId author) capID
|
||||
(repoID, maybeBranch) (recipLoomID, clothID, bundleID)
|
||||
return (Entity recipLoomActorID recipLoomActor, ticketID, diffs)
|
||||
|
||||
-- Insert Apply activity to repo's inbox
|
||||
-- Produce an Accept activity and deliver locally
|
||||
-- Mark the ticket as resolved
|
||||
mhttp <- lift $ runSiteDB $ 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
|
||||
case maybeNewApply of
|
||||
Nothing ->
|
||||
return "I already have this activity in my inbox, doing nothing"
|
||||
Just (Entity recipLoomActorID recipLoomActor, ticketID, diffs) -> do
|
||||
|
||||
_ <- insertResolve author ltid ractid obiidAccept
|
||||
-- Apply patches
|
||||
applyPatches repoID maybeBranch diffs
|
||||
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptLocalSharer luApply shr talid obiidAccept
|
||||
maybeHttp <- lift $ runDB $ do
|
||||
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorRepo shrRecip rpRecip)
|
||||
(repoInbox repoRecip)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
-- Insert the Apply to loom's inbox
|
||||
mractid <- insertToInbox now author body (actorInbox recipLoomActor) luApply False
|
||||
for mractid $ \ applyID -> do
|
||||
|
||||
-- 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
|
||||
-- Forward the Apply activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdApply <- for mfwd $ \ (localRecips, sig) -> do
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[ LocalStageLoomFollowers recipLoomHash
|
||||
, LocalStageClothFollowers recipLoomHash clothHash
|
||||
]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes False applyID $
|
||||
localRecipSieve' sieve False False localRecips
|
||||
remoteRecipsHttp <-
|
||||
deliverRemoteDB_L
|
||||
(actbBL body) applyID recipLoomID sig remoteRecips
|
||||
return $
|
||||
if isJust mremotesHttpFwd
|
||||
then "Applied patches, did inbox-forwarding"
|
||||
else "Applied patches, no inbox-forwarding to do"
|
||||
deliverRemoteHTTP_L
|
||||
now recipLoomHash (actbBL body) sig remoteRecipsHttp
|
||||
|
||||
Left (Right (ltid, bnid)) -> do
|
||||
-- Verify we have this ticket and bundle in the DB, and that
|
||||
-- the bundle is the latest version
|
||||
mticket <- lift $ runSiteDB $ getRepoProposal shrRecip rpRecip ltid
|
||||
(_, _, _, _, _, _, _, 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"
|
||||
-- Mark ticket in DB as resolved by the Apply
|
||||
acceptID <-
|
||||
insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
insertResolve ticketID applyID acceptID
|
||||
|
||||
-- Grab the bundle's patches from DB and apply them
|
||||
patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
|
||||
case repoVcs repoRecip of
|
||||
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
|
||||
-- Prepare an Accept activity and insert to loom's outbox
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptToOutbox uCap clothID acceptID
|
||||
|
||||
-- Insert Apply activity to repo's inbox
|
||||
-- Produce an Accept activity and deliver locally
|
||||
-- Mark the ticket as resolved
|
||||
mhttp <- lift $ runSiteDB $ do
|
||||
mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False
|
||||
for mractid $ \ ractid -> do
|
||||
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[ 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
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False (LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
acceptID localRecipsAccept
|
||||
remoteRecipsHttpAccept <-
|
||||
deliverRemoteDB''
|
||||
fwdHostsAccept acceptID remoteRecipsAccept
|
||||
knownRemoteRecipsAccept
|
||||
|
||||
_ <- 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) <-
|
||||
insertAcceptLocalRepo luApply ltid 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"
|
||||
|
||||
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?
|
||||
-}
|
||||
-- Launch asynchronous HTTP forwarding of the Apply activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
case maybeHttp of
|
||||
Nothing ->
|
||||
return
|
||||
"When I started serving this activity, I didn't have it in my inbox, \
|
||||
\but now suddenly it seems I already do, so ignoring"
|
||||
Just (maybeHttpFwdApply, deliverHttpAccept) -> do
|
||||
forkWorker "loomApplyF Accept HTTP delivery" deliverHttpAccept
|
||||
case maybeHttpFwdApply of
|
||||
Nothing -> return "Applied the patch(es), no inbox-forwarding to do"
|
||||
Just forwardHttpApply -> do
|
||||
forkWorker "loomApplyF inbox-forwarding" forwardHttpApply
|
||||
return "Applied the patch(es) and ran inbox-forwarding of the Apply"
|
||||
|
||||
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
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
|
||||
audTicket =
|
||||
AudRemote hTicket [] [AP.ticketParticipants tlocal]
|
||||
|
||||
audRepo =
|
||||
audSender =
|
||||
AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
audTracker =
|
||||
AudLocal
|
||||
[]
|
||||
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
|
||||
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
||||
[ LocalStageLoomFollowers recipLoomHash
|
||||
, LocalStageClothFollowers recipLoomHash clothHash
|
||||
]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAuthor, audTicket, audRepo]
|
||||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
doc = AP.Doc hLocal AP.Activity
|
||||
{ AP.activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
RepoOutboxItemR shrRecip rpRecip obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
LoomOutboxItemR recipLoomHash acceptHash
|
||||
, AP.activityActor =
|
||||
encodeRouteLocal $ LoomR recipLoomHash
|
||||
, AP.activityCapability = Just uCap
|
||||
, AP.activitySummary = Nothing
|
||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.activityFulfills = []
|
||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
||||
{ acceptObject = ObjURI hAuthor luApply
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
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
|
||||
:: UTCTime
|
||||
-> KeyHashid Person
|
||||
|
|
|
|||
|
|
@ -142,6 +142,8 @@ postLoomInboxR recipLoomHash =
|
|||
case specific of
|
||||
AP.AcceptActivity accept ->
|
||||
loomAcceptF now recipLoomHash author body mfwd luActivity accept
|
||||
AP.ApplyActivity apply->
|
||||
loomApplyF now recipLoomHash author body mfwd luActivity apply
|
||||
AP.InviteActivity invite ->
|
||||
topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
|
||||
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
|
||||
( serveCommit
|
||||
, generatePatches
|
||||
, applyPatches
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Time.Clock
|
||||
|
|
@ -47,6 +49,7 @@ import Data.Patch.Local hiding (Patch)
|
|||
|
||||
import qualified Data.Patch.Local as P
|
||||
|
||||
import Vervis.Darcs
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Git
|
||||
|
|
@ -138,3 +141,24 @@ generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $
|
|||
lift $ runSiteDB $ do
|
||||
bundleID <- insert $ Bundle clothID True
|
||||
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.Collab
|
||||
Vervis.Persist.Ticket
|
||||
|
||||
Vervis.Query
|
||||
Vervis.Readme
|
||||
|
|
|
|||
Loading…
Reference in a new issue