diff --git a/src/System/Process/Typed/Local.hs b/src/System/Process/Typed/Local.hs new file mode 100644 index 0000000..d7709eb --- /dev/null +++ b/src/System/Process/Typed/Local.hs @@ -0,0 +1,51 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index f4bc1f9..cd2933d 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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 diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 65409b4..b7a783e 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -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 ++ "'"] diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index 05f3daf..81c5951 100644 --- a/src/Vervis/Data/Ticket.hs +++ b/src/Vervis/Data/Ticket.hs @@ -19,6 +19,7 @@ module Vervis.Data.Ticket , Merge (..) , TrackerAndMerge (..) , WorkItemOffer (..) + , checkTip , checkOfferTicket -- These are exported only for Vervis.Client diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 9951e36..e8f5ae0 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -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"] diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index c64b692..ca40d4b 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -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 -} diff --git a/vervis.cabal b/vervis.cabal index 69c354d..db29ad5 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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