darcs-fastconvert 0.1.1 → 0.2
raw patch · 6 files changed
+217/−90 lines, 6 filesdep +containers
Dependencies added: containers
Files
- Export.hs +94/−60
- Import.hs +49/−20
- Marks.hs +27/−0
- Utils.hs +10/−0
- darcs-fastconvert.cabal +3/−3
- main.hs +34/−7
Export.hs view
@@ -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 ++ " <unknown>"+ (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 ++ " <unknown>"- (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
Import.hs view
@@ -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')
+ Marks.hs view
@@ -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"]
+ Utils.hs view
@@ -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)
darcs-fastconvert.cabal view
@@ -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:
main.hs view
@@ -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)