1 % Copyright (C) 2002-2005 David Roundy 2 % 3 % This program is free software; you can redistribute it and/or modify 4 % it under the terms of the GNU General Public License as published by 5 % the Free Software Foundation; either version 2, or (at your option) 6 % any later version. 7 % 8 % This program is distributed in the hope that it will be useful, 9 % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 % GNU General Public License for more details. 12 % 13 % You should have received a copy of the GNU General Public License 14 % along with this program; see the file COPYING. If not, write to 15 % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 % Boston, MA 02110-1301, USA. 17 18 \darcsCommand{get} 19 \begin{code} 20 {-# OPTIONS_GHC -cpp #-} 21 {-# LANGUAGE CPP #-} 22 23 module Darcs.Commands.Get ( get, clone ) where 24 25 import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, 26 createDirectory ) 27 import Workaround ( getCurrentDirectory ) 28 import Data.Maybe ( isJust ) 29 import Control.Monad ( when ) 30 31 import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) 32 import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy, 33 UseFormat2, UseOldFashionedInventory, UseHashedInventory, 34 SetScriptsExecutable, Quiet, OnePattern ), 35 get_context, get_inventory_choices, 36 partial, reponame, 37 match_one_context, set_default, set_scripts_executable, nolinks, 38 network_options ) 39 import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo, 40 createPristineDirectoryTree, 41 tentativelyRemovePatches, patchSetToPatches, patchSetToRepository, 42 copyRepository, tentativelyAddToPending, 43 finalizeRepositoryChanges, sync_repo, setScriptsExecutable ) 44 import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat, 45 RepoProperty ( Darcs2, HashedInventory ), format_has ) 46 import Darcs.Repository.DarcsRepo ( write_inventory ) 47 import qualified Darcs.Repository.DarcsRepo as DR ( read_repo ) 48 import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches, 49 createRepository) 50 import Darcs.Repository.ApplyPatches ( apply_patches ) 51 import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint ) 52 import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert, 53 effect, description ) 54 import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, mapRL, concatRL, reverseRL, lengthFL ) 55 import Darcs.External ( copyFileOrUrl, Cachable(..) ) 56 import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag ) 57 import Darcs.Repository.Prefs ( set_defaultrepo ) 58 import Darcs.Repository.Motd ( show_motd ) 59 import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, ) 60 import Darcs.SignalHandler ( catchInterrupt ) 61 import Darcs.Commands.Init ( initialize ) 62 import Darcs.Match ( have_patchset_match, get_one_patchset ) 63 import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError ) 64 import Progress ( debugMessage ) 65 import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, ) 66 import Darcs.Lock ( writeBinFile ) 67 import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote) 68 import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) 69 import Darcs.Global ( darcsdir ) 70 import English ( englishNum, Noun(..) ) 71 import Darcs.Gorsvet( invalidateIndex ) 72 #include "impossible.h" 73 74 get_description :: String 75 get_description = "Create a local copy of a repository." 76 77 get_help :: String 78 get_help = 79 "Get creates a local copy of a repository. The optional second\n" ++ 80 "argument specifies a destination directory for the new copy; if\n" ++ 81 "omitted, it is inferred from the source location.\n" ++ 82 "\n" ++ 83 "By default Darcs will copy every patch from the original repository.\n" ++ 84 "This means the copy is completely independent of the original; you can\n" ++ 85 "operate on the new repository even when the original is inaccessible.\n" ++ 86 "If you expect the original repository to remain accessible, you can\n" ++ 87 "use --lazy to avoid copying patches until they are needed (`copy on\n" ++ 88 "demand'). This is particularly useful when copying a remote\n" ++ 89 "repository with a long history that you don't care about.\n" ++ 90 "\n" ++ 91 "The --lazy option isn't as useful for local copies, because Darcs will\n" ++ 92 "automatically use `hard linking' where possible. As well as saving\n" ++ 93 "time and space, you can move or delete the original repository without\n" ++ 94 "affecting a complete, hard-linked copy. Hard linking requires that\n" ++ 95 "the copy be on the same filesystem and the original repository, and\n" ++ 96 "that the filesystem support hard linking. This includes NTFS, HFS+\n" ++ 97 "and all general-purpose Unix filesystems (such as ext3, UFS and ZFS).\n" ++ 98 "FAT does not support hard links.\n" ++ 99 "\n" ++ 100 "Darcs get will not copy unrecorded changes to the source repository's\n" ++ 101 "working tree.\n" ++ 102 "\n" ++ 103 get_help_tag ++ 104 "\n" ++ 105 -- The remaining help text covers backwards-compatibility options. 106 get_help_partial ++ 107 "\n" ++ 108 "A repository created by `darcs get' will be in the best available\n" ++ 109 "format: it will be able to exchange patches with the source\n" ++ 110 "repository, but will not be directly readable by Darcs binaries older\n" ++ 111 "than 2.0.0. Use the `--old-fashioned-inventory' option if the latter\n" ++ 112 "is required.\n" 113 114 get :: DarcsCommand 115 get = DarcsCommand {command_name = "get", 116 command_help = get_help, 117 command_description = get_description, 118 command_extra_args = -1, 119 command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"], 120 command_command = get_cmd, 121 command_prereq = contextExists, 122 command_get_arg_possibilities = return [], 123 command_argdefaults = nodefaults, 124 command_advanced_options = network_options ++ 125 command_advanced_options initialize, 126 command_basic_options = [reponame, 127 partial, 128 match_one_context, 129 set_default, 130 set_scripts_executable, 131 nolinks, 132 get_inventory_choices]} 133 134 clone :: DarcsCommand 135 clone = command_alias "clone" get 136 137 get_cmd :: [DarcsFlag] -> [String] -> IO () 138 get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir] 139 get_cmd opts [inrepodir] = do 140 debugMessage "Starting work on get..." 141 typed_repodir <- ioAbsoluteOrRemote inrepodir 142 let repodir = toPath typed_repodir 143 show_motd opts repodir 144 when (Partial `elem` opts) $ debugMessage "Reading checkpoint..." 145 rfsource_or_e <- identifyRepoFormat repodir 146 rfsource <- case rfsource_or_e of Left e -> fail e 147 Right x -> return x 148 debugMessage $ "Found the format of "++repodir++"..." 149 mysimplename <- make_repo_name opts repodir 150 createDirectory mysimplename 151 setCurrentDirectory mysimplename 152 when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $ 153 putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n" 154 let opts' = if format_has Darcs2 rfsource 155 then UseFormat2:opts 156 else if not (UseOldFashionedInventory `elem` opts) 157 then UseHashedInventory:filter (/= UseFormat2) opts 158 else UseOldFashionedInventory:filter (/= UseFormat2) opts 159 createRepository opts' 160 debugMessage "Finished initializing new directory." 161 set_defaultrepo repodir opts 162 163 rf_or_e <- identifyRepoFormat "." 164 rf <- case rf_or_e of Left e -> fail e 165 Right x -> return x 166 if format_has HashedInventory rf -- refactor this into repository 167 then writeBinFile (darcsdir++"/hashed_inventory") "" 168 else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch) 169 170 if not (null [p | OnePattern p <- opts]) -- --to-match given 171 && not (Partial `elem` opts) && not (Lazy `elem` opts) 172 then withRepository opts $- \repository -> do 173 debugMessage "Using economical get --to-match handling" 174 fromrepo <- identifyRepositoryFor repository repodir 175 Sealed patches_to_get <- get_one_patchset fromrepo opts 176 patchSetToRepository fromrepo patches_to_get opts 177 debugMessage "Finished converting selected patch set to new repository" 178 else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo 179 where am_informative = not $ Quiet `elem` opts 180 putInfo s = when am_informative $ putDocLn s 181 182 get_cmd _ _ = fail "You must provide 'get' with either one or two arguments." 183 184 -- | called by get_cmd 185 -- assumes that the target repo of the get is the current directory, and that an inventory in the 186 -- right format has already been created. 187 copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO () 188 copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do 189 copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.") 190 withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts 191 putInfo $ text "Finished getting." 192 where copy_repo = 193 withRepository opts $- \repository -> do 194 if format_has HashedInventory rf || format_has HashedInventory rfsource 195 then do debugMessage "Identifying and copying repository..." 196 identifyRepositoryFor repository repodir >>= copyRepository 197 when (SetScriptsExecutable `elem` opts) setScriptsExecutable 198 else copy_repo_old_fashioned repository opts repodir 199 200 make_repo_name :: [DarcsFlag] -> FilePath -> IO String 201 make_repo_name (NewRepo n:_) _ = 202 do exists <- doesDirectoryExist n 203 file_exists <- doesFileExist n 204 if exists || file_exists 205 then fail $ "Directory or file named '" ++ n ++ "' already exists." 206 else return n 207 make_repo_name (_:as) d = make_repo_name as d 208 make_repo_name [] d = 209 case dropWhile (=='.') $ reverse $ 210 takeWhile (\c -> c /= '/' && c /= ':') $ 211 dropWhile (=='/') $ reverse d of 212 "" -> modify_repo_name "anonymous_repo" 213 base -> modify_repo_name base 214 215 modify_repo_name :: String -> IO String 216 modify_repo_name name = 217 if head name == '/' 218 then mrn name (-1) 219 else do cwd <- getCurrentDirectory 220 mrn (cwd ++ "/" ++ name) (-1) 221 where 222 mrn :: String -> Int -> IO String 223 mrn n i = do 224 exists <- doesDirectoryExist thename 225 file_exists <- doesFileExist thename 226 if not exists && not file_exists 227 then do when (i /= -1) $ 228 putStrLn $ "Directory '"++ n ++ 229 "' already exists, creating repository as '"++ 230 thename ++"'" 231 return thename 232 else mrn n $ i+1 233 where thename = if i == -1 then n else n++"_"++show i 234 235 get_help_tag :: String 236 get_help_tag = 237 "It is often desirable to make a copy of a repository that excludes\n" ++ 238 "some patches. For example, if releases are tagged then `darcs get\n" ++ 239 "--tag .' would make a copy of the repository as at the latest release.\n" ++ 240 "\n" ++ 241 "An untagged repository state can still be identified unambiguously by\n" ++ 242 "a context file, as generated by `darcs changes --context'. Given the\n" ++ 243 "name of such a file, the --context option will create a repository\n" ++ 244 "that includes only the patches from that context. When a user reports\n" ++ 245 "a bug in an unreleased version of your project, the recommended way to\n" ++ 246 "find out exactly what version they were running is to have them\n" ++ 247 "include a context file in the bug report.\n" ++ 248 "\n" ++ 249 "You can also make a copy of an untagged state using the --to-patch or\n" ++ 250 "--to-match options, which exclude patches `after' the first matching\n" ++ 251 "patch. Because these options treat the set of patches as an ordered\n" ++ 252 "sequence, you may get different results after reordering with `darcs\n" ++ 253 "optimize', so tagging is preferred.\n" 254 255 contextExists :: [DarcsFlag] -> IO (Either String ()) 256 contextExists opts = 257 case get_context opts of 258 Nothing -> return $ Right () 259 Just f -> do exists <- doesFileExist $ toFilePath f 260 if exists 261 then return $ Right () 262 else return . Left $ "Context file "++toFilePath f++" does not exist" 263 264 go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ()) 265 -> [DarcsFlag] -> IO () 266 go_to_chosen_version repository putInfo opts = 267 when (have_patchset_match opts) $ do 268 debugMessage "Going to specified version..." 269 patches <- read_repo repository 270 Sealed context <- get_one_patchset repository opts 271 let (_,us':\/:them') = get_common_and_uncommon (patches, context) 272 case them' of 273 NilRL:<:NilRL -> return () 274 _ -> errorDoc $ text "Missing these patches from context:" 275 $$ (vcat $ mapRL description $ head $ unsafeUnRL them') 276 let ps = patchSetToPatches us' 277 putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++ 278 (englishNum (lengthFL ps) (Noun "patch") "") 279 invalidateIndex repository 280 withRepoLock opts $- \_ -> 281 do tentativelyRemovePatches repository opts ps 282 tentativelyAddToPending repository opts $ invert $ effect ps 283 finalizeRepositoryChanges repository 284 apply opts (invert $ effect ps) `catch` \e -> 285 fail ("Couldn't undo patch in working dir.\n" ++ show e) 286 sync_repo repository 287 288 289 get_help_partial :: String 290 get_help_partial = 291 "If the source repository is in a legacy darcs-1 format and contains at\n" ++ 292 "least one checkpoint (see `darcs optimize'), the --partial option will\n" ++ 293 "create a partial repository. A partial repository discards history\n" ++ 294 "from before the checkpoint in order to reduce resource requirements.\n" ++ 295 "For modern darcs-2 repositories, --partial is a deprecated alias for\n" ++ 296 "the --lazy option.\n" 297 298 copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO () 299 copy_repo_old_fashioned repository opts repodir = do 300 myname <- getCurrentDirectory 301 fromrepo <- identifyRepositoryFor repository repodir 302 mch <- get_checkpoint fromrepo 303 patches <- read_repo fromrepo 304 debugMessage "Getting the inventory..." 305 write_inventory "." patches 306 debugMessage "Copying patches..." 307 copy_oldrepo_patches opts fromrepo "." 308 debugMessage "Patches copied" 309 Sealed local_patches <- DR.read_repo opts "." :: IO (SealedPatchSet Patch) 310 debugMessage "Repo read" 311 repo_is_local <- doesDirectoryExist repodir 312 debugMessage $ "Repo local: " ++ formatPath (show repo_is_local) 313 if repo_is_local && not (Partial `elem` opts) 314 then do 315 debugMessage "Copying prefs" 316 copyFileOrUrl opts 317 (repodir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600) 318 `catchall` return () 319 debugMessage "Writing working directory" 320 createPristineDirectoryTree fromrepo myname 321 withCurrentDirectory myname $ do 322 -- note: SetScriptsExecutable is normally checked in PatchApply 323 -- but darcs get on local repositories does not apply patches 324 if SetScriptsExecutable `elem` opts 325 then setScriptsExecutable 326 else return () 327 else do 328 setCurrentDirectory myname 329 if Partial `elem` opts && isJust mch 330 then let Sealed p_ch = fromJust mch 331 pi_ch = patch2patchinfo p_ch 332 needed_patches = reverseRL $ concatRL $ unsafeUnflippedseal $ 333 get_patches_beyond_tag pi_ch local_patches 334 in do write_checkpoint_patch p_ch 335 apply opts p_ch `catch` 336 \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e) 337 apply_patches opts needed_patches 338 else apply_patches opts $ reverseRL $ concatRL local_patches 339 debugMessage "Writing the pristine" 340 pristine <- identifyPristine 341 createPristineFromWorking pristine 342 setCurrentDirectory myname 343 debugMessage "Syncing the repository..." 344 sync_repo repository 345 debugMessage "Repository synced." 346 347 \end{code}