src/Git/Base.hs

   1 -- |
   2 -- Module      : Git.Base
   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 -- Git monad. Handles state, and executing the git-fast-import program
  11 --
  12
  13 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  14
  15 module Git.Base (
  16     Git (unGit),
  17     RWState (..),
  18     failure,
  19     fastGitCommand,
  20     startGitFastImport,
  21     stopGitFastImport,
  22     gitWriteFilePS,
  23     gitRemoveFile,
  24     gitRename,
  25     checkout,
  26     gitBinary,
  27     marksFile,
  28     modifyVerbose,
  29     getVerbose,
  30     getTouched,
  31     setTouched,
  32     getMark,
  33     setMark,
  34     getTree,
  35     setTree,
  36     checkProcessExitCode,
  37 ) where
  38
  39 import Control.Monad.State.Strict (StateT, gets, modify)
  40 import Control.Monad.Trans (MonadIO, liftIO)
  41 import Control.Monad (MonadPlus, when)
  42 import System.Exit (exitFailure, ExitCode (..))
  43 import System.IO (Handle, hPutStr, hClose, hPutStrLn, stderr)
  44 import System.Process (ProcessHandle, runProcess, waitForProcess)
  45 import System.Posix (createPipe, setFdOption, fdToHandle, FdOption (..))
  46 import System.FilePath ((</>), FilePath)
  47
  48 import Darcs.SlurpDirectory (Slurpy)
  49 import Darcs.Patch.FileName (FileName, fn2fp)
  50 import qualified Data.ByteString as B
  51
  52 -- | path to git executable
  53 gitBinary :: FilePath
  54 gitBinary = "/usr/bin/git"
  55
  56 -- | file that maps marks to git commits (created by git-fast-import)
  57 marksFile :: FilePath
  58 marksFile =  ".git" </> "darcs-marks"
  59
  60 data RWState = RWState {
  61     gitPipe :: Handle,         -- ^ pipe to git-fast-import
  62     gitPid  :: ProcessHandle,  -- ^ process handle of git-fast-import
  63     tree    :: !Slurpy,        -- ^ current working tree
  64     mark    :: !Int,           -- ^ mark of latest commit
  65     touched :: !Int,           -- ^ count modified files
  66     verbose :: !Int            -- ^ be verbose
  67 }
  68
  69 -- | Git monad
  70 newtype Git a = Git { unGit :: StateT RWState IO a }
  71     deriving (Monad, MonadPlus, MonadIO, Functor)
  72
  73 -- | pass some commands to git-fast-import
  74 fastGitCommand :: [String] -> Git ()
  75 fastGitCommand cmd = do
  76     v <- getVerbose
  77     when (v > 1) $ liftIO $ print cmd
  78     h <- getGitPipe
  79     liftIO $ hPutStr h $ unlines cmd
  80
  81 -- | start git-fast-import
  82 -- git-fast-import must be running for 'fastGitCommand' to work
  83 startGitFastImport :: Git ()
  84 startGitFastImport = do
  85     v <- getVerbose
  86     (iw, pid) <- liftIO $ do
  87         -- set up pipe
  88         (irFd, iwFd) <- createPipe
  89         setFdOption iwFd CloseOnExec True
  90         ir <- fdToHandle irFd
  91         iw <- fdToHandle iwFd
  92         -- fdToHandle sets O_NONBLOCK, which confuses git
  93         setFdOption irFd NonBlockingRead False
  94         -- run git-fast-import
  95         pid <- runProcess gitBinary
  96             (["fast-import",
  97              "--date-format=rfc2822",
  98              "--active-branches=1",
  99              "--force",
 100              "--import-marks=" ++ marksFile,
 101              "--export-marks=" ++ marksFile] ++
 102             ["--quiet" | v == 0])
 103             Nothing Nothing (Just ir) Nothing Nothing
 104         return (iw, pid)
 105     Git $ modify (\s -> s { gitPid = pid, gitPipe = iw })
 106
 107 -- | stop git-darcs-import
 108 stopGitFastImport :: Git ()
 109 stopGitFastImport = do
 110     h <- getGitPipe
 111     git <- getGitPid
 112     liftIO $ do
 113         hClose h
 114         checkProcessExitCode "git-fast-import failed." git
 115
 116 -- | check out final tree
 117 checkout :: String -> Git ExitCode
 118 checkout branch = liftIO $ do
 119     pid <- runProcess gitBinary ["checkout", "-f", "-q", branch]
 120                Nothing Nothing Nothing Nothing Nothing
 121     waitForProcess pid
 122
 123 -- | abort due to some error
 124 failure :: String -> Git a
 125 failure msg = do
 126     liftIO $ putStrLn msg
 127     stopGitFastImport
 128     liftIO $ exitFailure
 129
 130 gitWriteFilePS :: FileName -> B.ByteString -> Git ()
 131 gitWriteFilePS f ps = do
 132     fastGitCommand ["M 644 inline " ++ quoteFN f,
 133                     "data " ++ show (B.length ps)]
 134     h <- getGitPipe
 135     liftIO $ B.hPut h ps
 136     incTouched
 137
 138 gitRemoveFile :: FileName -> Git ()
 139 gitRemoveFile f = fastGitCommand ["D " ++ quoteFN f]
 140
 141 gitRename :: FileName -> FileName -> Git ()
 142 gitRename f1 f2 = fastGitCommand ["R " ++ quoteFN f1 ++ " " ++ quoteFN f2]
 143
 144 -- FIXME:
 145 -- should quote \", \\, \  and \n at least
 146 quoteFN :: FileName -> String
 147 quoteFN f = case fn2fp f of
 148     '.' : '/' : f' -> f'
 149     f' -> f'
 150
 151 -- fixme: this doesn't belong here
 152 -- | wait for a process that is expected to terminate successfully
 153 --   print a message and abort if it fails.
 154 checkProcessExitCode :: String -> ProcessHandle -> IO ()
 155 checkProcessExitCode msg pid = do
 156     ec <- waitForProcess pid
 157     case ec of
 158         ExitSuccess -> return ()
 159         ExitFailure c -> do
 160             hPutStrLn stderr $ msg ++ " (exit code " ++ show c ++ ")"
 161             exitFailure
 162
 163 -- trivial setters and getters for our state
 164 -- | modify verbosity level
 165 modifyVerbose :: (Int -> Int) -> Git ()
 166 modifyVerbose f = Git $ modify (\s -> s { verbose = f (verbose s) })
 167
 168 -- | get verbosity level
 169 getVerbose :: Git Int
 170 getVerbose = Git $ gets verbose
 171
 172 -- | get pipe to git-fast-import process
 173 getGitPipe :: Git Handle
 174 getGitPipe = Git $ gets gitPipe
 175
 176 -- | get pid of git-fast-import process
 177 getGitPid :: Git ProcessHandle
 178 getGitPid = Git $ gets gitPid
 179
 180 -- | get current mark (see Git.Fast)
 181 getMark :: Git Int
 182 getMark = Git $ gets mark
 183
 184 -- | set current mark (see Git.Fast)
 185 setMark :: Int -> Git ()
 186 setMark m = Git $ modify (\s -> s { mark = m })
 187
 188 -- | get number of touched files (see Git.Fast)
 189 getTouched :: Git Int
 190 getTouched = Git $ gets touched
 191
 192 -- | set number of touched files (see Git.Fast)
 193 setTouched :: Int -> Git ()
 194 setTouched t = Git $ modify (\s -> s { touched = t })
 195
 196 -- | increment number of touched files (see Git.Fast)
 197 incTouched :: Git ()
 198 incTouched = Git $ modify (\s -> s { touched = touched s + 1 })
 199
 200 -- | get current repo contents (see Git.Fast)
 201 getTree :: Git Slurpy
 202 getTree = Git $ gets tree
 203
 204 -- | set current repo contents (see Git.Fast)
 205 setTree :: Slurpy -> Git ()
 206 setTree t = Git $ modify (\s -> s { tree = t })