module Data.FileStore.Darcs ( darcsFileStore ) where
import Control.Exception (throwIO)
import Control.Monad (when)
import Data.DateTime (toSqlString)
import Data.List (sort, isPrefixOf)
#ifdef USE_MAXCOUNT
import Data.List (isInfixOf)
#endif
import System.Exit (ExitCode(..))
import System.Directory (doesDirectoryExist, createDirectoryIfMissing)
import System.FilePath ((</>), dropFileName, addTrailingPathSeparator)
import Data.FileStore.DarcsXml (parseDarcsXML)
import Data.FileStore.Types
import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, ensureFileExists, grepSearchRepo, withVerifyDir)
import Codec.Binary.UTF8.String (encodeString)
import Data.ByteString.Lazy.UTF8 (toString)
import qualified Data.ByteString.Lazy as B (ByteString, 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
, directory = darcsDirectory 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)
darcsInit :: FilePath -> IO ()
darcsInit repo = do
exists <- doesDirectoryExist repo
when exists $ withVerifyDir repo $ 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 -> FilePath -> Author -> Description -> a -> IO ()
darcsSave repo name author logMsg contents = do
withSanityCheck repo ["_darcs"] name $ B.writeFile (repo </> encodeString name) $ toByteString contents
runDarcsCommand repo "add" [name]
darcsCommit repo [name] author logMsg
darcsCommit :: FilePath -> [FilePath] -> 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 -> FilePath -> FilePath -> Author -> Description -> IO ()
darcsMove repo oldName newName author logMsg = do
withSanityCheck repo ["_darcs"] newName $ do
(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 -> FilePath -> Author -> Description -> IO ()
darcsDelete repo name author logMsg = withSanityCheck repo ["_darcs"] name $ do
runShellCommand repo Nothing "rm" [name]
darcsCommit repo [name] author logMsg
darcsLog :: FilePath -> [FilePath] -> 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 (_,_,output) <- runDarcsCommand repo "changes"
["--xml-output", "--summary", "--match=hash " ++ hash]
let hists = parseDarcsXML $ toString output
case hists of
Nothing -> throwIO NotFound
Just a -> return $ head a
darcsLatestRevId :: FilePath -> FilePath -> IO RevisionId
darcsLatestRevId repo name = do
ensureFileExists repo name
#ifdef USE_MAXCOUNT
(status, err, output) <- runDarcsCommand repo "changes" ["--xml-output", "--max-count=1", name]
when (status /= ExitSuccess && "unrecognized option" `isInfixOf` err) $ throwIO NoMaxCount
#else
(_, _, output) <- runDarcsCommand repo "changes" ["--xml-output", name]
#endif
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
-> FilePath
-> Maybe RevisionId
-> IO a
darcsRetrieve repo name mbId = do
ensureFileExists repo name
let opts = case mbId of
Nothing -> ["contents", name]
Just revid -> ["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 [FilePath]
darcsIndex repo = withVerifyDir repo $ do
(status, _errOutput, output) <- runDarcsCommand repo "query" ["files","--no-directories"]
if status == ExitSuccess
then return $ map (drop 2) . lines . toString $ output
else return []
darcsDirectory :: FilePath -> FilePath -> IO [Resource]
darcsDirectory repo dir = withVerifyDir (repo </> dir) $ do
let dir' = if null dir then "" else addTrailingPathSeparator dir
(status1, _errOutput1, output1) <- runDarcsCommand repo "query" ["files","--no-directories"]
(status2, _errOutput2, output2) <- runDarcsCommand repo "query" ["files","--no-files"]
if status1 == ExitSuccess && status2 == ExitSuccess
then do
let files = adhocParsing dir' . lines . toString $ output1
let dirs = adhocParsing dir' . drop 1 . lines . toString $ output2
let files' = map FSFile $ filter ('/' `notElem`) files
let dirs' = map FSDirectory $ filter ('/' `notElem`) dirs
return $ sort (files' ++ dirs')
else return []
where adhocParsing d = map (drop $ length d + 2) . filter (("." </> d) `isPrefixOf`)
darcsSearch :: FilePath -> SearchQuery -> IO [SearchMatch]
darcsSearch = grepSearchRepo darcsIndex