1 % Copyright (C) 2002-2005,2007 David Roundy 2 % 3 % This program is free software; you can redistribute it and/or modify 4 % it under the terms of the GNU General Public License as published by 5 % the Free Software Foundation; either version 2, or (at your option) 6 % any later version. 7 % 8 % This program is distributed in the hope that it will be useful, 9 % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 % GNU General Public License for more details. 12 % 13 % You should have received a copy of the GNU General Public License 14 % along with this program; see the file COPYING. If not, write to 15 % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 % Boston, MA 02110-1301, USA. 17 18 \darcsCommand{convert} 19 \begin{code} 20 {-# OPTIONS_GHC -cpp -fglasgow-exts #-} 21 {-# LANGUAGE CPP #-} 22 -- , MagicHash #-} 23 24 #include "gadts.h" 25 26 module Darcs.Commands.Convert ( convert ) where 27 28 import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, 29 createDirectory ) 30 import Workaround ( getCurrentDirectory ) 31 import Control.Monad ( when ) 32 import GHC.Base ( unsafeCoerce# ) 33 import Data.Maybe ( catMaybes ) 34 35 import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully ) 36 import Darcs.Commands ( DarcsCommand(..), nodefaults ) 37 import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo, 38 SetScriptsExecutable, UseFormat2, NoUpdateWorking, 39 Verbose, Quiet ), 40 reponame, 41 set_scripts_executable, 42 network_options ) 43 import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo, 44 createRepository, 45 slurp_recorded, optimizeInventory, 46 tentativelyMergePatches, patchSetToPatches, 47 createPristineDirectoryTree, 48 revertRepositoryChanges, finalizeRepositoryChanges, sync_repo ) 49 import Darcs.Global ( darcsdir ) 50 import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch, 51 modernize_patch, 52 adddeps, getdeps, effect, flattenFL, is_merger, patchcontents ) 53 import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL, 54 concatFL, concatRL, mapRL ) 55 import Darcs.Patch.Info ( pi_rename, pi_tag, is_tag ) 56 import Darcs.Patch.Commute ( public_unravel ) 57 import Darcs.Patch.Real ( mergeUnravelled ) 58 import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) 59 import Darcs.Repository.Motd ( show_motd ) 60 import Darcs.Utils ( clarify_errors, askUser ) 61 import Darcs.ProgressPatches ( progressFL ) 62 import Darcs.Sealed ( FlippedSeal(..) ) 63 import Printer ( text, putDocLn, ($$) ) 64 import Darcs.ColorPrinter ( traceDoc ) 65 import Darcs.SlurpDirectory ( list_slurpy_files ) 66 import Darcs.Lock ( writeBinFile ) 67 import Workaround ( setExecutable ) 68 import qualified Data.ByteString as B (isPrefixOf, readFile) 69 import qualified Data.ByteString.Char8 as BC (pack) 70 import Darcs.Gorsvet( invalidateIndex ) 71 72 convert_description :: String 73 convert_description = "Convert a repository from a legacy format." 74 75 convert_help :: String 76 convert_help = 77 "The current repository format is called `darcs-2'. It was introduced\n" ++ 78 "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++ 79 "The `darcs convert' command allows existing projects to migrate to\n" ++ 80 "this format from the older `darcs-1' format.\n" ++ 81 "\n" ++ 82 "This command DOES NOT modify the source repository; a new destination\n" ++ 83 "repository is created. It is safe to run this command more than once\n" ++ 84 "on a repository (e.g. for testing), before the final conversion.\n" ++ 85 "\n" ++ 86 convert_help' ++ 87 "\n" ++ 88 "Due to this limitation, migrating a multi-branch project is a little\n" ++ 89 "awkward. Sorry! Here is the recommended process:\n" ++ 90 "\n" ++ 91 " 1. for each branch `foo', tag that branch with `foo-final';\n" ++ 92 " 2. merge all branches together (--allow-conflicts may help);\n" ++ 93 " 3. run `darcs optimize --reorder' on the result;\n" ++ 94 " 4. run `darcs convert' to create a merged darcs-2 repository;\n" ++ 95 " 5. re-create each branch by calling `darcs get --tag foo-final' on\n" ++ 96 " the darcs-2 repository; and finally\n" ++ 97 " 6. use `darcs obliterate' to delete the foo-final tags.\n" 98 99 -- | This part of the help is split out because it is used twice: in 100 -- the help string, and in the prompt for confirmation. 101 convert_help' :: String 102 convert_help' = 103 "WARNING: the repository produced by this command is not understood by\n" ++ 104 "Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++ 105 "darcs-1 and darcs-2 formats.\n" ++ 106 "\n" ++ 107 "Furthermore, darcs 2 repositories created by different invocations of\n" ++ 108 "this command SHOULD NOT exchange patches, unless those repositories\n" ++ 109 "had no patches in common when they were converted. (That is, within a\n" ++ 110 "set of repos that exchange patches, no patch should be converted more\n" ++ 111 "than once.)\n" 112 113 convert :: DarcsCommand 114 convert = DarcsCommand {command_name = "convert", 115 command_help = convert_help, 116 command_description = convert_description, 117 command_extra_args = -1, 118 command_extra_arg_help = ["<SOURCE>", "[<DESTINATION>]"], 119 command_command = convert_cmd, 120 command_prereq = \_ -> return $ Right (), 121 command_get_arg_possibilities = return [], 122 command_argdefaults = nodefaults, 123 command_advanced_options = network_options, 124 command_basic_options = [reponame,set_scripts_executable]} 125 126 convert_cmd :: [DarcsFlag] -> [String] -> IO () 127 convert_cmd opts [inrepodir, outname] = convert_cmd (NewRepo outname:opts) [inrepodir] 128 convert_cmd orig_opts [inrepodir] = do 129 putStrLn convert_help' 130 let vow = "I understand the consequences of my action" 131 putStrLn "Please confirm that you have read and understood the above" 132 vow' <- askUser ("by typing `" ++ vow ++ "': ") 133 when (vow' /= vow) $ fail "User didn't understand the consequences." 134 let opts = UseFormat2:orig_opts 135 typed_repodir <- ioAbsoluteOrRemote inrepodir 136 let repodir = toPath typed_repodir 137 show_motd opts repodir 138 mysimplename <- make_repo_name opts repodir 139 createDirectory mysimplename 140 setCurrentDirectory mysimplename 141 createRepository opts 142 writeBinFile (darcsdir++"/hashed_inventory") "" 143 withRepoLock (NoUpdateWorking:opts) $- \repositoryfoo -> 144 withRepositoryDirectory opts repodir $- \themrepobar -> do 145 -- We really ought to have special versions of withRepoLock and 146 -- withRepositoryDirectory that check at runtime that it's the right 147 -- sort of repository and accept a function of (Repository Patch) or 148 -- (Repository (FL RealPatch)), but that seems like a lot of work 149 -- when these functions would be used exactly once, right here. So I 150 -- go with a horrible evil hack. 151 152 -- The other alternative (which is what we used to do) is to use 153 -- "universal" functions to do the conversion, but that's also 154 -- unsatisfying. 155 156 let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch) 157 themrepo = unsafeCoerce# themrepobar :: Repository Patch 158 theirstuff <- read_repo themrepo 159 let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff 160 inOrderTags = iot theirstuff 161 where iot ((t:<:NilRL):<:r) = info t : iot r 162 iot (NilRL:<:r) = iot r 163 iot NilRL = [] 164 iot ((_:<:x):<:y) = iot (x:<:y) 165 outOfOrderTags = catMaybes $ mapRL oot $ concatRL theirstuff 166 where oot t = if is_tag (info t) && not (info t `elem` inOrderTags) 167 then Just (info t, getdeps $ hopefully t) 168 else Nothing 169 fixDep p = case lookup p outOfOrderTags of 170 Just d -> p : concatMap fixDep d 171 Nothing -> [p] 172 convertOne :: Patch -> FL RealPatch 173 convertOne x | is_merger x = case mergeUnravelled $ public_unravel $ modernize_patch x of 174 Just (FlippedSeal y) -> 175 case effect y =/\= effect x of 176 IsEq -> y :>: NilFL 177 NotEq -> 178 traceDoc (text "lossy conversion:" $$ 179 showPatch x) 180 fromPrims (effect x) 181 Nothing -> traceDoc (text 182 "lossy conversion of complicated conflict:" $$ 183 showPatch x) 184 fromPrims (effect x) 185 | otherwise = case flattenFL x of 186 NilFL -> NilFL 187 (x':>:NilFL) -> fromPrims $ effect x' 188 xs -> concatFL $ mapFL_FL convertOne xs 189 convertNamed :: Named Patch -> PatchInfoAnd (FL RealPatch) 190 convertNamed n = n2pia $ 191 adddeps (infopatch (convertInfo $ patch2patchinfo n) $ 192 convertOne $ patchcontents n) 193 (map convertInfo $ concatMap fixDep $ getdeps n) 194 convertInfo n | n `elem` inOrderTags = n 195 | otherwise = maybe n (\t -> pi_rename n ("old tag: "++t)) $ pi_tag n 196 applySome xs = do tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs 197 finalizeRepositoryChanges repository -- this is to clean out pristine.hashed 198 revertRepositoryChanges repository 199 sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches 200 invalidateIndex repository 201 revertable $ createPristineDirectoryTree repository "." 202 when (SetScriptsExecutable `elem` opts) $ 203 do putVerbose $ text "Making scripts executable" 204 c <- list_slurpy_files `fmap` slurp_recorded repository 205 let setExecutableIfScript f = 206 do contents <- B.readFile f 207 when (BC.pack "#!" `B.isPrefixOf` contents) $ do 208 putVerbose $ text ("Making executable: " ++ f) 209 setExecutable f True 210 mapM_ setExecutableIfScript c 211 sync_repo repository 212 optimizeInventory repository 213 putInfo $ text "Finished converting." 214 where am_verbose = Verbose `elem` orig_opts 215 am_informative = not $ Quiet `elem` orig_opts 216 putVerbose s = when am_verbose $ putDocLn s 217 putInfo s = when am_informative $ putDocLn s 218 revertable x = x `clarify_errors` unlines 219 ["An error may have left your new working directory an inconsistent", 220 "but recoverable state. You should be able to make the new", 221 "repository consistent again by running darcs revert -a."] 222 223 convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments." 224 225 make_repo_name :: [DarcsFlag] -> FilePath -> IO String 226 make_repo_name (NewRepo n:_) _ = 227 do exists <- doesDirectoryExist n 228 file_exists <- doesFileExist n 229 if exists || file_exists 230 then fail $ "Directory or file named '" ++ n ++ "' already exists." 231 else return n 232 make_repo_name (_:as) d = make_repo_name as d 233 make_repo_name [] d = 234 case dropWhile (=='.') $ reverse $ 235 takeWhile (\c -> c /= '/' && c /= ':') $ 236 dropWhile (=='/') $ reverse d of 237 "" -> modify_repo_name "anonymous_repo" 238 base -> modify_repo_name base 239 240 modify_repo_name :: String -> IO String 241 modify_repo_name name = 242 if head name == '/' 243 then mrn name (-1) 244 else do cwd <- getCurrentDirectory 245 mrn (cwd ++ "/" ++ name) (-1) 246 where 247 mrn :: String -> Int -> IO String 248 mrn n i = do 249 exists <- doesDirectoryExist thename 250 file_exists <- doesFileExist thename 251 if not exists && not file_exists 252 then do when (i /= -1) $ 253 putStrLn $ "Directory '"++ n ++ 254 "' already exists, creating repository as '"++ 255 thename ++"'" 256 return thename 257 else mrn n $ i+1 258 where thename = if i == -1 then n else n++"_"++show i 259 260 \end{code}