Put.lhs

\subsection{darcs put}
\begin{code}
{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}

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 Darcs.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"
\end{code}
\begin{code}
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 = 
 "Put is the opposite of get. Put copies the content of the current \n" ++
 "repository and puts it in a newly created repository.\n"
\end{code}
\begin{code}
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]}
\end{code}
\begin{code}
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
 -- Test to make sure we aren't trying to push to the current repo
 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 -- is_ssh req_absolute_repo_dir
             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  -- todo: make sure get_one_patchset has the right type
                     else read_repo repository >>= (return . seal)
  Sealed patchset2 <- if have_patchset_match opts
                      then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type
                      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}

\emph{WARNING:} Put is far less optimized than get, especially for local
repositories.  We recommend avoiding use of put except for small
repositories.

Put is used when you already have a repository and want to make a copy
of it.  A typical use-case is when you want to branch your project.

Put works by first initializing a repository. If the new repository is
not on the local file system then darcs will login to the remote host
and run \verb!darcs init! there. After the new repository is created
all selected patches will be pushed just as with the command
\verb!push!.

\begin{options}
--apply-as
\end{options}

If you give the \verb!--apply-as! flag, darcs will use sudo to apply the
changes as a different user.  This can be useful if you want to set up a
system where several users can modify the same repository, but you don't
want to allow them full write access.  This isn't secure against skilled
malicious attackers, but at least can protect your repository from clumsy,
inept or lazy users.

\begin{options}
--context, --tag, --to-patch, --to-match
\end{options}
If you want to put a specific version of a repository, you have a few
options.  You can either use the \verb!--tag!, \verb!--to-patch! or
\verb!--to-match! options, or you can use the \verb!--context=FILENAME!
option, which specifies a file containing a context generated with
\verb!darcs changes --context!.  This allows you (for example) to include in
your compiled program an option to output the precise version of the
repository from which it was generated, and then perhaps ask users to
include this information in bug reports.

Note that when specifying \verb!--to-patch! or \verb!--to-match!, you may
get a version of your code that has never before been seen, if the patches
have gotten themselves reordered.  If you ever want to be able to precisely
reproduce a given version, you need either to tag it or create a context
file.