module Git.Vogue where
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.List
import Data.Monoid
import Data.String.Utils
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Posix.Files
import System.Process
import Git.Vogue.Plugins
import Git.Vogue.Types
import Paths_git_vogue
data VogueOptions = Options
{ optSearch :: SearchMode
, optCommand :: VogueCommand
}
deriving (Eq, Show)
data VogueCommand
= CmdInit { templatePath :: Maybe FilePath }
| CmdVerify
| CmdPlugins
| CmdRunCheck
| CmdRunFix
deriving (Eq, Show)
newtype Vogue m x = Vogue { vogue :: ReaderT [Plugin] m x }
deriving ( Functor, Applicative, Monad
, MonadTrans, MonadIO, MonadReader [Plugin] )
runVogue
:: [Plugin]
-> Vogue m a
-> m a
runVogue ps (Vogue act) = runReaderT act ps
runCommand
:: (MonadIO m, Functor m)
=> VogueCommand
-> SearchMode
-> Vogue m ()
runCommand CmdInit{..} _ = runWithRepoPath (gitAddHook templatePath)
runCommand CmdVerify _ = runWithRepoPath (gitCheckHook runsVogue)
runCommand CmdPlugins _ = listPlugins
runCommand CmdRunCheck search = runCheck search
runCommand CmdRunFix search = runFix search
runFix :: (MonadIO m, Functor m) => SearchMode -> Vogue m ()
runFix sm = do
rs <- ask >>= mapM (\x -> (x,) <$> executeCheck ioPluginExecutorImpl sm x)
getWorst (executeFix ioPluginExecutorImpl sm) [ x | (x, Failure{}) <- rs ]
>>= outputStatusAndExit
runCheck :: MonadIO m => SearchMode -> Vogue m ()
runCheck sm =
ask
>>= getWorst (executeCheck ioPluginExecutorImpl sm)
>>= outputStatusAndExit
runWithRepoPath
:: MonadIO m
=> (FilePath -> m a)
-> m a
runWithRepoPath action =
liftIO (readProcess "git" ["rev-parse", "--show-toplevel"] "")
>>= action . strip
preCommitCommand :: String
preCommitCommand = "git-vogue check"
gitAddHook
:: MonadIO m
=> Maybe FilePath
-> FilePath
-> Vogue m ()
gitAddHook template path = liftIO $ do
let hook = path </> ".git" </> "hooks" </> "pre-commit"
exists <- fileExist hook
if exists
then updateHook hook
else createHook hook
where
createHook = copyHookTemplateTo template
updateHook hook = do
content <- readFile hook
unless (preCommitCommand `isInfixOf` content) $ do
putStrLn $ "A pre-commit hook already exists at \n\t"
<> hook
<> "\nbut it does not contain the command\n\t"
<> preCommitCommand
<> "\nPlease edit the hook and add this command yourself!"
exitFailure
putStrLn "Your commit hook is already in place."
copyHookTemplateTo
:: Maybe FilePath
-> FilePath
-> IO ()
copyHookTemplateTo maybe_t hook = do
template <- maybe (getDataFileName "templates/pre-commit") return maybe_t
copyFile template hook
perm <- getPermissions hook
setPermissions hook $ perm { executable = True }
gitCheckHook
:: MonadIO m
=> (FilePath -> IO Bool)
-> FilePath
-> Vogue m ()
gitCheckHook p path = do
let hook = path </> ".git" </> "hooks" </> "pre-commit"
exists <- liftIO . fileExist $ hook
if exists
then checkPredicate hook
else failWith $ "Missing file " <> hook
liftIO exitSuccess
where
checkPredicate hook = liftIO $ do
pass <- p hook
unless pass $ failWith "Invalid configuration."
failWith msg = liftIO $ do
hPutStrLn stderr msg
exitFailure
runsVogue
:: FilePath
-> IO Bool
runsVogue path = do
c <- readFile path
return $ preCommitCommand `isInfixOf` c
listPlugins :: MonadIO m => Vogue m ()
listPlugins = do
dir <- liftIO ((</> "git-vogue") <$> getLibexecDir)
liftIO . putStrLn $ "git-vogue looks for plugins in:\n\n\t" <> dir <> "\n"
plugins <- ask
liftIO . putStr
$ "git-vogue knows about the following plugins:\n\n"
<> unlines (fmap (('\t':) . unPlugin) plugins)
disabledPlugins
:: (Monad m, Functor m, MonadIO m)
=> m [String]
disabledPlugins = lines <$> liftIO (readConfig `catch` none)
where
readConfig = readProcess "git" ["config", "--get-all", "vogue.disable"] ""
none (SomeException _) = return []