\darcsCommand{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 Storage.Hashed.Tree( emptyTree )
    import Darcs.Commands ( DarcsCommand(..), nodefaults, putVerbose, putInfo )
    import Darcs.Arguments ( DarcsFlag( UseFormat2, UseHashedInventory, UseOldFashionedInventory ),
                            applyas, matchOneContext, fixUrl,
                            networkOptions, flagToString, getInventoryChoices,
                            setScriptsExecutableOption, workingRepoDir, setDefault
                          )
    import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository )
    import Darcs.Repository.Format ( identifyRepoFormat,
                                     RepoProperty ( Darcs2, HashedInventory ), formatHas )
    import Darcs.Patch.Bundle ( make_bundle2 )
    import Darcs.Witnesses.Ordered ( FL(..) )
    import Darcs.Match ( havePatchsetMatch, getOnePatchset )
    import Darcs.Repository.Prefs ( getPreflist, setDefaultrepo )
    import Darcs.URL ( is_url, is_file )
    import Darcs.Utils ( withCurrentDirectory )
    import Progress ( debugMessage )
    import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )
    import Darcs.External ( execSSH )
    import Darcs.RemoteApply ( remote_apply )
    import Darcs.Commands.Init ( initialize )
    import Darcs.Email ( make_email )
    import Darcs.Witnesses.Sealed ( Sealed(..), seal )
    import Printer ( text )
    #include "impossible.h"

    putDescription :: String
    putDescription =
     "Makes a copy of the repository"

    putHelp :: String
    putHelp =
     "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 {commandName = "put",
                        commandHelp = putHelp,
                        commandDescription = putDescription,
                        commandExtraArgs = 1,
                        commandExtraArgHelp = ["<NEW REPOSITORY>"],
                        commandCommand = putCmd,
                        commandPrereq = amInRepository,
                        commandGetArgPossibilities = getPreflist "repos",
                        commandArgdefaults = nodefaults,
                        commandAdvancedOptions = [applyas] ++ networkOptions,
                        commandBasicOptions = [matchOneContext, setScriptsExecutableOption,
                                                 getInventoryChoices,
                                                 setDefault, workingRepoDir]}

    putCmd :: [DarcsFlag] -> [String] -> IO ()
    putCmd _ [""] = fail "Empty repository argument given to put."
    putCmd opts [unfixedrepodir] =
     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 opts $ text "Creating repository"
     rf_or_e <- identifyRepoFormat "."
     rf <- case rf_or_e of Left e -> fail e
                           Right x -> return x
     let initopts = if formatHas Darcs2 rf
                    then UseFormat2:filter (/= UseOldFashionedInventory) opts
                    else if formatHas HashedInventory rf &&
                            not (UseOldFashionedInventory `elem` opts)
                         then UseHashedInventory:filter (/= UseFormat2) opts
                         else UseOldFashionedInventory:filter (/= UseFormat2) opts
     if is_file req_absolute_repo_dir
         then do createDirectory req_absolute_repo_dir
                 withCurrentDirectory req_absolute_repo_dir $ (commandCommand 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
      setDefaultrepo req_absolute_repo_dir opts
      Sealed patchset <- if havePatchsetMatch opts
                         then getOnePatchset repository opts  -- todo: make sure getOnePatchset has the right type
                         else read_repo repository >>= (return . seal)
      Sealed patchset2 <- if havePatchsetMatch opts
                          then getOnePatchset repository opts  -- todo: make sure getOnePatchset 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 opts $ text "No patches were selected to put. Nothing to be done."
              exitWith ExitSuccess
      bundle <- make_bundle2 opts emptyTree [] patches patches2
      let message = if is_file req_absolute_repo_dir
                    then bundle
                    else make_email req_absolute_repo_dir [] Nothing bundle Nothing
      putVerbose opts $ text "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 opts $ text "Put successful."
    putCmd _ _ = impossible

    remoteInit :: FilePath -> [DarcsFlag] -> IO ()
    remoteInit repo opts = do
        let args = catMaybes $ map (flagToString $ commandBasicOptions 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}