filestore 0.3.3.1 → 0.3.4
raw patch · 6 files changed
+361/−59 lines, 6 filesdep +old-localePVP ok
version bump matches the API change (PVP)
Dependencies added: old-locale
API changes (from Hackage documentation)
+ Data.FileStore.Mercurial: mercurialFileStore :: FilePath -> FileStore
Files
- CHANGES +19/−0
- Data/FileStore.hs +2/−0
- Data/FileStore/Git.hs +24/−46
- Data/FileStore/Mercurial.hs +278/−0
- Tests.lhs +33/−8
- filestore.cabal +5/−5
CHANGES view
@@ -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
Data/FileStore.hs view
@@ -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
Data/FileStore/Git.hs view
@@ -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
+ Data/FileStore/Mercurial.hs view
@@ -0,0 +1,278 @@+{- |+ Module : Data.FileStore.Mercurial+ Copyright : Copyright (C) 2009 John MacFarlane+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ 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+-- (<http://mercurial.selenic.com/>).+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+ }+-}
Tests.lhs view
@@ -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
filestore.cabal view
@@ -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