{-# 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 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 ()
`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 = []