% Copyright (C) 2002-2005,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 02110-1301, USA.
\darcsCommand{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, putInfo, putVerbose )
import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo,
SetScriptsExecutable, UseFormat2, NoUpdateWorking),
reponame,
setScriptsExecutableOption,
networkOptions )
import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo,
createRepository, invalidateIndex,
slurp_recorded, optimizeInventory,
tentativelyMergePatches, patchSetToPatches,
createPristineDirectoryTree,
revertRepositoryChanges, finalizeRepositoryChanges )
import Darcs.Global ( darcsdir )
import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch,
modernizePatch,
adddeps, getdeps, effect, flattenFL, isMerger, patchcontents )
import Darcs.Witnesses.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.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))
import Darcs.Repository.Motd ( show_motd )
import Darcs.Utils ( clarifyErrors, askUser )
import Darcs.ProgressPatches ( progressFL )
import Darcs.Witnesses.Sealed ( FlippedSeal(..) )
import Printer ( text, ($$) )
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)
convertDescription :: String
convertDescription = "Convert a repository from a legacy format."
convertHelp :: String
convertHelp =
"The current repository format is called `darcs-2'. It was introduced\n" ++
"in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++
"The `darcs convert' command allows existing projects to migrate to\n" ++
"this format from the older `darcs-1' format.\n" ++
"\n" ++
"This command DOES NOT modify the source repository; a new destination\n" ++
"repository is created. It is safe to run this command more than once\n" ++
"on a repository (e.g. for testing), before the final conversion.\n" ++
"\n" ++
convertHelp' ++
"\n" ++
"Due to this limitation, migrating a multi-branch project is a little\n" ++
"awkward. Sorry! Here is the recommended process:\n" ++
"\n" ++
" 1. for each branch `foo', tag that branch with `foo-final';\n" ++
" 2. merge all branches together (--allow-conflicts may help);\n" ++
" 3. run `darcs optimize --reorder' on the result;\n" ++
" 4. run `darcs convert' to create a merged darcs-2 repository;\n" ++
" 5. re-create each branch by calling `darcs get --tag foo-final' on\n" ++
" the darcs-2 repository; and finally\n" ++
" 6. use `darcs obliterate' to delete the foo-final tags.\n"
convertHelp' :: String
convertHelp' =
"WARNING: the repository produced by this command is not understood by\n" ++
"Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++
"darcs-1 and darcs-2 formats.\n" ++
"\n" ++
"Furthermore, darcs 2 repositories created by different invocations of\n" ++
"this command SHOULD NOT exchange patches, unless those repositories\n" ++
"had no patches in common when they were converted. (That is, within a\n" ++
"set of repos that exchange patches, no patch should be converted more\n" ++
"than once.)\n"
convert :: DarcsCommand
convert = DarcsCommand {commandName = "convert",
commandHelp = convertHelp,
commandDescription = convertDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"],
commandCommand = convertCmd,
commandPrereq = \_ -> return $ Right (),
commandGetArgPossibilities = return [],
commandArgdefaults = nodefaults,
commandAdvancedOptions = networkOptions,
commandBasicOptions = [reponame,setScriptsExecutableOption]}
convertCmd :: [DarcsFlag] -> [String] -> IO ()
convertCmd opts [inrepodir, outname] = convertCmd (NewRepo outname:opts) [inrepodir]
convertCmd orig_opts [inrepodir] = do
typed_repodir <- ioAbsoluteOrRemote inrepodir
let repodir = toPath typed_repodir
Right format <- identifyRepoFormat repodir
when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."
putStrLn convertHelp'
let vow = "I understand the consequences of my action"
putStrLn "Please confirm that you have read and understood the above"
vow' <- askUser ("by typing `" ++ vow ++ "': ")
when (vow' /= vow) $ fail "User didn't understand the consequences."
let opts = UseFormat2:orig_opts
show_motd opts repodir
mysimplename <- makeRepoName 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 | isMerger x = case mergeUnravelled $ public_unravel $ modernizePatch 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
invalidateIndex repository
revertable $ createPristineDirectoryTree repository "."
when (SetScriptsExecutable `elem` opts) $
do putVerbose opts $ 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 opts $ text ("Making executable: " ++ f)
setExecutable f True
mapM_ setExecutableIfScript c
optimizeInventory repository
putInfo opts $ text "Finished converting."
where revertable x = x `clarifyErrors` 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."]
convertCmd _ _ = fail "You must provide 'convert' with either one or two arguments."
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
\end{code}