src/Darcs/Commands/Push.lhs

   1 %  Copyright (C) 2002-2004 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18 \subsection{darcs push}
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 module Darcs.Commands.Push ( push ) where
  24 import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ) )
  25 import Control.Monad ( when )
  26 import Data.Char ( toUpper )
  27 import Workaround ( getCurrentDirectory )
  28 import Darcs.Commands ( DarcsCommand(..) )
  29 import Darcs.Arguments ( DarcsFlag( DryRun, Verbose, Quiet, Sign, SignAs, NoSign, SignSSL ),
  30                          definePatches,
  31                          working_repo_dir, summary,
  32                          print_dry_run_message_and_exit,
  33                          applyas, match_several, fixUrl, deps_sel,
  34                          all_interactive, dry_run, nolinks,
  35                          remote_repo, network_options,
  36                          set_default, sign, allow_unrelated_repos
  37                       )
  38 import Darcs.Hopefully ( hopefully )
  39 import Darcs.Repository ( withRepoReadLock, ($-), identifyRepositoryFor, slurp_recorded,
  40                           read_repo, amInRepository, checkUnrelatedRepos )
  41 import Darcs.Patch ( description )
  42 import Darcs.Ordered ( RL(..), (:>)(..), (:\/:)(..),
  43                              nullFL, reverseRL, mapFL_FL, unsafeUnRL, mapRL, lengthRL )
  44 import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist )
  45 import Darcs.External ( maybeURLCmd, signString )
  46 import Darcs.URL ( is_url, is_file )
  47 import Darcs.SelectChanges ( with_selected_changes )
  48 import Darcs.Utils ( formatPath )
  49 import Darcs.Patch.Depends ( get_common_and_uncommon )
  50 import Darcs.Patch.Bundle ( make_bundle )
  51 import Printer ( vcat, empty, text, ($$), (<+>), putDocLn, errorDoc )
  52 import Darcs.RemoteApply ( remote_apply, apply_as )
  53 import Darcs.Email ( make_email )
  54 import English (englishNum, Noun(..))
  55 #include "impossible.h"
  56 \end{code}
  57 \begin{code}
  58 push_description :: String
  59 push_description =
  60  "Copy and apply patches from this repository to another one."
  61 \end{code}
  62
  63 \options{push}
  64 \haskell{push_help}
  65 \begin{code}
  66 push_help :: String
  67 push_help =
  68  "Push is the opposite of pull.  Push allows you to copy changes from the\n"++
  69  "current repository into another repository.\n"
  70 \end{code}
  71 \begin{code}
  72 push :: DarcsCommand
  73 push = DarcsCommand {command_name = "push",
  74                      command_help = push_help,
  75                      command_description = push_description,
  76                      command_extra_args = 1,
  77                      command_extra_arg_help = ["[REPOSITORY]"],
  78                      command_command = push_cmd,
  79                      command_prereq = amInRepository,
  80                      command_get_arg_possibilities = get_preflist "repos",
  81                      command_argdefaults = defaultrepo,
  82                      command_advanced_options = [applyas,
  83                                                  nolinks,
  84                                                  remote_repo] ++
  85                                                 network_options,
  86                      command_basic_options = [match_several, deps_sel,
  87                                               all_interactive,
  88                                               sign]++dry_run++[summary,
  89                                               working_repo_dir,
  90                                               set_default,
  91                                               allow_unrelated_repos]}
  92 \end{code}
  93 \begin{code}
  94 push_cmd :: [DarcsFlag] -> [String] -> IO ()
  95 push_cmd opts [""] = push_cmd opts []
  96 push_cmd opts [unfixedrepodir] =
  97   let am_verbose = Verbose `elem` opts
  98       am_quiet = Quiet `elem` opts
  99       putVerbose s = when am_verbose $ putDocLn s
 100       putInfo s = when (not am_quiet) $ putDocLn s
 101   in
 102  do
 103  repodir <- fixUrl opts unfixedrepodir
 104  -- Test to make sure we aren't trying to push to the current repo
 105  here <- getCurrentDirectory
 106  when (repodir == here) $
 107        fail "Can't push to current repository!"
 108        -- absolute '.' also taken into account by fix_filepath
 109  (bundle,num_to_pull) <- withRepoReadLock opts $- \repository -> do
 110   if is_url repodir then do
 111        when (apply_as opts /= Nothing) $
 112            let msg = text "Cannot --apply-as when pushing to URLs" in
 113              if DryRun `elem` opts
 114              then putInfo $ text "NOTE: " <+> msg
 115                          $$ text ""
 116              else errorDoc msg
 117        maybeapply <- maybeURLCmd "APPLY" repodir
 118        when (maybeapply == Nothing) $
 119          let lprot = takeWhile (/= ':') repodir
 120              prot = map toUpper lprot
 121              msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++
 122                          "You may be able to hack this to work"++
 123                          " using DARCS_APPLY_"++prot) in
 124            if DryRun `elem` opts
 125            then putInfo $ text "NOTE:" <+> msg
 126                        $$ text ""
 127            else errorDoc msg
 128    else do
 129        when (want_sign opts) $
 130         let msg = text "Signing doesn't make sense for local repositories or when pushing over ssh."
 131         in if DryRun `elem` opts
 132             then putInfo $ text "NOTE:" <+> msg
 133             else errorDoc msg
 134   them <- identifyRepositoryFor repository repodir >>= read_repo
 135   old_default <- get_preflist "defaultrepo"
 136   set_defaultrepo repodir opts
 137   when (old_default == [repodir]) $
 138        let pushing = if DryRun `elem` opts then "Would push" else "Pushing"
 139        in  putInfo $ text $ pushing++" to "++formatPath repodir++"..."
 140   us <- read_repo repository
 141   case get_common_and_uncommon (us, them) of
 142     (common, us' :\/: them') -> do
 143      checkUnrelatedRepos opts common us them
 144      putVerbose $ text "We have the following patches to push:"
 145                $$ (vcat $ mapRL description $ head $ unsafeUnRL us')
 146      firstUs <- case us' of
 147                    NilRL:<:NilRL -> do putInfo $ text "No recorded local changes to push!"
 148                                        exitWith ExitSuccess
 149                    NilRL -> bug "push_cmd: us' is empty!"
 150                    (x:<:_) -> return x
 151      s <- slurp_recorded repository
 152      with_selected_changes "push" opts s (reverseRL firstUs) $
 153       \ (to_be_pushed:>_) -> do
 154       definePatches to_be_pushed
 155       print_dry_run_message_and_exit "push" opts to_be_pushed
 156       when (nullFL to_be_pushed) $ do
 157           putInfo $
 158             text "You don't want to push any patches, and that's fine with me!"
 159           exitWith ExitSuccess
 160       let num_to_pull = lengthRL $ head $ unsafeUnRL them'
 161           bundle = make_bundle []
 162                      (bug "using slurpy in make_bundle called from Push")
 163                      common (mapFL_FL hopefully to_be_pushed)
 164       return (bundle, num_to_pull)
 165  sbundle <- signString opts bundle
 166  let body = if is_file repodir
 167             then sbundle
 168             else make_email repodir Nothing sbundle Nothing
 169  rval <- remote_apply opts repodir body
 170  let pull_reminder =
 171          if num_to_pull > 0
 172          then text $ "(By the way, the remote repository has " ++ show num_to_pull ++ " "
 173                      ++ englishNum num_to_pull (Noun "patch") " to pull.)"
 174          else empty
 175  case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"
 176                                    exitWith (ExitFailure ec)
 177               ExitSuccess -> putInfo $ text "Push successful." $$ pull_reminder
 178
 179 push_cmd _ _ = impossible
 180 \end{code}
 181 \begin{code}
 182 want_sign :: [DarcsFlag] -> Bool
 183 want_sign opts = case opts of
 184     []            -> False
 185     Sign:_        -> True
 186     (SignAs _):_  -> True
 187     (SignSSL _):_ -> True
 188     NoSign:_      -> False
 189     _:opts'       -> want_sign opts'
 190 \end{code}
 191
 192 For obvious reasons, you can only push to repositories to which you have
 193 write access.  In addition, you can only push to repos that you access
 194 either on the local file system or with ssh.  In order to apply with ssh,
 195 darcs must also be installed on the remote computer.  The command invoked
 196 to run ssh may be configured by the \verb!DARCS_SSH! environment variable
 197 (see subsection~\ref{env:DARCS_SSH}).  The command invoked via ssh is always
 198 \verb!darcs!, i.e.\ the darcs executable must be in the default path on
 199 the remote machine.
 200
 201 Push works by creating a patch bundle, and then running darcs apply in the
 202 target repository using that patch bundle.  This means that the default
 203 options for \emph{apply} in the \emph{target} repository (such as, for
 204 example, \verb!--test!) will affect the behavior of push.  This also means
 205 that push is somewhat less efficient than pull.
 206
 207 When you receive an error message such as
 208 \begin{verbatim}
 209 bash: darcs: command not found
 210 \end{verbatim}
 211 then this means that the darcs on the remote machine could
 212 not be started.  Make sure that the darcs executable is called
 213 \verb!darcs! and is found in the default path.  The default path can
 214 be different in interactive and in non-interactive shells.  Say
 215 \begin{verbatim}
 216 ssh login@remote.machine darcs
 217 \end{verbatim}
 218 to try whether the remote darcs can be found, or
 219 \begin{verbatim}
 220 ssh login@remote.machine 'echo $PATH'
 221 \end{verbatim}
 222 (note the single quotes) to check the default path.
 223
 224 \begin{options}
 225 --apply-as
 226 \end{options}
 227
 228 If you give the \verb!--apply-as! flag, darcs will use sudo to apply the
 229 changes as a different user.  This can be useful if you want to set up a
 230 system where several users can modify the same repository, but you don't
 231 want to allow them full write access.  This isn't secure against skilled
 232 malicious attackers, but at least can protect your repository from clumsy,
 233 inept or lazy users.
 234
 235 \begin{options}
 236 --matches, --patches, --tags, --no-deps
 237 \end{options}
 238
 239 The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!
 240 options can be used to select which patches to push, as described in
 241 subsection~\ref{selecting}.
 242
 243 When there are conflicts, the behavior of push is determined by the default
 244 flags to \verb!apply! in the \emph{target} repository.  Most commonly, for
 245 pushed-to repositories, you'd like to have \verb!--dont-allow-conflicts! as
 246 a default option to apply (by default, it is already the default\ldots).  If
 247 this is the case, when there are conflicts on push, darcs will fail with an
 248 error message.  You can then resolve by pulling the conflicting patch,
 249 recording a resolution and then pushing the resolution together with the
 250 conflicting patch.
 251
 252 Darcs does not have an explicit way to tell you which patch conflicted, only the
 253 file name. You may want to pull all the patches from the remote repository just
 254 to be sure. If you don't want to do this in your working directory,
 255 you can create another darcs working directory for this purpose.
 256
 257 If you want, you could set the target repository to use \verb!--allow-conflicts!.
 258 In this case conflicting patches will be applied, but the conflicts will
 259 not be marked in the working directory.
 260
 261 If, on the other hand, you have \verb!--mark-conflicts! specified as a
 262 default flag for apply in the target repository, when there is a conflict,
 263 it will be marked in the working directory of the target repository.  In
 264 this case, you should resolve the conflict in the target repository itself.