src/Darcs/Commands/Convert.lhs

   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 \subsection{darcs 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.Commands.Init ( initialize )
  38 import Darcs.Arguments ( DarcsFlag( AllowConflicts, WorkDir,
  39                                     SetScriptsExecutable, UseFormat2, NoUpdateWorking,
  40                                     Verbose, Quiet ),
  41                         reponame,
  42                         set_scripts_executable,
  43                         network_options )
  44 import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo,
  45                           slurp_recorded, optimizeInventory,
  46                           tentativelyMergePatches, patchSetToPatches,
  47                           createPristineDirectoryTree,
  48                           revertRepositoryChanges, finalizeRepositoryChanges, sync_repo )
  49 import Darcs.Global ( darcsdir )
  50 import Darcs.FilePathUtils ( absolute_dir )
  51 import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch,
  52                      modernize_patch,
  53                      adddeps, getdeps, effect, flattenFL, is_merger, patchcontents )
  54 import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL,
  55                              concatFL, concatRL, mapRL )
  56 import Darcs.Patch.Depends ( is_tag )
  57 import Darcs.Patch.Info ( pi_rename, pi_tag )
  58 import Darcs.Patch.Commute ( public_unravel )
  59 import Darcs.Patch.Real ( mergeUnravelled )
  60 import Darcs.Repository.Motd ( show_motd )
  61 import Darcs.Utils ( clarify_errors, askUser )
  62 import Darcs.Progress ( progressFL )
  63 import Darcs.Sealed ( FlippedSeal(..) )
  64 import Printer ( text, putDocLn, ($$) )
  65 import Darcs.ColorPrinter ( traceDoc )
  66 import Darcs.SlurpDirectory ( list_slurpy_files )
  67 import Darcs.Lock ( writeBinFile )
  68 import Workaround ( setExecutable )
  69 import qualified Data.ByteString as B (isPrefixOf, readFile)
  70 import qualified Data.ByteString.Char8 as BC (pack)
  71
  72 convert_description :: String
  73 convert_description =
  74  "Convert a repository to darcs-2 format."
  75 \end{code}
  76
  77 \options{convert}
  78
  79 You may specify the name of the repository created by providing a second
  80 argument to convert, which is a directory name.
  81
  82 \begin{code}
  83 convert_help :: String
  84 convert_help =
  85  "Convert is used to convert a repository to darcs-2 format.\n\n" ++
  86  "The recommended way to convert an existing project from darcs 1 to\n" ++
  87  "darcs 2 is to merge all branches, `darcs convert' the resulting\n" ++
  88  "repository, re-create each branch by using `darcs get' on the\n" ++
  89  "converted repository, then using `darcs obliterate' to delete patches\n" ++
  90  "of branches.\n"
  91 \end{code}
  92 \begin{code}
  93 convert :: DarcsCommand
  94 convert = DarcsCommand {command_name = "convert",
  95                     command_help = convert_help,
  96                     command_description = convert_description,
  97                     command_extra_args = -1,
  98                     command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],
  99                     command_command = convert_cmd,
 100                     command_prereq = \_ -> return $ Right (),
 101                     command_get_arg_possibilities = return [],
 102                     command_argdefaults = nodefaults,
 103                     command_advanced_options = network_options,
 104                     command_basic_options = [reponame,set_scripts_executable]}
 105 \end{code}
 106 \begin{code}
 107 convert_cmd :: [DarcsFlag] -> [String] -> IO ()
 108 convert_cmd opts [inrepodir, outname] = convert_cmd (WorkDir outname:opts) [inrepodir]
 109 convert_cmd orig_opts [inrepodir] = do
 110   putDocLn $ text "WARNING: the repository produced by this command is not understood by" $$
 111              text "the darcs 1 program, and patches cannot be exchanged between" $$
 112              text "repositories in darcs 1 and darcs 2 formats.\n" $$
 113              text "Furthermore, darcs 2 repositories created by different invocations of" $$
 114              text "this command SHOULD NOT exchange patches, unless those repositories" $$
 115              text "had no patches in common when they were converted.  (That is, within a" $$
 116              text "set of repos that exchange patches, no patch should be converted more" $$
 117              text "than once.)\n" $$
 118              text "This command DOES NOT modify the source repository.  It is safe to run" $$
 119              text "this command more than once on a single repository, but the resulting" $$
 120              text "repositories will not be able to exchange patches.\n" $$
 121              text "Please confirm that you have read and understood the above"
 122   let vow = "I understand the consequences of my action"
 123   vow' <- askUser ("by typing `" ++ vow ++ "': ")
 124   when (vow' /= vow) $ fail "User didn't understand the consequences."
 125   let opts = UseFormat2:orig_opts
 126   repodir <- absolute_dir inrepodir
 127   show_motd opts repodir
 128   mysimplename <- make_repo_name opts repodir
 129   createDirectory mysimplename
 130   setCurrentDirectory mysimplename
 131   (command_command initialize) opts []
 132   writeBinFile (darcsdir++"/hashed_inventory") ""
 133   withRepoLock (NoUpdateWorking:opts) $- \repositoryfoo ->
 134     withRepositoryDirectory opts repodir $- \themrepobar -> do
 135       -- We really ought to have special versions of withRepoLock and
 136       -- withRepositoryDirectory that check at runtime that it's the right
 137       -- sort of repository and accept a function of (Repository Patch) or
 138       -- (Repository (FL RealPatch)), but that seems like a lot of work
 139       -- when these functions would be used exactly once, right here.  So I
 140       -- go with a horrible evil hack.
 141
 142       -- The other alternative (which is what we used to do) is to use
 143       -- "universal" functions to do the conversion, but that's also
 144       -- unsatisfying.
 145
 146       let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch)
 147           themrepo = unsafeCoerce# themrepobar :: Repository Patch
 148       theirstuff <- read_repo themrepo
 149       let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff
 150           inOrderTags = iot theirstuff
 151               where iot ((t:<:NilRL):<:r) = info t : iot r
 152                     iot (NilRL:<:r) = iot r
 153                     iot NilRL = []
 154                     iot ((_:<:x):<:y) = iot (x:<:y)
 155           outOfOrderTags = catMaybes $ mapRL oot $ concatRL theirstuff
 156               where oot t = if is_tag (info t) && not (info t `elem` inOrderTags)
 157                             then Just (info t, getdeps $ hopefully t)
 158                             else Nothing
 159           fixDep p = case lookup p outOfOrderTags of
 160                      Just d -> p : concatMap fixDep d
 161                      Nothing -> [p]
 162           convertOne :: Patch -> FL RealPatch
 163           convertOne x | is_merger x = case mergeUnravelled $ public_unravel $ modernize_patch x of
 164                                        Just (FlippedSeal y) ->
 165                                            case effect y =/\= effect x of
 166                                            IsEq -> y :>: NilFL
 167                                            NotEq ->
 168                                                traceDoc (text "lossy conversion:" $$
 169                                                          showPatch x)
 170                                                fromPrims (effect x)
 171                                        Nothing -> traceDoc (text
 172                                                             "lossy conversion of complicated conflict:" $$
 173                                                             showPatch x)
 174                                                   fromPrims (effect x)
 175                        | otherwise = case flattenFL x of
 176                                      NilFL -> NilFL
 177                                      (x':>:NilFL) -> fromPrims $ effect x'
 178                                      xs -> concatFL $ mapFL_FL convertOne xs
 179           convertNamed :: Named Patch -> PatchInfoAnd (FL RealPatch)
 180           convertNamed n = n2pia $
 181                            adddeps (infopatch (convertInfo $ patch2patchinfo n) $
 182                                               convertOne $ patchcontents n)
 183                                    (map convertInfo $ concatMap fixDep $ getdeps n)
 184           convertInfo n | n `elem` inOrderTags = n
 185                         | otherwise = maybe n (\t -> pi_rename n ("old tag: "++t)) $ pi_tag n
 186           applySome xs = do tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs
 187                             finalizeRepositoryChanges repository -- this is to clean out pristine.hashed
 188                             revertRepositoryChanges repository
 189       sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches
 190       revertable $ createPristineDirectoryTree repository "."
 191       when (SetScriptsExecutable `elem` opts) $
 192                do putVerbose $ text "Making scripts executable"
 193                   c <- list_slurpy_files `fmap` slurp_recorded repository
 194                   let setExecutableIfScript f =
 195                             do contents <- B.readFile f
 196                                when (BC.pack "#!" `B.isPrefixOf` contents) $ do
 197                                  putVerbose $ text ("Making executable: " ++ f)
 198                                  setExecutable f True
 199                   mapM_ setExecutableIfScript c
 200       sync_repo repository
 201       optimizeInventory repository
 202       putInfo $ text "Finished converting."
 203       where am_verbose = Verbose `elem` orig_opts
 204             am_informative = not $ Quiet `elem` orig_opts
 205             putVerbose s = when am_verbose $ putDocLn s
 206             putInfo s = when am_informative $ putDocLn s
 207             revertable x = x `clarify_errors` unlines
 208                   ["An error may have left your new working directory an inconsistent",
 209                    "but recoverable state. You should be able to make the new",
 210                    "repository consistent again by running darcs revert -a."]
 211
 212 convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments."
 213 \end{code}
 214
 215 \begin{code}
 216 make_repo_name :: [DarcsFlag] -> FilePath -> IO String
 217 make_repo_name (WorkDir n:_) _ =
 218     do exists <- doesDirectoryExist n
 219        file_exists <- doesFileExist n
 220        if exists || file_exists
 221           then fail $ "Directory or file named '" ++ n ++ "' already exists."
 222           else return n
 223 make_repo_name (_:as) d = make_repo_name as d
 224 make_repo_name [] d =
 225   case dropWhile (=='.') $ reverse $
 226        takeWhile (\c -> c /= '/' && c /= ':') $
 227        dropWhile (=='/') $ reverse d of
 228   "" -> modify_repo_name "anonymous_repo"
 229   base -> modify_repo_name base
 230
 231 modify_repo_name :: String -> IO String
 232 modify_repo_name name =
 233     if head name == '/'
 234     then mrn name (-1)
 235     else do cwd <- getCurrentDirectory
 236             mrn (cwd ++ "/" ++ name) (-1)
 237  where
 238   mrn :: String -> Int -> IO String
 239   mrn n i = do
 240     exists <- doesDirectoryExist thename
 241     file_exists <- doesFileExist thename
 242     if not exists && not file_exists
 243        then do when (i /= -1) $
 244                     putStrLn $ "Directory '"++ n ++
 245                                "' already exists, creating repository as '"++
 246                                thename ++"'"
 247                return thename
 248        else mrn n $ i+1
 249     where thename = if i == -1 then n else n++"_"++show i
 250
 251 \end{code}