C2S: Implement applyC (apply a patch/MR to a repo/branch)
Both Git and Darcs are supported - Darcs implementation applies right on the bare repo, I haven't tested to make sure it works right (federated MR demo is going to be only for Git) - Git implementation clones to temporary repo, runs `git am` on it to apply, then pushes to the real bare repo (because `git am` doesn't work on bare repos; I haven't tested yet to see how it handles conflicts; cloning and pushing should be efficient since the refs are just hardlinked rather than copied)
This commit is contained in:
fr33domlover
parent
b5adfce971
commit
be95f15b21
7 changed files with 289 additions and 431 deletions
51
src/System/Process/Typed/Local.hs
Normal file
51
src/System/Process/Typed/Local.hs
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
{- 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 System.Process.Typed.Local
|
||||
( runProcessE
|
||||
, readProcessE
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
import System.Exit
|
||||
import System.Process.Typed
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
|
||||
import qualified Data.Text.UTF8.Local as TU
|
||||
|
||||
runProcessE name spec = do
|
||||
exitCode <- runProcess spec
|
||||
case exitCode of
|
||||
ExitFailure n ->
|
||||
throwE $
|
||||
T.concat
|
||||
[ "`", name, "` failed with exit code "
|
||||
, T.pack (show n)
|
||||
]
|
||||
ExitSuccess -> return ()
|
||||
|
||||
readProcessE name spec = do
|
||||
(exitCode, out) <- readProcessStdout spec
|
||||
case exitCode of
|
||||
ExitFailure n ->
|
||||
throwE $
|
||||
T.concat
|
||||
[ "`", name, "` failed with exit code "
|
||||
, T.pack (show n)
|
||||
]
|
||||
ExitSuccess -> return $ TU.decodeStrict $ BL.toStrict out
|
||||
|
|
@ -62,6 +62,7 @@ import Network.HTTP.Client
|
|||
import System.Directory
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.IO.Temp
|
||||
import System.Process.Typed
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
|
||||
|
|
@ -77,7 +78,7 @@ import qualified Data.Text.Lazy as TL
|
|||
import Database.Persist.JSON
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
|
||||
import Web.ActivityPub hiding (Patch (..), Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
|
|
@ -97,6 +98,7 @@ import qualified Darcs.Local.Repository as D (createRepo)
|
|||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Cloth
|
||||
import Vervis.Darcs
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Ticket
|
||||
|
|
@ -104,6 +106,7 @@ import Vervis.Delivery
|
|||
import Vervis.FedURI
|
||||
import Vervis.Fetch
|
||||
import Vervis.Foundation
|
||||
import Vervis.Git
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Role
|
||||
|
|
@ -588,426 +591,280 @@ addBundleC (Entity pidUser personUser) summary audience patches uTarget = do
|
|||
|
||||
applyC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe FedURI
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Maybe (ObjURI URIMode)
|
||||
-> Apply URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
applyC (Entity pidUser personUser) summary audience muCap (Apply uObject uTarget) = do
|
||||
error "[August 2022] applyC temporarily disabled"
|
||||
applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (AP.Apply uObject target) = do
|
||||
|
||||
{-
|
||||
|
||||
-- Verify the patch bundle URI is one of:
|
||||
-- * A local sharer-hosted bundle
|
||||
-- * A local repo-hosted bundle
|
||||
-- * A remote URI
|
||||
bundle <- parseProposalBundle "Apply object" uObject
|
||||
|
||||
-- Identify local & remote recipients
|
||||
-- Produce recipient list for public use, i.e. with BTO and BCC hidden
|
||||
-- Produce list of hosts whom to authorize to inbox-forward our activity
|
||||
-- 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)
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Apply with no recipients"
|
||||
checkFederation remoteRecips
|
||||
|
||||
-- If remote recipients are specified, make sure federation is enabled
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
|
||||
-- Verify the apply's target is one of:
|
||||
-- * A local repo
|
||||
-- * A local repo's branch
|
||||
-- * A remote URI
|
||||
target <- checkBranch uTarget
|
||||
-- Verify that the bundle's loom is addressed
|
||||
for_ maybeLocalTarget $ \ (_, _, loomID, _, _) -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $
|
||||
throwE "Bundle's loom not addressed by the Apply"
|
||||
|
||||
-- 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 <- fromMaybeE muCap "Asking to apply patch but no capability provided"
|
||||
parseActivityURI "Apply capability" uCap
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
nameExceptT "Apply capability" $ parseActivityURI uCap
|
||||
|
||||
-- If target is remote, just proceed to send out the Apply activity
|
||||
-- If target is a local repo/branch, consider to apply the patch(es)
|
||||
mapplied <- case target of
|
||||
Right _u -> return Nothing
|
||||
maybeLocalTargetDB <- for maybeLocalTarget $
|
||||
\ (repoID, maybeBranch, loomID, clothID, bundleID) -> runDBExcept $ do
|
||||
|
||||
Left (shrTarget, rpTarget, mbranch) -> Just <$> 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 ""
|
||||
|
||||
-- Find the target repo in DB
|
||||
mrepo <- lift $ runDB $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shrTarget
|
||||
MaybeT $ getBy $ UniqueRepo rpTarget sid
|
||||
Entity ridTarget repoTarget <- fromMaybeE mrepo "Apply target: No such local repo in DB"
|
||||
-- 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"
|
||||
|
||||
-- Verify the repo is among the activity recipients
|
||||
let repoRecipFound = do
|
||||
sharerSet <- lookup shrTarget localRecips
|
||||
repoSet <- lookup rpTarget $ localRecipRepoRelated sharerSet
|
||||
guard $ localRecipRepo $ localRecipRepoDirect repoSet
|
||||
fromMaybeE repoRecipFound "Target local repo isn't listed as a recipient"
|
||||
-- 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"
|
||||
|
||||
-- Check in DB whether the provided capability matches a DB
|
||||
-- record we have, and that it gives the Apply author permission to
|
||||
-- apply patches to the target repo
|
||||
runDBExcept $ verifyCapability ridTarget capID
|
||||
-- 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"
|
||||
|
||||
-- Grab the bundle and its patches from DB or HTTP
|
||||
-- Make sure the ticket it's attached to is listed under the repo
|
||||
-- Make sure ticket isn't marked as resolved
|
||||
-- Make sure the bundle is the latest version
|
||||
(patches, mltid, ticketFollowers) <-
|
||||
case bundle of
|
||||
Left (Left (shr, talid, bnid)) -> do
|
||||
-- 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"
|
||||
|
||||
mticket <- lift $ runDB $ getSharerProposal shr talid
|
||||
(_, Entity ltid _, _, context, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket"
|
||||
-- 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)
|
||||
|
||||
case context of
|
||||
Left (_, Entity _ trl) ->
|
||||
unless (ticketRepoLocalRepo trl == ridTarget) $
|
||||
throwE "Apply object: Ticket under some other local repo"
|
||||
Right _ -> throwE "Apply object: Ticket not under a local repo"
|
||||
-- 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"
|
||||
|
||||
_ <- fromMaybeE mresolved "Apply object: Proposal already applied"
|
||||
return
|
||||
(Entity loomID loom, clothID, ticketID, repoID, maybeBranch, diffs)
|
||||
|
||||
unless (bnid == bnid') $
|
||||
throwE "Apply object: Bundle isn't the latest version"
|
||||
-- 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
|
||||
|
||||
let grabContent (Entity _ (Patch _ _ typ content)) =
|
||||
(typ, content)
|
||||
ps <- lift $ runDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
|
||||
case ps of
|
||||
[] -> error "Local sharer-bundle without any patches found"
|
||||
p : l -> return (NE.map grabContent $ p :| l, Just ltid, Left $ Left (shr, talid))
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
Left (Right (shr, rp, ltid, bnid)) -> do
|
||||
(applyID, deliverHttpApply, maybeDeliverHttpAccept) <- runDBExcept $ do
|
||||
|
||||
unless (shr == shrTarget && rp == rpTarget) $
|
||||
throwE "Bundle's repo mismatches Apply target"
|
||||
-- Insert Apply to sender's outbox
|
||||
applyID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
(luApply, docApply) <-
|
||||
lift $ insertApplyToOutbox senderHash blinded applyID
|
||||
|
||||
mticket <- lift $ runDB $ getRepoProposal shrTarget rpTarget 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"
|
||||
|
||||
let grabContent (Entity _ (Patch _ _ typ content)) =
|
||||
(typ, content)
|
||||
ps <- lift $ runDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
|
||||
case ps of
|
||||
[] -> error "Local repo-bundle without any patches found"
|
||||
p : l -> return (NE.map grabContent $ p :| l, Just ltid, Left $ Right ltid)
|
||||
|
||||
Right uBundle@(ObjURI hBundle luBundle) -> do
|
||||
|
||||
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"
|
||||
|
||||
verifyNothingE (AP.ticketResolved ticket) "Apply object: Ticket already marked as resolved"
|
||||
|
||||
e <- runDBExcept $ getRemoteTicketByURI uTicket
|
||||
case e of
|
||||
Right (_, _, _, _, _, Right (Entity _ trl))
|
||||
| ticketRepoLocalRepo trl == ridTarget -> pure ()
|
||||
_ -> throwE "Target repo doesn't have the ticket listed under it"
|
||||
|
||||
let followers =
|
||||
ObjURI hBundle $ AP.ticketParticipants tlocal
|
||||
fmap (,Nothing,Right followers) $ 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 repoTarget) $
|
||||
throwE "Patch type and repo VCS mismatch"
|
||||
return (typ, content)
|
||||
|
||||
-- Apply patches
|
||||
case repoVcs repoTarget of
|
||||
VCSGit -> do
|
||||
branch <- fromMaybeE mbranch "Apply target is a Git repo, but branch not specified"
|
||||
unless (all ((== PatchMediaTypeGit) . fst) patches) $
|
||||
throwE "Trying to apply non-Git patch to a Git repo"
|
||||
applyGitPatches shrTarget rpTarget 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 shrTarget rpTarget patch
|
||||
|
||||
return (shrTarget, rpTarget, repoTarget, mltid, ticketFollowers)
|
||||
|
||||
-- Insert Apply to outbox and deliver to local recipients via DB
|
||||
-- If we applied patches to a local repo, produce Accept and deliver via DB
|
||||
(obiid, doc, remotesHttp, maybeAccept) <- runDBExcept $ do
|
||||
(obiidApply, docApply, luApply) <- lift $ insertApplyToOutbox (personOutbox personUser) blinded
|
||||
remotesHttpApply <- do
|
||||
encodeLTID <- getEncodeKeyHashid
|
||||
encodeTALID <- getEncodeKeyHashid
|
||||
let shrUser = sharerIdent sharerUser
|
||||
sieve =
|
||||
let ticketC =
|
||||
case bundle of
|
||||
Left (Left (shr, talid, _)) ->
|
||||
[LocalPersonCollectionSharerProposalFollowers shr $ encodeTALID talid]
|
||||
Left (Right (shr, rp, ltid, _)) ->
|
||||
[LocalPersonCollectionRepoProposalFollowers shr rp $ encodeLTID ltid]
|
||||
Right _u ->
|
||||
[]
|
||||
(repoA, repoC) =
|
||||
case target of
|
||||
Left (shr, rp, _) ->
|
||||
( [LocalActorRepo shr rp]
|
||||
, [ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
)
|
||||
Right _u ->
|
||||
([], [])
|
||||
actors = repoA
|
||||
collections = ticketC ++ repoC
|
||||
in makeRecipientSet
|
||||
actors
|
||||
(LocalPersonCollectionSharerFollowers shrUser :
|
||||
collections
|
||||
)
|
||||
-- Deliver the Apply activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
remoteRecipsHttpApply <- do
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
hashCloth <- getEncodeKeyHashid
|
||||
let maybeLoom =
|
||||
maybeLocalTargetDB <&>
|
||||
\ (Entity loomID _, clothID, _, _, _, _) ->
|
||||
(hashLoom loomID, hashCloth clothID)
|
||||
sieveActors = catMaybes
|
||||
[ LocalActorLoom . fst <$> maybeLoom
|
||||
]
|
||||
sieveStages = catMaybes
|
||||
[ LocalStageLoomFollowers . fst <$> maybeLoom
|
||||
, uncurry LocalStageClothFollowers <$> maybeLoom
|
||||
, Just $ LocalStagePersonFollowers senderHash
|
||||
]
|
||||
sieve = makeRecipientSet sieveActors sieveStages
|
||||
moreRemoteRecips <-
|
||||
lift $
|
||||
deliverLocal'
|
||||
True
|
||||
(LocalActorSharer shrUser)
|
||||
(personInbox personUser)
|
||||
obiidApply
|
||||
(localRecipSieve sieve False localRecips)
|
||||
unless (federation || null moreRemoteRecips) $
|
||||
throwE "Federation disabled, but recipient collection remote members found"
|
||||
lift $ deliverRemoteDB'' fwdHosts obiidApply remoteRecips moreRemoteRecips
|
||||
lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) applyID $
|
||||
localRecipSieve sieve False localRecips
|
||||
checkFederation moreRemoteRecips
|
||||
lift $ deliverRemoteDB'' fwdHosts applyID remoteRecips moreRemoteRecips
|
||||
|
||||
maccept <- lift $ for mapplied $ \ (shr, rp, repo, mltid, ticketFollowers) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox repo) now
|
||||
for_ mltid $ \ ltid -> insertResolve ltid obiidApply obiidAccept
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAccept shr rp ticketFollowers obiidApply obiidAccept
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorRepo shr rp)
|
||||
(repoInbox repo)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
-- Verify that the loom has received the Apply, resolve the Ticket in
|
||||
-- DB, and publish Accept
|
||||
maybeDeliverHttpAccept <- for maybeLocalTargetDB $ \ (Entity loomID loom, clothID, ticketID, _repoID, _mb, _diffs) -> do
|
||||
|
||||
return (obiidApply, docApply, remotesHttpApply, maccept)
|
||||
-- Verify that loom received the Apply
|
||||
let loomActorID = loomActor loom
|
||||
verifyActorHasItem loomActorID applyID "Local loom didn't receive the Apply"
|
||||
|
||||
-- Deliver Apply and Accept to remote recipients via HTTP
|
||||
-- Mark ticket in DB as resolved by the Apply
|
||||
acceptID <- lift $ do
|
||||
actor <- getJust loomActorID
|
||||
insertEmptyOutboxItem (actorOutbox actor) now
|
||||
lift $ insertResolve ticketID applyID acceptID
|
||||
|
||||
-- Insert an Accept activity to loom's outbox
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
let acceptRecipActors = [LocalActorPerson senderHash]
|
||||
acceptRecipStages =
|
||||
[ LocalStageLoomFollowers loomHash
|
||||
, LocalStageClothFollowers loomHash clothHash
|
||||
, LocalStagePersonFollowers senderHash
|
||||
]
|
||||
docAccept <-
|
||||
lift $ insertAcceptToOutbox senderHash loomHash luApply acceptID acceptRecipActors acceptRecipStages
|
||||
|
||||
-- Deliver the Accept activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
remoteRecipsHttpAccept <- do
|
||||
remoteRecips <-
|
||||
lift $ deliverLocal' True (LocalActorLoom loomHash) loomActorID acceptID $
|
||||
makeRecipientSet acceptRecipActors acceptRecipStages
|
||||
checkFederation remoteRecips
|
||||
lift $ deliverRemoteDB'' [] acceptID [] remoteRecips
|
||||
|
||||
-- Return instructions for HTTP delivery of the Accept to remote
|
||||
-- recipients
|
||||
return $
|
||||
deliverRemoteHttp' [] acceptID docAccept remoteRecipsHttpAccept
|
||||
|
||||
-- Return instructions for HTTP delivery or Apply and Accept to remote
|
||||
-- recipients
|
||||
return
|
||||
( applyID
|
||||
, deliverRemoteHttp' fwdHosts applyID docApply remoteRecipsHttpApply
|
||||
, maybeDeliverHttpAccept
|
||||
)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Apply and Accept
|
||||
lift $ do
|
||||
forkWorker "applyC: async HTTP Apply delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp
|
||||
for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) ->
|
||||
forkWorker "applyC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
|
||||
return obiid
|
||||
forkWorker "applyC: async HTTP Apply delivery" deliverHttpApply
|
||||
for_ maybeDeliverHttpAccept $
|
||||
forkWorker "applyC: async HTTP Accept delivery"
|
||||
|
||||
return applyID
|
||||
|
||||
where
|
||||
checkBranch u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal lu)
|
||||
"Apply target is local but isn't a valid route"
|
||||
case route of
|
||||
RepoR shr rp -> return (shr, rp, Nothing)
|
||||
RepoBranchR shr rp b -> return (shr, rp, Just b)
|
||||
_ ->
|
||||
throwE
|
||||
"Apply target is a valid local route, but isn't a \
|
||||
\repo or branch route"
|
||||
else return $ Right u
|
||||
|
||||
verifyCapability ridTarget capID = 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
|
||||
pidCollab <- do
|
||||
mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid
|
||||
crl <- fromMaybeE mcrl "No local recip for capability"
|
||||
mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid
|
||||
verifyNothingE mcrr "Both local & remote recip for capability!"
|
||||
return $ collabRecipLocalPerson crl
|
||||
-- Verify the recipient is the author of the Apply activity
|
||||
unless (pidCollab == pidUser) $
|
||||
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 == ridTarget) $
|
||||
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"
|
||||
|
||||
insertApplyToOutbox obid blinded = do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
now <- liftIO getCurrentTime
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
insertApplyToOutbox senderHash blinded applyID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
applyHash <- encodeKeyHashid applyID
|
||||
let luApply = encodeRouteLocal $ PersonOutboxItemR senderHash applyHash
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
{ activityId = Just luApply
|
||||
, activityActor = encodeRouteLocal $ PersonR senderHash
|
||||
, activityCapability = muCap
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = ApplyActivity $ Apply uObject uTarget
|
||||
, activityFulfills = []
|
||||
, activitySpecific = ApplyActivity $ Apply uObject target
|
||||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
update applyID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (luApply, doc)
|
||||
|
||||
insertResolve ltid obiidApply obiidAccept = do
|
||||
insertResolve ticketID applyID acceptID = do
|
||||
trid <- insert TicketResolve
|
||||
{ ticketResolveTicket = ltid
|
||||
, ticketResolveAccept = obiidAccept
|
||||
{ ticketResolveTicket = ticketID
|
||||
, ticketResolveAccept = acceptID
|
||||
}
|
||||
insert_ TicketResolveLocal
|
||||
{ ticketResolveLocalTicket = trid
|
||||
, ticketResolveLocalActivity = obiidApply
|
||||
, ticketResolveLocalActivity = applyID
|
||||
}
|
||||
tid <- localTicketTicket <$> getJust ltid
|
||||
update tid [TicketStatus =. TSClosed]
|
||||
update ticketID [TicketStatus =. TSClosed]
|
||||
|
||||
insertAccept shrTarget rpTarget ticketFollowers obiidApply obiidAccept = do
|
||||
insertAcceptToOutbox personHash loomHash luApply acceptID actors stages = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeTALID <- getEncodeKeyHashid
|
||||
encodeLTID <- getEncodeKeyHashid
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
obikhidApply <- encodeKeyHashid obiidApply
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
|
||||
let shrUser = sharerIdent sharerUser
|
||||
audAuthor =
|
||||
AudLocal
|
||||
[LocalActorSharer shrUser]
|
||||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
audTicket =
|
||||
case ticketFollowers of
|
||||
Left (Left (shr, talid)) -> AudLocal [] [LocalPersonCollectionSharerProposalFollowers shr $ encodeTALID talid]
|
||||
Left (Right ltid) -> AudLocal [] [LocalPersonCollectionRepoProposalFollowers shrTarget rpTarget $ encodeLTID ltid]
|
||||
Right (ObjURI h lu) -> AudRemote h [] [lu]
|
||||
audRepo =
|
||||
AudLocal
|
||||
[]
|
||||
[ LocalPersonCollectionRepoTeam shrTarget rpTarget
|
||||
, LocalPersonCollectionRepoFollowers shrTarget rpTarget
|
||||
]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAuthor, audTicket, audRepo]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalStage stages
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
RepoOutboxItemR shrTarget rpTarget obikhidAccept
|
||||
, activityActor =
|
||||
encodeRouteLocal $ RepoR shrTarget rpTarget
|
||||
LoomOutboxItemR loomHash acceptHash
|
||||
, activityActor = encodeRouteLocal $ LoomR loomHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject =
|
||||
encodeRouteHome $
|
||||
SharerOutboxItemR shrUser obikhidApply
|
||||
{ acceptObject = ObjURI hLocal luApply
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-}
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return doc
|
||||
|
||||
parseComment :: LocalURI -> ExceptT Text Handler (PersonId, LocalMessageId)
|
||||
parseComment luParent = do
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ module Vervis.Darcs
|
|||
--, lastChange
|
||||
, readPatch
|
||||
, writePostApplyHooks
|
||||
--, applyDarcsPatch
|
||||
, applyDarcsPatch
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -83,6 +83,7 @@ import Data.List.NonEmpty.Local
|
|||
import Data.Patch.Local hiding (Patch)
|
||||
import Data.Text.UTF8.Local (decodeStrict)
|
||||
import Data.Time.Clock.Local ()
|
||||
import System.Process.Typed.Local
|
||||
|
||||
import qualified Data.Patch.Local as DP
|
||||
import qualified Data.Text.UTF8.Local as TU
|
||||
|
|
@ -398,22 +399,6 @@ writePostApplyHooks = do
|
|||
liftIO $
|
||||
writeDefaultsFile path hook authority (keyHashidText repoHash)
|
||||
|
||||
{-
|
||||
applyDarcsPatch shr rp patch = do
|
||||
path <- askRepoDir shr rp
|
||||
applyDarcsPatch repoPath patch = do
|
||||
let input = BL.fromStrict $ TE.encodeUtf8 patch
|
||||
(exitCode, out, err) <-
|
||||
readProcess $ setStdin (byteStringInput input) $
|
||||
proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--repodir='" ++ path ++ "'"]
|
||||
let out2text = TU.decodeLenient . BL.toStrict
|
||||
case exitCode of
|
||||
ExitFailure n ->
|
||||
throwE $
|
||||
T.concat
|
||||
[ "`darcs apply` failed with exit code "
|
||||
, T.pack (show n)
|
||||
, "\nstdout: ", out2text out
|
||||
, "\nstderr: ", out2text err
|
||||
]
|
||||
ExitSuccess -> return ()
|
||||
-}
|
||||
runProcessE "darcs apply" $ setStdin (byteStringInput input) $ proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--repodir='" ++ repoPath ++ "'"]
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ module Vervis.Data.Ticket
|
|||
, Merge (..)
|
||||
, TrackerAndMerge (..)
|
||||
, WorkItemOffer (..)
|
||||
, checkTip
|
||||
, checkOfferTicket
|
||||
|
||||
-- These are exported only for Vervis.Client
|
||||
|
|
|
|||
|
|
@ -22,18 +22,16 @@ module Vervis.Git
|
|||
--, lastCommitTime
|
||||
, writePostReceiveHooks
|
||||
, generateGitPatches
|
||||
--, applyGitPatches
|
||||
, applyGitPatches
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Exception.Base
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Except
|
||||
import Patience (diff, Item (..))
|
||||
import Data.Byteable (toBytes)
|
||||
import Data.Foldable
|
||||
import Data.Git.Diff
|
||||
import Data.Git.Graph
|
||||
|
|
@ -56,7 +54,6 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
|||
import Data.Traversable (for)
|
||||
import Data.Word (Word32)
|
||||
import Database.Persist
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.Hourglass (timeCurrent)
|
||||
import System.Process.Typed
|
||||
|
|
@ -87,6 +84,7 @@ import Data.EventTime.Local
|
|||
import Data.Git.Local
|
||||
import Data.List.Local
|
||||
import Data.Patch.Local hiding (Patch)
|
||||
import System.Process.Typed.Local
|
||||
|
||||
import qualified Data.Patch.Local as P
|
||||
import qualified Data.Text.UTF8.Local as TU
|
||||
|
|
@ -372,7 +370,7 @@ generateGitPatches
|
|||
-> FilePath -- ^ Temporary directory to use for the operation
|
||||
-> ExceptT Text IO (NonEmpty Text)
|
||||
generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDir = do
|
||||
runProcessE "git clone" $ proc "git" ["clone", "--bare", "--verbose", "--origin", "target", "--single-branch", "--branch", targetBranch, "--", targetRepoPath, tempDir]
|
||||
runProcessE "git clone" $ proc "git" ["clone", "--bare", "--verbose", "--single-branch", "--branch", targetBranch, "--", targetRepoPath, tempDir]
|
||||
runProcessE "git remote add" $ proc "git" ["-C", tempDir, "remote", "--verbose", "add", "-t", originBranch, "real-origin", originRepoURI]
|
||||
runProcessE "git fetch" $ proc "git" ["-C", tempDir, "fetch", "real-origin", originBranch]
|
||||
runProcessE "git merge-base --is-ancestor" $ proc "git" ["-C", tempDir, "merge-base", "--is-ancestor", targetBranch, "real-origin/" ++ originBranch]
|
||||
|
|
@ -388,49 +386,12 @@ generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDi
|
|||
]
|
||||
Right t -> return t
|
||||
|
||||
where
|
||||
|
||||
runProcessE name spec = do
|
||||
exitCode <- runProcess spec
|
||||
case exitCode of
|
||||
ExitFailure n ->
|
||||
throwE $
|
||||
T.concat
|
||||
[ "`", name, "` failed with exit code "
|
||||
, T.pack (show n)
|
||||
]
|
||||
ExitSuccess -> return ()
|
||||
|
||||
readProcessE name spec = do
|
||||
(exitCode, out) <- readProcessStdout spec
|
||||
case exitCode of
|
||||
ExitFailure n ->
|
||||
throwE $
|
||||
T.concat
|
||||
[ "`", name, "` failed with exit code "
|
||||
, T.pack (show n)
|
||||
]
|
||||
ExitSuccess -> return $ TU.decodeStrict $ BL.toStrict out
|
||||
|
||||
{-
|
||||
applyGitPatches shr rp branch patches = do
|
||||
path <- askRepoDir shr rp
|
||||
-- Since 'git am' doesn't work on a bare repo, clone target repo into the given
|
||||
-- temporary directory, apply there, and finally push
|
||||
applyGitPatches repoPath branch patches tempDir = do
|
||||
runProcessE "git clone" $ proc "git" ["clone", "--verbose", "--single-branch", "--branch", branch, "--", repoPath, tempDir]
|
||||
let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches
|
||||
readProcessE "git checkout" $ proc "git" ["-C", path, "checkout", T.unpack branch]
|
||||
readProcessE "git am" $ setStdin (byteStringInput input) $ proc "git" ["-C", "'" ++ path ++ "'", "am"]
|
||||
where
|
||||
readProcessE name spec = do
|
||||
(exitCode, out, err) <- readProcess spec
|
||||
case exitCode of
|
||||
ExitFailure n ->
|
||||
throwE $
|
||||
T.concat
|
||||
[ "`", name, "` failed with exit code "
|
||||
, T.pack (show n)
|
||||
, "\nstdout: ", out2text out
|
||||
, "\nstderr: ", out2text err
|
||||
]
|
||||
ExitSuccess -> return ()
|
||||
where
|
||||
out2text = TU.decodeLenient . BL.toStrict
|
||||
-}
|
||||
runProcessE "git am" $ setStdin (byteStringInput input) $ proc "git" ["-C", tempDir, "am"]
|
||||
runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.name", "vervis"]
|
||||
runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.email", "vervis@vervis.vervis"]
|
||||
runProcessE "git push" $ proc "git" ["-C", tempDir, "push"]
|
||||
|
|
|
|||
|
|
@ -276,6 +276,8 @@ postPersonOutboxR personHash = do
|
|||
case specific of
|
||||
AP.AcceptActivity accept ->
|
||||
acceptC eperson actorDB summary audience accept
|
||||
AP.ApplyActivity apply ->
|
||||
applyC eperson actorDB mcap summary audience apply
|
||||
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||
case obj of
|
||||
{-
|
||||
|
|
@ -297,8 +299,8 @@ postPersonOutboxR personHash = do
|
|||
Right (AddBundle patches) ->
|
||||
addBundleC eperson sharer summary audience patches target
|
||||
_ -> throwE "Unsupported Add 'object' type"
|
||||
ApplyActivity apply ->
|
||||
applyC eperson sharer summary audience mcap apply
|
||||
-}
|
||||
{-
|
||||
FollowActivity follow ->
|
||||
followC shr summary audience follow
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -100,6 +100,7 @@ library
|
|||
Network.HTTP.Client.Conduit.ActivityPub
|
||||
Network.HTTP.Digest
|
||||
Network.SSH.Local
|
||||
System.Process.Typed.Local
|
||||
Text.Blaze.Local
|
||||
Text.Display
|
||||
Text.Email.Local
|
||||
|
|
|
|||
Loading…
Reference in a new issue