hsubconvert 0.0.1 → 0.0.2
raw patch · 2 files changed
+134/−36 lines, 2 filesdep +lensdep +mtldep +stringabledep −lzma-conduitdep −shellydep ~unix
Dependencies added: lens, mtl, stringable, system-filepath, text-format
Dependencies removed: lzma-conduit, shelly
Dependency ranges changed: unix
Files
- Main.hs +127/−32
- hsubconvert.cabal +7/−4
Main.hs view
@@ -2,23 +2,29 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main where +import Control.Lens+import Control.Monad.Trans+import Control.Monad.Trans.State import qualified Data.ByteString as B import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Internal as BLI import Data.Git+import Data.Stringable hiding (fromText, length)+import Data.Text.Format ( format ) import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as T+--import qualified Data.Text.Lazy as T import Filesystem (isDirectory, removeTree)+import Filesystem.Path.CurrentOS hiding (null, toText) import Foreign.ForeignPtr import Foreign.Ptr import GHC.Conc import Prelude.General-import Shelly import Subversion.Dump import System.Console.CmdArgs import System.Environment@@ -55,8 +61,15 @@ program "hsubconvert" &= help "One-time, faithful conversion of Subversion repositories to Git" +data HSubconvertState = HSubconvertState { _pastTrees :: [(Int, ObjRef Tree)] }+ deriving Show++makeClassy ''HSubconvertState++type SIO = StateT HSubconvertState IO+ withRepository :: Text -> (Repository -> IO ()) -> IO ()-withRepository n f = do let p = fromText n+withRepository n f = do let p = toFilePath n exists <- isDirectory p when exists $ removeTree p f =<< createRepository p True@@ -75,17 +88,25 @@ hSetBuffering stdout NoBuffering + unless (length (files opts) == 2) $+ void (withArgs ["--help"] (cmdArgs hSubconvert))+ withRepository "test.git" $ \repo -> do file <- BL.readFile (head (files opts)) let revs = readSvnDump file- (c, lastRev) <-- foldM (\(co, _) rev -> do- when (isJust co) $- reportProgress False (revNumber rev) (fromJust co)- co' <- applyRevision repo co rev- return (co', rev))- (Nothing, head revs) revs+ (c, _, lastRev) <- -- _ = finalState+ foldM+ (\(co, st, _) rev -> do+ when (isJust co) $+ reportProgress False (revNumber rev) (fromJust co)+ (co', st') <- flip runStateT st $ applyRevision repo co rev+ let st'' = case co' of+ Nothing -> st'+ Just x ->+ pastTrees %~ (:) (revNumber rev, x^.commitTree) $ st'+ return (co', st'', rev))+ (Nothing, HSubconvertState [], head revs) revs case c of Nothing -> putStrLn "No revisions were converted!"@@ -108,15 +129,16 @@ | otherwise = when (num `mod` 1000 == 0) $ showProgress num obj showProgress :: Updatable a => Int -> a -> IO ()- showProgress num _ = do+ showProgress num _ = putStr $ "Converting " ++ show num ++ "...\r" -- void (forkOS (update_ obj)) applyRevision :: Repository -> Maybe Commit -> Revision- -> IO (Maybe Commit)+ -> SIO (Maybe Commit) applyRevision repo c rev = do- case foldl' (\co op -> co `seq` foldOp co op)- (Left (makeCommit c)) (revOperations rev) of+ result <- foldM (\co op -> co `seq` foldOp co op)+ (Left (makeCommit c)) (revOperations rev)+ case result of Left _ -> return c Right x -> Just <$> x @@ -136,29 +158,84 @@ $ commitCommitter .~ sig $ commitLog .~ fromMaybe "" (revComment rev) $ nco - foldOp :: Either Commit (IO Commit) -> Operation- -> Either Commit (IO Commit)- foldOp c' op =- case opAction op of- Add ->- case opKind op of- Directory -> c'- File -> addFile op c'+ foldOp :: Either Commit (SIO Commit) -> Operation+ -> SIO (Either Commit (SIO Commit))+ foldOp c' op+ | opKind op == File && BL.null (opContents op) = return c' - Change -> c'- Replace -> c'- Delete -> c'+ | opKind op == File && (opAction op == Add || opAction op == Change) = do+ lift $ debugL (format "F{}: {}"+ [ if opAction op == Add then "A" else "C"+ , opPathname op ])+ addFile c' op - addFile op c'- | BL.null (opContents op) = c'- | otherwise =- Right (case c' of Left f -> return f; Right x -> x- >>= updateCommit (opFilePath op) (wrapBlob op repo)- >>= update)+ | opAction op == Delete = do+ lift $ debugL (format "?D: {}" [ opPathname op ])+ return $ Right $ deleteItem c' op + | isJust (opCopyFromRev op)+ && opKind op == Directory && opAction op == Add = do+ lift $ debugL (format "DA: {} [r{}] -> {}"+ [ fromJust (opCopyFromPath op)+ , show $ fromJust (opCopyFromRev op)+ , opPathname op ])+ copyEntry c' op++ | otherwise = return c'++ addFile c' op+ | isJust (opCopyFromRev op) = copyEntry c' op+ | otherwise = returnUpdate c' op (wrapBlob op repo)++ copyEntry c' op = do+ pastTree <- getPastTree (fromJust (opCopyFromRev op))+ case pastTree of+ Nothing -> do+ lift $ errorL $ format "Could not find past tree for r{}"+ [ show $ fromJust (opCopyFromRev op) ]+ return c'+ Just pastTree' ->+ applyToCommit c' $ \c'' ->+ lift $ withObject pastTree' c'' $ \pt -> do+ pastEntry <- lookupTreeEntry (opCopyFromFilePath op) pt+ case pastEntry of+ Nothing -> do+ error $ toString+ $ format "Could not find {} in tree r{}"+ [ fromJust (opCopyFromPath op)+ , show $ fromJust (opCopyFromRev op) ]+ Just entry -> return entry+ >>= returnUpdate c' op++ returnUpdate c' op entry =+ return $ Right $ updateCommit' (opFilePath op) entry c'++ deleteItem c' op =+ applyToCommitAndUpdate c' $ lift . removeFromCommitTree (opFilePath op)++applyToCommit :: Either a (SIO a) -> (a -> SIO b) -> SIO b+applyToCommit eitherCommit f =+ (case eitherCommit of Left x -> return x; Right y -> y) >>= f++applyToCommitAndUpdate :: Updatable a+ => Either a (SIO a) -> (a -> SIO a) -> SIO a+applyToCommitAndUpdate eitherCommit f =+ applyToCommit eitherCommit f >>= lift . update++updateCommit' :: FilePath -> TreeEntry -> Either Commit (SIO Commit)+ -> SIO Commit+updateCommit' path entry c =+ applyToCommitAndUpdate c $ lift . updateCommit path entry++getPastTree :: Int -> SIO (Maybe (ObjRef Tree))+getPastTree rev = return . lookup rev . (^.pastTrees) =<< get+ opFilePath :: Operation -> FilePath-opFilePath = fromText . T.pack . opPathname+opFilePath = toFilePath . opPathname +opCopyFromFilePath :: Operation -> FilePath+opCopyFromFilePath = toFilePath . fromJust . opCopyFromPath+ opBlob :: Operation -> Repository -> Blob opBlob op = createBlob (lazyToStrict (opContents op)) @@ -175,5 +252,23 @@ withForeignPtr fp $ \p -> do BI.memcpy ptr (p `plusPtr` s) (fromIntegral l) go r (ptr `plusPtr` l)++debugL :: Text -> IO ()+debugL = debugM "pushme" . toString++infoL :: Text -> IO ()+infoL = infoM "pushme" . toString++noticeL :: Text -> IO ()+noticeL = noticeM "pushme" . toString++warningL :: Text -> IO ()+warningL = warningM "pushme" . toString++errorL :: Text -> IO ()+errorL = errorM "pushme" . toString++criticalL :: Text -> IO ()+criticalL = criticalM "pushme" . toString -- Main.hs (hsubconvert) ends here
hsubconvert.cabal view
@@ -1,6 +1,6 @@ Name: hsubconvert -Version: 0.0.1+Version: 0.0.2 Synopsis: One-time, faithful conversion of Subversion repositories to Git Description: One-time, faithful conversion of Subversion repositories to Git.@@ -27,15 +27,18 @@ , bytestring >= 0.9.2.1 , cmdargs >= 0.10 , hslogger >= 1.2.0+ , lens >= 3.0.2+ , mtl >= 2.1.2 , parallel-io >= 0.3.2 , regex-posix >= 0.95.2- , shelly >= 0.14.1+ , system-filepath >= 0.4.7 , system-fileio >= 0.3.10 , text >= 0.11.2.0+ , text-format >= 0.3.0.8 , time >= 1.4+ , stringable >= 0.1.1 , transformers >= 0.3.0- , lzma-conduit >= 0.5.2.1- , unix >= 2.5.1.1+ , unix >= 2.6.0.0 Source-repository head type: git