darcs-fastconvert (empty) → 0.1
raw patch · 6 files changed
+571/−0 lines, 6 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, cmdlib, darcs, darcs-beta, datetime, directory, filepath, hashed-storage, mtl, old-time, utf8-string
Files
- Export.hs +111/−0
- Import.hs +317/−0
- LICENSE +30/−0
- Setup.hs +3/−0
- darcs-fastconvert.cabal +86/−0
- main.hs +24/−0
+ Export.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GADTs, OverloadedStrings #-}+module Export( fastExport ) where++import Prelude hiding ( readFile )++import Data.Maybe ( catMaybes, fromJust )+import Data.DateTime ( formatDateTime, fromClockTime )+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString.Lazy.UTF8 as BLU++import Control.Monad ( when, forM_ )+import Control.Monad.Trans ( liftIO )+import Control.Monad.State.Strict( gets )+import Control.Exception( finally )++import System.Time ( toClockTime )++import Darcs.Hopefully ( PatchInfoAnd, info )+import Darcs.Repository ( ($-), readRepo, withRepository )+import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )+import Darcs.Repository.HashedRepo ( readHashedPristineRoot )+import Darcs.Repository.HashedIO ( cleanHashdir )+import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Patch ( effect, listTouchedFiles, apply, RepoPatch )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, nullFL )+import Darcs.Patch.Info ( isTag, PatchInfo, piAuthor, piName, piLog, piDate )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2FL )+import Darcs.Utils ( withCurrentDirectory )++import Storage.Hashed.Monad hiding ( createDirectory, exists )+import Storage.Hashed.Darcs+import Storage.Hashed.Tree( emptyTree, listImmediate, findTree )+import Storage.Hashed.AnchoredPath( anchorPath, appendPath, floatPath+ , AnchoredPath )++fastExport :: String -> IO ()+fastExport repodir = withCurrentDirectory repodir $+ withRepository [] $- \repo -> do+ putStrLn "progress (reading repository)"+ patchset <- readRepo repo+ 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++ 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 dumpTag p n+ 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 ()+ `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+ where go :: RL(Tagged t1) -> [PatchInfo]+ go (Tagged t _ _ :<: ts') = info t : go ts'+ go NilRL = []+
+ Import.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Import( fastImport, RepoFormat(..) ) where++import Prelude hiding ( readFile, lex, maybe )+import Data.Data+import Data.DateTime ( formatDateTime, parseDateTime, startOfTime )+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BL++import Control.Monad ( when )+import Control.Applicative ( (<|>) )+import Control.Monad.Trans ( liftIO )+import Control.Monad.State.Strict( gets, modify )+import System.Directory ( setCurrentDirectory, doesFileExist, createDirectory )+import System.IO ( stdin )+import System.Time ( toClockTime )++import Darcs.Hopefully ( n2pia )+import Darcs.Flags( Compression( .. )+ , DarcsFlag( UseHashedInventory, UseFormat2 ) )+import Darcs.Repository ( Repository, withRepoLock, ($-)+ , readTentativeRepo+ , createRepository+ , createPristineDirectoryTree+ , finalizeRepositoryChanges+ , cleanRepository )++import Darcs.Repository.HashedRepo ( addToTentativeInventory )+import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository.Prefs( FileType(..) )++import Darcs.Patch ( RepoPatch, RealPatch, fromPrims, infopatch, adddeps,identity )+import Darcs.Patch.Depends ( getTagsRight )+import Darcs.Patch.Prim ( sortCoalesceFL )+import Darcs.Patch.Info ( PatchInfo, patchinfo )+import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )++import Storage.Hashed.Monad hiding ( createDirectory, exists )+import qualified Storage.Hashed.Monad as TM+import qualified Storage.Hashed.Tree as T+import Storage.Hashed.Darcs+import Storage.Hashed.Hash( encodeBase16, sha256, Hash(..) )+import Storage.Hashed.Tree( emptyTree, Tree, treeHash, readBlob, TreeItem(..) )+import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath(..), Name(..)+ , appendPath )+import Darcs.Diff( treeDiff )++import qualified Data.Attoparsec.Char8 as A+import Data.Attoparsec.Char8( (<?>) )++data RepoFormat = Darcs2Format | HashedFormat deriving (Eq, Data, Typeable)++type Marked = Maybe Int+type Branch = B.ByteString+type AuthorInfo = B.ByteString+type Message = B.ByteString+type Content = B.ByteString++data RefId = MarkId Int | HashId B.ByteString | Inline+ deriving Show++data Object = Blob (Maybe Int) Content+ | Reset Branch (Maybe RefId)+ | Commit Branch Marked AuthorInfo Message+ | Tag Int AuthorInfo Message+ | Modify (Either Int Content) B.ByteString -- (mark or content), filename+ | Gitlink B.ByteString+ | Delete B.ByteString -- filename+ | From Int+ | Merge Int+ | Progress B.ByteString+ | End+ deriving Show++type Ancestors = (Marked, [Int])+data State = Toplevel Marked Branch+ | InCommit Marked Ancestors Branch (Tree IO) PatchInfo+ | Done++instance Show State where+ show (Toplevel _ _) = "Toplevel"+ show (InCommit _ _ _ _ _) = "InCommit"+ show Done = "Done"++fastImport :: String -> RepoFormat -> IO ()+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++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"+ go :: State -> B.ByteString -> TreeIO ()+ go state rest = do (rest', item) <- next object rest+ state' <- process state item+ case state' of+ Done -> return ()+ _ -> go state' rest'++ -- sort marks into buckets, since there can be a *lot* of them+ markpath :: Int -> AnchoredPath+ markpath n = floatPath "_darcs/marks"+ `appendPath` (Name $ BC.pack $ show (n `div` 1000))+ `appendPath` (Name $ BC.pack $ show (n `mod` 1000))++ makeinfo author message tag = do+ let (name:log) = lines $ BC.unpack message+ (author'', date'') = span (/='>') $ BC.unpack author+ date' = dropWhile (`notElem` "0123456789") date''+ author' = author'' ++ ">"+ date = formatDateTime "%Y%m%d%H%M%S" $ case (parseDateTime "%s %z" date') of+ Just x -> x+ Nothing -> startOfTime+ liftIO $ patchinfo date (if tag then "TAG " ++ name else name) author' log++ addtag author msg =+ do info <- makeinfo author msg True+ gotany <- liftIO $ doesFileExist "_darcs/tentative_hashed_pristine"+ deps <- if gotany then liftIO $ getTagsRight `fmap` readTentativeRepo repo+ else return []+ let ident = identity :: FL RealPatch+ patch = adddeps (infopatch info ident) deps+ liftIO $ addToTentativeInventory (extractCache repo)+ GzipCompression (n2pia patch)+ return ()++ -- processing items+ updateHashes = do+ let nodarcs = (\(AnchoredPath (Name x:_)) _ -> x /= BC.pack "_darcs")+ hashblobs (File blob@(T.Blob con NoHash)) =+ do hash <- sha256 `fmap` readBlob blob+ return $ File (T.Blob con hash)+ hashblobs x = return x+ tree' <- liftIO . T.partiallyUpdateTree hashblobs nodarcs =<< gets tree+ modify $ \s -> s { tree = tree' }+ return $ T.filter nodarcs tree'++ process :: State -> Object -> TreeIO State+ process s (Progress p) = do+ liftIO $ putStrLn ("progress " ++ BC.unpack p)+ return s++ process (Toplevel _ _) End = do+ tree' <- (liftIO . darcsAddMissingHashes) =<< updateHashes+ modify $ \s -> s { tree = tree' } -- lets dump the right tree, without _darcs+ let root = encodeBase16 $ treeHash tree'+ liftIO $ do+ putStrLn $ "\\o/ It seems we survived. Enjoy your new repo."+ B.writeFile "_darcs/tentative_pristine" $+ BC.concat [BC.pack "pristine:", root]+ return Done++ process (Toplevel n b) (Tag what author msg) = do+ if Just what == n+ then addtag author msg+ else liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " +++ (head $ lines $ BC.unpack msg)+ return (Toplevel n b)++ process (Toplevel n b) (Reset branch from) =+ do case from of+ (Just (MarkId k)) | Just k == n ->+ addtag (BC.pack "Anonymous Tagger <> 0 +0000") branch+ _ -> liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " +++ BC.unpack branch+ return $ Toplevel n branch++ process (Toplevel n b) (Blob (Just m) bits) = do+ TM.writeFile (markpath m) $ (BL.fromChunks [bits])+ return $ Toplevel n b++ process x (Gitlink link) = do+ liftIO $ putStrLn $ "WARNING: Ignoring gitlink " ++ BC.unpack link+ return x++ process (Toplevel previous pbranch) (Commit branch mark author message) = do+ when (pbranch /= branch) $ do+ liftIO $ putStrLn ("Tagging branch: " ++ BC.unpack pbranch)+ addtag author pbranch+ info <- makeinfo author message False+ startstate <- updateHashes+ return $ InCommit mark (previous, []) branch startstate info++ process s@(InCommit _ _ _ _ _) (Modify (Left m) path) = do+ TM.copy (markpath m) (floatPath $ BC.unpack path)+ return s++ process s@(InCommit _ _ _ _ _) (Modify (Right bits) path) = do+ TM.writeFile (floatPath $ BC.unpack path) (BL.fromChunks [bits])+ return s++ process s@(InCommit _ _ _ _ _) (Delete path) = do+ TM.unlink (floatPath $ BC.unpack path)+ return s++ process (InCommit mark (prev, current) branch start info) (From from) = do+ return $ InCommit mark (prev, from:current) branch start info++ process (InCommit mark (prev, current) branch start info) (Merge from) = do+ return $ InCommit mark (prev, from:current) branch start info++ process (InCommit mark ancestors branch start info) x = do+ case ancestors of+ (_, []) -> return () -- OK, previous commit is the ancestor+ (Just n, list)+ | n `elem` list -> return () -- OK, we base off one of the ancestors+ | otherwise -> liftIO $ putStrLn $+ "WARNING: Linearising non-linear ancestry:" +++ " currently at " ++ show n ++ ", ancestors " ++ show list+ (Nothing, list) ->+ liftIO $ putStrLn $ "WARNING: Linearising non-linear ancestry " ++ show list++ current <- updateHashes+ Sealed diff+ <- unFreeLeft `fmap` (liftIO $ treeDiff (const TextFile) start current)+ prims <- return $ fromPrims $ sortCoalesceFL diff+ let patch = infopatch info ((identity :: RealPatch) :>: prims)+ liftIO $ addToTentativeInventory (extractCache repo)+ GzipCompression (n2pia patch)+ 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+ lex p = p >>= \x -> A.skipSpace >> return x+ lexString s = A.string (BC.pack s) >> A.skipSpace+ line = lex $ A.takeWhile (/='\n')+ maybe p = Just `fmap` p <|> return Nothing+ p_object = p_blob+ <|> p_reset+ <|> p_commit+ <|> p_tag+ <|> p_modify+ <|> p_from+ <|> p_merge+ <|> p_delete+ <|> (lexString "progress" >> Progress `fmap` line)+ <|> (A.endOfInput >> return End)+ p_author name = lexString name >> line+ p_reset = do lexString "reset"+ branch <- line+ refid <- maybe $ lexString "from" >> p_refid+ return $ Reset branch refid+ p_commit = do lexString "commit"+ branch <- line+ mark <- maybe p_mark+ author <- maybe $ p_author "author"+ committer <- p_author "committer"+ message <- p_data+ return $ Commit branch mark committer message+ p_tag = do lexString "tag" >> line -- FIXME we ignore branch for now+ lexString "from"+ mark <- p_marked+ author <- p_author "tagger"+ message <- p_data+ return $ Tag mark author message++ p_blob = do lexString "blob"+ mark <- maybe p_mark+ Blob mark `fmap` p_data+ <?> "p_blob"+ p_mark = do lexString "mark"+ lex $ A.char ':'+ lex A.decimal+ <?> "p_mark"+ p_refid = MarkId `fmap` p_marked+ <|> (lexString "inline" >> return Inline)+ <|> HashId `fmap` p_hash+ p_data = do lexString "data"+ len <- A.decimal+ A.char '\n'+ lex $ A.take len+ <?> "p_data"+ p_marked = lex $ A.char ':' >> A.decimal+ p_hash = lex $ A.takeWhile1 (A.inClass "0123456789abcdefABCDEF")+ p_from = lexString "from" >> From `fmap` p_marked+ p_merge = lexString "merge" >> Merge `fmap` p_marked+ p_delete = lexString "D" >> Delete `fmap` line+ p_modify = do lexString "M"+ mode <- lex $ A.takeWhile (A.inClass "01234567890")+ mark <- p_refid+ path <- line+ case mark of+ HashId hash | mode == BC.pack "160000" -> return $ Gitlink hash+ | otherwise -> fail ":(("+ MarkId n -> return $ Modify (Left n) path+ Inline -> do bits <- p_data+ return $ Modify (Right bits) path++ next :: (B.ByteString -> A.Result Object) -> B.ByteString -> TreeIO (B.ByteString, Object)+ next parser rest =+ do chunk <- if B.null rest then liftIO $ B.hGet stdin (64 * 1024)+ else return rest+ next_chunk parser chunk+ next_chunk parser chunk =+ do case parser chunk of+ A.Done rest result -> return (rest, result)+ A.Partial cont -> next cont B.empty+ A.Fail _ ctx err -> do+ liftIO $ putStrLn $ "=== chunk ===\n" ++ BC.unpack chunk ++ "\n=== end chunk ===="+ fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Petr Rockai <me@mornfall.net> 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Petr Rockai nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ darcs-fastconvert.cabal view
@@ -0,0 +1,86 @@+-- darcs-fastconvert.cabal auto-generated by cabal init. For+-- additional options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: darcs-fastconvert++-- 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++-- A short (one-line) description of the package.+Synopsis: Import/export git fast-import streams to/from darcs.++Description: The darcs-fastconvert tool allows you to both import+ git repositories into darcs (using git fast-export)+ and export darcs repositories into git (using git+ fast-import). You may also achieve some success with + 3rd-party fast-import/fast-export tools, like+ bzr-fastimport although this is not explicitly + supported or tested. Often, converting from X to git + and then to darcs works better than direct X to darcs + conversion using 3rd-party tools.++-- A longer description of the package.+-- Description: ++-- The license under which the package is released.+License: BSD3+License-file: LICENSE++-- The package author(s).+Author: Petr Rockai <me@mornfall.net>++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: me@mornfall.net++-- A copyright notice.+-- Copyright: ++-- Stability of the pakcage (experimental, provisional, stable...)+Stability: Experimental++Category: Development++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.6++source-repository head+ type: darcs+ location: http://repos.mornfall.net/darcs-fastconvert++flag beta+ description: use darcs-beta instead of darcs++Executable darcs-fastconvert+ -- .hs or .lhs file containing the Main module.+ Main-is: main.hs+ ghc-options: -Wall -fno-warn-unused-do-bind++ if flag(beta)+ build-depends: darcs-beta >= 2.4.98.5 && < 2.5+ else+ build-depends: darcs >= 2.5 && < 2.6++ -- Packages needed in order to build this package.+ Build-depends: hashed-storage >= 0.5.3 && < 0.6,+ cmdlib >= 0.2 && < 0.3,+ base >= 4 && < 5,+ attoparsec >= 0.8 && < 0.9,+ datetime, old-time, filepath, bytestring, mtl,+ directory, utf8-string++ -- Modules not exported by this package.+ Other-modules: Export Import++ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools:+
+ main.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveDataTypeable #-}+import Import+import Export+import System.Console.CmdLib++data Cmd = Import { repo :: String, format :: RepoFormat }+ | Export { repo :: String }+ 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 ]+ readFlag _ = readCommon <+< readFormat+ where readFormat "darcs-2" = Darcs2Format+ readFormat "hashed" = HashedFormat+ readFormat x = error $ "No such repository format " ++ show x++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."+main = getArgs >>= dispatchR [] undefined >>= \x -> case x of+ Import {} -> (format x) `seq` fastImport (repo x) (format x) -- XXX hack+ Export {} -> fastExport (repo x)