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 (runInteractiveProcess, 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 wd env cmd args = do
(hInp, hOut, hErr, ph) <- runInteractiveProcess (encodeString cmd) (map encodeString args) (Just wd) env
hClose hInp
output <- B.hGetContents hOut
errorOutput <- B.hGetContents hErr
status <- waitForProcess ph
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