-- Copyright (C) 2002-2004 David Roundy -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2, or (at your option) -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; see the file COPYING. If not, write to -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. {-# LANGUAGE TypeOperators #-} module Darcs.UI.Commands.Push ( push ) where import Prelude () import Darcs.Prelude import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ), exitSuccess ) import Control.Monad ( when, unless ) import Data.Maybe ( isJust ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , putVerbose , putInfo , abortRun , setEnvDarcsPatches , defaultRepo , amInHashedRepository ) import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos ) import Darcs.UI.Completion ( prefArgs ) import Darcs.UI.Flags ( DarcsFlag , isInteractive, verbosity, withContext , xmlOutput, selectDeps, applyAs, remoteDarcs , changesReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl ) import Darcs.UI.Options ( (^), odesc, ocheck, onormalise , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( DryRun (..) ) import qualified Darcs.Repository.Flags as R ( remoteDarcs ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully ) import Darcs.Repository ( Repository, withRepository, RepoJob(..), identifyRepositoryFor, readRepo ) import Darcs.Patch ( IsRepoType, RepoPatch, description ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), RL, FL, nullRL, nullFL, reverseFL, mapFL_FL, mapRL ) import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) import Darcs.UI.External ( signString, darcsProgram , pipeDoc, pipeDocSSH ) import Darcs.Util.Exception ( die ) import Darcs.Util.URL ( isHttpUrl, isValidLocalPath , isSshUrl, splitSshUrl, SshFilePath(..) ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.UI.SelectChanges ( WhichChanges(..) , selectionContext , runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Patch.Depends ( findCommonWithThem, countUsThem ) import Darcs.Patch.Bundle ( makeBundleN ) import Darcs.Patch.Show( ShowPatch ) import Darcs.Patch.Set ( PatchSet, Origin ) import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$) ) import Darcs.UI.Email ( makeEmail ) import Darcs.Util.English (englishNum, Noun(..)) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.Text ( quote ) import Darcs.Util.Tree( Tree ) pushDescription :: String pushDescription = "Copy and apply patches from this repository to another one." pushHelp :: String pushHelp = unlines [ "Push is the opposite of pull. Push allows you to copy patches from the" , "current repository into another repository." , "" , "If you give the `--apply-as` flag, darcs will use `sudo` to apply the" , "patches as a different user. This can be useful if you want to set up a" , "system where several users can modify the same repository, but you don't" , "want to allow them full write access. This isn't secure against skilled" , "malicious attackers, but at least can protect your repository from clumsy," , "inept or lazy users." , "" , "`darcs push` will compress the patch data before sending it to a remote" , "location via ssh. This works as long as the remote darcs is not older" , "than version 2.5. If you get errors that indicate a corrupt patch bundle," , "you should try again with the `--no-compress` option." ] push :: DarcsCommand [DarcsFlag] push = DarcsCommand { commandProgramName = "darcs" , commandName = "push" , commandHelp = pushHelp , commandDescription = pushDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[REPOSITORY]"] , commandCommand = pushCmd , commandPrereq = amInHashedRepository , commandCompleteArgs = prefArgs "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc pushAdvancedOpts , commandBasicOptions = odesc pushBasicOpts , commandDefaults = defaultFlags pushOpts , commandCheckOptions = ocheck pushOpts , commandParseOptions = onormalise pushOpts } where pushBasicOpts = O.matchSeveral ^ O.selectDeps ^ O.interactive ^ O.sign ^ O.dryRunXml ^ O.summary ^ O.repoDir ^ O.setDefault ^ O.allowUnrelatedRepos pushAdvancedOpts = O.applyAs ^ O.remoteRepos ^ O.changesReverse ^ O.compress ^ O.network pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () pushCmd (_, o) opts [unfixedrepodir] = do repodir <- fixUrl o unfixedrepodir here <- getCurrentDirectory checkOptionsSanity opts repodir -- make sure we aren't trying to push to the current repo when (repodir == here) $ die "Cannot push from repository to itself." bundle <- withRepository (useCache ? opts) $ RepoJob $ prepareBundle opts repodir sbundle <- signString (parseFlags O.sign opts) bundle let body = if isValidLocalPath repodir then sbundle else makeEmail repodir [] Nothing Nothing sbundle Nothing rval <- remoteApply opts repodir body case rval of ExitFailure ec -> do putStrLn "Apply failed!" exitWith (ExitFailure ec) ExitSuccess -> putInfo opts $ text "Push successful." pushCmd _ _ [] = die "No default repository to push to, please specify one." pushCmd _ _ _ = die "Cannot push to more than one repo." prepareBundle :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> String -> Repository rt p wR wU wT -> IO Doc prepareBundle opts repodir repository = do old_default <- getPreflist "defaultrepo" when (old_default == [repodir]) $ let pushing = if dryRun ? opts == YesDryRun then "Would push" else "Pushing" in putInfo opts $ text $ pushing++" to "++quote repodir++"..." them <- identifyRepositoryFor repository (useCache ? opts) repodir >>= readRepo addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts) (setDefault False opts) us <- readRepo repository common :> us' <- return $ findCommonWithThem us them prePushChatter opts us (reverseFL us') them let direction = if changesReverse ? opts then FirstReversed else First context = selectionContext direction "push" (pushPatchSelOpts opts) Nothing Nothing runSelection us' context >>= bundlePatches opts common prePushChatter :: forall rt p a wX wY wT . (RepoPatch p, ShowPatch a) => [DarcsFlag] -> PatchSet rt p Origin wX -> RL a wT wX -> PatchSet rt p Origin wY -> IO () prePushChatter opts us us' them = do checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them let num_to_pull = snd $ countUsThem us them pull_reminder = if num_to_pull > 0 then text $ "The remote repository has " ++ show num_to_pull ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull." else empty putVerbose opts $ text "We have the following patches to push:" $$ vcat (mapRL description us') unless (nullRL us') $ putInfo opts pull_reminder when (nullRL us') $ do putInfo opts $ text "No recorded local patches to push!" exitSuccess bundlePatches :: forall t rt p wZ wW wA. (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> PatchSet rt p wA wZ -> (FL (PatchInfoAnd rt p) :> t) wZ wW -> IO Doc bundlePatches opts common (to_be_pushed :> _) = do setEnvDarcsPatches to_be_pushed printDryRunMessageAndExit "push" (verbosity ? opts) (O.summary ? opts) (dryRun ? opts) (xmlOutput ? opts) (isInteractive True opts) to_be_pushed when (nullFL to_be_pushed) $ do putInfo opts $ text "You don't want to push any patches, and that's fine with me!" exitSuccess makeBundleN Nothing common (mapFL_FL hopefully to_be_pushed) checkOptionsSanity :: [DarcsFlag] -> String -> IO () checkOptionsSanity opts repodir = if isHttpUrl repodir then do when (isJust $ applyAs ? opts) $ abortRun opts $ text "Cannot --apply-as when pushing to URLs" let lprot = takeWhile (/= ':') repodir msg = text ("Pushing to "++lprot++" URLs is not supported.") abortRun opts msg else when (parseFlags O.sign opts /= O.NoSign) $ abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh." pushPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions pushPatchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveral flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps ? flags , S.summary = O.summary ? flags , S.withContext = withContext ? flags } remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode remoteApply opts repodir bundle = case applyAs ? opts of Nothing | isSshUrl repodir -> applyViaSsh opts (splitSshUrl repodir) bundle | otherwise -> applyViaLocal opts repodir bundle Just un | isSshUrl repodir -> applyViaSshAndSudo opts (splitSshUrl repodir) un bundle | otherwise -> applyViaSudo un repodir bundle applyViaSudo :: String -> String -> Doc -> IO ExitCode applyViaSudo user repo bundle = darcsProgram >>= \darcs -> pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode applyViaLocal opts repo bundle = darcsProgram >>= \darcs -> pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode applyViaSsh opts repo = pipeDocSSH (parseFlags O.compress opts) repo [R.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++ " --repodir '"++sshRepo repo++"'"] applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode applyViaSshAndSudo opts repo username = pipeDocSSH (parseFlags O.compress opts) repo ["sudo -u "++username++" "++R.remoteDarcs (remoteDarcs opts)++ " apply --all --repodir '"++sshRepo repo++"'"] applyopts :: [DarcsFlag] -> [String] applyopts opts = if parseFlags O.debug opts then ["--debug"] else []