% Copyright (C) 20022005,2007 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 021101301, USA.
\subsection{darcs convert}
\begin{code}
#include "gadts.h"
module Darcs.Commands.Convert ( convert ) where
import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,
createDirectory )
import Workaround ( getCurrentDirectory )
import Control.Monad ( when )
import GHC.Base ( unsafeCoerce# )
import Data.Maybe ( catMaybes )
import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo,
SetScriptsExecutable, UseFormat2, NoUpdateWorking,
Verbose, Quiet ),
reponame,
set_scripts_executable,
network_options )
import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo,
createRepository,
slurp_recorded, optimizeInventory,
tentativelyMergePatches, patchSetToPatches,
createPristineDirectoryTree,
revertRepositoryChanges, finalizeRepositoryChanges, sync_repo )
import Darcs.Global ( darcsdir )
import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch,
modernize_patch,
adddeps, getdeps, effect, flattenFL, is_merger, patchcontents )
import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL,
concatFL, concatRL, mapRL )
import Darcs.Patch.Info ( pi_rename, pi_tag, is_tag )
import Darcs.Patch.Commute ( public_unravel )
import Darcs.Patch.Real ( mergeUnravelled )
import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )
import Darcs.Repository.Motd ( show_motd )
import Darcs.Utils ( clarify_errors, askUser )
import Darcs.ProgressPatches ( progressFL )
import Darcs.Sealed ( FlippedSeal(..) )
import Printer ( text, putDocLn, ($$) )
import Darcs.ColorPrinter ( traceDoc )
import Darcs.SlurpDirectory ( list_slurpy_files )
import Darcs.Lock ( writeBinFile )
import Workaround ( setExecutable )
import qualified Data.ByteString as B (isPrefixOf, readFile)
import qualified Data.ByteString.Char8 as BC (pack)
convert_description :: String
convert_description =
"Convert a repository to darcs-2 format."
\end{code}
\options{convert}
You may specify the name of the repository created by providing a second
argument to convert, which is a directory name.
\begin{code}
convert_help :: String
convert_help =
"Convert is used to convert a repository to darcs-2 format.\n\n" ++
"The recommended way to convert an existing project from darcs 1 to\n" ++
"darcs 2 is to merge all branches, `darcs convert' the resulting\n" ++
"repository, re-create each branch by using `darcs get' on the\n" ++
"converted repository, then using `darcs obliterate' to delete patches\n" ++
"of branches.\n"
convert :: DarcsCommand
convert = DarcsCommand {command_name = "convert",
command_help = convert_help,
command_description = convert_description,
command_extra_args = 1,
command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],
command_command = convert_cmd,
command_prereq = \_ -> return $ Right (),
command_get_arg_possibilities = return [],
command_argdefaults = nodefaults,
command_advanced_options = network_options,
command_basic_options = [reponame,set_scripts_executable]}
convert_cmd :: [DarcsFlag] -> [String] -> IO ()
convert_cmd opts [inrepodir, outname] = convert_cmd (NewRepo outname:opts) [inrepodir]
convert_cmd orig_opts [inrepodir] = do
putDocLn $ text "WARNING: the repository produced by this command is not understood by" $$
text "the darcs 1 program, and patches cannot be exchanged between" $$
text "repositories in darcs 1 and darcs 2 formats.\n" $$
text "Furthermore, darcs 2 repositories created by different invocations of" $$
text "this command SHOULD NOT exchange patches, unless those repositories" $$
text "had no patches in common when they were converted. (That is, within a" $$
text "set of repos that exchange patches, no patch should be converted more" $$
text "than once.)\n" $$
text "This command DOES NOT modify the source repository. It is safe to run" $$
text "this command more than once on a single repository, but the resulting" $$
text "repositories will not be able to exchange patches.\n" $$
text "Please confirm that you have read and understood the above"
let vow = "I understand the consequences of my action"
vow' <- askUser ("by typing `" ++ vow ++ "': ")
when (vow' /= vow) $ fail "User didn't understand the consequences."
let opts = UseFormat2:orig_opts
typed_repodir <- ioAbsoluteOrRemote inrepodir
let repodir = toPath typed_repodir
show_motd opts repodir
mysimplename <- make_repo_name opts repodir
createDirectory mysimplename
setCurrentDirectory mysimplename
createRepository opts
writeBinFile (darcsdir++"/hashed_inventory") ""
withRepoLock (NoUpdateWorking:opts) $- \repositoryfoo ->
withRepositoryDirectory opts repodir $- \themrepobar -> do
let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch)
themrepo = unsafeCoerce# themrepobar :: Repository Patch
theirstuff <- read_repo themrepo
let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff
inOrderTags = iot theirstuff
where iot ((t:<:NilRL):<:r) = info t : iot r
iot (NilRL:<:r) = iot r
iot NilRL = []
iot ((_:<:x):<:y) = iot (x:<:y)
outOfOrderTags = catMaybes $ mapRL oot $ concatRL theirstuff
where oot t = if is_tag (info t) && not (info t `elem` inOrderTags)
then Just (info t, getdeps $ hopefully t)
else Nothing
fixDep p = case lookup p outOfOrderTags of
Just d -> p : concatMap fixDep d
Nothing -> [p]
convertOne :: Patch -> FL RealPatch
convertOne x | is_merger x = case mergeUnravelled $ public_unravel $ modernize_patch x of
Just (FlippedSeal y) ->
case effect y =/\= effect x of
IsEq -> y :>: NilFL
NotEq ->
traceDoc (text "lossy conversion:" $$
showPatch x)
fromPrims (effect x)
Nothing -> traceDoc (text
"lossy conversion of complicated conflict:" $$
showPatch x)
fromPrims (effect x)
| otherwise = case flattenFL x of
NilFL -> NilFL
(x':>:NilFL) -> fromPrims $ effect x'
xs -> concatFL $ mapFL_FL convertOne xs
convertNamed :: Named Patch -> PatchInfoAnd (FL RealPatch)
convertNamed n = n2pia $
adddeps (infopatch (convertInfo $ patch2patchinfo n) $
convertOne $ patchcontents n)
(map convertInfo $ concatMap fixDep $ getdeps n)
convertInfo n | n `elem` inOrderTags = n
| otherwise = maybe n (\t -> pi_rename n ("old tag: "++t)) $ pi_tag n
applySome xs = do tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs
finalizeRepositoryChanges repository
revertRepositoryChanges repository
sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches
revertable $ createPristineDirectoryTree repository "."
when (SetScriptsExecutable `elem` opts) $
do putVerbose $ text "Making scripts executable"
c <- list_slurpy_files `fmap` slurp_recorded repository
let setExecutableIfScript f =
do contents <- B.readFile f
when (BC.pack "#!" `B.isPrefixOf` contents) $ do
putVerbose $ text ("Making executable: " ++ f)
setExecutable f True
mapM_ setExecutableIfScript c
sync_repo repository
optimizeInventory repository
putInfo $ text "Finished converting."
where am_verbose = Verbose `elem` orig_opts
am_informative = not $ Quiet `elem` orig_opts
putVerbose s = when am_verbose $ putDocLn s
putInfo s = when am_informative $ putDocLn s
revertable x = x `clarify_errors` unlines
["An error may have left your new working directory an inconsistent",
"but recoverable state. You should be able to make the new",
"repository consistent again by running darcs revert -a."]
convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments."
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
\end{code}