module Darcs.UI.Commands.Push ( push ) where
import Prelude ()
import Darcs.Prelude
import Prelude hiding ( (^) )
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
, printDryRunMessageAndExit
, setEnvDarcsPatches
, defaultRepo
, amInHashedRepository
)
import Darcs.UI.Flags
( DarcsFlag
, isInteractive, verbosity, isUnified, hasSummary
, hasXmlOutput, selectDeps, applyAs, remoteDarcs
, doReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl )
import Darcs.UI.Options
( DarcsOption, (^), 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, checkUnrelatedRepos )
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.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.Patchy( ShowPatch )
import Darcs.Patch.Set ( PatchSet, Origin )
import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$), RenderMode(..) )
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 )
#include "impossible.h"
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."
]
pushBasicOpts :: DarcsOption a
([O.MatchFlag]
-> O.SelectDeps
-> Maybe Bool
-> O.Sign
-> O.DryRun
-> O.XmlOutput
-> Maybe O.Summary
-> Maybe String
-> Maybe Bool
-> Bool
-> a)
pushBasicOpts
= O.matchSeveral
^ O.selectDeps
^ O.interactive
^ O.sign
^ O.dryRunXml
^ O.summary
^ O.workingRepoDir
^ O.setDefault
^ O.allowUnrelatedRepos
pushAdvancedOpts :: DarcsOption a
(Maybe String -> O.RemoteRepos -> Bool -> O.Compression -> O.NetworkOptions -> a)
pushAdvancedOpts
= O.applyAs
^ O.remoteRepos
^ O.changesReverse
^ O.compress
^ O.network
pushOpts :: DarcsOption a
([O.MatchFlag]
-> O.SelectDeps
-> Maybe Bool
-> O.Sign
-> DryRun
-> O.XmlOutput
-> Maybe O.Summary
-> Maybe String
-> Maybe Bool
-> Bool
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> Maybe String
-> O.RemoteRepos
-> Bool
-> O.Compression
-> O.NetworkOptions
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts
push :: DarcsCommand [DarcsFlag]
push = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "push"
, commandHelp = pushHelp
, commandDescription = pushDescription
, commandExtraArgs = 1
, commandExtraArgHelp = ["[REPOSITORY]"]
, commandCommand = pushCmd
, commandPrereq = amInHashedRepository
, commandGetArgPossibilities = getPreflist "repos"
, commandArgdefaults = defaultRepo
, commandAdvancedOptions = odesc pushAdvancedOpts
, commandBasicOptions = odesc pushBasicOpts
, commandDefaults = defaultFlags pushOpts
, commandCheckOptions = ocheck pushOpts
, commandParseOptions = onormalise pushOpts
}
pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
pushCmd _ _ [""] = impossible
pushCmd (_,o) opts [unfixedrepodir] =
do
repodir <- fixUrl o unfixedrepodir
here <- getCurrentDirectory
checkOptionsSanity opts repodir
when (repodir == here) $
fail "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 _ _ _ = impossible
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 doReverse 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)
(hasSummary O.NoSummary opts)
(dryRun opts)
(hasXmlOutput 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 = hasSummary O.NoSummary flags
, S.withContext = isUnified 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 Standard "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle
applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode
applyViaLocal opts repo bundle =
darcsProgram >>= \darcs ->
pipeDoc Standard darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle
applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode
applyViaSsh opts repo =
pipeDocSSH (parseFlags O.compress opts) Standard 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) Standard 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 []