diff --git a/Export.hs b/Export.hs --- a/Export.hs +++ b/Export.hs @@ -3,21 +3,26 @@ import Prelude hiding ( readFile ) +import Marks + import Data.Maybe ( catMaybes, fromJust ) import Data.DateTime ( formatDateTime, fromClockTime ) +import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Lazy.UTF8 as BLU +import Data.IORef ( newIORef, modifyIORef, readIORef ) -import Control.Monad ( when, forM_ ) +import Control.Monad ( when, forM_, unless ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Strict( gets ) import Control.Exception( finally ) import System.Time ( toClockTime ) +import System.IO ( hPutStrLn, openFile, IOMode(..), stderr ) import Darcs.Hopefully ( PatchInfoAnd, info ) -import Darcs.Repository ( ($-), readRepo, withRepository ) +import Darcs.Repository ( Repository, ($-), readRepo, withRepository ) import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) import Darcs.Repository.HashedRepo ( readHashedPristineRoot ) import Darcs.Repository.HashedIO ( cleanHashdir ) @@ -27,6 +32,7 @@ import Darcs.Patch.Info ( isTag, PatchInfo, piAuthor, piName, piLog, piDate ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2FL ) import Darcs.Utils ( withCurrentDirectory ) +import Utils import Storage.Hashed.Monad hiding ( createDirectory, exists ) import Storage.Hashed.Darcs @@ -34,75 +40,103 @@ import Storage.Hashed.AnchoredPath( anchorPath, appendPath, floatPath , AnchoredPath ) -fastExport :: String -> IO () -fastExport repodir = withCurrentDirectory repodir $ - withRepository [] $- \repo -> do +inOrderTag tags p = isTag (info p) && info p `elem` tags && nullFL (effect p) +next tags n p = if inOrderTag tags p then n else n + 1 + +tagName = map (cleanup " .") . drop 4 . patchName -- FIXME many more chars are probably illegal + where cleanup bad x | x `elem` bad = '_' + | otherwise = x + +patchName = piName . info +patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime . piDate . info + +patchAuthor p = case span (/='<') $ piAuthor (info p) of + (n, "") -> n ++ " " + (n, rest) -> case span (/='>') $ tail rest of + (email, _) -> n ++ "<" ++ email ++ ">" + +patchMessage p = BL.concat [ BLU.fromString (piName $ info p) + , case (unlines . piLog $ info p) of + "" -> BL.empty + plog -> BLU.fromString ("\n" ++ plog)] + +dumpBits = liftIO . BL.putStrLn . BL.intercalate "\n" + +dumpFiles :: [AnchoredPath] -> TreeIO () +dumpFiles files = forM_ files $ \file -> do + isfile <- fileExists file + isdir <- directoryExists file + when isfile $ do bits <- readFile file + dumpBits [ BLU.fromString $ "M 100644 inline " ++ anchorPath "" file + , BLU.fromString $ "data " ++ show (BL.length bits) + , bits ] + when isdir $ do tt <- gets tree -- ick + let subs = [ file `appendPath` n | (n, _) <- + listImmediate $ fromJust $ findTree tt file ] + dumpFiles subs + when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ anchorPath "" file + +dumpPatch mark p n = + do dumpBits [ BLC.pack $ "progress " ++ show n ++ ": " ++ patchName p + , "commit refs/heads/master" ] + mark p n + dumpBits [ BLU.fromString $ "committer " ++ patchAuthor p ++ " " ++ patchDate p + , BLU.fromString $ "data " ++ show (BL.length $ patchMessage p) + , patchMessage p ] + when (n > 1) $ dumpBits [ BLU.fromString $ "from :" ++ show (n - 1) ] + +dumpTag p n = + dumpBits [ BLU.fromString $ "progress TAG " ++ tagName p + , BLU.fromString $ "tag " ++ tagName p -- FIXME is this valid? + , BLU.fromString $ "from :" ++ show (n - 1) -- the previous mark + , BLU.fromString $ "tagger " ++ patchAuthor p ++ " " ++ patchDate p + , BLU.fromString $ "data " ++ show (BL.length (patchMessage p) - 4) + , BL.drop 4 $ patchMessage p ] + +dumpPatches :: (RepoPatch p) => [PatchInfo] -> (PatchInfoAnd p -> Int -> TreeIO ()) + -> Int -> FL (PatchInfoAnd p) -> TreeIO () +dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)" +dumpPatches tags mark n (p:>:ps) = do + apply [] p + if inOrderTag tags p && n > 0 + then dumpTag p n + else do dumpPatch mark p n + dumpFiles $ map floatPath $ listTouchedFiles p + dumpPatches tags mark (next tags n p) ps + +fastExport :: String -> Marks -> IO Marks +fastExport repodir marks = + withCurrentDirectory repodir $ withRepository [] $- \repo -> fastExport' repo marks + +fastExport' :: (RepoPatch p) => Repository p -> Marks -> IO Marks +fastExport' repo marks = do putStrLn "progress (reading repository)" patchset <- readRepo repo + marksref <- newIORef marks let total = show (lengthFL patches) patches = newset2FL patchset tags = optimizedTags patchset - dumpfiles :: [AnchoredPath] -> TreeIO () - dumpfiles files = forM_ files $ \file -> do - isfile <- fileExists file - isdir <- directoryExists file - when isfile $ do bits <- readFile file - liftIO $ putStrLn $ "M 100644 inline " ++ anchorPath "" file - liftIO $ putStrLn $ "data " ++ show (BL.length bits) - liftIO $ BL.putStr bits - when isdir $ do tt <- gets tree -- ick - let subs = [ file `appendPath` n | (n, _) <- - listImmediate $ fromJust $ findTree tt file ] - dumpfiles subs - when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ anchorPath "" file + mark p n = liftIO $ do putStrLn $ "mark :" ++ show n + modifyIORef marksref $ \m -> addMark m n (patchHash p) + checkOne n p = do apply [] p + unless (inOrderTag tags p || + (getMark marks n == Just (patchHash p))) $ + die $ "FATAL: Marks do not correspond: expected " ++ + (show $ getMark marks n) ++ ", got " ++ (BSC.unpack $ patchHash p) + check _ NilFL = return (1, NilFL) + check n allps@(p:>:ps) + | n <= lastMark marks = do checkOne n p >> check (next tags n p) ps + | n > lastMark marks = return (n, allps) + | lastMark marks == 0 = return (1, allps) - name = piName . info - tagname = map (cleanup " .") . drop 4 . name -- FIXME many more chars are probably illegal - where cleanup bad x | x `elem` bad = '_' - | otherwise = x - date = formatDateTime "%s +0000" . fromClockTime . toClockTime . piDate . info - message p = BL.concat [ BLU.fromString (piName $ info p) - , case (unlines . piLog $ info p) of - "" -> BL.empty - plog -> BLU.fromString ("\n" ++ plog)] - realTag p = isTag (info p) && info p `elem` tags && nullFL (effect p) - author p = case span (/='<') $ piAuthor (info p) of - (n, "") -> n ++ " " - (n, rest) -> case span (/='>') $ tail rest of - (email, _) -> n ++ "<" ++ email ++ ">" - dumpPatch p n = liftIO $ BL.putStr $ BL.intercalate "\n" - [ BLC.pack $ "progress " ++ show n ++ " / " ++ total ++ ": " ++ name p - , "commit refs/heads/master" - , BLU.fromString $ "mark :" ++ show n -- mark the stream - , BLU.fromString $ "committer " ++ author p ++ " " ++ date p - , BLU.fromString $ "data " ++ show (BL.length $ message p) - , message p ] - dumpTag p n = liftIO $ BL.putStr $ BL.intercalate "\n" - [ BLU.fromString $ "progress TAG " ++ tagname p - , BLU.fromString $ "tag " ++ tagname p -- FIXME is this valid? - , BLU.fromString $ "from :" ++ show (n - 1) -- the previous mark - , BLU.fromString $ "tagger " ++ author p ++ " " ++ date p - , BLU.fromString $ "data " ++ show (BL.length (message p) - 4) - , BL.drop 4 $ message p ] - dump :: (RepoPatch p) => Int -> FL (PatchInfoAnd p) -> TreeIO () - dump _ NilFL = liftIO $ putStrLn "progress (patches converted)" - dump n (p:>:ps) = do - apply [] p - if realTag p && n > 0 - then do dumpTag p n - dump n ps - else do dumpPatch p n - dumpfiles $ map floatPath $ listTouchedFiles p - dump (n + 1) ps - putStrLn "reset refs/heads/master" - hashedTreeIO (dump 1 patches) emptyTree "_darcs/pristine.hashed" - return () + ((n, patches'), tree) <- hashedTreeIO (check 1 patches) emptyTree "_darcs/pristine.hashed" + hashedTreeIO (dumpPatches tags mark n patches') tree "_darcs/pristine.hashed" + readIORef marksref `finally` do putStrLn "progress (cleaning up)" current <- readHashedPristineRoot repo cleanHashdir (extractCache repo) HashedPristineDir $ catMaybes [current] putStrLn "progress done" - return () optimizedTags :: PatchSet p -> [PatchInfo] optimizedTags (PatchSet _ ts) = go ts diff --git a/Import.hs b/Import.hs --- a/Import.hs +++ b/Import.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Import( fastImport, RepoFormat(..) ) where +module Import( fastImport, fastImportIncremental, RepoFormat(..) ) where import Prelude hiding ( readFile, lex, maybe ) import Data.Data @@ -7,6 +7,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BL +import Data.IORef ( newIORef, modifyIORef, readIORef ) import Control.Monad ( when ) import Control.Applicative ( (<|>) ) @@ -20,11 +21,12 @@ import Darcs.Flags( Compression( .. ) , DarcsFlag( UseHashedInventory, UseFormat2 ) ) import Darcs.Repository ( Repository, withRepoLock, ($-) - , readTentativeRepo + , readTentativeRepo, readRepo , createRepository , createPristineDirectoryTree , finalizeRepositoryChanges , cleanRepository ) +import Darcs.Repository.State( readRecorded ) import Darcs.Repository.HashedRepo ( addToTentativeInventory ) import Darcs.Repository.InternalTypes ( extractCache ) @@ -34,6 +36,7 @@ import Darcs.Patch.Depends ( getTagsRight ) import Darcs.Patch.Prim ( sortCoalesceFL ) import Darcs.Patch.Info ( PatchInfo, patchinfo ) +import Darcs.Patch.Set ( newset2FL ) import Darcs.Witnesses.Ordered ( FL(..) ) import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft ) @@ -46,7 +49,11 @@ import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath(..), Name(..) , appendPath ) import Darcs.Diff( treeDiff ) +import Darcs.Utils ( withCurrentDirectory ) +import Utils +import Marks + import qualified Data.Attoparsec.Char8 as A import Data.Attoparsec.Char8( () ) @@ -84,26 +91,37 @@ show (InCommit _ _ _ _ _) = "InCommit" show Done = "Done" -fastImport :: String -> RepoFormat -> IO () +fastImport :: String -> RepoFormat -> IO Marks fastImport outrepo fmt = do createDirectory outrepo - setCurrentDirectory outrepo - createRepository $ case fmt of - Darcs2Format -> [UseFormat2] - HashedFormat -> [UseHashedInventory] - withRepoLock [] $- \repo -> do - fastImport' repo - finalizeRepositoryChanges repo - cleanRepository repo - createPristineDirectoryTree repo "." -- this name is really confusing + withCurrentDirectory outrepo $ do + createRepository $ case fmt of + Darcs2Format -> [UseFormat2] + HashedFormat -> [UseHashedInventory] + withRepoLock [] $- \repo -> do + marks <- fastImport' repo emptyMarks + createPristineDirectoryTree repo "." -- this name is really confusing + return marks -fastImport' :: (RepoPatch p) => Repository p -> IO () -fastImport' repo = - do hashedTreeIO (go initial B.empty) emptyTree "_darcs/pristine.hashed" - return () - where initial = Toplevel Nothing $ BC.pack "refs/branches/master" +fastImportIncremental :: String -> Marks -> IO Marks +fastImportIncremental repodir marks = + withCurrentDirectory repodir $ withRepoLock [] $- \repo -> fastImport' repo marks + +fastImport' :: (RepoPatch p) => Repository p -> Marks -> IO Marks +fastImport' repo marks = do + pristine <- readRecorded repo + patches <- newset2FL `fmap` readRepo repo + marksref <- newIORef marks + let initial = Toplevel Nothing $ BC.pack "refs/branches/master" + + check NilFL [] = return () + check (p:>:ps) ((k,h):ms) = do + when (patchHash p /= h) $ die "FATAL: Marks do not correspond." + check ps ms + check _ _ = die "FATAL: Patch and mark count do not agree." + go :: State -> B.ByteString -> TreeIO () - go state rest = do (rest', item) <- next object rest + go state rest = do (rest', item) <- parseObject rest state' <- process state item case state' of Done -> return () @@ -229,14 +247,25 @@ let patch = infopatch info ((identity :: RealPatch) :>: prims) liftIO $ addToTentativeInventory (extractCache repo) GzipCompression (n2pia patch) + case mark of + Nothing -> return () + Just n -> case getMark marks n of + Nothing -> liftIO $ modifyIORef marksref $ \m -> addMark m n (patchHash $ n2pia patch) + Just n' -> die $ "FATAL: Mark already exists: " ++ BC.unpack n' process (Toplevel mark branch) x process state obj = do liftIO $ print obj fail $ "Unexpected object in state " ++ show state - -- parser follows ------------------------ - object = A.parse p_object + check patches (listMarks marks) + hashedTreeIO (go initial B.empty) pristine "_darcs/pristine.hashed" + finalizeRepositoryChanges repo + cleanRepository repo + readIORef marksref + +parseObject = next object + where object = A.parse p_object lex p = p >>= \x -> A.skipSpace >> return x lexString s = A.string (BC.pack s) >> A.skipSpace line = lex $ A.takeWhile (/='\n') diff --git a/Marks.hs b/Marks.hs new file mode 100644 --- /dev/null +++ b/Marks.hs @@ -0,0 +1,27 @@ +module Marks where +import qualified Data.IntMap as M +import qualified Data.ByteString.Char8 as BS +import System.Directory( removeFile ) + +type Marks = M.IntMap BS.ByteString + +emptyMarks = M.empty +lastMark m = if M.null m then 0 else fst $ M.findMax m + +getMark marks key = M.lookup key marks +addMark marks key value = M.insert key value marks +listMarks = M.assocs + +readMarks :: FilePath -> IO Marks +readMarks p = do lines <- BS.split '\n' `fmap` BS.readFile p + return $ foldl merge M.empty lines + `catch` \_ -> return emptyMarks + where merge set line = case (BS.split ':' line) of + [id, hash] -> M.insert (read $ BS.unpack id) (BS.dropWhile (== ' ') hash) set + _ -> set -- ignore, although it is maybe not such a great idea... + +writeMarks :: FilePath -> Marks -> IO () +writeMarks fp m = do removeFile fp `catch` \_ -> return () -- unlink + BS.writeFile fp marks + where marks = BS.concat $ map format $ listMarks m + format (k, s) = BS.concat [BS.pack $ show k, BS.pack ": ", s, BS.pack "\n"] diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,10 @@ +module Utils where +import System.IO ( hPutStrLn, stderr ) +import Control.Monad.Trans ( liftIO ) +import System.Exit +import Darcs.Hopefully ( info ) +import Darcs.Patch.Info ( makeFilename ) +import qualified Data.ByteString.Char8 as BSC + +die str = liftIO (hPutStrLn stderr str >> exitWith (ExitFailure 1)) +patchHash p = BSC.pack $ makeFilename (info p) diff --git a/darcs-fastconvert.cabal b/darcs-fastconvert.cabal --- a/darcs-fastconvert.cabal +++ b/darcs-fastconvert.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version:0.1.1 +Version: 0.2 -- A short (one-line) description of the package. Synopsis: Import/export git fast-import streams to/from darcs. @@ -76,10 +76,10 @@ base >= 4 && < 5, attoparsec >= 0.8 && < 0.9, datetime, old-time, filepath, bytestring, mtl, - directory, utf8-string + directory, utf8-string, containers -- Modules not exported by this package. - Other-modules: Export Import + Other-modules: Export Import Marks Utils -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -1,16 +1,30 @@ {-# LANGUAGE DeriveDataTypeable #-} +import qualified Marks import Import import Export import System.Console.CmdLib -data Cmd = Import { repo :: String, format :: RepoFormat } - | Export { repo :: String } +data Cmd = Import { repo :: String + , format :: RepoFormat + , create :: Bool + , readMarks :: FilePath + , writeMarks :: FilePath } + | Export { repo :: String + , readMarks :: FilePath + , writeMarks :: FilePath } deriving (Eq, Typeable, Data) instance Attributes Cmd where - attributes _ = repo %> [ Positional 0 ] %% - format %> [ Help "Repository type to create: darcs-2 (default) or hashed." - , Default Darcs2Format ] + attributes _ = + repo %> [ Positional 0 ] %% group "Options" + [ format %> [ Help "repository type to create: darcs-2 (default) or hashed" + , Default Darcs2Format ] + , create %> [ Help "create a new repository", Default True ] + , readMarks %> [ Help "continue conversion, previously checkpointed by --write-marks" + , ArgHelp "FILE" ] + , writeMarks %> [ Help "checkpoint conversion to continue it later" + , ArgHelp "FILE" ] ] + readFlag _ = readCommon <+< readFormat where readFormat "darcs-2" = Darcs2Format readFormat "hashed" = HashedFormat @@ -19,6 +33,19 @@ instance RecordCommand Cmd where mode_summary Import {} = "Import a git-fast-export dump into darcs." mode_summary Export {} = "Export a darcs repository to a git-fast-import stream." + +handleMarks cmd act = do + do marks <- case readMarks cmd of + [] -> return Marks.emptyMarks + x -> Marks.readMarks x + marks' <- act marks + case writeMarks cmd of + [] -> return () + x -> Marks.writeMarks x marks' + main = getArgs >>= dispatchR [] undefined >>= \x -> case x of - Import {} -> (format x) `seq` fastImport (repo x) (format x) -- XXX hack - Export {} -> fastExport (repo x) + Import {} | create x && null (readMarks x) -> case readMarks x of + [] -> (format x) `seq` -- avoid late failure + handleMarks x (const $ fastImport (repo x) (format x)) + | otherwise -> handleMarks x $ fastImportIncremental (repo x) + Export {} -> handleMarks x $ fastExport (repo x)