% 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}
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" ++
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 = ["<REPOSITORY>", "[<DIRECTORY>]"],
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" 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
then writeBinFile (darcsdir++"/hashed_inventory") ""
else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch)
if not (null [p | OnePattern p <- opts])
&& 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."
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
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}