\subsection{darcs put}
\begin{code}
module Darcs.Commands.Put ( put ) where
import System.Exit ( ExitCode( ExitSuccess, ExitFailure ), exitWith )
import Control.Monad ( when )
import Data.Maybe ( catMaybes )
import System.Directory ( createDirectory )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag( Quiet, Verbose,
UseFormat2, UseHashedInventory, UseOldFashionedInventory ),
applyas, match_one_context, fixUrl,
network_options, flagToString, get_inventory_choices,
set_scripts_executable, working_repo_dir, set_default
)
import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository )
import Darcs.Repository.Format ( identifyRepoFormat,
RepoProperty ( Darcs2, HashedInventory ), format_has )
import Darcs.Patch.Bundle ( make_bundle2 )
import Darcs.Ordered ( FL(..) )
import Darcs.Match ( have_patchset_match, get_one_patchset )
import Darcs.Repository.Prefs ( get_preflist, set_defaultrepo )
import Darcs.URL ( is_url, is_file )
import Darcs.Utils ( withCurrentDirectory )
import Progress ( debugMessage )
import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )
import Darcs.SlurpDirectory ( empty_slurpy )
import Darcs.External ( execSSH )
import Darcs.RemoteApply ( remote_apply )
import Darcs.Commands.Init ( initialize )
import Darcs.Email ( make_email )
import Darcs.Sealed ( Sealed(..), seal )
#include "impossible.h"
put_description :: String
put_description =
"Makes a copy of the repository"
\end{code}
\options{put}
\haskell{put_help}
\begin{code}
put_help :: String
put_help =
"The `darcs put' command creates a copy of the current repository. It\n" ++
"is currently very inefficient, so when creating local copies you\n" ++
"should use `darcs get . x' instead of `darcs put x'.\n" ++
"\n" ++
"Currently this command just uses `darcs init' to create the target\n" ++
"repository, then `darcs push --all' to copy patches to it. Options\n" ++
"passed to `darcs put' are passed to the init and/or push commands as\n" ++
"appropriate. See those commands for an explanation of each option.\n"
put ::DarcsCommand
put = DarcsCommand {command_name = "put",
command_help = put_help,
command_description = put_description,
command_extra_args = 1,
command_extra_arg_help = ["<NEW REPOSITORY>"],
command_command = put_cmd,
command_prereq = amInRepository,
command_get_arg_possibilities = get_preflist "repos",
command_argdefaults = nodefaults,
command_advanced_options = [applyas] ++ network_options,
command_basic_options = [match_one_context, set_scripts_executable,
get_inventory_choices,
set_default, working_repo_dir]}
put_cmd :: [DarcsFlag] -> [String] -> IO ()
put_cmd _ [""] = fail "Empty repository argument given to put."
put_cmd opts [unfixedrepodir] =
let am_quiet = Quiet `elem` opts
putInfo s = when (not am_quiet) $ putStrLn s
putVerbose = when (Verbose `elem` opts) . putStrLn
in
do
repodir <- fixUrl opts unfixedrepodir
t_cur_absolute_repo_dir <- ioAbsoluteOrRemote "."
t_req_absolute_repo_dir <- ioAbsoluteOrRemote repodir
let cur_absolute_repo_dir = toPath t_cur_absolute_repo_dir
req_absolute_repo_dir = toPath t_req_absolute_repo_dir
when (cur_absolute_repo_dir == req_absolute_repo_dir) $
fail "Can't put to current repository!"
when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!"
debugMessage "Creating repository"
putVerbose "Creating repository"
rf_or_e <- identifyRepoFormat "."
rf <- case rf_or_e of Left e -> fail e
Right x -> return x
let initopts = if format_has Darcs2 rf
then UseFormat2:filter (/= UseOldFashionedInventory) opts
else if format_has HashedInventory rf &&
not (UseOldFashionedInventory `elem` opts)
then UseHashedInventory:filter (/= UseFormat2) opts
else filter (/= UseFormat2) opts
if is_file req_absolute_repo_dir
then do createDirectory req_absolute_repo_dir
withCurrentDirectory req_absolute_repo_dir $ (command_command initialize) initopts []
else do
remoteInit req_absolute_repo_dir initopts
withCurrentDirectory cur_absolute_repo_dir $
withRepoReadLock opts $- \repository -> do
set_defaultrepo req_absolute_repo_dir opts
Sealed patchset <- if have_patchset_match opts
then get_one_patchset repository opts
else read_repo repository >>= (return . seal)
Sealed patchset2 <- if have_patchset_match opts
then get_one_patchset repository opts
else read_repo repository >>= (return . seal)
let patches = patchSetToPatches patchset
patches2 = patchSetToPatches patchset2
nullFL NilFL = True
nullFL _ = False
when (nullFL patches) $ do
putInfo "No patches were selected to put. Nothing to be done."
exitWith ExitSuccess
let bundle = (make_bundle2 opts empty_slurpy [] patches patches2)
message = if is_file req_absolute_repo_dir
then bundle
else make_email req_absolute_repo_dir [] Nothing bundle Nothing
putVerbose "Applying patches in new repository..."
rval <- remote_apply opts req_absolute_repo_dir message
case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"
exitWith (ExitFailure ec)
ExitSuccess -> putInfo "Put successful."
put_cmd _ _ = impossible
remoteInit :: FilePath -> [DarcsFlag] -> IO ()
remoteInit repo opts = do
let args = catMaybes $ map (flagToString $ command_basic_options initialize) opts
command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args
exitCode <- execSSH addr command
when (exitCode /= ExitSuccess) $
fail "Couldn't initialize remote repository."
where (addr,':':path) = break (==':') repo
\end{code}