% Copyright (C) 2002-2005 David Roundy % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; see the file COPYING. If not, write to % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, % Boston, MA 02110-1301, USA. \darcsCommand{get} \begin{code} {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} module Darcs.Commands.Get ( get, clone ) where import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, createDirectory ) import Workaround ( getCurrentDirectory ) import Data.Maybe ( isJust ) import Control.Monad ( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy, UseFormat2, UseOldFashionedInventory, UseHashedInventory, SetScriptsExecutable, Quiet, OnePattern ), get_context, get_inventory_choices, partial, reponame, match_one_context, set_default, set_scripts_executable, nolinks, network_options ) import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo, createPristineDirectoryTree, tentativelyRemovePatches, patchSetToPatches, patchSetToRepository, copyRepository, tentativelyAddToPending, finalizeRepositoryChanges, sync_repo, setScriptsExecutable ) import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat, RepoProperty ( Darcs2, HashedInventory ), format_has ) import Darcs.Repository.DarcsRepo ( write_inventory ) import qualified Darcs.Repository.DarcsRepo as DR ( read_repo ) import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches, createRepository) import Darcs.Repository.ApplyPatches ( apply_patches ) import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint ) import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert, effect, description ) import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, mapRL, concatRL, reverseRL, lengthFL ) import Darcs.External ( copyFileOrUrl, Cachable(..) ) import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag ) import Darcs.Repository.Prefs ( set_defaultrepo ) import Darcs.Repository.Motd ( show_motd ) import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, ) import Darcs.SignalHandler ( catchInterrupt ) import Darcs.Commands.Init ( initialize ) import Darcs.Match ( have_patchset_match, get_one_patchset ) import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError ) import Progress ( debugMessage ) import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, ) import Darcs.Lock ( writeBinFile ) import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote) import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) import Darcs.Global ( darcsdir ) import English ( englishNum, Noun(..) ) import Darcs.Gorsvet( invalidateIndex ) #include "impossible.h" get_description :: String get_description = "Create a local copy of a repository." get_help :: String get_help = "Get creates a local copy of a repository. The optional second\n" ++ "argument specifies a destination directory for the new copy; if\n" ++ "omitted, it is inferred from the source location.\n" ++ "\n" ++ "By default Darcs will copy every patch from the original repository.\n" ++ "This means the copy is completely independent of the original; you can\n" ++ "operate on the new repository even when the original is inaccessible.\n" ++ "If you expect the original repository to remain accessible, you can\n" ++ "use --lazy to avoid copying patches until they are needed (`copy on\n" ++ "demand'). This is particularly useful when copying a remote\n" ++ "repository with a long history that you don't care about.\n" ++ "\n" ++ "The --lazy option isn't as useful for local copies, because Darcs will\n" ++ "automatically use `hard linking' where possible. As well as saving\n" ++ "time and space, you can move or delete the original repository without\n" ++ "affecting a complete, hard-linked copy. Hard linking requires that\n" ++ "the copy be on the same filesystem and the original repository, and\n" ++ "that the filesystem support hard linking. This includes NTFS, HFS+\n" ++ "and all general-purpose Unix filesystems (such as ext3, UFS and ZFS).\n" ++ "FAT does not support hard links.\n" ++ "\n" ++ "Darcs get will not copy unrecorded changes to the source repository's\n" ++ "working tree.\n" ++ "\n" ++ get_help_tag ++ "\n" ++ -- The remaining help text covers backwards-compatibility options. get_help_partial ++ "\n" ++ "A repository created by `darcs get' will be in the best available\n" ++ "format: it will be able to exchange patches with the source\n" ++ "repository, but will not be directly readable by Darcs binaries older\n" ++ "than 2.0.0. Use the `--old-fashioned-inventory' option if the latter\n" ++ "is required.\n" get :: DarcsCommand get = DarcsCommand {command_name = "get", command_help = get_help, command_description = get_description, command_extra_args = -1, command_extra_arg_help = ["", "[]"], command_command = get_cmd, command_prereq = contextExists, command_get_arg_possibilities = return [], command_argdefaults = nodefaults, command_advanced_options = network_options ++ command_advanced_options initialize, command_basic_options = [reponame, partial, match_one_context, set_default, set_scripts_executable, nolinks, get_inventory_choices]} clone :: DarcsCommand clone = command_alias "clone" get get_cmd :: [DarcsFlag] -> [String] -> IO () get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir] get_cmd opts [inrepodir] = do debugMessage "Starting work on get..." typed_repodir <- ioAbsoluteOrRemote inrepodir let repodir = toPath typed_repodir show_motd opts repodir when (Partial `elem` opts) $ debugMessage "Reading checkpoint..." rfsource_or_e <- identifyRepoFormat repodir rfsource <- case rfsource_or_e of Left e -> fail e Right x -> return x debugMessage $ "Found the format of "++repodir++"..." mysimplename <- make_repo_name opts repodir createDirectory mysimplename setCurrentDirectory mysimplename when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $ putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n" let opts' = if format_has Darcs2 rfsource then UseFormat2:opts else if not (UseOldFashionedInventory `elem` opts) then UseHashedInventory:filter (/= UseFormat2) opts else UseOldFashionedInventory:filter (/= UseFormat2) opts createRepository opts' debugMessage "Finished initializing new directory." set_defaultrepo repodir opts rf_or_e <- identifyRepoFormat "." rf <- case rf_or_e of Left e -> fail e Right x -> return x if format_has HashedInventory rf -- refactor this into repository then writeBinFile (darcsdir++"/hashed_inventory") "" else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch) if not (null [p | OnePattern p <- opts]) -- --to-match given && not (Partial `elem` opts) && not (Lazy `elem` opts) then withRepository opts $- \repository -> do debugMessage "Using economical get --to-match handling" fromrepo <- identifyRepositoryFor repository repodir Sealed patches_to_get <- get_one_patchset fromrepo opts patchSetToRepository fromrepo patches_to_get opts debugMessage "Finished converting selected patch set to new repository" else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo where am_informative = not $ Quiet `elem` opts putInfo s = when am_informative $ putDocLn s get_cmd _ _ = fail "You must provide 'get' with either one or two arguments." -- | called by get_cmd -- assumes that the target repo of the get is the current directory, and that an inventory in the -- right format has already been created. copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO () copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.") withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts putInfo $ text "Finished getting." where copy_repo = withRepository opts $- \repository -> do if format_has HashedInventory rf || format_has HashedInventory rfsource then do debugMessage "Identifying and copying repository..." identifyRepositoryFor repository repodir >>= copyRepository when (SetScriptsExecutable `elem` opts) setScriptsExecutable else copy_repo_old_fashioned repository opts repodir make_repo_name :: [DarcsFlag] -> FilePath -> IO String make_repo_name (NewRepo n:_) _ = do exists <- doesDirectoryExist n file_exists <- doesFileExist n if exists || file_exists then fail $ "Directory or file named '" ++ n ++ "' already exists." else return n make_repo_name (_:as) d = make_repo_name as d make_repo_name [] d = case dropWhile (=='.') $ reverse $ takeWhile (\c -> c /= '/' && c /= ':') $ dropWhile (=='/') $ reverse d of "" -> modify_repo_name "anonymous_repo" base -> modify_repo_name base modify_repo_name :: String -> IO String modify_repo_name name = if head name == '/' then mrn name (-1) else do cwd <- getCurrentDirectory mrn (cwd ++ "/" ++ name) (-1) where mrn :: String -> Int -> IO String mrn n i = do exists <- doesDirectoryExist thename file_exists <- doesFileExist thename if not exists && not file_exists then do when (i /= -1) $ putStrLn $ "Directory '"++ n ++ "' already exists, creating repository as '"++ thename ++"'" return thename else mrn n $ i+1 where thename = if i == -1 then n else n++"_"++show i get_help_tag :: String get_help_tag = "It is often desirable to make a copy of a repository that excludes\n" ++ "some patches. For example, if releases are tagged then `darcs get\n" ++ "--tag .' would make a copy of the repository as at the latest release.\n" ++ "\n" ++ "An untagged repository state can still be identified unambiguously by\n" ++ "a context file, as generated by `darcs changes --context'. Given the\n" ++ "name of such a file, the --context option will create a repository\n" ++ "that includes only the patches from that context. When a user reports\n" ++ "a bug in an unreleased version of your project, the recommended way to\n" ++ "find out exactly what version they were running is to have them\n" ++ "include a context file in the bug report.\n" ++ "\n" ++ "You can also make a copy of an untagged state using the --to-patch or\n" ++ "--to-match options, which exclude patches `after' the first matching\n" ++ "patch. Because these options treat the set of patches as an ordered\n" ++ "sequence, you may get different results after reordering with `darcs\n" ++ "optimize', so tagging is preferred.\n" contextExists :: [DarcsFlag] -> IO (Either String ()) contextExists opts = case get_context opts of Nothing -> return $ Right () Just f -> do exists <- doesFileExist $ toFilePath f if exists then return $ Right () else return . Left $ "Context file "++toFilePath f++" does not exist" go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ()) -> [DarcsFlag] -> IO () go_to_chosen_version repository putInfo opts = when (have_patchset_match opts) $ do debugMessage "Going to specified version..." patches <- read_repo repository Sealed context <- get_one_patchset repository opts let (_,us':\/:them') = get_common_and_uncommon (patches, context) case them' of NilRL:<:NilRL -> return () _ -> errorDoc $ text "Missing these patches from context:" $$ (vcat $ mapRL description $ head $ unsafeUnRL them') let ps = patchSetToPatches us' putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++ (englishNum (lengthFL ps) (Noun "patch") "") invalidateIndex repository withRepoLock opts $- \_ -> do tentativelyRemovePatches repository opts ps tentativelyAddToPending repository opts $ invert $ effect ps finalizeRepositoryChanges repository apply opts (invert $ effect ps) `catch` \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e) sync_repo repository get_help_partial :: String get_help_partial = "If the source repository is in a legacy darcs-1 format and contains at\n" ++ "least one checkpoint (see `darcs optimize'), the --partial option will\n" ++ "create a partial repository. A partial repository discards history\n" ++ "from before the checkpoint in order to reduce resource requirements.\n" ++ "For modern darcs-2 repositories, --partial is a deprecated alias for\n" ++ "the --lazy option.\n" copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO () copy_repo_old_fashioned repository opts repodir = do myname <- getCurrentDirectory fromrepo <- identifyRepositoryFor repository repodir mch <- get_checkpoint fromrepo patches <- read_repo fromrepo debugMessage "Getting the inventory..." write_inventory "." patches debugMessage "Copying patches..." copy_oldrepo_patches opts fromrepo "." debugMessage "Patches copied" Sealed local_patches <- DR.read_repo opts "." :: IO (SealedPatchSet Patch) debugMessage "Repo read" repo_is_local <- doesDirectoryExist repodir debugMessage $ "Repo local: " ++ formatPath (show repo_is_local) if repo_is_local && not (Partial `elem` opts) then do debugMessage "Copying prefs" copyFileOrUrl opts (repodir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600) `catchall` return () debugMessage "Writing working directory" createPristineDirectoryTree fromrepo myname withCurrentDirectory myname $ do -- note: SetScriptsExecutable is normally checked in PatchApply -- but darcs get on local repositories does not apply patches if SetScriptsExecutable `elem` opts then setScriptsExecutable else return () else do setCurrentDirectory myname if Partial `elem` opts && isJust mch then let Sealed p_ch = fromJust mch pi_ch = patch2patchinfo p_ch needed_patches = reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag pi_ch local_patches in do write_checkpoint_patch p_ch apply opts p_ch `catch` \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e) apply_patches opts needed_patches else apply_patches opts $ reverseRL $ concatRL local_patches debugMessage "Writing the pristine" pristine <- identifyPristine createPristineFromWorking pristine setCurrentDirectory myname debugMessage "Syncing the repository..." sync_repo repository debugMessage "Repository synced." \end{code}