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
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 []