src/Darcs/Commands/Put.lhs

   1 \subsection{darcs put}
   2 \begin{code}
   3 {-# OPTIONS_GHC -cpp #-}
   4 {-# LANGUAGE CPP #-}
   5
   6 module Darcs.Commands.Put ( put ) where
   7 import System.Exit ( ExitCode( ExitSuccess, ExitFailure ), exitWith )
   8 import Control.Monad ( when )
   9 import Data.Maybe ( catMaybes )
  10 import System.Directory ( createDirectory )
  11 import Darcs.Commands ( DarcsCommand(..), nodefaults )
  12 import Darcs.Arguments ( DarcsFlag( Quiet, Verbose,
  13                                     UseFormat2, UseHashedInventory, UseOldFashionedInventory ),
  14                         applyas, match_one_context, fixUrl,
  15                         network_options, flagToString, get_inventory_choices,
  16                         set_scripts_executable, working_repo_dir, set_default
  17                       )
  18 import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository )
  19 import Darcs.Repository.Format ( identifyRepoFormat,
  20                                  RepoProperty ( Darcs2, HashedInventory ), format_has )
  21 import Darcs.Patch.Bundle ( make_bundle2 )
  22 import Darcs.Ordered ( FL(..) )
  23 import Darcs.Match ( have_patchset_match, get_one_patchset )
  24 import Darcs.Repository.Prefs ( get_preflist, set_defaultrepo )
  25 import Darcs.URL ( is_url, is_file )
  26 import Darcs.Utils ( withCurrentDirectory )
  27 import Darcs.Progress ( debugMessage )
  28 import Darcs.FilePathUtils ( absolute_dir )
  29 import Darcs.SlurpDirectory ( empty_slurpy )
  30 import Darcs.External ( execSSH )
  31 import Darcs.RemoteApply ( remote_apply )
  32 import Darcs.Commands.Init ( initialize )
  33 import Darcs.Email ( make_email )
  34 import Darcs.Sealed ( Sealed(..), seal )
  35 #include "impossible.h"
  36 \end{code}
  37 \begin{code}
  38 put_description :: String
  39 put_description =
  40  "Makes a copy of the repository"
  41 \end{code}
  42 \options{put}
  43 \haskell{put_help}
  44 \begin{code}
  45 put_help :: String
  46 put_help =
  47  "Put is the opposite of get. Put copies the content of the current \n" ++
  48  "repository and puts it in a newly created repository.\n"
  49 \end{code}
  50 \begin{code}
  51 put ::DarcsCommand
  52 put = DarcsCommand {command_name = "put",
  53                     command_help = put_help,
  54                     command_description = put_description,
  55                     command_extra_args = 1,
  56                     command_extra_arg_help = ["<NEW REPOSITORY>"],
  57                     command_command = put_cmd,
  58                     command_prereq = amInRepository,
  59                     command_get_arg_possibilities = get_preflist "repos",
  60                     command_argdefaults = nodefaults,
  61                     command_advanced_options = [applyas] ++ network_options,
  62                     command_basic_options = [match_one_context, set_scripts_executable,
  63                                              get_inventory_choices,
  64                                              set_default, working_repo_dir]}
  65 \end{code}
  66 \begin{code}
  67 put_cmd :: [DarcsFlag] -> [String] -> IO ()
  68 put_cmd _ [""] = fail "Empty repository argument given to put."
  69 put_cmd opts [unfixedrepodir] =
  70   let am_quiet = Quiet `elem` opts
  71       putInfo s = when (not am_quiet) $ putStrLn s
  72       putVerbose = when (Verbose `elem` opts) . putStrLn
  73   in
  74  do
  75  repodir <- fixUrl opts unfixedrepodir
  76  -- Test to make sure we aren't trying to push to the current repo
  77  cur_absolute_repo_dir <- absolute_dir "."
  78  req_absolute_repo_dir <- absolute_dir repodir
  79  when (cur_absolute_repo_dir == req_absolute_repo_dir) $
  80        fail "Can't put to current repository!"
  81  when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!"
  82
  83  debugMessage "Creating repository"
  84  putVerbose "Creating repository"
  85  rf_or_e <- identifyRepoFormat "."
  86  rf <- case rf_or_e of Left e -> fail e
  87                        Right x -> return x
  88  let initopts = if format_has Darcs2 rf
  89                 then UseFormat2:filter (/= UseOldFashionedInventory) opts
  90                 else if format_has HashedInventory rf &&
  91                         not (UseOldFashionedInventory `elem` opts)
  92                      then UseHashedInventory:filter (/= UseFormat2) opts
  93                      else filter (/= UseFormat2) opts
  94  if is_file req_absolute_repo_dir
  95      then do createDirectory req_absolute_repo_dir
  96              withCurrentDirectory req_absolute_repo_dir $ (command_command initialize) initopts []
  97      else do -- is_ssh req_absolute_repo_dir
  98              remoteInit req_absolute_repo_dir initopts
  99
 100  withCurrentDirectory cur_absolute_repo_dir $
 101                       withRepoReadLock opts $- \repository -> do
 102   set_defaultrepo req_absolute_repo_dir opts
 103   Sealed patchset <- if have_patchset_match opts
 104                      then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type
 105                      else read_repo repository >>= (return . seal)
 106   Sealed patchset2 <- if have_patchset_match opts
 107                       then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type
 108                       else read_repo repository >>= (return . seal)
 109   let patches = patchSetToPatches patchset
 110       patches2 = patchSetToPatches patchset2
 111       nullFL NilFL = True
 112       nullFL _ = False
 113   when (nullFL patches) $ do
 114           putInfo "No patches were selected to put. Nothing to be done."
 115           exitWith ExitSuccess
 116   let bundle = (make_bundle2 opts empty_slurpy [] patches patches2)
 117       message = if is_file req_absolute_repo_dir
 118                 then bundle
 119                 else make_email req_absolute_repo_dir Nothing bundle Nothing
 120   putVerbose "Applying patches in new repository..."
 121   rval <- remote_apply opts req_absolute_repo_dir message
 122   case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"
 123                                     exitWith (ExitFailure ec)
 124                ExitSuccess -> putInfo "Put successful."
 125 put_cmd _ _ = impossible
 126
 127 remoteInit :: FilePath -> [DarcsFlag] -> IO ()
 128 remoteInit repo opts = do
 129     let args = catMaybes $ map (flagToString $ command_basic_options initialize) opts
 130         command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args
 131     exitCode <- execSSH addr command
 132     when (exitCode /= ExitSuccess) $
 133          fail "Couldn't initialize remote repository."
 134   where (addr,':':path) = break (==':') repo
 135 \end{code}
 136
 137 \emph{WARNING:} Put is far less optimized than get, especially for local
 138 repositories.  We recommend avoiding use of put except for small
 139 repositories.
 140
 141 Put is used when you already have a repository and want to make a copy
 142 of it.  A typical use-case is when you want to branch your project.
 143
 144 Put works by first initializing a repository. If the new repository is
 145 not on the local file system then darcs will login to the remote host
 146 and run \verb!darcs init! there. After the new repository is created
 147 all selected patches will be pushed just as with the command
 148 \verb!push!.
 149
 150 \begin{options}
 151 --apply-as
 152 \end{options}
 153
 154 If you give the \verb!--apply-as! flag, darcs will use sudo to apply the
 155 changes as a different user.  This can be useful if you want to set up a
 156 system where several users can modify the same repository, but you don't
 157 want to allow them full write access.  This isn't secure against skilled
 158 malicious attackers, but at least can protect your repository from clumsy,
 159 inept or lazy users.
 160
 161 \begin{options}
 162 --context, --tag, --to-patch, --to-match
 163 \end{options}
 164 If you want to put a specific version of a repository, you have a few
 165 options.  You can either use the \verb!--tag!, \verb!--to-patch! or
 166 \verb!--to-match! options, or you can use the \verb!--context=FILENAME!
 167 option, which specifies a file containing a context generated with
 168 \verb!darcs changes --context!.  This allows you (for example) to include in
 169 your compiled program an option to output the precise version of the
 170 repository from which it was generated, and then perhaps ask users to
 171 include this information in bug reports.
 172
 173 Note that when specifying \verb!--to-patch! or \verb!--to-match!, you may
 174 get a version of your code that has never before been seen, if the patches
 175 have gotten themselves reordered.  If you ever want to be able to precisely
 176 reproduce a given version, you need either to tag it or create a context
 177 file.