diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,22 @@ +Version 0.3.4 released 10 Dec 2009 + +* Added Mercurial module and associated tests. + Thanks to John Lenz for the patch. + +* Added test case for nonascii directory name + +* gitLatestRevId - added check to make sure resource hasn't been removed. + Without this, you get a ResourceExists error when creating a file + that has been previously deleted from the repo. + +* Use -z with git ls-tree. This resolves Issue #77. + When 'git ls-tree' is used with -z, it prints regular UTF8 instead of + octal encoding it. So we can avoid the problem we were having with + filenames like Foo\230\331/Bar. + +* Use -z for 'git whatchanged'. This allows us to remove the kludgy + 'convertEncoded' function, which parsed encoded filenames. + Version 0.3.3.1 released 22 Nov 2009 * Raise an IllegalResourceName error if the user tries to diff --git a/Data/FileStore.hs b/Data/FileStore.hs --- a/Data/FileStore.hs +++ b/Data/FileStore.hs @@ -19,6 +19,7 @@ , module Data.FileStore.Generic , module Data.FileStore.Git , module Data.FileStore.Darcs + , module Data.FileStore.Mercurial ) where @@ -26,3 +27,4 @@ import Data.FileStore.Generic import Data.FileStore.Git import Data.FileStore.Darcs +import Data.FileStore.Mercurial diff --git a/Data/FileStore/Git.hs b/Data/FileStore/Git.hs --- a/Data/FileStore/Git.hs +++ b/Data/FileStore/Git.hs @@ -18,14 +18,14 @@ where import Data.FileStore.Types import Data.Maybe (mapMaybe) +import Data.List.Split (endByOneOf) import System.Exit import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, escapeRegexSpecialChars, withVerifyDir) import Data.ByteString.Lazy.UTF8 (toString) import qualified Data.ByteString.Lazy as B import qualified Text.ParserCombinators.Parsec as P -import Codec.Binary.UTF8.String (decodeString, encodeString) -import Data.Char (chr) +import Codec.Binary.UTF8.String (encodeString) import Control.Monad (when) import System.FilePath (()) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, executable, getPermissions, setPermissions) @@ -138,8 +138,11 @@ -- | Return revision ID for latest commit for a resource. gitLatestRevId :: FilePath -> FilePath -> IO RevisionId gitLatestRevId repo name = do - (status, _, output) <- runGitCommand repo "rev-list" ["--max-count=1", "HEAD", "--", name] - if status == ExitSuccess + (revListStatus, _, output) <- runGitCommand repo "rev-list" ["--max-count=1", "HEAD", "--", name] + -- we need to check separately to make sure the resource hasn't been removed + -- from the repository: + (catStatus,_, _) <- runGitCommand repo "cat-file" ["-e", "HEAD:" ++ name] + if revListStatus == ExitSuccess && catStatus == ExitSuccess then do let result = takeWhile (`notElem` "\n\r \t") $ toString output if null result @@ -150,7 +153,7 @@ -- | Get revision information for a particular revision ID, or latest revision. gitGetRevision :: FilePath -> RevisionId -> IO Revision gitGetRevision repo revid = do - (status, _, output) <- runGitCommand repo "whatchanged" ["--pretty=format:" ++ gitLogFormat, "--max-count=1", revid] + (status, _, output) <- runGitCommand repo "whatchanged" ["-z","--pretty=format:" ++ gitLogFormat, "--max-count=1", revid] if status == ExitSuccess then case P.parse parseGitLog "" (toString output) of Left err' -> throwIO $ UnknownError $ "error parsing git log: " ++ show err' @@ -162,27 +165,24 @@ -- | Get a list of all known files inside and managed by a repository. gitIndex :: FilePath ->IO [FilePath] gitIndex repo = withVerifyDir repo $ do - (status, _err, output) <- runGitCommand repo "ls-tree" ["-r","-t","HEAD"] + (status, _err, output) <- runGitCommand repo "ls-tree" ["-r","-t","-z","HEAD"] if status == ExitSuccess - then return $ mapMaybe (lineToFilename . words) . lines . toString $ output + then return $ mapMaybe (lineToFilename . words) . endByOneOf ['\0'] . toString $ output else return [] -- if error, will return empty list -- note: on a newly initialized repo, 'git ls-tree HEAD' returns an error - where lineToFilename (_:"blob":_:rest) = Just $ convertEncoded $ unwords rest + where lineToFilename (_:"blob":_:rest) = Just $ unwords rest lineToFilename _ = Nothing - - - -- | Get list of resources in one directory of the repository. gitDirectory :: FilePath -> FilePath -> IO [Resource] gitDirectory repo dir = withVerifyDir (repo dir) $ do - (status, _err, output) <- runGitCommand repo "ls-tree" ["HEAD:" ++ dir] + (status, _err, output) <- runGitCommand repo "ls-tree" ["-z","HEAD:" ++ dir] if status == ExitSuccess - then return $ map (lineToResource . words) $ lines $ toString output + then return $ map (lineToResource . words) $ endByOneOf ['\0'] $ toString output else return [] -- if error, this will return empty list -- note: on a newly initialized repo, 'git ls-tree HEAD:' returns an error - where lineToResource (_:"blob":_:rest) = FSFile $ convertEncoded $ unwords rest - lineToResource (_:"tree":_:rest) = FSDirectory $ convertEncoded $ unwords rest + where lineToResource (_:"blob":_:rest) = FSFile $ unwords rest + lineToResource (_:"tree":_:rest) = FSDirectory $ unwords rest lineToResource _ = error "Encountered an item that is neither blob nor tree in git ls-tree" -- | Uses git-grep to search repository. Escape regex special characters, so the pattern @@ -230,7 +230,7 @@ gitLog :: FilePath -> [FilePath] -> TimeRange -> IO [Revision] gitLog repo names (TimeRange mbSince mbUntil) = do (status, err, output) <- runGitCommand repo "whatchanged" $ - ["--pretty=format:" ++ gitLogFormat] ++ + ["-z","--pretty=format:" ++ gitLogFormat] ++ (case mbSince of Just since -> ["--since='" ++ show since ++ "'"] Nothing -> []) ++ @@ -257,16 +257,18 @@ nonblankLine :: P.GenParser Char st String nonblankLine = P.notFollowedBy P.newline >> wholeLine +nullChar :: P.GenParser Char st () +nullChar = P.satisfy (=='\0') >> return () + gitLogEntry :: P.Parser Revision gitLogEntry = do rev <- nonblankLine date <- nonblankLine author <- wholeLine email <- wholeLine - subject <- P.manyTill P.anyChar (P.satisfy (=='\x00')) - P.spaces - changes <- P.many gitLogChange + subject <- P.manyTill P.anyChar nullChar P.spaces + changes <- P.manyTill gitLogChange (P.eof P.<|> nullChar) let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse return Revision { revId = rev @@ -277,36 +279,12 @@ gitLogChange :: P.Parser Change gitLogChange = do - P.char ':' - line <- nonblankLine - let (changeType : fileWords) = drop 4 $ words line - let file' = convertEncoded $ unwords fileWords + line <- P.manyTill P.anyChar nullChar + let changeType = take 1 $ reverse line + file' <- P.manyTill P.anyChar nullChar case changeType of "A" -> return $ Added file' "M" -> return $ Modified file' "D" -> return $ Deleted file' _ -> return $ Modified file' --- | git ls-files returns UTF-8 filenames in quotes, with characters octal-escaped. --- like this: "\340\244\226.page" --- This function decodes these. -convertEncoded :: String -> String -convertEncoded s = - case P.parse pEncodedString s s of - Left _ -> s - Right res -> res - -pEncodedString :: P.GenParser Char st String -pEncodedString = do - P.char '"' - res <- P.many1 (pOctalChar P.<|> P.anyChar) - if last res == '"' - then return $ decodeString $ init res - else fail "No ending quotation mark." - -pOctalChar :: P.GenParser Char st Char -pOctalChar = P.try $ do - P.char '\\' - ds <- P.count 3 (P.oneOf "01234567") - let num = read $ "0o" ++ ds - return $ chr num diff --git a/Data/FileStore/Mercurial.hs b/Data/FileStore/Mercurial.hs new file mode 100644 --- /dev/null +++ b/Data/FileStore/Mercurial.hs @@ -0,0 +1,278 @@ +{- | + Module : Data.FileStore.Mercurial + Copyright : Copyright (C) 2009 John MacFarlane + License : BSD 3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : GHC 6.10 required + + A versioned filestore implemented using mercurial. + Normally this module should not be imported: import + "Data.FileStore" instead. +-} + +module Data.FileStore.Mercurial + ( mercurialFileStore + ) +where +import Data.FileStore.Types +import Data.Maybe (fromJust) +import System.Exit +import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, withVerifyDir, grepSearchRepo) +import Data.ByteString.Lazy.UTF8 (toString) +import qualified Data.ByteString.Lazy as B +import qualified Text.ParserCombinators.Parsec as P +import Codec.Binary.UTF8.String (encodeString) +import Data.List (nub) +import Control.Monad (when, liftM, unless) +import System.FilePath ((), splitDirectories, takeFileName) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import Control.Exception (throwIO) +import System.Locale (defaultTimeLocale) +import Data.Time (parseTime) +import Data.Time.Clock (UTCTime) + +-- | Return a filestore implemented using the mercurial distributed revision control system +-- (). +mercurialFileStore :: FilePath -> FileStore +mercurialFileStore repo = FileStore { + initialize = mercurialInit repo + , save = mercurialSave repo + , retrieve = mercurialRetrieve repo + , delete = mercurialDelete repo + , rename = mercurialMove repo + , history = mercurialLog repo + , latest = mercurialLatestRevId repo + , revision = mercurialGetRevision repo + , index = mercurialIndex repo + , directory = mercurialDirectory repo + , search = mercurialSearch repo + , idsMatch = const hashsMatch repo + } + +-- | Run a mercurial command and return error status, error output, standard output. The repository +-- is used as working directory. +runMercurialCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString) +runMercurialCommand repo command args = do + (status, err, out) <- runShellCommand repo Nothing "hg" (command : args) + return (status, toString err, out) + +-- | Initialize a repository, creating the directory if needed. +mercurialInit :: FilePath -> IO () +mercurialInit repo = do + exists <- doesDirectoryExist repo + when exists $ withVerifyDir repo $ throwIO RepositoryExists + createDirectoryIfMissing True repo + (status, err, _) <- runMercurialCommand repo "init" [] + if status == ExitSuccess + then + -- Add a hook so that changes made remotely via hg will be reflected in + -- the working directory. See: + -- http://mercurial.selenic.com/wiki/FAQ#FAQ.2BAC8-CommonProblems.Any_way_to_.27hg_push.27_and_have_an_automatic_.27hg_update.27_on_the_remote_server.3F + B.writeFile (repo ".hg" "hgrc") $ + toByteString "[hooks]\nchangegroup = hg update >&2\n" + else throwIO $ UnknownError $ "mercurial init failed:\n" ++ err + +-- | Commit changes to a resource. Raise 'Unchanged' exception if there were +-- no changes. +mercurialCommit :: FilePath -> [FilePath] -> Author -> String -> IO () +mercurialCommit repo names author logMsg = do + let email = authorEmail author + email' = if not (null email) + then " <" ++ email ++ ">" + else "" + (statusCommit, errCommit, _) <- runMercurialCommand repo "commit" $ ["--user", authorName author ++ email', "-m", logMsg] ++ names + unless (statusCommit == ExitSuccess) $ do + throwIO $ if null errCommit + then Unchanged + else UnknownError $ "Could not hg commit " ++ unwords names ++ "\n" ++ errCommit + +-- | Save changes (creating file and directory if needed), add, and commit. +mercurialSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO () +mercurialSave repo name author logMsg contents = do + withSanityCheck repo [".hg"] name $ B.writeFile (repo encodeString name) $ toByteString contents + (statusAdd, errAdd, _) <- runMercurialCommand repo "add" ["path:" ++ name] + if statusAdd == ExitSuccess + then mercurialCommit repo [name] author logMsg + else throwIO $ UnknownError $ "Could not hg add '" ++ name ++ "'\n" ++ errAdd + +-- | Retrieve contents from resource. +-- Mercurial does not track directories so catting from a directory returns all files +mercurialRetrieve :: Contents a + => FilePath + -> FilePath + -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest + -> IO a +mercurialRetrieve repo name revid = do + let revname = case revid of + Nothing -> "tip" + Just rev -> rev + (statcheck, _, _) <- runMercurialCommand repo "locate" ["-r", revname, "-X", "glob:" ++ name "*", "path:" ++ name] + when (statcheck /= ExitSuccess) $ throwIO NotFound + (status, err, output) <- runMercurialCommand repo "cat" ["-r", revname, "-X", "glob:" ++ name "*", "path:" ++ name] + if status == ExitSuccess + then return $ fromByteString output + else throwIO $ UnknownError $ "Error in mercurial cat:\n" ++ err + +-- | Delete a resource from the repository. +mercurialDelete :: FilePath -> FilePath -> Author -> Description -> IO () +mercurialDelete repo name author logMsg = withSanityCheck repo [".hg"] name $ do + (statusAdd, errRm, _) <- runMercurialCommand repo "remove" ["path:" ++ name] + if statusAdd == ExitSuccess + then mercurialCommit repo [name] author logMsg + else throwIO $ UnknownError $ "Could not hg rm '" ++ name ++ "'\n" ++ errRm + +-- | Change the name of a resource. +mercurialMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO () +mercurialMove repo oldName newName author logMsg = do + mercurialLatestRevId repo oldName -- will throw a NotFound error if oldName doesn't exist + (statusAdd, err, _) <- withSanityCheck repo [".hg"] newName $ runMercurialCommand repo "mv" [oldName, newName] + if statusAdd == ExitSuccess + then mercurialCommit repo [oldName, newName] author logMsg + else throwIO $ UnknownError $ "Could not hg mv " ++ oldName ++ " " ++ newName ++ "\n" ++ err + +-- | Return revision ID for latest commit for a resource. +mercurialLatestRevId :: FilePath -> FilePath -> IO RevisionId +mercurialLatestRevId repo name = do + (status, _, output) <- runMercurialCommand repo "log" ["--template", "{node}\\n{file_dels}\\n", "--limit", "1", "--removed", "path:" ++ name] + if status == ExitSuccess + then do + let result = lines $ toString output + if null result || name `elem` drop 1 result + then throwIO NotFound + else return $ head result + else throwIO NotFound + +-- | Get revision information for a particular revision ID, or latest revision. +mercurialGetRevision :: FilePath -> RevisionId -> IO Revision +mercurialGetRevision repo revid = do + (status, _, output) <- runMercurialCommand repo "log" ["--template", mercurialLogFormat, "--limit", "1", "-r", revid] + if status == ExitSuccess + then case P.parse parseMercurialLog "" (toString output) of + Left err' -> throwIO $ UnknownError $ "error parsing mercurial log: " ++ show err' + Right [r] -> return r + Right [] -> throwIO NotFound + Right xs -> throwIO $ UnknownError $ "mercurial log returned more than one result: " ++ show xs + else throwIO NotFound + +-- | Get a list of all known files inside and managed by a repository. +mercurialIndex :: FilePath ->IO [FilePath] +mercurialIndex repo = withVerifyDir repo $ do + (status, _err, output) <- runMercurialCommand repo "manifest" ["-r", "tip"] + if status == ExitSuccess + then return $ lines $ toString $ output + else return [] -- if error, will return empty list + +-- | Get list of resources in one directory of the repository. Mercurial does not store or track directories, +-- so the locate command does not return any directories. Instead we first list all the files, then list all +-- files in subdirectories of the given directory and use that to contruct the list of directories. +mercurialDirectory :: FilePath -> FilePath -> IO [Resource] +mercurialDirectory repo dir = withVerifyDir (repo dir) $ do + (status, _, output) <- runMercurialCommand repo "locate" ["-r", "tip", "glob:" ++ (dir "*")] + let files = if status == ExitSuccess + then map (FSFile . takeFileName . removePrefix dir) $ lines $ toString output + else [] + (status2, _, output2) <- runMercurialCommand repo "locate" ["-r", "tip", "glob:" ++ (dir "*" "*")] + let dirs = if status2 == ExitSuccess + then map FSDirectory $ nub $ map (head . splitDirectories . removePrefix dir) $ lines $ toString output2 + else [] + return $ files ++ dirs + where removePrefix d = drop $ length d + +-- | Use generic grep to search +mercurialSearch :: FilePath -> SearchQuery -> IO [SearchMatch] +mercurialSearch = grepSearchRepo mercurialIndex + +{- The following code goes not work because of a bug in mercurial. If the final line of a file +does not end with a newline and you search for a word in the final line, hg does not display +the line from the file correctly. In the results, the last character line is not printed. +mercurialSearch repo query = do + let patterns = map escapeRegexSpecialChars $ queryPatterns query + pattern = if queryWholeWords query + then "(\\b" ++ foldr1 (\a b -> a ++ "\\b|\\b" ++ b) patterns ++ "\\b)" + else "(" ++ foldr1 (\a b -> a ++ "|" ++ b) patterns ++ ")" + (status, errOutput, output) <- runMercurialCommand repo "grep" (["--ignore-case" | queryIgnoreCase query] ++ ["-n", "-0", pattern]) + case status of + ExitSuccess -> do + putStrLn $ show output + case P.parse parseMercurialSearch "" (toString output) of + Left err' -> throwIO $ UnknownError $ "Error parsing mercurial search results.\n" ++ show err' + Right parsed -> return parsed + ExitFailure 1 -> return [] -- status of 1 means no matches + ExitFailure _ -> throwIO $ UnknownError $ "mercurial grep returned error status.\n" ++ errOutput +-} + +mercurialLogFormat :: String +mercurialLogFormat = "{node}\\n{date|rfc822date}\\n{author|person}\\n{author|email}\\n{desc}\\x00{file_adds}\\x00{file_mods}\\x00{file_dels}\\x00" + +-- | Return list of log entries for the given time frame and list of resources. +-- If list of resources is empty, log entries for all resources are returned. +mercurialLog :: FilePath -> [FilePath] -> TimeRange -> IO [Revision] +mercurialLog repo names (TimeRange mbSince mbUntil) = do + (status, err, output) <- runMercurialCommand repo "log" $ ["--template", mercurialLogFormat] ++ revOpts mbSince mbUntil ++ names + if status == ExitSuccess + then case P.parse parseMercurialLog "" (toString output) of + Left err' -> throwIO $ UnknownError $ "Error parsing mercurial log.\n" ++ show err' + Right parsed -> return parsed + else throwIO $ UnknownError $ "mercurial log returned error status.\n" ++ err + where revOpts Nothing Nothing = [] + revOpts Nothing (Just u) = ["-d", "<" ++ show u] + revOpts (Just s) Nothing = ["-d", ">" ++ show s] + revOpts (Just s) (Just u) = ["-d", show s ++ " to " ++ show u] + +-- +-- Parsers to parse mercurial log into Revisions. +-- + +parseMercurialLog :: P.Parser [Revision] +parseMercurialLog = P.manyTill mercurialLogEntry P.eof + +wholeLine :: P.GenParser Char st String +wholeLine = P.manyTill P.anyChar P.newline + +nonblankLine :: P.GenParser Char st String +nonblankLine = P.notFollowedBy P.newline >> wholeLine + +nullStr :: P.GenParser Char st String +nullStr = P.manyTill P.anyChar (P.satisfy (=='\x00')) + +mercurialLogEntry :: P.Parser Revision +mercurialLogEntry = do + rev <- nonblankLine + date <- nonblankLine + author <- nonblankLine + email <- wholeLine + subject <- nullStr + P.spaces + file_add <- liftM (map Added . lines) $ nullStr + P.spaces + file_mod <- liftM (map Modified . lines) $ nullStr + P.spaces + file_del <- liftM (map Deleted . lines) $ nullStr + P.spaces + let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse + return Revision { + revId = rev + , revDateTime = fromJust (parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" date :: Maybe UTCTime) + , revAuthor = Author { authorName = author, authorEmail = email } + , revDescription = stripTrailingNewlines subject + , revChanges = file_add ++ file_mod ++ file_del + } + +{- +parseMercurialSearch :: P.Parser [SearchMatch] +parseMercurialSearch = P.manyTill mercurialSearchFormat P.eof + +mercurialSearchFormat :: P.Parser SearchMatch +mercurialSearchFormat = do + fname <- nullStr + nullStr -- revision number + lineNum <- nullStr + txt <- nullStr + return SearchMatch { + matchResourceName = fname + , matchLineNumber = read lineNum + , matchLine = txt + } +-} diff --git a/Tests.lhs b/Tests.lhs --- a/Tests.lhs +++ b/Tests.lhs @@ -21,6 +21,7 @@ > main = do > testFileStore (gitFileStore "tmp/gitfs") "Data.FileStore.Git" > testFileStore (darcsFileStore "tmp/darcsfs") "Data.FileStore.Darcs" +> testFileStore (mercurialFileStore "tmp/mercurialfs") "Data.FileStore.Mercurial" > removeDirectoryRecursive "tmp" @@ -35,6 +36,7 @@ > , ("create resource", createTest1) > , ("create resource in subdirectory", createTest2) > , ("create resource with non-ascii name", createTest3) +> , ("create resource with non-ascii subdirectory", createTest3a) > , ("try to create resource outside repo", createTest4) > , ("try to create resource in special directory", createTest5 fsName) > , ("directory", directoryTest) @@ -66,6 +68,9 @@ > nonasciiTestTitle :: String > nonasciiTestTitle = "αβγ" +> subdirNonasciiTestTitle :: String +> subdirNonasciiTestTitle = "Fooé/bar" + *** index and directory for noexisting repository should raise error: > preInitializeTest fs = TestCase $ do @@ -103,9 +108,18 @@ > createTest3 fs = TestCase $ do > create fs nonasciiTestTitle testAuthor "description of change" testContents -> revid <- latest fs testTitle +> revid <- latest fs nonasciiTestTitle > assertBool "revision returns a revision after create" (not (null revid)) +> allfiles <- index fs +> assertBool "index contains file with nonascii name" (nonasciiTestTitle `elem` allfiles) +> createTest3a fs = TestCase $ do +> create fs subdirNonasciiTestTitle testAuthor "description of change" testContents +> revid <- latest fs subdirNonasciiTestTitle +> assertBool "revision returns a revision after create" (not (null revid)) +> allfiles <- index fs +> assertBool "index contains file with nonascii subdir" (subdirNonasciiTestTitle `elem` allfiles) + *** Try to create a resource outside the repository (should fail with an error and NOT write the file): > createTest4 fs = TestCase $ do @@ -119,9 +133,10 @@ > createTest5 fsName fs = TestCase $ do > let (realpath, special) = case fsName of -> "Data.FileStore.Git" -> ("tmp" "gitfs" ".git" "newfile", ".git/newfile") -> "Data.FileStore.Darcs" -> ("tmp" "darcsfs" "_darcs" "newfile", "_darcs/newfile") -> _ -> error "Unknown filestore type! Add a test case." +> "Data.FileStore.Git" -> ("tmp" "gitfs" ".git" "newfile", ".git/newfile") +> "Data.FileStore.Darcs" -> ("tmp" "darcsfs" "_darcs" "newfile", "_darcs/newfile") +> "Data.FileStore.Mercurial" -> ("tmp" "mercurialfs" ".hg" "newfile", ".hg/newfile") +> _ -> error "Unknown filestore type! Add a test case." > catch (create fs special testAuthor "description of change" testContents >> > (assertFailure $ "did not return error from create " ++ special)) $ > \e -> assertEqual ("error from create " ++ special) IllegalResourceName e @@ -135,7 +150,7 @@ Get directory for top-level > files <- directory fs "" -> assertEqual "result of directory on top-level" (sort [FSDirectory "subdir", FSFile testTitle, FSFile nonasciiTestTitle]) (sort files) +> assertEqual "result of directory on top-level" (sort [FSDirectory (takeDirectory subdirTestTitle), FSFile testTitle, FSFile nonasciiTestTitle, FSDirectory (takeDirectory subdirNonasciiTestTitle)]) (sort files) Get contents of subdirectory @@ -227,12 +242,22 @@ > ind <- index fs > assertBool "index does not contain resource that was deleted" (toBeDeleted `notElem` ind) + Now make sure you can create and delete it again. + +> create fs toBeDeleted testAuthor "description of change" testContents +> ind <- index fs +> assertBool "index contains re-created resource" (toBeDeleted `elem` ind) +> delete fs toBeDeleted testAuthor "goodbye" +> ind <- index fs +> assertBool "index does not contain resource that was deleted" (toBeDeleted `notElem` ind) + Try to delete a file somewhere we shouldn't be able to delete > let (realpath, special) = case fsName of -> "Data.FileStore.Git" -> ("tmp" "gitfs" ".git" "newfile", ".git/newfile") -> "Data.FileStore.Darcs" -> ("tmp" "darcsfs" "_darcs" "newfile", "_darcs/newfile") -> _ -> error "Unknown filestore type! Add a test case." +> "Data.FileStore.Git" -> ("tmp" "gitfs" ".git" "newfile", ".git/newfile") +> "Data.FileStore.Darcs" -> ("tmp" "darcsfs" "_darcs" "newfile", "_darcs/newfile") +> "Data.FileStore.Mercurial" -> ("tmp" "mercurialfs" ".hg" "newfile", ".hg/newfile") +> _ -> error "Unknown filestore type! Add a test case." > catch (delete fs special testAuthor "description of change" >> > (assertFailure $ "did not return error from delete " ++ special)) $ > \e -> assertEqual ("error from delete " ++ special) IllegalResourceName e diff --git a/filestore.cabal b/filestore.cabal --- a/filestore.cabal +++ b/filestore.cabal @@ -1,13 +1,13 @@ Name: filestore -Version: 0.3.3.1 +Version: 0.3.4 Cabal-version: >= 1.2 Build-type: Custom Tested-with: GHC==6.10.1 Synopsis: Interface for versioning file stores. Description: The filestore library provides an abstract interface for a versioning file store, and modules that instantiate this interface. Currently - only Git & Darcs modules are provided, but other VCSs or databases could be - added. + Git, Darcs, and Mercurial modules are provided, and other VCSs + or databases could be added. Category: Data Stability: Experimental License: BSD3 @@ -32,9 +32,9 @@ Library Build-depends: base >= 4 && < 5, bytestring, utf8-string, filepath, directory, datetime, - parsec >= 2 && < 3, process, time, datetime, regex-posix, xml, split, Diff + parsec >= 2 && < 3, process, time, datetime, regex-posix, xml, split, Diff, old-locale - Exposed-modules: Data.FileStore, Data.FileStore.Types, Data.FileStore.Git, Data.FileStore.Darcs, + Exposed-modules: Data.FileStore, Data.FileStore.Types, Data.FileStore.Git, Data.FileStore.Darcs, Data.FileStore.Mercurial, -- Data.FileStore.Sqlite3, Data.FileStore.Utils, Data.FileStore.Generic Other-modules: Paths_filestore, Data.FileStore.DarcsXml