-- 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. {-# LANGUAGE CPP, MagicHash #-} #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 qualified Data.ByteString as B import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully ) import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo ) import Darcs.Arguments ( DarcsFlag ( AllowConflicts, NewRepo, SetScriptsExecutable, UseFormat2 , NoUpdateWorking ) , reponame , setScriptsExecutableOption , networkOptions ) import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withRepositoryDirectory, readRepo, createRepository, invalidateIndex, optimizeInventory, tentativelyMergePatches, patchSetToPatches, createPristineDirectoryTree, revertRepositoryChanges, finalizeRepositoryChanges, applyToWorking, setScriptsExecutable ) import Darcs.Global ( darcsdir ) import Darcs.Patch ( Named, showPatch, patch2patchinfo, fromPrim, fromPrims, infopatch, adddeps, getdeps, effect, patchcontents ) import Darcs.Witnesses.Eq ( EqCheck(..), (=/\=) ) import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapFL_FL, concatFL, mapRL ) import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo ) import Darcs.Patch.V1 ( Patch ) import Darcs.Patch.V2 ( RealPatch ) import Darcs.Patch.V1.Commute ( publicUnravel ) import Darcs.Patch.V1.Core ( Patch(PP), isMerger ) import Darcs.Patch.V2.Real ( mergeUnravelled ) import Darcs.Patch.Prim.V1 ( Prim ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2)) import Darcs.Repository.Motd ( showMotd ) import Darcs.Utils ( clarifyErrors, askUser, catchall ) import Darcs.ProgressPatches ( progressFL ) import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(..) ) import Printer ( text, ($$) ) import Darcs.ColorPrinter ( traceDoc ) import Darcs.Lock ( writeBinFile ) import Darcs.External ( fetchFilePS, Cachable(Uncachable) ) import System.FilePath.Posix #include "gadts.h" #include "impossible.h" 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" -- | This part of the help is split out because it is used twice: in -- the help string, and in the prompt for confirmation. 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 {commandProgramName = "darcs", commandName = "convert", commandHelp = convertHelp, commandDescription = convertDescription, commandExtraArgs = -1, commandExtraArgHelp = ["", "[]"], 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 --test for converting darcs-2 repository 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 showMotd opts repodir mysimplename <- makeRepoName opts repodir createDirectory mysimplename setCurrentDirectory mysimplename createRepository opts writeBinFile (darcsdir++"/hashed_inventory") "" withRepoLock (NoUpdateWorking:opts) $ V2Job $ \repository -> withRepositoryDirectory opts repodir $ V1Job $ \themrepo -> do theirstuff <- readRepo themrepo let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff inOrderTags = iot theirstuff where iot :: PatchSet p C(s x) -> [PatchInfo] iot (PatchSet _ ts) = iot_ ts iot_ :: RL(Tagged t1) C(t y) -> [PatchInfo] iot_ (Tagged t _ _ :<: ts) = info t : iot_ ts iot_ NilRL = [] outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff where oot t = if isTag (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 Prim C(x y) -> FL (RealPatch Prim) C(x y) convertOne x | isMerger x = case mergeUnravelled $ publicUnravel 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) convertOne (PP x) = fromPrim x :>: NilFL convertOne _ = impossible convertFL :: FL (Patch Prim) C(x y) -> FL (RealPatch Prim) C(x y) convertFL = concatFL . mapFL_FL convertOne convertNamed :: Named (Patch Prim) C(x y) -> PatchInfoAnd (RealPatch Prim) C(x y) convertNamed n = n2pia $ adddeps (infopatch (convertInfo $ patch2patchinfo n) $ convertFL $ patchcontents n) (map convertInfo $ concatMap fixDep $ getdeps n) convertInfo n | n `elem` inOrderTags = n | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n applySome xs = do -- TODO this unsafeCoerce hack is because we don't keep track of the repository state properly -- Really sequence_ $ mapFL applySome below should instead be a repeated add operation - -- there doesn't seem to be any reason we need to do a merge here. let repository2 = unsafeCoerce# repository :: Repository (RealPatch Prim) C(a b a) Sealed pw <- tentativelyMergePatches repository2 "convert" (AllowConflicts:opts) NilFL xs finalizeRepositoryChanges repository2 -- this is to clean out pristine.hashed revertRepositoryChanges repository2 _ <- revertable $ applyToWorking repository2 opts pw invalidateIndex repository2 sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches invalidateIndex repository revertable $ createPristineDirectoryTree repository "." when (SetScriptsExecutable `elem` opts) $ setScriptsExecutable -- Copy over the prefs file let prefsRelPath = darcsdir "prefs" "prefs" (fetchFilePS (repodir prefsRelPath) Uncachable >>= B.writeFile prefsRelPath) `catchall` return () 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