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

573
src/Vervis/API.hs
View file

@ -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
-- Check input
maybeLocalTarget <- do
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
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"
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 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
unless (shr == shrTarget && rp == rpTarget) $
throwE "Bundle's repo mismatches Apply target"
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)
return
(Entity loomID loom, clothID, ticketID, repoID, maybeBranch, diffs)
-- 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"
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 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
case diffs of
t :| [] -> return t
_ :| (_ : _) ->
throwE "Darcs repo given multiple patch bundles"
applyDarcsPatch repoPath patch
return (shrTarget, rpTarget, repoTarget, mltid, ticketFollowers)
senderHash <- encodeKeyHashid senderPersonID
now <- liftIO getCurrentTime
-- 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
(applyID, deliverHttpApply, maybeDeliverHttpAccept) <- runDBExcept $ do
-- Insert Apply to sender's outbox
applyID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
(luApply, docApply) <-
lift $ insertApplyToOutbox senderHash blinded applyID
-- 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
]
)
Right _u ->
([], [])
actors = repoA
collections = ticketC ++ repoC
in makeRecipientSet
actors
(LocalPersonCollectionSharerFollowers shrUser :
collections
)
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

23
src/Vervis/Darcs.hs
View file

@ -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 ++ "'"]

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

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

61
src/Vervis/Git.hs
View file

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

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

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

1
vervis.cabal
View file

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