module Data.FileStore.Darcs ( darcsFileStore ) where
import Codec.Binary.UTF8.String (encodeString)
import Control.Exception (throwIO)
import Control.Monad (liftM, unless, when)
import Data.ByteString.Lazy.UTF8 (toString)
import Data.Char (isSpace)
import Data.DateTime (parseDateTime, toSqlString)
import Data.FileStore.Types
import Data.FileStore.Utils (hashsMatch, isInsideRepo, parseMatchLine, runShellCommand, escapeRegexSpecialChars)
import Data.List (intersect, nub)
import Data.Maybe (fromMaybe, fromJust)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import System.Directory (doesDirectoryExist, createDirectoryIfMissing)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath ((</>), takeDirectory, dropFileName)
import System.IO.Error (isDoesNotExistError)
import Text.Regex.Posix ((=~))
import Text.XML.Light
import qualified Data.ByteString.Lazy as B (ByteString, readFile, writeFile)
darcsFileStore :: FilePath -> FileStore
darcsFileStore repo = FileStore {
initialize = darcsInit repo
, save = darcsSave repo
, retrieve = darcsRetrieve repo
, delete = darcsDelete repo
, rename = darcsMove repo
, history = darcsLog repo
, latest = darcsLatestRevId repo
, revision = darcsGetRevision repo
, index = darcsIndex repo
, search = darcsSearch repo
, idsMatch = const hashsMatch repo }
runDarcsCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)
runDarcsCommand repo command args = do
(status, err, out) <- runShellCommand repo Nothing "darcs" (command : args)
return (status, toString err, out)
parseDarcsXML :: String -> Maybe [Revision]
parseDarcsXML str = do changelog <- parseXMLDoc str
let patches = filterChildrenName (\(QName n _ _) -> n == "patch") changelog
return $ map parseIntoRevision patches
parseIntoRevision :: Element -> Revision
parseIntoRevision a = Revision { revId = hashXML a,
revDateTime = date a,
revAuthor = Author { authorName=authorXML a, authorEmail=emailXML a },
revDescription = descriptionXML a,
revChanges = changesXML a }
where
date = fromMaybe (posixSecondsToUTCTime $ realToFrac (0::Int)) . parseDateTime "%c" . dateXML
authorXML, dateXML, descriptionXML, emailXML, hashXML :: Element -> String
authorXML = snd . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)
emailXML = fromMaybe"" . fst . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)
dateXML = fromMaybe "" . findAttr (QName "local_date" Nothing Nothing)
hashXML = fromMaybe "" . findAttr (QName "hash" Nothing Nothing)
descriptionXML = fromMaybe "" . liftM strContent . findChild (QName "name" Nothing Nothing)
changesXML :: Element -> [Change]
changesXML = analyze . filterSummary . changes
splitEmailAuthor :: String -> (Maybe String, String)
splitEmailAuthor x = if '<' `elem` x then (Just (tail $ init c), reverse . dropWhile isSpace $ reverse b)
else (Nothing,x)
where (_,b,c) = x =~ "[^<]*" :: (String,String,String)
changes :: Element -> Element
changes = fromJust . findElement (QName "summary" Nothing Nothing)
analyze :: [Element] -> [Change]
analyze s = map convert s
where convert a
| x == "add_directory" || x == "add_file" = Added b
| x == "remove_file" || x == "remove_directory" = Deleted b
| x == "added_lines"
|| x == "modify_file"
|| x == "removed_lines"
|| x == "replaced_tokens" = Modified b
| otherwise = error "Unknown change type"
where x = qName . elName $ a
b = takeWhile (/='\n') $ dropWhile isSpace $ strContent a
filterSummary :: Element -> [Element]
filterSummary = filterElementsName (\(QName {qName = x}) -> x == "add_file"
|| x == "add_directory"
|| x == "remove_file"
|| x == "remove_directory"
|| x == "modify_file"
|| x == "added_lines"
|| x == "removed_lines"
|| x == "replaced_tokens")
go :: FilePath -> [String] -> String -> IO [String]
go repo filesToCheck pattern = do (_, _, result) <- runShellCommand repo
Nothing "grep" $ ["--line-number", "-l", "-E", "-e", pattern] ++ filesToCheck
let results = intersect filesToCheck $ lines $ toString result
return results
go' :: [String] -> FilePath -> [String] -> String -> IO [String]
go' os repo patterns file = do res <- mapM (\x -> run file x) patterns
return $ nub $ concat res
where run f p = do (_,_,r) <- runShellCommand repo Nothing "grep" $
os ++ [p, f]
return $ lines $ toString r
darcsInit :: FilePath -> IO ()
darcsInit repo = do
exists <- doesDirectoryExist repo
when exists $ throwIO RepositoryExists
createDirectoryIfMissing True repo
(status, err, _) <- runDarcsCommand repo "init" []
if status == ExitSuccess
then return ()
else throwIO $ UnknownError $ "darcs init failed:\n" ++ err
darcsSave :: Contents a => FilePath -> ResourceName -> Author -> Description -> a -> IO ()
darcsSave repo name author logMsg contents = do
let filename = repo </> encodeString name
inside <- isInsideRepo repo filename
unless inside $ throwIO IllegalResourceName
createDirectoryIfMissing True $ takeDirectory filename
B.writeFile filename $ toByteString contents
runDarcsCommand repo "add" [name]
darcsCommit repo [name] author logMsg
darcsCommit :: FilePath -> [ResourceName] -> Author -> Description -> IO ()
darcsCommit repo names author logMsg = do
let args = ["--all", "-A", (authorName author ++ " <" ++ authorEmail author ++ ">"), "-m", logMsg] ++ names
(statusCommit, errCommit, _) <- runDarcsCommand repo "record" args
if statusCommit == ExitSuccess
then return ()
else throwIO $ if null errCommit
then Unchanged
else UnknownError $ "Could not darcs record " ++ unwords names ++ "\n" ++ errCommit
darcsMove :: FilePath -> ResourceName -> ResourceName -> Author -> Description -> IO ()
darcsMove repo oldName newName author logMsg = do
let newPath = repo </> newName
inside <- isInsideRepo repo newPath
unless inside $ throwIO IllegalResourceName
createDirectoryIfMissing True $ takeDirectory newPath
(statusAdd,_,_) <- runDarcsCommand repo "add" [dropFileName newName]
(statusAdd',_,_) <- runDarcsCommand repo "mv" [oldName, newName]
if statusAdd == ExitSuccess && statusAdd' == ExitSuccess
then darcsCommit repo [oldName, newName] author logMsg
else throwIO NotFound
darcsDelete :: FilePath -> ResourceName -> Author -> Description -> IO ()
darcsDelete repo name author logMsg = do
runShellCommand repo Nothing "rm" [name]
darcsCommit repo [name] author logMsg
darcsLog :: FilePath -> [ResourceName] -> TimeRange -> IO [Revision]
darcsLog repo names (TimeRange begin end) = do
let opts = timeOpts begin end
do (status, err, output) <- runDarcsCommand repo "changes" $ ["--xml-output", "--summary"] ++ names ++ opts
if status == ExitSuccess
then case parseDarcsXML $ toString output of
Nothing -> throwIO ResourceExists
Just parsed -> return parsed
else throwIO $ UnknownError $ "darcs changes returned error status.\n" ++ err
where
timeOpts :: Maybe DateTime -> Maybe DateTime ->[String]
timeOpts b e = case (b,e) of
(Nothing,Nothing) -> []
(Just b', Just e') -> from b' ++ to e'
(Just b', Nothing) -> from b'
(Nothing, Just e') -> to e'
where from z = ["--match=date \"after " ++ undate z ++ "\""]
to z = ["--to-match=date \"before " ++ undate z ++ "\""]
undate = toSqlString
darcsGetRevision :: FilePath -> RevisionId -> IO Revision
darcsGetRevision repo hash = do hists <- darcsLog repo [] (TimeRange Nothing Nothing)
let hist = filter (\x -> hashsMatch (revId x) hash) hists
let result = if null hist then hists else hist
return $ head result
darcsLatestRevId :: FilePath -> ResourceName -> IO RevisionId
darcsLatestRevId repo name = do
(_, _, output) <- runDarcsCommand repo "changes" ["--xml-output", "--summary", name]
let patchs = parseDarcsXML $ toString output
case patchs of
Nothing -> throwIO NotFound
Just as -> if null as then throwIO NotFound else return $ revId $ head as
darcsRetrieve :: Contents a
=> FilePath
-> ResourceName
-> Maybe RevisionId
-> IO a
darcsRetrieve repo name Nothing = do
let filename = repo </> encodeString name
catch (liftM fromByteString $ B.readFile filename) $
\e -> if isDoesNotExistError e then throwIO NotFound else throwIO e
darcsRetrieve repo name (Just revid) = do
let opts = ["contents", "--match=hash " ++ revid, name]
(status, err, output) <- runDarcsCommand repo "query" opts
if status == ExitSuccess
then return $ fromByteString output
else throwIO $ UnknownError $ "Error in darcs query contents:\n" ++ err
darcsIndex :: FilePath ->IO [ResourceName]
darcsIndex repo = do
(status, errOutput, output) <- runDarcsCommand repo "query" ["manifest"]
if status == ExitSuccess
then return (map (drop 2) . lines . toString $ output)
else error $ "'darcs query manifest' returned error status.\n" ++ errOutput
darcsSearch :: FilePath -> SearchQuery -> IO [SearchMatch]
darcsSearch repo query = do
let opts = ["--line-number", "--with-filename"] ++
(if queryIgnoreCase query then ["-i"] else []) ++
(if queryWholeWords query then ["--word-regexp"] else ["-E"])
let regexps = map escapeRegexSpecialChars $ queryPatterns query
files <- darcsIndex repo
if queryMatchAll query then do
filesMatchingAllPatterns <- liftM (foldr1 intersect) $ mapM (go repo files) regexps
output <- mapM (go' 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