forge/Vervis
1
0
Fork 0
Code Pull requests Activity

C2S: Implement applyC (apply a patch/MR to a repo/branch)

Browse source 
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 2022-09-24 09:04:10 +00:00
parent b5adfce971
commit be95f15b21
7 changed files with 289 additions and 431 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
src/System/Process/Typed/Local.hs Normal file
View 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

577
src/Vervis/API.hs
View file

@ -62,6 +62,7 @@ import Network.HTTP.Client
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.FilePath import System.FilePath
import System.IO.Temp
import System.Process.Typed import System.Process.Typed
import Text.Blaze.Html.Renderer.Text import Text.Blaze.Html.Renderer.Text
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
@ -77,7 +78,7 @@ import qualified Data.Text.Lazy as TL
import Database.Persist.JSON import Database.Persist.JSON
import Development.PatchMediaType import Development.PatchMediaType
import Network.FedURI 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 Web.Text
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
@ -97,6 +98,7 @@ import qualified Darcs.Local.Repository as D (createRepo)
import Vervis.Access import Vervis.Access
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.Cloth import Vervis.Cloth
import Vervis.Darcs
import Vervis.Data.Actor import Vervis.Data.Actor
import Vervis.Data.Collab import Vervis.Data.Collab
import Vervis.Data.Ticket import Vervis.Data.Ticket
@ -104,6 +106,7 @@ import Vervis.Delivery
import Vervis.FedURI import Vervis.FedURI
import Vervis.Fetch import Vervis.Fetch
import Vervis.Foundation import Vervis.Foundation
import Vervis.Git
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Role import Vervis.Model.Role
@ -588,426 +591,280 @@ addBundleC (Entity pidUser personUser) summary audience patches uTarget = do
applyC applyC
:: Entity Person :: Entity Person
-> Actor
-> Maybe FedURI
-> Maybe HTML -> Maybe HTML
-> Audience URIMode -> Audience URIMode
-> Maybe (ObjURI URIMode)
-> Apply URIMode -> Apply URIMode
-> ExceptT Text Handler OutboxItemId -> ExceptT Text Handler OutboxItemId
applyC (Entity pidUser personUser) summary audience muCap (Apply uObject uTarget) = do applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (AP.Apply uObject target) = do
error "[August 2022] applyC temporarily disabled"
{- -- Check input
maybeLocalTarget <- do
-- Verify the patch bundle URI is one of: bundle <- parseProposalBundle "Apply object" uObject
-- * A local sharer-hosted bundle targetTip <- nameExceptT "Apply target" $ checkTip target
-- * A local repo-hosted bundle let maybeLocal =
-- * A remote URI case targetTip of
bundle <- parseProposalBundle "Apply object" uObject TipLocalRepo repoID -> Just (repoID, Nothing)
TipLocalBranch repoID branch -> Just (repoID, Just branch)
-- Identify local & remote recipients TipRemote _ -> Nothing
-- Produce recipient list for public use, i.e. with BTO and BCC hidden TipRemoteBranch _ _ -> Nothing
-- Produce list of hosts whom to authorize to inbox-forward our activity 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"
checkFederation remoteRecips
-- If remote recipients are specified, make sure federation is enabled -- Verify that the bundle's loom is addressed
federation <- asksSite $ appFederation . appSettings for_ maybeLocalTarget $ \ (_, _, loomID, _, _) -> do
unless (federation || null remoteRecips) $ loomHash <- encodeKeyHashid loomID
throwE "Federation disabled, but remote recipients specified" unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $
throwE "Bundle's loom not addressed by the Apply"
-- Verify the apply's target is one of:
-- * A local repo
-- * A local repo's branch
-- * A remote URI
target <- checkBranch uTarget
-- 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 capID <- do
uCap <- fromMaybeE muCap "Asking to apply patch but no capability provided" uCap <- fromMaybeE muCap "No capability provided"
parseActivityURI "Apply capability" uCap nameExceptT "Apply capability" $ parseActivityURI uCap
-- If target is remote, just proceed to send out the Apply activity maybeLocalTargetDB <- for maybeLocalTarget $
-- If target is a local repo/branch, consider to apply the patch(es) \ (repoID, maybeBranch, loomID, clothID, bundleID) -> runDBExcept $ do
mapplied <- case target of
Right _u -> return Nothing
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 -- Verify the target repo/branch iof the Apply is identical to the
mrepo <- lift $ runDB $ runMaybeT $ do -- target repo/branch of the MR
sid <- MaybeT $ getKeyBy $ UniqueSharer shrTarget unless (maybeBranch == clothBranch) $
MaybeT $ getBy $ UniqueRepo rpTarget sid throwE "Apply target != MR target"
Entity ridTarget repoTarget <- fromMaybeE mrepo "Apply target: No such local repo in DB"
-- Verify the repo is among the activity recipients -- Find target repo in DB and verify it consents to being served by
let repoRecipFound = do -- the loom
sharerSet <- lookup shrTarget localRecips unless (repoID == loomRepo loom) $
repoSet <- lookup rpTarget $ localRecipRepoRelated sharerSet throwE "MR target repo isn't the one served by the Apply object bundle's loom"
guard $ localRecipRepo $ localRecipRepoDirect repoSet repo <- getE repoID "Apply target: No such local repo in DB"
fromMaybeE repoRecipFound "Target local repo isn't listed as a recipient" 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 -- Verify that VCS type matches the presence of a branch:
-- record we have, and that it gives the Apply author permission to -- Branch specified for Git, isn't specified for Darcs
-- apply patches to the target repo case (repoVcs repo, maybeBranch) of
runDBExcept $ verifyCapability ridTarget capID (VCSDarcs, Nothing) -> pure ()
(VCSGit, Just _) -> pure ()
_ -> throwE "VCS type and branch presence mismatch"
-- Grab the bundle and its patches from DB or HTTP -- Verify the MR isn't already resolved and the bundle is the
-- Make sure the ticket it's attached to is listed under the repo -- latest version
-- Make sure ticket isn't marked as resolved unless (isNothing maybeResolve) $
-- Make sure the bundle is the latest version throwE "MR is already resolved"
(patches, mltid, ticketFollowers) <- unless (bundleID == latest) $
case bundle of throwE "Bundle isn't the latest version"
Left (Left (shr, talid, bnid)) -> do
mticket <- lift $ runDB $ getSharerProposal shr talid -- Verify the sender is authorized by the loom to apply a patch
(_, Entity ltid _, _, context, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket" 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 -- Get the patches from DB, verify VCS match just in case
Left (_, Entity _ trl) -> diffs <- do
unless (ticketRepoLocalRepo trl == ridTarget) $ ps <-
throwE "Apply object: Ticket under some other local repo" lift $ map entityVal <$>
Right _ -> throwE "Apply object: Ticket not under a local repo" 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') $ -- Apply patches
throwE "Apply object: Bundle isn't the latest version" 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)) = senderHash <- encodeKeyHashid senderPersonID
(typ, content) now <- liftIO getCurrentTime
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))
Left (Right (shr, rp, ltid, bnid)) -> do (applyID, deliverHttpApply, maybeDeliverHttpAccept) <- runDBExcept $ do
unless (shr == shrTarget && rp == rpTarget) $ -- Insert Apply to sender's outbox
throwE "Bundle's repo mismatches Apply target" applyID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
(luApply, docApply) <-
lift $ insertApplyToOutbox senderHash blinded applyID
mticket <- lift $ runDB $ getRepoProposal shrTarget rpTarget ltid -- Deliver the Apply activity to local recipients, and schedule
(_, _, _, _, _, _, _, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket" -- delivery for unavailable remote recipients
remoteRecipsHttpApply <- do
_ <- fromMaybeE mresolved "Apply object: Proposal already applied" hashLoom <- getEncodeKeyHashid
hashCloth <- getEncodeKeyHashid
unless (bnid == bnid') $ let maybeLoom =
throwE "Apply object: Bundle isn't the latest version" maybeLocalTargetDB <&>
\ (Entity loomID _, clothID, _, _, _, _) ->
let grabContent (Entity _ (Patch _ _ typ content)) = (hashLoom loomID, hashCloth clothID)
(typ, content) sieveActors = catMaybes
ps <- lift $ runDB $ selectList [PatchBundle ==. bnid] [Asc PatchId] [ LocalActorLoom . fst <$> maybeLoom
case ps of ]
[] -> error "Local repo-bundle without any patches found" sieveStages = catMaybes
p : l -> return (NE.map grabContent $ p :| l, Just ltid, Left $ Right ltid) [ LocalStageLoomFollowers . fst <$> maybeLoom
, uncurry LocalStageClothFollowers <$> maybeLoom
Right uBundle@(ObjURI hBundle luBundle) -> do , Just $ LocalStagePersonFollowers senderHash
]
manager <- asksSite appHttpManager sieve = makeRecipientSet sieveActors sieveStages
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
)
moreRemoteRecips <- moreRemoteRecips <-
lift $ lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) applyID $
deliverLocal' localRecipSieve sieve False localRecips
True checkFederation moreRemoteRecips
(LocalActorSharer shrUser) lift $ deliverRemoteDB'' fwdHosts applyID remoteRecips moreRemoteRecips
(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
maccept <- lift $ for mapplied $ \ (shr, rp, repo, mltid, ticketFollowers) -> do -- Verify that the loom has received the Apply, resolve the Ticket in
now <- liftIO getCurrentTime -- DB, and publish Accept
obiidAccept <- insertEmptyOutboxItem (repoOutbox repo) now maybeDeliverHttpAccept <- for maybeLocalTargetDB $ \ (Entity loomID loom, clothID, ticketID, _repoID, _mb, _diffs) -> do
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
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 lift $ do
forkWorker "applyC: async HTTP Apply delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp forkWorker "applyC: async HTTP Apply delivery" deliverHttpApply
for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) -> for_ maybeDeliverHttpAccept $
forkWorker "applyC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept forkWorker "applyC: async HTTP Accept delivery"
return obiid
return applyID
where 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 insertApplyToOutbox senderHash blinded applyID = 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
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
obikhid <- encodeKeyHashid obiid hLocal <- asksSite siteInstanceHost
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid applyHash <- encodeKeyHashid applyID
let luApply = encodeRouteLocal $ PersonOutboxItemR senderHash applyHash
doc = Doc hLocal Activity doc = Doc hLocal Activity
{ activityId = Just luAct { activityId = Just luApply
, activityActor = encodeRouteLocal $ SharerR shrUser , activityActor = encodeRouteLocal $ PersonR senderHash
, activityCapability = muCap , activityCapability = muCap
, activitySummary = summary , activitySummary = summary
, activityAudience = blinded , activityAudience = blinded
, activitySpecific = ApplyActivity $ Apply uObject uTarget , activityFulfills = []
, activitySpecific = ApplyActivity $ Apply uObject target
} }
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] update applyID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc, luAct) return (luApply, doc)
insertResolve ltid obiidApply obiidAccept = do insertResolve ticketID applyID acceptID = do
trid <- insert TicketResolve trid <- insert TicketResolve
{ ticketResolveTicket = ltid { ticketResolveTicket = ticketID
, ticketResolveAccept = obiidAccept , ticketResolveAccept = acceptID
} }
insert_ TicketResolveLocal insert_ TicketResolveLocal
{ ticketResolveLocalTicket = trid { ticketResolveLocalTicket = trid
, ticketResolveLocalActivity = obiidApply , ticketResolveLocalActivity = applyID
} }
tid <- localTicketTicket <$> getJust ltid update ticketID [TicketStatus =. TSClosed]
update tid [TicketStatus =. TSClosed]
insertAccept shrTarget rpTarget ticketFollowers obiidApply obiidAccept = do insertAcceptToOutbox personHash loomHash luApply acceptID actors stages = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeTALID <- getEncodeKeyHashid
encodeLTID <- getEncodeKeyHashid
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
acceptHash <- encodeKeyHashid acceptID
obikhidApply <- encodeKeyHashid obiidApply let recips =
obikhidAccept <- encodeKeyHashid obiidAccept map encodeRouteHome $
map renderLocalActor actors ++
let shrUser = sharerIdent sharerUser map renderLocalStage stages
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
doc = Doc hLocal Activity doc = Doc hLocal Activity
{ activityId = { activityId =
Just $ encodeRouteLocal $ Just $ encodeRouteLocal $
RepoOutboxItemR shrTarget rpTarget obikhidAccept LoomOutboxItemR loomHash acceptHash
, activityActor = , activityActor = encodeRouteLocal $ LoomR loomHash
encodeRouteLocal $ RepoR shrTarget rpTarget
, activityCapability = Nothing , activityCapability = Nothing
, activitySummary = Nothing , activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] [] , activityAudience = Audience recips [] [] [] [] []
, activityFulfills = []
, activitySpecific = AcceptActivity Accept , activitySpecific = AcceptActivity Accept
{ acceptObject = { acceptObject = ObjURI hLocal luApply
encodeRouteHome $
SharerOutboxItemR shrUser obikhidApply
, acceptResult = Nothing , acceptResult = Nothing
} }
} }
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return doc
return (doc, recipientSet, remoteActors, fwdHosts)
-}
parseComment :: LocalURI -> ExceptT Text Handler (PersonId, LocalMessageId) parseComment :: LocalURI -> ExceptT Text Handler (PersonId, LocalMessageId)
parseComment luParent = do parseComment luParent = do

23
src/Vervis/Darcs.hs
View file

@ -21,7 +21,7 @@ module Vervis.Darcs
--, lastChange --, lastChange
, readPatch , readPatch
, writePostApplyHooks , writePostApplyHooks
--, applyDarcsPatch , applyDarcsPatch
) )
where where
@ -83,6 +83,7 @@ import Data.List.NonEmpty.Local
import Data.Patch.Local hiding (Patch) import Data.Patch.Local hiding (Patch)
import Data.Text.UTF8.Local (decodeStrict) import Data.Text.UTF8.Local (decodeStrict)
import Data.Time.Clock.Local () import Data.Time.Clock.Local ()
import System.Process.Typed.Local
import qualified Data.Patch.Local as DP import qualified Data.Patch.Local as DP
import qualified Data.Text.UTF8.Local as TU import qualified Data.Text.UTF8.Local as TU
@ -398,22 +399,6 @@ writePostApplyHooks = do
liftIO $ liftIO $
writeDefaultsFile path hook authority (keyHashidText repoHash) writeDefaultsFile path hook authority (keyHashidText repoHash)
{- applyDarcsPatch repoPath patch = do
applyDarcsPatch shr rp patch = do
path <- askRepoDir shr rp
let input = BL.fromStrict $ TE.encodeUtf8 patch let input = BL.fromStrict $ TE.encodeUtf8 patch
(exitCode, out, err) <- runProcessE "darcs apply" $ setStdin (byteStringInput input) $ proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--repodir='" ++ repoPath ++ "'"]
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 ()
-}

1
src/Vervis/Data/Ticket.hs
View file

@ -19,6 +19,7 @@ module Vervis.Data.Ticket
, Merge (..) , Merge (..)
, TrackerAndMerge (..) , TrackerAndMerge (..)
, WorkItemOffer (..) , WorkItemOffer (..)
, checkTip
, checkOfferTicket , checkOfferTicket
-- These are exported only for Vervis.Client -- These are exported only for Vervis.Client

61
src/Vervis/Git.hs
View file

@ -22,18 +22,16 @@ module Vervis.Git
--, lastCommitTime --, lastCommitTime
, writePostReceiveHooks , writePostReceiveHooks
, generateGitPatches , generateGitPatches
--, applyGitPatches , applyGitPatches
) )
where where
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Exception.Base import Control.Exception.Base
import Control.Monad (join)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Patience (diff, Item (..)) import Patience (diff, Item (..))
import Data.Byteable (toBytes)
import Data.Foldable import Data.Foldable
import Data.Git.Diff import Data.Git.Diff
import Data.Git.Graph import Data.Git.Graph
@ -56,7 +54,6 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Traversable (for) import Data.Traversable (for)
import Data.Word (Word32) import Data.Word (Word32)
import Database.Persist import Database.Persist
import System.Exit
import System.FilePath import System.FilePath
import System.Hourglass (timeCurrent) import System.Hourglass (timeCurrent)
import System.Process.Typed import System.Process.Typed
@ -87,6 +84,7 @@ import Data.EventTime.Local
import Data.Git.Local import Data.Git.Local
import Data.List.Local import Data.List.Local
import Data.Patch.Local hiding (Patch) import Data.Patch.Local hiding (Patch)
import System.Process.Typed.Local
import qualified Data.Patch.Local as P import qualified Data.Patch.Local as P
import qualified Data.Text.UTF8.Local as TU import qualified Data.Text.UTF8.Local as TU
@ -372,7 +370,7 @@ generateGitPatches
-> FilePath -- ^ Temporary directory to use for the operation -> FilePath -- ^ Temporary directory to use for the operation
-> ExceptT Text IO (NonEmpty Text) -> ExceptT Text IO (NonEmpty Text)
generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDir = do 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 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 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] 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 Right t -> return t
where -- Since 'git am' doesn't work on a bare repo, clone target repo into the given
-- temporary directory, apply there, and finally push
runProcessE name spec = do applyGitPatches repoPath branch patches tempDir = do
exitCode <- runProcess spec runProcessE "git clone" $ proc "git" ["clone", "--verbose", "--single-branch", "--branch", branch, "--", repoPath, tempDir]
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
let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches
readProcessE "git checkout" $ proc "git" ["-C", path, "checkout", T.unpack branch] runProcessE "git am" $ setStdin (byteStringInput input) $ proc "git" ["-C", tempDir, "am"]
readProcessE "git am" $ setStdin (byteStringInput input) $ proc "git" ["-C", "'" ++ path ++ "'", "am"] runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.name", "vervis"]
where runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.email", "vervis@vervis.vervis"]
readProcessE name spec = do runProcessE "git push" $ proc "git" ["-C", tempDir, "push"]
(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
-}

6
src/Vervis/Handler/Person.hs
View file

@ -276,6 +276,8 @@ postPersonOutboxR personHash = do
case specific of case specific of
AP.AcceptActivity accept -> AP.AcceptActivity accept ->
acceptC eperson actorDB summary audience accept acceptC eperson actorDB summary audience accept
AP.ApplyActivity apply ->
applyC eperson actorDB mcap summary audience apply
AP.CreateActivity (AP.Create obj mtarget) -> AP.CreateActivity (AP.Create obj mtarget) ->
case obj of case obj of
{- {-
@ -297,8 +299,8 @@ postPersonOutboxR personHash = do
Right (AddBundle patches) -> Right (AddBundle patches) ->
addBundleC eperson sharer summary audience patches target addBundleC eperson sharer summary audience patches target
_ -> throwE "Unsupported Add 'object' type" _ -> throwE "Unsupported Add 'object' type"
ApplyActivity apply -> -}
applyC eperson sharer summary audience mcap apply {-
FollowActivity follow -> FollowActivity follow ->
followC shr summary audience follow followC shr summary audience follow
-} -}

1
vervis.cabal
View file

@ -100,6 +100,7 @@ library
Network.HTTP.Client.Conduit.ActivityPub Network.HTTP.Client.Conduit.ActivityPub
Network.HTTP.Digest Network.HTTP.Digest
Network.SSH.Local Network.SSH.Local
System.Process.Typed.Local
Text.Blaze.Local Text.Blaze.Local
Text.Display Text.Display
Text.Email.Local Text.Email.Local