% 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}

    {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
    {-# 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 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,
                              applyToWorking )
    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(..), Sealed(..) )
    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"

    -- | 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 {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

      --test for converting darcs-2 repository
      Right format <- identifyRepoFormat repodir -- just fail in case of error
      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
          -- We really ought to have special versions of withRepoLock and
          -- withRepositoryDirectory that check at runtime that it's the right
          -- sort of repository and accept a function of (Repository Patch) or
          -- (Repository (FL RealPatch)), but that seems like a lot of work
          -- when these functions would be used exactly once, right here.  So I
          -- go with a horrible evil hack.

          -- The other alternative (which is what we used to do) is to use
          -- "universal" functions to do the conversion, but that's also
          -- unsatisfying.

          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 Sealed pw <- tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs
                                finalizeRepositoryChanges repository -- this is to clean out pristine.hashed
                                revertRepositoryChanges repository
                                revertable $ applyToWorking repository opts pw
                                invalidateIndex 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}