diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/hsubconvert.cabal b/hsubconvert.cabal --- a/hsubconvert.cabal +++ b/hsubconvert.cabal @@ -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