{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Push ( push ) where
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
, putFinished
, abortRun
, setEnvDarcsPatches
, defaultRepo
, amInHashedRepository
)
import Darcs.UI.Commands.Clone ( otherHelpInheritDefault )
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
, 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
( RepoJob(..)
, Repository
, identifyRepositoryFor
, ReadingOrWriting(..)
, readRepo
, withRepository
)
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(..)
, selectionConfig
, runSelection
)
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )
import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )
import Darcs.Patch.Bundle ( makeBundle )
import Darcs.Patch.Show( ShowPatch )
import Darcs.Patch.Set ( PatchSet, Origin )
import Darcs.Util.Printer.Color ( ePutDocLn )
import Darcs.Util.Printer
( Doc
, ($$)
, ($+$)
, (<+>)
, empty
, formatWords
, quoted
, text
, vcat
)
import Darcs.UI.Email ( makeEmail )
import Darcs.Util.English (englishNum, Noun(..))
import Darcs.Util.Workaround ( getCurrentDirectory )
import Darcs.Util.Tree( Tree )
pushDescription :: String
pushDescription :: [Char]
pushDescription =
[Char]
"Copy and apply patches from this repository to another one."
pushHelp :: Doc
pushHelp :: Doc
pushHelp =
[[Char]] -> Doc
formatWords
[ [Char]
"Push is the opposite of pull. Push allows you to copy patches from the"
, [Char]
"current repository into another repository."
]
Doc -> Doc -> Doc
$+$ [[Char]] -> Doc
formatWords
[ [Char]
"If you give the `--apply-as` flag, darcs will use `sudo` to apply the"
, [Char]
"patches as a different user. This can be useful if you want to set up a"
, [Char]
"system where several users can modify the same repository, but you don't"
, [Char]
"want to allow them full write access. This isn't secure against skilled"
, [Char]
"malicious attackers, but at least can protect your repository from clumsy,"
, [Char]
"inept or lazy users."
]
Doc -> Doc -> Doc
$+$ [[Char]] -> Doc
formatWords
[ [Char]
"`darcs push` will compress the patch data before sending it to a remote"
, [Char]
"location via ssh. This works as long as the remote darcs is not older"
, [Char]
"than version 2.5. If you get errors that indicate a corrupt patch bundle,"
, [Char]
"you should try again with the `--no-compress` option."
]
Doc -> Doc -> Doc
$+$
Doc
otherHelpInheritDefault
push :: DarcsCommand
push :: DarcsCommand
push = DarcsCommand
{ commandProgramName :: [Char]
commandProgramName = [Char]
"darcs"
, commandName :: [Char]
commandName = [Char]
"push"
, commandHelp :: Doc
commandHelp = Doc
pushHelp
, commandDescription :: [Char]
commandDescription = [Char]
pushDescription
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [[Char]]
commandExtraArgHelp = [[Char]
"[REPOSITORY]"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
pushCmd
, commandPrereq :: [DarcsFlag] -> IO (Either [Char] ())
commandPrereq = [DarcsFlag] -> IO (Either [Char] ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
commandCompleteArgs = [Char]
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [[Char]]
-> IO [[Char]]
prefArgs [Char]
"repos"
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
defaultRepo
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char]
-> RemoteRepos -> Bool -> Compression -> NetworkOptions -> a)
pushAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
([MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Sign
-> DryRun
-> XmlOutput
-> WithSummary
-> Maybe [Char]
-> Maybe Bool
-> InheritDefault
-> Bool
-> a)
pushBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
([MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Sign
-> DryRun
-> XmlOutput
-> WithSummary
-> Maybe [Char]
-> Maybe Bool
-> InheritDefault
-> Bool
-> Maybe StdCmdAction
-> Verbosity
-> Maybe [Char]
-> RemoteRepos
-> Bool
-> Compression
-> NetworkOptions
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
pushOpts
, commandCheckOptions :: [DarcsFlag] -> [[Char]]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [[Char]]
ocheck forall {a}.
DarcsOption
a
([MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Sign
-> DryRun
-> XmlOutput
-> WithSummary
-> Maybe [Char]
-> Maybe Bool
-> InheritDefault
-> Bool
-> Maybe StdCmdAction
-> Verbosity
-> Maybe [Char]
-> RemoteRepos
-> Bool
-> Compression
-> NetworkOptions
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
pushOpts
}
where
pushBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
([MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Sign
-> DryRun
-> XmlOutput
-> WithSummary
-> Maybe [Char]
-> Maybe Bool
-> InheritDefault
-> Bool
-> a)
pushBasicOpts
= MatchOption
O.matchSeveral
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption SelectDeps
O.selectDeps
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe Bool)
O.interactive
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Sign
O.sign
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ forall a. DarcsOption a (DryRun -> XmlOutput -> a)
O.dryRunXml
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption WithSummary
O.withSummary
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe [Char])
O.repoDir
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe Bool)
O.setDefault
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption InheritDefault
O.inheritDefault
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.allowUnrelatedRepos
pushAdvancedOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char]
-> RemoteRepos -> Bool -> Compression -> NetworkOptions -> a)
pushAdvancedOpts
= PrimDarcsOption (Maybe [Char])
O.applyAs
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption RemoteRepos
O.remoteRepos
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.changesReverse
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Compression
O.compress
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption NetworkOptions
O.network
pushOpts :: DarcsOption
a
([MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Sign
-> DryRun
-> XmlOutput
-> WithSummary
-> Maybe [Char]
-> Maybe Bool
-> InheritDefault
-> Bool
-> Maybe StdCmdAction
-> Verbosity
-> Maybe [Char]
-> RemoteRepos
-> Bool
-> Compression
-> NetworkOptions
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
pushOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
([MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Sign
-> DryRun
-> XmlOutput
-> WithSummary
-> Maybe [Char]
-> Maybe Bool
-> InheritDefault
-> Bool
-> a)
pushBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char]
-> RemoteRepos -> Bool -> Compression -> NetworkOptions -> a)
pushAdvancedOpts
pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
pushCmd (AbsolutePath
_, AbsolutePath
o) [DarcsFlag]
opts [[Char]
unfixedrepodir] = do
[Char]
repodir <- AbsolutePath -> [Char] -> IO [Char]
fixUrl AbsolutePath
o [Char]
unfixedrepodir
[Char]
here <- IO [Char]
getCurrentDirectory
[DarcsFlag] -> [Char] -> IO ()
checkOptionsSanity [DarcsFlag]
opts [Char]
repodir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
repodir forall a. Eq a => a -> a -> Bool
== [Char]
here) forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IO a
die [Char]
"Cannot push from repository to itself."
Doc
bundle <-
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag] -> [Char] -> Repository rt p wR wU wT -> IO Doc
prepareBundle [DarcsFlag]
opts [Char]
repodir
Doc
sbundle <- Sign -> Doc -> IO Doc
signString (forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Sign
O.sign [DarcsFlag]
opts) Doc
bundle
let body :: Doc
body =
if [Char] -> Bool
isValidLocalPath [Char]
repodir
then Doc
sbundle
else [Char]
-> [([Char], [Char])]
-> Maybe Doc
-> Maybe [Char]
-> Doc
-> Maybe [Char]
-> Doc
makeEmail [Char]
repodir [] forall a. Maybe a
Nothing forall a. Maybe a
Nothing Doc
sbundle forall a. Maybe a
Nothing
ExitCode
rval <- [DarcsFlag] -> [Char] -> Doc -> IO ExitCode
remoteApply [DarcsFlag]
opts [Char]
repodir Doc
body
case ExitCode
rval of
ExitFailure Int
ec -> do
Doc -> IO ()
ePutDocLn ([Char] -> Doc
text [Char]
"Apply failed!")
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
ec)
ExitCode
ExitSuccess -> [DarcsFlag] -> [Char] -> IO ()
putFinished [DarcsFlag]
opts [Char]
"pushing"
pushCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [] = forall a. [Char] -> IO a
die [Char]
"No default repository to push to, please specify one."
pushCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [[Char]]
_ = forall a. [Char] -> IO a
die [Char]
"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 :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag] -> [Char] -> Repository rt p wR wU wT -> IO Doc
prepareBundle [DarcsFlag]
opts [Char]
repodir Repository rt p wR wU wT
repository = do
[[Char]]
old_default <- [Char] -> IO [[Char]]
getPreflist [Char]
"defaultrepo"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([[Char]]
old_default forall a. Eq a => a -> a -> Bool
== [[Char]
repodir]) forall a b. (a -> b) -> a -> b
$
let pushing :: [Char]
pushing = if PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts forall a. Eq a => a -> a -> Bool
== DryRun
YesDryRun then [Char]
"Would push" else [Char]
"Pushing"
in [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
pushing Doc -> Doc -> Doc
<+> Doc
"to" Doc -> Doc -> Doc
<+> [Char] -> Doc
quoted [Char]
repodir forall a. Semigroup a => a -> a -> a
<> Doc
"..."
PatchSet rt p Origin Any
them <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT vR vU vT.
ReadingOrWriting
-> Repository rt p wR wU wT
-> UseCache
-> [Char]
-> IO (Repository rt p vR vU vT)
identifyRepositoryFor ReadingOrWriting
Writing Repository rt p wR wU wT
repository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) [Char]
repodir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo
[Char]
-> DryRun
-> RemoteRepos
-> SetDefault
-> InheritDefault
-> Bool
-> IO ()
addRepoSource [Char]
repodir (PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption RemoteRepos
remoteRepos forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(Bool -> [DarcsFlag] -> SetDefault
setDefault Bool
False [DarcsFlag]
opts) (PrimDarcsOption InheritDefault
O.inheritDefault forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts)
PatchSet rt p Origin wR
us <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repository
PatchSet rt p Origin wZ
common :> FL (PatchInfoAnd rt p) wZ wR
us' <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
Commute p =>
PatchSet rt p Origin wX
-> PatchSet rt p Origin wY
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wX
findCommonWithThem PatchSet rt p Origin wR
us PatchSet rt p Origin Any
them
forall (rt :: RepoType) (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 [DarcsFlag]
opts PatchSet rt p Origin wR
us (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) wZ wR
us') PatchSet rt p Origin Any
them
let direction :: WhichChanges
direction = if PrimDarcsOption Bool
changesReverse forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts then WhichChanges
FirstReversed else WhichChanges
First
selection_config :: SelectionConfig (PatchInfoAnd rt p)
selection_config = forall (p :: * -> * -> *).
Matchable p =>
WhichChanges
-> [Char]
-> PatchSelectionOptions
-> Maybe (Splitter p)
-> Maybe [AnchoredPath]
-> SelectionConfig p
selectionConfig WhichChanges
direction [Char]
"push" ([DarcsFlag] -> PatchSelectionOptions
pushPatchSelOpts [DarcsFlag]
opts) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
forall (p :: * -> * -> *) wX wY.
(MatchableRP p, ShowPatch p, ShowContextPatch p,
ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd rt p) wZ wR
us' SelectionConfig (PatchInfoAnd rt p)
selection_config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> * -> *) (rt :: RepoType) (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 [DarcsFlag]
opts PatchSet rt p Origin wZ
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 :: forall (rt :: RepoType) (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 [DarcsFlag]
opts PatchSet rt p Origin wX
us RL a wT wX
us' PatchSet rt p Origin wY
them = do
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Bool -> PatchSet rt p Origin wX -> PatchSet rt p Origin wY -> IO ()
checkUnrelatedRepos (forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Bool
O.allowUnrelatedRepos [DarcsFlag]
opts) PatchSet rt p Origin wX
us PatchSet rt p Origin wY
them
let num_to_pull :: Int
num_to_pull = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
Commute p =>
PatchSet rt p Origin wX -> PatchSet rt p Origin wY -> (Int, Int)
countUsThem PatchSet rt p Origin wX
us PatchSet rt p Origin wY
them
pull_reminder :: Doc
pull_reminder = if Int
num_to_pull forall a. Ord a => a -> a -> Bool
> Int
0
then [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"The remote repository has " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
num_to_pull
forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall n. Countable n => Int -> n -> ShowS
englishNum Int
num_to_pull ([Char] -> Noun
Noun [Char]
"patch") [Char]
" to pull."
else Doc
empty
[DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"We have the following patches to push:" Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description RL a wT wX
us')
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Bool
nullRL RL a wT wX
us') forall a b. (a -> b) -> a -> b
$ [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
pull_reminder
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Bool
nullRL RL a wT wX
us') forall a b. (a -> b) -> a -> b
$ do [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"No recorded local patches to push!"
forall a. IO a
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 :: forall (t :: * -> * -> *) (rt :: RepoType) (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 [DarcsFlag]
opts PatchSet rt p wA wZ
common (FL (PatchInfoAnd rt p) wZ wZ
to_be_pushed :> t wZ wW
_) =
do
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wZ wZ
to_be_pushed
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
[Char]
-> Verbosity
-> WithSummary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd rt p) wX wY
-> IO ()
printDryRunMessageAndExit [Char]
"push"
(PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption WithSummary
O.withSummary forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption XmlOutput
xmlOutput forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts)
FL (PatchInfoAnd rt p) wZ wZ
to_be_pushed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wZ wZ
to_be_pushed) forall a b. (a -> b) -> a -> b
$ do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$
[Char] -> Doc
text [Char]
"You don't want to push any patches, and that's fine with me!"
forall a. IO a
exitSuccess
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Maybe (Tree IO)
-> PatchSet rt p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle forall a. Maybe a
Nothing PatchSet rt p wA wZ
common (forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully FL (PatchInfoAnd rt p) wZ wZ
to_be_pushed)
checkOptionsSanity :: [DarcsFlag] -> String -> IO ()
checkOptionsSanity :: [DarcsFlag] -> [Char] -> IO ()
checkOptionsSanity [DarcsFlag]
opts [Char]
repodir =
if [Char] -> Bool
isHttpUrl [Char]
repodir then do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ PrimDarcsOption (Maybe [Char])
applyAs forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
[DarcsFlag] -> Doc -> IO ()
abortRun [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Cannot --apply-as when pushing to URLs"
let lprot :: [Char]
lprot = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
':') [Char]
repodir
msg :: Doc
msg = [Char] -> Doc
text ([Char]
"Pushing to "forall a. [a] -> [a] -> [a]
++[Char]
lprotforall a. [a] -> [a] -> [a]
++[Char]
" URLs is not supported.")
[DarcsFlag] -> Doc -> IO ()
abortRun [DarcsFlag]
opts Doc
msg
else forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Sign
O.sign [DarcsFlag]
opts forall a. Eq a => a -> a -> Bool
/= Sign
O.NoSign) forall a b. (a -> b) -> a -> b
$
[DarcsFlag] -> Doc -> IO ()
abortRun [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Signing doesn't make sense for local repositories or when pushing over ssh."
pushPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
pushPatchSelOpts :: [DarcsFlag] -> PatchSelectionOptions
pushPatchSelOpts [DarcsFlag]
flags = S.PatchSelectionOptions
{ verbosity :: Verbosity
S.verbosity = PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, matchFlags :: [MatchFlag]
S.matchFlags = forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags MatchOption
O.matchSeveral [DarcsFlag]
flags
, interactive :: Bool
S.interactive = Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
flags
, selectDeps :: SelectDeps
S.selectDeps = PrimDarcsOption SelectDeps
selectDeps forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, withSummary :: WithSummary
S.withSummary = PrimDarcsOption WithSummary
O.withSummary forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, withContext :: WithContext
S.withContext = PrimDarcsOption WithContext
withContext forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
}
remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode
remoteApply :: [DarcsFlag] -> [Char] -> Doc -> IO ExitCode
remoteApply [DarcsFlag]
opts [Char]
repodir Doc
bundle
= case PrimDarcsOption (Maybe [Char])
applyAs forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
Maybe [Char]
Nothing
| [Char] -> Bool
isSshUrl [Char]
repodir -> [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode
applyViaSsh [DarcsFlag]
opts ([Char] -> SshFilePath
splitSshUrl [Char]
repodir) Doc
bundle
| Bool
otherwise -> [DarcsFlag] -> [Char] -> Doc -> IO ExitCode
applyViaLocal [DarcsFlag]
opts [Char]
repodir Doc
bundle
Just [Char]
un
| [Char] -> Bool
isSshUrl [Char]
repodir -> [DarcsFlag] -> SshFilePath -> [Char] -> Doc -> IO ExitCode
applyViaSshAndSudo [DarcsFlag]
opts ([Char] -> SshFilePath
splitSshUrl [Char]
repodir) [Char]
un Doc
bundle
| Bool
otherwise -> [Char] -> [Char] -> Doc -> IO ExitCode
applyViaSudo [Char]
un [Char]
repodir Doc
bundle
applyViaSudo :: String -> String -> Doc -> IO ExitCode
applyViaSudo :: [Char] -> [Char] -> Doc -> IO ExitCode
applyViaSudo [Char]
user [Char]
repo Doc
bundle =
IO [Char]
darcsProgram forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
darcs ->
[Char] -> [[Char]] -> Doc -> IO ExitCode
pipeDoc [Char]
"sudo" [[Char]
"-u",[Char]
user,[Char]
darcs,[Char]
"apply",[Char]
"--all",[Char]
"--repodir",[Char]
repo] Doc
bundle
applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode
applyViaLocal :: [DarcsFlag] -> [Char] -> Doc -> IO ExitCode
applyViaLocal [DarcsFlag]
opts [Char]
repo Doc
bundle =
IO [Char]
darcsProgram forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
darcs ->
[Char] -> [[Char]] -> Doc -> IO ExitCode
pipeDoc [Char]
darcs ([Char]
"apply"forall a. a -> [a] -> [a]
:[Char]
"--all"forall a. a -> [a] -> [a]
:[Char]
"--repodir"forall a. a -> [a] -> [a]
:[Char]
repoforall a. a -> [a] -> [a]
:[DarcsFlag] -> [[Char]]
applyopts [DarcsFlag]
opts) Doc
bundle
applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode
applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode
applyViaSsh [DarcsFlag]
opts SshFilePath
repo =
Compression -> SshFilePath -> [[Char]] -> Doc -> IO ExitCode
pipeDocSSH (forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Compression
O.compress [DarcsFlag]
opts) SshFilePath
repo
[RemoteDarcs -> [Char]
R.remoteDarcs ([DarcsFlag] -> RemoteDarcs
remoteDarcs [DarcsFlag]
opts) forall a. [a] -> [a] -> [a]
++[Char]
" apply --all "forall a. [a] -> [a] -> [a]
++[[Char]] -> [Char]
unwords ([DarcsFlag] -> [[Char]]
applyopts [DarcsFlag]
opts)forall a. [a] -> [a] -> [a]
++
[Char]
" --repodir '"forall a. [a] -> [a] -> [a]
++SshFilePath -> [Char]
sshRepo SshFilePath
repoforall a. [a] -> [a] -> [a]
++[Char]
"'"]
applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode
applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> [Char] -> Doc -> IO ExitCode
applyViaSshAndSudo [DarcsFlag]
opts SshFilePath
repo [Char]
username =
Compression -> SshFilePath -> [[Char]] -> Doc -> IO ExitCode
pipeDocSSH (forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Compression
O.compress [DarcsFlag]
opts) SshFilePath
repo
[[Char]
"sudo -u "forall a. [a] -> [a] -> [a]
++[Char]
usernameforall a. [a] -> [a] -> [a]
++[Char]
" "forall a. [a] -> [a] -> [a]
++RemoteDarcs -> [Char]
R.remoteDarcs ([DarcsFlag] -> RemoteDarcs
remoteDarcs [DarcsFlag]
opts)forall a. [a] -> [a] -> [a]
++
[Char]
" apply --all --repodir '"forall a. [a] -> [a] -> [a]
++SshFilePath -> [Char]
sshRepo SshFilePath
repoforall a. [a] -> [a] -> [a]
++[Char]
"'"]
applyopts :: [DarcsFlag] -> [String]
applyopts :: [DarcsFlag] -> [[Char]]
applyopts [DarcsFlag]
opts = if forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Bool
O.debug [DarcsFlag]
opts then [[Char]
"--debug"] else []