1 \darcsCommand{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 Progress ( debugMessage )
   28 import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )
   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 
   37 put_description :: String 
   38 put_description =
   39  "Makes a copy of the repository"
   40 
   41 put_help :: String
   42 put_help =
   43  "The `darcs put' command creates a copy of the current repository.  It\n" ++
   44  "is currently very inefficient, so when creating local copies you\n" ++
   45  "should use `darcs get . x' instead of `darcs put x'.\n" ++
   46  "\n" ++
   47  "Currently this command just uses `darcs init' to create the target\n" ++
   48  "repository, then `darcs push --all' to copy patches to it.  Options\n" ++
   49  "passed to `darcs put' are passed to the init and/or push commands as\n" ++
   50  "appropriate.  See those commands for an explanation of each option.\n"
   51 
   52 put ::DarcsCommand
   53 put = DarcsCommand {command_name = "put",
   54                     command_help = put_help,
   55                     command_description = put_description,
   56                     command_extra_args = 1,
   57                     command_extra_arg_help = ["<NEW REPOSITORY>"],
   58                     command_command = put_cmd,
   59                     command_prereq = amInRepository,
   60                     command_get_arg_possibilities = get_preflist "repos",
   61                     command_argdefaults = nodefaults,
   62                     command_advanced_options = [applyas] ++ network_options,
   63                     command_basic_options = [match_one_context, set_scripts_executable,
   64                                              get_inventory_choices,
   65                                              set_default, working_repo_dir]}
   66 
   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  t_cur_absolute_repo_dir <- ioAbsoluteOrRemote "."
   78  t_req_absolute_repo_dir <- ioAbsoluteOrRemote repodir
   79  let cur_absolute_repo_dir = toPath t_cur_absolute_repo_dir
   80      req_absolute_repo_dir = toPath t_req_absolute_repo_dir
   81  when (cur_absolute_repo_dir == req_absolute_repo_dir) $
   82        fail "Can't put to current repository!"
   83  when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!"
   84 
   85  debugMessage "Creating repository"
   86  putVerbose "Creating repository"
   87  rf_or_e <- identifyRepoFormat "."
   88  rf <- case rf_or_e of Left e -> fail e
   89                        Right x -> return x
   90  let initopts = if format_has Darcs2 rf
   91                 then UseFormat2:filter (/= UseOldFashionedInventory) opts
   92                 else if format_has HashedInventory rf &&
   93                         not (UseOldFashionedInventory `elem` opts)
   94                      then UseHashedInventory:filter (/= UseFormat2) opts
   95                      else UseOldFashionedInventory:filter (/= UseFormat2) opts
   96  if is_file req_absolute_repo_dir
   97      then do createDirectory req_absolute_repo_dir
   98              withCurrentDirectory req_absolute_repo_dir $ (command_command initialize) initopts []
   99      else do -- is_ssh req_absolute_repo_dir
  100              remoteInit req_absolute_repo_dir initopts
  101 
  102  withCurrentDirectory cur_absolute_repo_dir $
  103                       withRepoReadLock opts $- \repository -> do
  104   set_defaultrepo req_absolute_repo_dir opts
  105   Sealed patchset <- if have_patchset_match opts
  106                      then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type
  107                      else read_repo repository >>= (return . seal)
  108   Sealed patchset2 <- if have_patchset_match opts
  109                       then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type
  110                       else read_repo repository >>= (return . seal)
  111   let patches = patchSetToPatches patchset
  112       patches2 = patchSetToPatches patchset2
  113       nullFL NilFL = True
  114       nullFL _ = False
  115   when (nullFL patches) $ do
  116           putInfo "No patches were selected to put. Nothing to be done."
  117           exitWith ExitSuccess
  118   let bundle = (make_bundle2 opts empty_slurpy [] patches patches2)
  119       message = if is_file req_absolute_repo_dir
  120                 then bundle
  121                 else make_email req_absolute_repo_dir [] Nothing bundle Nothing
  122   putVerbose "Applying patches in new repository..."
  123   rval <- remote_apply opts req_absolute_repo_dir message
  124   case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"
  125                                     exitWith (ExitFailure ec)
  126                ExitSuccess -> putInfo "Put successful."
  127 put_cmd _ _ = impossible                                                                                                       
  128 
  129 remoteInit :: FilePath -> [DarcsFlag] -> IO ()
  130 remoteInit repo opts = do
  131     let args = catMaybes $ map (flagToString $ command_basic_options initialize) opts
  132         command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args
  133     exitCode <- execSSH addr command
  134     when (exitCode /= ExitSuccess) $ 
  135          fail "Couldn't initialize remote repository."
  136   where (addr,':':path) = break (==':') repo
  137 \end{code}