#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"
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 = ["<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
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
let repository2 = unsafeCoerce# repository :: Repository (RealPatch Prim) C(a b a)
Sealed pw <- tentativelyMergePatches repository2 "convert" (AllowConflicts:opts) NilFL xs
finalizeRepositoryChanges repository2
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
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