module Data.FileStore.Utils (
runShellCommand
, mergeContents
, hashsMatch
, isInsideDir
, escapeRegexSpecialChars
, parseMatchLine
, splitEmailAuthor
, ensureFileExists
, regSearchFiles
, regsSearchFile
, withSanityCheck
, grepSearchRepo
, withVerifyDir ) where
import Codec.Binary.UTF8.String (encodeString)
import Control.Exception (throwIO)
import Control.Monad (liftM, when, unless)
import Data.ByteString.Lazy.UTF8 (toString)
import Data.Char (isSpace)
import Data.List (intersect, nub, isPrefixOf, isInfixOf)
import Data.List.Split (splitWhen)
import Data.Maybe (isJust)
import System.Directory (canonicalizePath, doesFileExist, getTemporaryDirectory, removeFile, findExecutable, createDirectoryIfMissing, getDirectoryContents)
import System.Exit (ExitCode(..))
import System.FilePath ((</>), takeDirectory)
import System.IO (openTempFile, hClose)
import System.Process (runProcess, waitForProcess)
import qualified Data.ByteString.Lazy as B
import Data.FileStore.Types (SearchMatch(..), FileStoreError(IllegalResourceName, NotFound, UnknownError), SearchQuery(..))
runShellCommand :: FilePath
-> Maybe [(String, String)]
-> String
-> [String]
-> IO (ExitCode, B.ByteString, B.ByteString)
runShellCommand workingDir environment command optionList = do
tempPath <- catch getTemporaryDirectory (\_ -> return ".")
(outputPath, hOut) <- openTempFile tempPath "out"
(errorPath, hErr) <- openTempFile tempPath "err"
hProcess <- runProcess (encodeString command) (map encodeString optionList) (Just workingDir) environment Nothing (Just hOut) (Just hErr)
status <- waitForProcess hProcess
errorOutput <- B.readFile errorPath
output <- B.readFile outputPath
removeFile errorPath
removeFile outputPath
return (status, errorOutput, output)
mergeContents :: (String, B.ByteString)
-> (String, B.ByteString)
-> (String, B.ByteString)
-> IO (Bool, String)
mergeContents (newLabel, newContents) (originalLabel, originalContents) (latestLabel, latestContents) = do
tempPath <- catch getTemporaryDirectory (\_ -> return ".")
(originalPath, hOriginal) <- openTempFile tempPath "orig"
(latestPath, hLatest) <- openTempFile tempPath "latest"
(newPath, hNew) <- openTempFile tempPath "new"
B.hPutStr hOriginal originalContents >> hClose hOriginal
B.hPutStr hLatest latestContents >> hClose hLatest
B.hPutStr hNew newContents >> hClose hNew
gitExists <- liftM isJust (findExecutable "git")
(conflicts, mergedContents) <-
if gitExists
then do
(status, err, out) <- runShellCommand tempPath Nothing "git" ["merge-file", "--stdout", "-L", newLabel, "-L",
originalLabel, "-L", latestLabel, newPath, originalPath, latestPath]
case status of
ExitSuccess -> return (False, out)
ExitFailure n | n >= 0 -> return (True, out)
_ -> error $ "merge failed: " ++ toString err
else do
mergeExists <- liftM isJust (findExecutable "merge")
if mergeExists
then do
(status, err, out) <- runShellCommand tempPath Nothing "merge" ["-p", "-q", "-L", newLabel, "-L",
originalLabel, "-L", latestLabel, newPath, originalPath, latestPath]
case status of
ExitSuccess -> return (False, out)
ExitFailure 1 -> return (True, out)
_ -> error $ "merge failed: " ++ toString err
else error "mergeContents requires 'git' or 'merge', and neither was found in the path."
removeFile originalPath
removeFile latestPath
removeFile newPath
return (conflicts, toString mergedContents)
escapeRegexSpecialChars :: String -> String
escapeRegexSpecialChars = backslashEscape "?*+{}[]\\^$.()"
where backslashEscape chars (x:xs) | x `elem` chars = '\\' : x : backslashEscape chars xs
backslashEscape chars (x:xs) = x : backslashEscape chars xs
backslashEscape _ [] = []
hashsMatch :: (Eq a) => [a] -> [a] -> Bool
hashsMatch r1 r2 = r1 `isPrefixOf` r2 || r2 `isPrefixOf` r1
isInsideDir :: FilePath -> FilePath -> IO Bool
isInsideDir name dir = do
gitDirPathCanon <- canonicalizePath dir
filenameCanon <- canonicalizePath name
return (gitDirPathCanon `isPrefixOf` filenameCanon)
parseMatchLine :: String -> SearchMatch
parseMatchLine str =
let (fn:n:res:_) = splitWhen (==':') str
in SearchMatch{matchResourceName = fn, matchLineNumber = read n, matchLine = res}
splitEmailAuthor :: String -> (Maybe String, String)
splitEmailAuthor x = (mbEmail, trim name)
where (name, rest) = break (=='<') x
mbEmail = if null rest
then Nothing
else Just $ takeWhile (/='>') $ drop 1 rest
trim :: String -> String
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
regSearchFiles :: FilePath -> [String] -> String -> IO [String]
regSearchFiles repo filesToCheck pattern = do (_, _, result) <- runShellCommand repo
Nothing "grep" $ ["--line-number", "-I", "-l", "-E", "-e", pattern] ++ filesToCheck
let results = intersect filesToCheck $ lines $ toString result
return results
regsSearchFile :: [String] -> FilePath -> [String] -> String -> IO [String]
regsSearchFile os repo patterns file = do res <- mapM (run file) patterns
return $ nub $ concat res
where run f p = do (_,_,r) <- runShellCommand repo Nothing "grep" (os ++ [p, f])
return $ lines $ toString r
ensureFileExists :: FilePath -> FilePath -> IO ()
ensureFileExists repo name = do
isFile <- doesFileExist (repo </> encodeString name)
unless isFile $ throwIO NotFound
withSanityCheck :: FilePath
-> [FilePath]
-> FilePath
-> IO b
-> IO b
withSanityCheck repo excludes name action = do
let filename = repo </> encodeString name
insideRepo <- filename `isInsideDir` repo
insideExcludes <- liftM or $ mapM (filename `isInsideDir`) $ map (repo </>) excludes
when (insideExcludes || not insideRepo) $ throwIO IllegalResourceName
createDirectoryIfMissing True $ takeDirectory filename
action
grepSearchRepo :: (FilePath -> IO [String]) -> FilePath -> SearchQuery -> IO [SearchMatch]
grepSearchRepo indexer repo query = do
let opts = ["-I", "--line-number", "--with-filename"] ++
["-i" | queryIgnoreCase query] ++
(if queryWholeWords query then ["--word-regexp"] else ["-E"])
let regexps = map escapeRegexSpecialChars $ queryPatterns query
files <- indexer repo
if queryMatchAll query
then do
filesMatchingAllPatterns <- liftM (foldr1 intersect) $ mapM (regSearchFiles repo files) regexps
output <- mapM (regsSearchFile opts repo regexps) filesMatchingAllPatterns
return $ map parseMatchLine $ concat output
else do
(_status, _errOutput, output) <-
runShellCommand repo Nothing "grep" $ opts ++
concatMap (\term -> ["-e", term]) regexps ++
files
let results = lines $ toString output
return $ map parseMatchLine results
withVerifyDir :: FilePath -> IO a -> IO a
withVerifyDir d a =
catch (liftM head (getDirectoryContents $ encodeString d) >> a) $ \e ->
if "No such file or directory" `isInfixOf` show e
then throwIO NotFound
else throwIO . UnknownError . show $ e