% 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, commandAlias, putInfo ) import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy, UseFormat2, UseOldFashionedInventory, UseHashedInventory, SetScriptsExecutable, OnePattern ), getContext, getInventoryChoices, partial, reponame, matchOneContext, setDefault, setScriptsExecutableOption, nolinks, networkOptions ) import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo, createPristineDirectoryTree, tentativelyRemovePatches, patchSetToPatches, patchSetToRepository, copyRepository, tentativelyAddToPending, finalizeRepositoryChanges, setScriptsExecutable , invalidateIndex ) import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat, RepoProperty ( Darcs2, HashedInventory ), formatHas ) 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.Witnesses.Ordered ( (:\/:)(..), RL(..), 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 ( setDefaultrepo ) import Darcs.Repository.Motd ( show_motd ) import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, ) import Darcs.SignalHandler ( catchInterrupt ) import Darcs.Commands.Init ( initialize ) import Darcs.Match ( havePatchsetMatch, getOnePatchset ) import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError ) import Progress ( debugMessage ) import Printer ( text, vcat, errorDoc, ($$) ) import Darcs.Lock ( writeBinFile ) import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote) import Darcs.Witnesses.Sealed ( Sealed(..), unsafeUnflippedseal ) import Darcs.Global ( darcsdir ) import English ( englishNum, Noun(..) ) #include "impossible.h" getDescription :: String getDescription = "Create a local copy of a repository." getHelp :: String getHelp = "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" ++ getHelpTag ++ "\n" ++ -- The remaining help text covers backwards-compatibility options. getHelpPartial ++ "\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 {commandName = "get", commandHelp = getHelp, commandDescription = getDescription, commandExtraArgs = -1, commandExtraArgHelp = ["", "[]"], commandCommand = getCmd, commandPrereq = contextExists, commandGetArgPossibilities = return [], commandArgdefaults = nodefaults, commandAdvancedOptions = networkOptions ++ commandAdvancedOptions initialize, commandBasicOptions = [reponame, partial, matchOneContext, setDefault, setScriptsExecutableOption, nolinks, getInventoryChoices]} clone :: DarcsCommand clone = commandAlias "clone" Nothing get getCmd :: [DarcsFlag] -> [String] -> IO () getCmd opts [inrepodir, outname] = getCmd (NewRepo outname:opts) [inrepodir] getCmd 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 <- makeRepoName opts repodir createDirectory mysimplename setCurrentDirectory mysimplename when (formatHas Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $ putInfo opts $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n" let opts' = if formatHas 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." setDefaultrepo repodir opts rf_or_e <- identifyRepoFormat "." rf <- case rf_or_e of Left e -> fail e Right x -> return x if formatHas 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 <- getOnePatchset fromrepo opts patchSetToRepository fromrepo patches_to_get opts debugMessage "Finished converting selected patch set to new repository" else copyRepoAndGoToChosenVersion opts repodir rfsource rf getCmd _ _ = fail "You must provide 'get' with either one or two arguments." -- | called by getCmd -- assumes that the target repo of the get is the current directory, and that an inventory in the -- right format has already been created. copyRepoAndGoToChosenVersion :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> IO () copyRepoAndGoToChosenVersion opts repodir rfsource rf = do copy_repo `catchInterrupt` (when (formatHas HashedInventory rfsource) (putInfo opts $ text "Using lazy repository.")) withRepository opts $- \repository -> goToChosenVersion repository opts putInfo opts $ text "Finished getting." where copy_repo = withRepository opts $- \repository -> do let hashUs = formatHas HashedInventory rf hashThem = formatHas HashedInventory rfsource case () of _ | hashUs && hashThem -> do debugMessage "Identifying and copying repository..." copyRepoHashed repository | hashUs -> do putInfo opts $ text "Converting old-fashioned repository to hashed format..." $$ text "*******************************************************************************" $$ text "Fetching a hashed repository would be faster. Perhaps you could persuade" $$ text "the maintainer to run darcs optimize --upgrade with darcs 2.4.0 or higher?" $$ text "*******************************************************************************" copyRepoHashed repository | hashThem -> do putInfo opts $ text "Fetching a hashed repository as an old-fashioned one..." copyRepoHashed repository | otherwise -> copyRepoOldFashioned repository opts repodir copyRepoHashed repository = do identifyRepositoryFor repository repodir >>= copyRepository when (SetScriptsExecutable `elem` opts) setScriptsExecutable makeRepoName :: [DarcsFlag] -> FilePath -> IO String makeRepoName (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 makeRepoName (_:as) d = makeRepoName as d makeRepoName [] d = case dropWhile (=='.') $ reverse $ takeWhile (\c -> c /= '/' && c /= ':') $ dropWhile (=='/') $ reverse d of "" -> modifyRepoName "anonymous_repo" base -> modifyRepoName base modifyRepoName :: String -> IO String modifyRepoName 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 getHelpTag :: String getHelpTag = "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 getContext 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" goToChosenVersion :: RepoPatch p => Repository p -> [DarcsFlag] -> IO () goToChosenVersion repository opts = when (havePatchsetMatch opts) $ do debugMessage "Going to specified version..." patches <- read_repo repository Sealed context <- getOnePatchset repository opts let (_,us':\/:them') = get_common_and_uncommon (patches, context) case them' of NilRL -> return () _ -> errorDoc $ text "Missing these patches from context:" $$ (vcat $ mapRL description them') let ps = patchSetToPatches (us':<:NilRL) putInfo opts $ 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) getHelpPartial :: String getHelpPartial = "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" copyRepoOldFashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO () copyRepoOldFashioned 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 $ 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 \end{code}