src/Git/Fast.hs

   1 -- |
   2 -- Module      : Git.Fast
   3 -- Copyright   : (c) 2008 Bertram Felgenhauer
   4 -- License     : GPL2
   5 --
   6 -- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>
   7 -- Stability   : experimental
   8 -- Portability : ghc
   9 --
  10 -- Functions for applying patches to git repositories.
  11 --
  12 -- Use git-fast-import for importing stuff, and a Slurpy tree for tracking
  13 -- commits.
  14 --
  15 -- This module also defines how git-darcs-import stores its metadata in the
  16 -- target repository, and how patch meta information is converted.
  17 --
  18
  19 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  20
  21 module Git.Fast (
  22     Git,
  23     runGit,
  24     getInventory,
  25     failure,
  26     applyAndCommit
  27 ) where
  28
  29 import Control.Monad.State.Strict (evalStateT)
  30 import Control.Monad.Trans (liftIO, MonadIO)
  31 import Control.Monad (when, liftM2)
  32 import System.Process (runProcess)
  33 import System.FilePath ((</>), FilePath)
  34 import System.Directory (doesDirectoryExist) -- , createDirectory)
  35
  36 import Darcs.SlurpDirectory (SlurpMonad, slurp, withSlurpy)
  37 import Darcs.Patch (RepoPatch, apply)
  38 import Darcs.Utils (withCurrentDirectory)
  39 import Darcs.IO (WriteableDirectory (..), ReadableDirectory (..))
  40 import Darcs.Patch.Core (Named (..))
  41 import Darcs.Patch.Info (make_filename)
  42 import FileName (fp2fn, (///), FileName)
  43 import Git.Base
  44 import Git.Metadata (GitInfo (..), extractGitInfo)
  45 import qualified Data.ByteString as B
  46 import qualified Data.ByteString.Char8 as BC
  47 import ByteStringUtils (linesPS, unlinesPS)
  48
  49 -- | location of inventory file
  50 -- format:
  51 -- 20051128181018-c2a52-a799f1a83580ad95053914b2171e790425b37dc6.gz :<mark>
  52 inventoryFile :: FilePath
  53 inventoryFile =  ".git" </> "darcs-inventory"
  54
  55 -- | a file placed into each directory, so git can keep track of it.
  56 directoryMarker :: FileName
  57 directoryMarker = fp2fn ".git-darcs-dir"
  58
  59 -- | the branch that we create
  60 branch :: FilePath
  61 branch = "refs/heads/git-darcs-import"
  62
  63 -- | create a checkpoint after this many files have been touched
  64 cpCount :: Int
  65 cpCount = 10000
  66
  67 -- | initialise empty repository. creates empty marksFile and inventoryFile.
  68 makeRepository :: IO ()
  69 makeRepository = do
  70     pid <- runProcess gitBinary ["init-db"]
  71                Nothing Nothing Nothing Nothing Nothing
  72     checkProcessExitCode "Failed to initialise git repo" pid
  73     B.writeFile inventoryFile B.empty
  74     B.writeFile marksFile B.empty
  75 --    createDirectory "_darcs"
  76 --    createDirectory "_darcs/prefs"
  77
  78 -- | the inventory might be ahead of git's actual commits - repair.
  79 checkInventory :: IO Int
  80 checkInventory = do
  81     inv <- liftIO $ B.readFile inventoryFile
  82     mrk <- liftIO $ B.readFile marksFile
  83     let is = tail (reverse (linesPS inv))
  84         is' = dropWhile (\l -> snd (splitInventoryLine l) > lastMark) is
  85         ms = linesPS mrk
  86         lastMark = length ms - 1
  87         inv' = unlinesPS (reverse (B.empty : is'))
  88         m' | null is  = 1
  89            | otherwise = snd (splitInventoryLine (head is'))
  90         commit = BC.unpack (snd (splitMarkLine (ms !! (m'-1))))
  91     when (length is' < length is) $ do
  92         putStrLn $ "resetting to " ++ commit
  93         B.writeFile inventoryFile inv'
  94         pid <- runProcess "git" ["checkout", "-f", "-q", commit]
  95                    Nothing Nothing Nothing Nothing Nothing
  96         checkProcessExitCode ("failed to check out tip (" ++ commit ++ ")") pid
  97         return ()
  98     return m'
  99
 100 -- | parse a line from our inventory file. return darcs hash and mark
 101 -- number.
 102 splitInventoryLine :: B.ByteString -> (B.ByteString, Int)
 103 splitInventoryLine ps = (B.take 64 ps, read . BC.unpack . B.drop 66 $ ps)
 104
 105 -- | parse a line from git-fast-import's marks file. return mark number
 106 -- and commit
 107 splitMarkLine :: B.ByteString -> (Int, B.ByteString)
 108 splitMarkLine ps =
 109    let l = B.length ps
 110    in  (read . tail . BC.unpack . B.take (l-41) $ ps, B.drop (l-40) ps)
 111
 112 -- | run a Git action in a repository. initialises the repository if it's fresh.
 113 runGit :: Git b     -- ^ pre initialisation hook, for setting options
 114        -> FilePath  -- ^ Root of repository
 115        -> Git a     -- ^ action to run on repository
 116        -> IO a
 117 runGit pre root act = withCurrentDirectory root $ do
 118     t <- liftIO $ doesDirectoryExist ".git"
 119     when (not t) makeRepository
 120     -- read working directory
 121     tr <- slurp "."
 122     mrk <- if t then do
 123         checkInventory
 124       else
 125         return 1
 126     let initialise = do
 127             startGitFastImport
 128             when (not t) $ do
 129                 -- create a dummy commit at the start of the repository
 130                 let message = "New empty repository"
 131                 fastGitCommand [
 132                     "commit " ++ branch,
 133                     "mark :1",
 134                     "author git-darcs-import <> Thu, 01 Jan 1970 00:00:00 UTC",
 135                     "committer git-darcs-import <> Thu, 01 Jan 1970 00:00:00 UTC",
 136                     "data " ++ show (length message),
 137                     message]
 138         finish = stopGitFastImport >> checkout branch
 139     let initState = RWState { mark = mrk, tree = tr, touched = 0,
 140             gitPipe = error "gitPipe", gitPid = error "gitPid",
 141             verbose = 0 }
 142     flip evalStateT initState $ unGit $
 143         pre >> initialise >> liftM2 const act finish
 144
 145 -- | read the inventory, and return a list of pairs of
 146 -- mark and darcs patch file
 147 getInventory :: Git [(B.ByteString, Int)]
 148 getInventory = liftIO $ do
 149     inv <- B.readFile inventoryFile
 150     return $ map splitInventoryLine (init (linesPS inv))
 151
 152 -- | apply a patch and add it to the inventory. the repository must be clean.
 153 -- it's an error to apply a patch that is already in the repository.
 154 applyAndCommit :: RepoPatch p => Named p -> Git ()
 155 applyAndCommit (NamedP pip _ p) = do
 156     m <- getMark
 157     let GitInfo {
 158             gitAuthor = aName,
 159             gitAEmail = aEmail,
 160             gitTag = aTag,
 161             gitDate = aDate,
 162             gitMessage = message
 163         } = extractGitInfo pip
 164         authorLine = aName ++ " " ++ aEmail ++ " " ++ aDate
 165     case aTag of
 166         Just tag -> do
 167             fastGitCommand [
 168                 "tag " ++ tag,
 169                 "from :" ++ show m,
 170                 "tagger " ++ authorLine,
 171                 "data " ++ show (length message),
 172                 message]
 173         Nothing -> do
 174             fastGitCommand [
 175                 "commit " ++ branch,
 176                 "mark :" ++ show (m + 1),
 177                 "author " ++ authorLine,
 178                 "committer " ++ authorLine,
 179                 "data " ++ show (length message),
 180                 message,
 181                 "from :" ++ show m]
 182             setMark (m+1)
 183     apply [] p
 184     t <- getTouched
 185     when (t > cpCount) $ do
 186         liftIO $ putStrLn "\nCreating checkpoint..."
 187 {-
 188         -- this way we could restart the import process, hmm
 189         stopGitFastImport
 190         startGitFastImport
 191 -}
 192         fastGitCommand ["checkpoint"]
 193         setTouched 0
 194     liftIO $ appendFile inventoryFile $ make_filename pip ++ " :" ++ show (m+1) ++ "\n"
 195     return ()
 196
 197 -- | run an action on the working tree
 198 liftSlurpMonad :: SlurpMonad a -> Git a
 199 liftSlurpMonad act = do
 200     t0 <- getTree
 201     case withSlurpy t0 act of
 202         Left  msg       -> failure msg
 203         Right (t1, res) -> do
 204             setTree t1
 205             return res
 206
 207 -- read the working tree - boring
 208 instance ReadableDirectory Git where
 209     mInCurrentDirectory = error "Git :: mInCurrentDirectory"
 210     mDoesDirectoryExist d = liftSlurpMonad $ mDoesDirectoryExist d
 211     mDoesFileExist f = liftSlurpMonad $ mDoesFileExist f
 212     mGetDirectoryContents = liftSlurpMonad $ mGetDirectoryContents
 213     mReadFilePS f = liftSlurpMonad $ mReadFilePS f
 214     mReadFilePSs f = liftSlurpMonad $ mReadFilePSs f
 215
 216 -- write to the working tree - notify the git-fast-import worker
 217 instance WriteableDirectory Git where
 218     mWithCurrentDirectory = error "Git :: mWithCurrentDirectory"
 219     mSetFileExecutable = error "Git :: mSetFileExecutable"
 220     mWriteFilePS f ps = do
 221         liftSlurpMonad $ mWriteFilePS f ps
 222         gitWriteFilePS f ps
 223     mCreateDirectory f = do
 224         liftSlurpMonad $ mCreateDirectory f
 225         mWriteFilePS (f /// directoryMarker) B.empty
 226     mRemoveDirectory f = do
 227         mRemoveFile (f /// directoryMarker)
 228         liftSlurpMonad $ mRemoveDirectory f
 229     mRemoveFile f = do
 230         liftSlurpMonad $ mRemoveFile f
 231         gitRemoveFile f
 232     mRename f1 f2 = do
 233         -- some old patches have moves where the source file doesn't exist
 234         exF <- mDoesFileExist f1
 235         exD <- mDoesDirectoryExist f1
 236         when (exF || exD) $ gitRename f1 f2
 237         liftSlurpMonad $ mRename f1 f2