{-# LANGUAGE DeriveDataTypeable #-}
{-# 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 Filesystem (isDirectory, removeTree)
import Filesystem.Path.CurrentOS hiding (null, toText)
import Foreign.ForeignPtr
import Foreign.Ptr
import GHC.Conc
import Prelude.General
import Subversion.Dump
import System.Console.CmdArgs
import System.Environment
import System.Log.Logger
default (Text)
version :: String
version = "0.0.1"
copyright :: String
copyright = "2012"
hSubconvertSummary :: String
hSubconvertSummary =
"hsubconvert v" ++ version ++ ", (C) John Wiegley " ++ copyright
data HSubconvert = HSubconvert { jobs :: Int
, verbose :: Bool
, debug :: Bool
, files :: [String] }
deriving (Data, Typeable, Show, Eq)
hSubconvert :: HSubconvert
hSubconvert = HSubconvert
{ jobs = def &= name "j" &= typ "INT"
&= help "Run INT concurrent jobs (default: 4)"
, verbose = def &= name "v"
&= help "Report progress verbosely"
, debug = def &= name "D"
&= help "Report debug information"
, files = def &= args } &=
summary hSubconvertSummary &=
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 = toFilePath n
exists <- isDirectory p
when exists $ removeTree p
f =<< createRepository p True
main :: IO ()
main = do
-- process command-line options
mainArgs <- getArgs
opts <- withArgs (if null mainArgs then ["--help"] else mainArgs)
(cmdArgs hSubconvert)
_ <- GHC.Conc.setNumCapabilities $ case jobs opts of 0 -> 4; x -> x
when (verbose opts) $ updateGlobalLogger "hsubconvert" (setLevel INFO)
when (debug opts) $ updateGlobalLogger "hsubconvert" (setLevel DEBUG)
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) <- -- _ = 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!"
Just c' -> do
reportProgress True (revNumber lastRev) c'
cid <- objectId c'
writeRef_ $ createRef "refs/heads/master" (RefTargetId cid) repo
writeRef_ $
createRef "HEAD" (RefTargetSymbolic "refs/heads/master") repo
putStr "\nConversion completed\n"
where
reportProgress :: Updatable a => Bool -> Int -> a -> IO ()
reportProgress force num obj
| force || num < 10 = showProgress num obj
| num < 100 = when (num `mod` 10 == 0) $ showProgress num obj
| num < 1000 = when (num `mod` 100 == 0) $ showProgress num obj
| otherwise = when (num `mod` 1000 == 0) $ showProgress num obj
showProgress :: Updatable a => Int -> a -> IO ()
showProgress num _ =
putStr $ "Converting " ++ show num ++ "...\r"
-- void (forkOS (update_ obj))
applyRevision :: Repository -> Maybe Commit -> Revision
-> SIO (Maybe Commit)
applyRevision repo c rev = do
result <- foldM (\co op -> co `seq` foldOp co op)
(Left (makeCommit c)) (revOperations rev)
case result of
Left _ -> return c
Right x -> Just <$> x
where
makeCommit co =
let nco = case co of
Nothing -> createCommit repo
Just p -> commitTree .~ p^.commitTree
$ commitParents .~ [ObjRef p]
$ createCommit repo
sig = Signature {
_signatureName = fromMaybe "Unknown" (revAuthor rev)
, _signatureEmail = "unknown@unknown.org"
, _signatureWhen = revDate rev }
in commitAuthor .~ sig
$ commitCommitter .~ sig
$ commitLog .~ fromMaybe "" (revComment rev) $ nco
foldOp :: Either Commit (SIO Commit) -> Operation
-> SIO (Either Commit (SIO Commit))
foldOp c' op
| opKind op == File && BL.null (opContents op) = return 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
| 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 = toFilePath . opPathname
opCopyFromFilePath :: Operation -> FilePath
opCopyFromFilePath = toFilePath . fromJust . opCopyFromPath
opBlob :: Operation -> Repository -> Blob
opBlob op = createBlob (lazyToStrict (opContents op))
wrapBlob :: Operation -> Repository -> TreeEntry
wrapBlob op repo = BlobEntry (ObjRef (opBlob op repo)) False
lazyToStrict :: BL.ByteString -> B.ByteString
lazyToStrict lb = BI.unsafeCreate len $ go lb
where
len = BLI.foldlChunks (\l sb -> l + B.length sb) 0 lb
go BLI.Empty _ = return ()
go (BLI.Chunk (BI.PS fp s l) r) ptr =
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