filestore 0.4.2 → 0.5

raw patch · 9 files changed

+497/−465 lines, 9 filesdep +filestoredep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: filestore

Dependency ranges changed: directory

API changes (from Hackage documentation)

Files

• CHANGES +10/−0
• Data/FileStore/Darcs.hs +21/−6
• Data/FileStore/Generic.hs +1/−1
• Data/FileStore/Git.hs +45/−48
• Data/FileStore/Mercurial.hs +6/−3
• Data/FileStore/Types.hs +1/−0
• Tests.lhs +0/−394
• filestore.cabal +18/−13
• tests/Tests.lhs +395/−0

@@ -1,3 +1,13 @@+Version 0.5 released 30 Apr 2012++* Added 'limit' parameter to 'history', so that in large repositories+  you don't need to generate and parse the entire log.++* Revised the git log parser, so it is faster and lazy.  This is+  helpful for applications where we may not need to parse the whole+  history.  It would be good to make similar modifications to the hg+  and darcs log parsers in the future.+ Version 0.3.4.3 released 26 Sep 2010  * runShellCommand: reverted to older version with temp files.

@@ -117,16 +117,30 @@  -- | Return list of log entries for the list of resources. -- If list of resources is empty, log entries for all resources are returned.-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+darcsLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]+darcsLog repo names (TimeRange begin end) mblimit = 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+            Just parsed -> return $+#ifdef USE_MAXCOUNT+                              parsed+#else+                              case mblimit of+                                   Just lim -> take lim parsed+                                   Nothing  -> parsed+#endif         else throwIO $ UnknownError $ "darcs changes returned error status.\n" ++ err     where+        opts = timeOpts begin end ++ limit+        limit = case mblimit of+#ifdef USE_MAXCOUNT+                    Just lim  -> ["--max-count",show lim]+#else+                    Just _    -> []+#endif+                    Nothing   -> []         timeOpts :: Maybe UTCTime -> Maybe UTCTime ->[String]         timeOpts b e = case (b,e) of                 (Nothing,Nothing) -> []@@ -160,7 +174,8 @@   let patchs = parseDarcsXML $ toString output   case patchs of       Nothing -> throwIO NotFound-      Just as -> if null as then throwIO NotFound else return $ revId $ head as+      Just [] -> throwIO NotFound+      Just (x:_) -> return $ revId x  -- | Retrieve the contents of a resource. darcsRetrieve :: Contents a

@@ -104,7 +104,7 @@   let matcher = if exact                 then (== desc)                 else (desc `isInfixOf`)-  revs <- history repo [name] (TimeRange Nothing Nothing)+  revs <- history repo [name] (TimeRange Nothing Nothing) Nothing   return $ Prelude.filter (matcher . revDescription) revs  -- | Try to retrieve a resource from the repository by name and possibly a

@@ -23,8 +23,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, escapeRegexSpecialChars, withVerifyDir, encodeArg) import Data.ByteString.Lazy.UTF8 (toString)-import qualified Data.ByteString.Lazy as B-import qualified Text.ParserCombinators.Parsec as P+import qualified Data.ByteString.Lazy.Char8 as B import Control.Monad (when) import System.FilePath ((</>)) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, executable, getPermissions, setPermissions)@@ -157,11 +156,7 @@ gitGetRevision repo revid = do   (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'-                 Right [r]   -> return r-                 Right []    -> throwIO NotFound-                 Right xs    -> throwIO $ UnknownError $ "git rev-list returned more than one result: " ++ show xs+     then parseLogEntry $ B.drop 1 output  -- drop initial \1      else throwIO NotFound  -- | Get a list of all known files inside and managed by a repository.@@ -233,12 +228,12 @@ -}  gitLogFormat :: String-gitLogFormat = "%H%n%ct%n%an%n%ae%n%B%n%x00"+gitLogFormat = "%x01%H%x00%ct%x00%an%x00%ae%x00%B%n%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.-gitLog :: FilePath -> [FilePath] -> TimeRange -> IO [Revision]-gitLog repo names (TimeRange mbSince mbUntil) = do+gitLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]+gitLog repo names (TimeRange mbSince mbUntil) mblimit = do   (status, err, output) <- runGitCommand repo "whatchanged" $                            ["-z","--pretty=format:" ++ gitLogFormat] ++                            (case mbSince of@@ -247,54 +242,56 @@                            (case mbUntil of                                  Just til   -> ["--until='" ++ show til ++ "'"]                                  Nothing      -> []) ++-                           ["--"] ++ names +                           (case mblimit of+                                 Just lim   -> ["-n", show lim]+                                 Nothing    -> []) +++                           ["--"] ++ names   if status == ExitSuccess-     then case P.parse parseGitLog "" (toString output) of-                Left err'    -> throwIO $ UnknownError $ "Error parsing git log.\n" ++ show err'-                Right parsed -> return parsed+     then parseGitLog output      else throwIO $ UnknownError $ "git whatchanged returned error status.\n" ++ err  -- -- Parsers to parse git log into Revisions. -- -parseGitLog :: P.Parser [Revision]-parseGitLog = P.manyTill gitLogEntry 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+parseGitLog :: B.ByteString -> IO [Revision]+parseGitLog = mapM parseLogEntry . splitEntries -nullChar :: P.GenParser Char st ()-nullChar = P.satisfy (=='\0') >> return ()+splitEntries :: B.ByteString -> [B.ByteString]+splitEntries = dropWhile B.null . B.split '\1' -- occurs just before each hash -gitLogEntry :: P.Parser Revision-gitLogEntry = do-  rev <- nonblankLine-  date <- nonblankLine-  author <- wholeLine-  email <- wholeLine-  subject <- P.manyTill P.anyChar nullChar-  P.spaces-  changes <- P.manyTill gitLogChange (P.eof P.<|> nullChar)-  let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse+parseLogEntry :: B.ByteString -> IO Revision+parseLogEntry entry = do+  let (rev : date' : author : email : subject : rest) = B.split '\0' entry+  date <- case B.readInteger date' of+               Just (x,_) -> return x+               Nothing    -> throwIO $ UnknownError $ "Could not read date"+  changes <- parseChanges $ takeWhile (not . B.null) rest   return Revision {-              revId          = rev-            , revDateTime    = posixSecondsToUTCTime $ realToFrac (read date :: Integer)-            , revAuthor      = Author { authorName = author, authorEmail = email }-            , revDescription = stripTrailingNewlines subject+              revId          = toString rev+            , revDateTime    = posixSecondsToUTCTime $ realToFrac date+            , revAuthor      = Author{ authorName = toString author+                                     , authorEmail = toString email }+            , revDescription = toString $ stripTrailingNewlines subject             , revChanges     = changes } -gitLogChange :: P.Parser Change-gitLogChange = do-  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'+stripTrailingNewlines :: B.ByteString -> B.ByteString+stripTrailingNewlines = B.reverse . B.dropWhile (=='\n') . B.reverse++parseChanges :: [B.ByteString] -> IO [Change]+parseChanges (x:y:zs) = do+  when (B.null x) $+     throwIO $ UnknownError "parseChanges found empty change description"+  let changeType = B.last x+  let file' = toString y+  let next = case changeType of+           'A'  -> Added file'+           'M'  -> Modified file'+           'D'  -> Deleted file'+           _    -> Modified file'+  rest <- parseChanges zs+  return (next:rest)+parseChanges [_] =+  throwIO $ UnknownError $ "parseChanges encountered odd number of fields"+parseChanges [] = return [] 

@@ -200,9 +200,9 @@  -- | 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+mercurialLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]+mercurialLog repo names (TimeRange mbSince mbUntil) mblimit = do+  (status, err, output) <- runMercurialCommand repo "log" $ ["--template", mercurialLogFormat] ++ revOpts mbSince mbUntil ++ limit ++ names   if status == ExitSuccess      then case P.parse parseMercurialLog "" (toString output) of                 Left err'    -> throwIO $ UnknownError $ "Error parsing mercurial log.\n" ++ show err'@@ -213,6 +213,9 @@        revOpts (Just s) Nothing  = ["-d", ">" ++ showTime s]        revOpts (Just s) (Just u) = ["-d", showTime s ++ " to " ++ showTime u]        showTime = formatTime defaultTimeLocale "%F %X"+       limit = case mblimit of+                    Just lim  -> ["--limit", show lim]+                    Nothing   -> []   --

@@ -184,6 +184,7 @@   , history        :: [FilePath]        -- List of resources to get history for                                         -- or @[]@ for all.                    -> TimeRange         -- Time range in which to get history.+                   -> Maybe Int         -- Maybe max number of entries.                    -> IO [Revision]      -- | Return the revision ID of the latest change for a resource.

@@ -1,394 +0,0 @@-#!/usr/bin/env runghc--This program runs tests for the filestore modules.--> import Data.FileStore-> import Data.List (sort, isInfixOf)-> import Test.HUnit-> import System.Directory (doesFileExist, removeDirectoryRecursive)-> import Control.Monad (forM)-> import Prelude hiding (catch)-> import Control.Exception (catch)-> import Data.Time-> import Data.Maybe (mapMaybe)-> import System.FilePath-> import System.Process-> import Data.Algorithm.Diff (DI(..))--> 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"---> testFileStore :: FileStore -> String -> IO Counts -> testFileStore fs fsName = do->   putStrLn   "**********************************"->   putStrLn $ "Testing " ++ fsName->   putStrLn   "**********************************"->   runTestTT $ TestList $ map (\(label, testFn) -> TestLabel label $ testFn fs) ->     [ ("pre initialize", preInitializeTest)->     , ("initialize", initializeTest)->     , ("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)->     , ("retrieve resource", retrieveTest1)->     , ("retrieve resource in a subdirectory", retrieveTest2)->     , ("retrieve resource with non-ascii name", retrieveTest3)->     , ("retrieve subdirectory (should raise error)", retrieveTest4)->     , ("modify resource", modifyTest)->     , ("delete resource", deleteTest fsName)->     , ("retrieve deleted file", retrieveTest5)->     , ("rename resource", renameTest)->     , ("test for matching IDs", matchTest)->     , ("history and revision", historyTest)->     , ("diff", diffTest)->     , ("search", searchTest)->     ]--> testAuthor :: Author-> testAuthor = Author "Test Suite" "suite@test.org"--> testContents :: String-> testContents = "Test contents.\nSecond line.\nThird test line with some Greek αβ."--> testTitle :: String-> testTitle = "New resource.txt"--> subdirTestTitle :: String-> subdirTestTitle = "subdir/Subdir title.txt"--> nonasciiTestTitle :: String-> nonasciiTestTitle = "αβγ"--> subdirNonasciiTestTitle :: String-> subdirNonasciiTestTitle = "Fooé/bar"--*** index and directory for noexisting repository should raise error:--> preInitializeTest fs = TestCase $ do->   catch (do index fs; assertFailure "preInitialize, uncaught error") $ ->                \e -> assertEqual "error status from attempt to get index of nonexistent repo" e NotFound->   catch (do directory fs "foo"; assertFailure "preInitialize, uncaught error") $ ->                \e -> assertEqual "error status from attempt to get directory of nonexistent repo" e NotFound--*** Initialize a repository, check for empty index, and then try to initialize again-*** in the same directory (should raise an error):--> initializeTest fs = TestCase $ do->   initialize fs->   ind <- index fs->   assertEqual "index of just-initialized repository" ind []->   catch (initialize fs >> assertFailure "did not return error for existing repository") $->     \e -> assertEqual "error status from existing repository" e RepositoryExists--*** Create a resource, and check to see that latest returns a revision ID for it:--> createTest1 fs = TestCase $ do->   create fs testTitle testAuthor "description of change" testContents->   revid <- latest fs testTitle->   assertBool "revision returns a revision after create" (not (null revid))--*** Create a resource in a subdirectory, and check to see that revision returns a revision for it:--> createTest2 fs = TestCase $ do->   create fs subdirTestTitle testAuthor "description of change" testContents->   revid <- latest fs testTitle->   assertBool "revision returns a revision after create" (not (null revid))->   create fs (subdirTestTitle ++ "2") testAuthor "+Second file" testContents--*** Create a resource with a non-ascii title, and check to see that revision returns a revision for it:--> createTest3 fs = TestCase $ do->   create fs nonasciiTestTitle testAuthor "description of change" testContents->   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->   catch (create fs "../oops" testAuthor "description of change" testContents >>->          assertFailure "did not return error from create ../oops") $->          \e -> assertEqual "error from create ../oops" IllegalResourceName e ->   exists <- doesFileExist "tmp/oops"->   assertBool "file ../oops was created outside repository" (not exists)--*** Try to create a resource in special directory (should fail with an error and NOT write the file):--> 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")->                             "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 ->   exists <- doesFileExist realpath->   assertBool ("file " ++ realpath ++ " was created outside repository") (not exists)--*** Test directory--> directoryTest fs = TestCase $ do--    Get directory for top-level-->   files <- directory fs ""->   assertEqual "result of directory on top-level" (sort [FSDirectory (takeDirectory subdirTestTitle), FSFile testTitle, FSFile nonasciiTestTitle, FSDirectory (takeDirectory subdirNonasciiTestTitle)]) (sort files)--    Get contents of subdirectory-->   subdirFiles <- directory fs "subdir"->   assertEqual "result of directory on subdir" [FSFile (takeFileName subdirTestTitle), FSFile (takeFileName (subdirTestTitle ++ "2"))] subdirFiles--    Try to get contents of nonexistent subdirectory-->   catch (do directory fs "foo"; assertFailure "nonexistent subdirectory, uncaught error") $ ->                \e -> assertEqual "error status from attempt to get directory listing of nonexistent directory" e NotFound--*** Retrieve latest version of a resource:--> retrieveTest1 fs = TestCase $->   retrieve fs testTitle Nothing >>=->     assertEqual "contents returned by retrieve" testContents--*** Retrieve latest version of a resource (in a subdirectory):--> retrieveTest2 fs = TestCase $->   retrieve fs subdirTestTitle Nothing >>=->     assertEqual "contents returned by retrieve" testContents--*** Retrieve latest version of a resource with a nonascii name:--> retrieveTest3 fs = TestCase $->   retrieve fs nonasciiTestTitle Nothing >>=->     assertEqual "contents returned by retrieve" testContents--*** Retrieve a directory (should fail):--> retrieveTest4 fs = TestCase $->   catch ((retrieve fs "subdir" Nothing :: IO String) >>->          assertFailure "did not return error from retrieve from subdir") $->      \e -> assertEqual "error from retrieve from subdir" NotFound e--*** Modify a resource:--> modifyTest fs = TestCase $ do--    Modify a resource.  Should return Right ().-->   revid <- latest fs testTitle->   let modifiedContents = unlines $ take 2 $ lines testContents->   modResult <- modify fs testTitle revid testAuthor "removed third line" modifiedContents->   assertEqual "results of modify" (Right ()) modResult--    Now retrieve the contents and make sure they were changed.-->   modifiedContents' <- retrieve fs testTitle Nothing->   newRevId <- latest fs testTitle->   newRev <- revision fs newRevId->   assertEqual "retrieved contents after modify" modifiedContents' modifiedContents--    Now try to modify again, using the old revision as base.  This should result in a merge with conflicts.-->   modResult2 <- modify fs testTitle revid testAuthor "modified from old version" (testContents ++ "\nFourth line")->   let normModResult2 = Left MergeInfo {mergeRevision = newRev, mergeConflicts = True, mergeText =->                         "Test contents.\nSecond line.\n<<<<<<< edited\nThird test line with some Greek \945\946.\nFourth line\n=======\n>>>>>>> " ++->                         newRevId ++ "\n"}->   assertEqual "results of modify from old version" normModResult2 modResult2--    Now try it again, still using the old version as base, but with contents of the new version.-    This should result in a merge without conflicts.-->   modResult3 <- modify fs testTitle revid testAuthor "modified from old version" modifiedContents->   let normModResult3 = Left MergeInfo {mergeRevision = newRev, mergeConflicts = False, mergeText = modifiedContents}->   assertEqual "results of modify from old version with new version's contents" normModResult3 modResult3--    Now try modifying again, this time using the new version as base. Should succeed with Right ().-->   modResult4 <- modify fs testTitle newRevId testAuthor "modified from new version" (modifiedContents ++ "\nThird line")->   assertEqual "results of modify from new version" (Right ()) modResult4 --*** Delete a resource:--> deleteTest fsName fs = TestCase $ do--    Create a file and verify that it's there.-->   let toBeDeleted = "Aaack!"->   create fs toBeDeleted testAuthor "description of change" testContents->   ind <- index fs->   assertBool "index contains resource to be deleted" (toBeDeleted `elem` ind) --    Now delete it and verify that it's gone.-->   delete fs toBeDeleted testAuthor "goodbye"->   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")->                             "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 --*** Retrieve earlier version of deleted file:--> retrieveTest5 fs = TestCase $ do->   hist <- history fs ["Aaack!"] (TimeRange Nothing Nothing)->   assertBool "history is nonempty" (not (null hist))->   let deletedId = revId $ last hist->   contents <- retrieve fs "Aaack!" (Just deletedId) :: IO String->   assertEqual "contents returned by retrieve" testContents contents--*** Rename a resource:--> renameTest fs = TestCase $ do--    Create a file and verify that it's there.-->   let oldName = "Old Name"->   let newName = "newdir/New Name.txt"->   create fs oldName testAuthor "description of change" testContents->   ind <- index fs->   assertBool "index contains old name" (oldName `elem` ind) ->   assertBool "index does not contain new name" (newName `notElem` ind)--    Now rename it and verify that it changed names.-->   rename fs oldName newName testAuthor "rename"->   ind <- index fs->   assertBool "index does not contain old name" (oldName `notElem` ind) ->   assertBool "index contains new name" (newName `elem` ind)--    Try renaming a file that doesn't exist.-->   catch (rename fs "nonexistent file" "other name" testAuthor "rename" >>->       assertFailure "rename of nonexistent file did not throw error") $->       \e -> assertEqual "error status from rename of nonexistent file" NotFound e--    Try to rename a file to a location we shouldn't be able to write in.-->   let badName = "../eek"->   let cmd = "rename " ++ newName ++ " " ++ badName->   catch (rename fs newName badName testAuthor "description of change" >>->          (assertFailure  $ "did not return error from " ++ cmd)) $->          \e -> assertEqual ("error from " ++ cmd) IllegalResourceName e ---*** Test history and revision--> historyTest fs = TestCase $ do--    Get history for three files-->   hist <- history fs [testTitle, subdirTestTitle, nonasciiTestTitle] (TimeRange Nothing Nothing)->   assertBool "history is nonempty" (not (null hist))->   now <- getCurrentTime->   rev <- latest fs testTitle >>= revision fs  -- get latest revision->   assertBool "history contains latest revision" (rev `elem` hist)->   assertEqual "revAuthor" testAuthor (revAuthor rev)->   assertBool "revId non-null" (not (null (revId rev)))->   assertBool "revDescription non-null" (not (null (revDescription rev)))->   assertEqual "revChanges" [Modified testTitle] (revChanges rev)->   let revtime = revDateTime rev->   histNow <- history fs [testTitle] (TimeRange (Just $ addUTCTime (60 * 60 * 24) now) Nothing)->   assertBool "history from now + 1 day onwards is empty" (null histNow)--*** Test diff--> diffTest fs = TestCase $ do--  Create a file and modiy it.-->   let diffTitle = "difftest.txt"->   create fs diffTitle testAuthor "description of change" testContents->   save fs diffTitle testAuthor "removed a line" (unlines . init . lines $ testContents)-->   [secondrev, firstrev] <- history fs [diffTitle] (TimeRange Nothing Nothing)->   diff' <- diff fs diffTitle (Just $ revId firstrev) (Just $ revId secondrev)->   let subtracted' = mapMaybe (\(d,s) -> if d == F then Just s else Nothing) diff'->   assertEqual "subtracted lines" [[last (lines testContents)]] subtracted'--    Diff from Nothing should be diff from empty document.-->   diff'' <- diff fs diffTitle Nothing (Just $ revId firstrev)->   let added'' = mapMaybe (\(d,s) -> if d == S then Just s else Nothing) diff''->   assertEqual "added lines from empty document to first revision" [lines testContents] added''--    Diff to Nothing should be diff to latest.-->   diff''' <- diff fs diffTitle (Just $ revId firstrev) Nothing->   assertEqual "diff from first revision to latest" diff' diff'''--*** Test search--> searchTest fs = TestCase $ do--    Search for "bing"-->   create fs "foo" testAuthor "my 1st search test doc" "bing\nbong\nbang\nφ"->   create fs "bar" testAuthor "my 2nd search test doc" "bing BONG" ->   create fs "baz" testAuthor "my 3nd search test doc" "bingbang\nbong"--    Search for "bing" with whole-word matches.-->   res1 <- search fs SearchQuery{queryPatterns = ["bing"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = True}->   assertEqual "search results 1" [SearchMatch "bar" 1 "bing BONG", SearchMatch "foo" 1 "bing"] res1--    Search for regex "BONG" case-sensitive.-->   res2 <- search fs SearchQuery{queryPatterns = ["BONG"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = False}->   assertEqual "search results 2" [SearchMatch "bar" 1 "bing BONG"] res2--    Search for "bong" and "φ"-->   res3 <- search fs SearchQuery{queryPatterns = ["bong", "φ"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = True}->   assertEqual "search results 3" [SearchMatch "foo" 2 "bong", SearchMatch "foo" 4 "φ"] res3--    Search for "bong" and "φ" but without match-all set-->   res4 <- search fs SearchQuery{queryPatterns = ["bong", "φ"], queryWholeWords = True, queryMatchAll = False, queryIgnoreCase = True}->   assertEqual "search results 4" [SearchMatch "bar" 1 "bing BONG", SearchMatch "baz" 2 "bong", SearchMatch "foo" 2 "bong", SearchMatch "foo" 4 "φ"] res4--    Search for "bing" but without whole-words set-->   res5 <- search fs SearchQuery{queryPatterns = ["bing"], queryWholeWords = False, queryMatchAll = True, queryIgnoreCase = True}->   assertEqual "search results 5" [SearchMatch "bar" 1 "bing BONG", SearchMatch "baz" 1 "bingbang", SearchMatch "foo" 1 "bing"] res5--*** Test IDs match--> matchTest fs = TestCase $ do-->   assertBool "match with two identical IDs" (idsMatch fs "abcde" "abcde")->   assertBool "match with nonidentical but matching IDs" (idsMatch fs "abcde" "abcde5553")->   assertBool "non-match" (not (idsMatch fs "abcde" "abedc"))-

@@ -1,6 +1,6 @@ Name:                filestore-Version:             0.4.2-Cabal-version:       >= 1.2+Version:             0.5+Cabal-version:       >= 1.8 Build-type:          Custom Synopsis:            Interface for versioning file stores. Description:         The filestore library provides an abstract interface for a versioning@@ -13,15 +13,13 @@ License-File:        LICENSE Author:              John MacFarlane, Gwern Branwen, Sebastiaan Visser Maintainer:          jgm@berkeley.edu-Homepage:            http://johnmacfarlane.net/repos/filestore+Bug-Reports:         https://github.com/jgm/filestore/issues  Data-Files:          extra/post-update, CHANGES-Extra-source-files:  Tests.lhs --- Commented out until Cabal 1.6 becomes common.--- Source-repository head---    Type:            darcs---    Location:        http://johnmacfarlane.net/repos/filestore+Source-repository head+  type:          git+  location:      git://github.com/jgm/filestore.git  Flag tests     default:    False@@ -67,10 +65,17 @@  Executable test-filestore     if flag(tests)-       Buildable: True+       Buildable:   True     else-       Buildable: False-    Main-is: Tests.lhs-    Build-depends:  base >= 4 && < 5, HUnit >= 1.2 && < 1.3, mtl,-                    time, Diff+       Buildable:   False+    Hs-source-dirs: tests+    Main-is:        Tests.lhs+    Build-depends:  base >= 4 && < 5,+                    HUnit >= 1.2 && < 1.3,+                    mtl,+                    time,+                    Diff,+                    filepath >= 1.1 && < 1.4,+                    directory >= 1.1 && < 1.2,+                    filestore 

@@ -0,0 +1,395 @@+#!/usr/bin/env runghc++This program runs tests for the filestore modules.++> import Data.FileStore+> import Data.List (sort, isInfixOf)+> import Test.HUnit+> import System.Directory (doesFileExist, removeDirectoryRecursive)+> import Control.Monad (forM)+> import Prelude hiding (catch)+> import Control.Exception (catch)+> import Data.Time+> import Data.Maybe (mapMaybe)+> import System.FilePath+> import Data.Algorithm.Diff (DI(..))++> 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"+++> testFileStore :: FileStore -> String -> IO Counts +> testFileStore fs fsName = do+>   putStrLn   "**********************************"+>   putStrLn $ "Testing " ++ fsName+>   putStrLn   "**********************************"+>   runTestTT $ TestList $ map (\(label, testFn) -> TestLabel label $ testFn fs) +>     [ ("pre initialize", preInitializeTest)+>     , ("initialize", initializeTest)+>     , ("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)+>     , ("retrieve resource", retrieveTest1)+>     , ("retrieve resource in a subdirectory", retrieveTest2)+>     , ("retrieve resource with non-ascii name", retrieveTest3)+>     , ("retrieve subdirectory (should raise error)", retrieveTest4)+>     , ("modify resource", modifyTest)+>     , ("delete resource", deleteTest fsName)+>     , ("retrieve deleted file", retrieveTest5)+>     , ("rename resource", renameTest)+>     , ("test for matching IDs", matchTest)+>     , ("history and revision", historyTest)+>     , ("diff", diffTest)+>     , ("search", searchTest)+>     ]++> testAuthor :: Author+> testAuthor = Author "Test Suite" "suite@test.org"++> testContents :: String+> testContents = "Test contents.\nSecond line.\nThird test line with some Greek αβ."++> testTitle :: String+> testTitle = "New resource.txt"++> subdirTestTitle :: String+> subdirTestTitle = "subdir/Subdir title.txt"++> nonasciiTestTitle :: String+> nonasciiTestTitle = "αβγ"++> subdirNonasciiTestTitle :: String+> subdirNonasciiTestTitle = "Fooé/bar"++*** index and directory for noexisting repository should raise error:++> preInitializeTest fs = TestCase $ do+>   catch (do index fs; assertFailure "preInitialize, uncaught error") $ +>                \e -> assertEqual "error status from attempt to get index of nonexistent repo" e NotFound+>   catch (do directory fs "foo"; assertFailure "preInitialize, uncaught error") $ +>                \e -> assertEqual "error status from attempt to get directory of nonexistent repo" e NotFound++*** Initialize a repository, check for empty index, and then try to initialize again+*** in the same directory (should raise an error):++> initializeTest fs = TestCase $ do+>   initialize fs+>   ind <- index fs+>   assertEqual "index of just-initialized repository" ind []+>   catch (initialize fs >> assertFailure "did not return error for existing repository") $+>     \e -> assertEqual "error status from existing repository" e RepositoryExists++*** Create a resource, and check to see that latest returns a revision ID for it:++> createTest1 fs = TestCase $ do+>   create fs testTitle testAuthor "description of change" testContents+>   revid <- latest fs testTitle+>   assertBool "revision returns a revision after create" (not (null revid))++*** Create a resource in a subdirectory, and check to see that revision returns a revision for it:++> createTest2 fs = TestCase $ do+>   create fs subdirTestTitle testAuthor "description of change" testContents+>   revid <- latest fs testTitle+>   assertBool "revision returns a revision after create" (not (null revid))+>   create fs (subdirTestTitle ++ "2") testAuthor "+Second file" testContents++*** Create a resource with a non-ascii title, and check to see that revision returns a revision for it:++> createTest3 fs = TestCase $ do+>   create fs nonasciiTestTitle testAuthor "description of change" testContents+>   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+>   catch (create fs "../oops" testAuthor "description of change" testContents >>+>          assertFailure "did not return error from create ../oops") $+>          \e -> assertEqual "error from create ../oops" IllegalResourceName e +>   exists <- doesFileExist "tmp/oops"+>   assertBool "file ../oops was created outside repository" (not exists)++*** Try to create a resource in special directory (should fail with an error and NOT write the file):++> 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")+>                             "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 +>   exists <- doesFileExist realpath+>   assertBool ("file " ++ realpath ++ " was created outside repository") (not exists)++*** Test directory++> directoryTest fs = TestCase $ do++    Get directory for top-level++>   files <- directory fs ""+>   assertEqual "result of directory on top-level" (sort [FSDirectory (takeDirectory subdirTestTitle), FSFile testTitle, FSFile nonasciiTestTitle, FSDirectory (takeDirectory subdirNonasciiTestTitle)]) (sort files)++    Get contents of subdirectory++>   subdirFiles <- directory fs "subdir"+>   assertEqual "result of directory on subdir" [FSFile (takeFileName subdirTestTitle), FSFile (takeFileName (subdirTestTitle ++ "2"))] subdirFiles++    Try to get contents of nonexistent subdirectory++>   catch (do directory fs "foo"; assertFailure "nonexistent subdirectory, uncaught error") $ +>                \e -> assertEqual "error status from attempt to get directory listing of nonexistent directory" e NotFound++*** Retrieve latest version of a resource:++> retrieveTest1 fs = TestCase $+>   retrieve fs testTitle Nothing >>=+>     assertEqual "contents returned by retrieve" testContents++*** Retrieve latest version of a resource (in a subdirectory):++> retrieveTest2 fs = TestCase $+>   retrieve fs subdirTestTitle Nothing >>=+>     assertEqual "contents returned by retrieve" testContents++*** Retrieve latest version of a resource with a nonascii name:++> retrieveTest3 fs = TestCase $+>   retrieve fs nonasciiTestTitle Nothing >>=+>     assertEqual "contents returned by retrieve" testContents++*** Retrieve a directory (should fail):++> retrieveTest4 fs = TestCase $+>   catch ((retrieve fs "subdir" Nothing :: IO String) >>+>          assertFailure "did not return error from retrieve from subdir") $+>      \e -> assertEqual "error from retrieve from subdir" NotFound e++*** Modify a resource:++> modifyTest fs = TestCase $ do++    Modify a resource.  Should return Right ().++>   revid <- latest fs testTitle+>   let modifiedContents = unlines $ take 2 $ lines testContents+>   modResult <- modify fs testTitle revid testAuthor "removed third line" modifiedContents+>   assertEqual "results of modify" (Right ()) modResult++    Now retrieve the contents and make sure they were changed.++>   modifiedContents' <- retrieve fs testTitle Nothing+>   newRevId <- latest fs testTitle+>   newRev <- revision fs newRevId+>   assertEqual "retrieved contents after modify" modifiedContents' modifiedContents++    Now try to modify again, using the old revision as base.  This should result in a merge with conflicts.++>   modResult2 <- modify fs testTitle revid testAuthor "modified from old version" (testContents ++ "\nFourth line")+>   let normModResult2 = Left MergeInfo {mergeRevision = newRev, mergeConflicts = True, mergeText =+>                         "Test contents.\nSecond line.\n<<<<<<< edited\nThird test line with some Greek \945\946.\nFourth line\n=======\n>>>>>>> " +++>                         newRevId ++ "\n"}+>   assertEqual "results of modify from old version" normModResult2 modResult2++    Now try it again, still using the old version as base, but with contents of the new version.+    This should result in a merge without conflicts.++>   modResult3 <- modify fs testTitle revid testAuthor "modified from old version" modifiedContents+>   let normModResult3 = Left MergeInfo {mergeRevision = newRev, mergeConflicts = False, mergeText = modifiedContents}+>   assertEqual "results of modify from old version with new version's contents" normModResult3 modResult3++    Now try modifying again, this time using the new version as base. Should succeed with Right ().++>   modResult4 <- modify fs testTitle newRevId testAuthor "modified from new version" (modifiedContents ++ "\nThird line")+>   assertEqual "results of modify from new version" (Right ()) modResult4 ++*** Delete a resource:++> deleteTest fsName fs = TestCase $ do++    Create a file and verify that it's there.++>   let toBeDeleted = "Aaack!"+>   create fs toBeDeleted testAuthor "description of change" testContents+>   ind <- index fs+>   assertBool "index contains resource to be deleted" (toBeDeleted `elem` ind) ++    Now delete it and verify that it's gone.++>   delete fs toBeDeleted testAuthor "goodbye"+>   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")+>                             "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 ++*** Retrieve earlier version of deleted file:++> retrieveTest5 fs = TestCase $ do+>   hist <- history fs ["Aaack!"] (TimeRange Nothing Nothing) Nothing+>   assertBool "history is nonempty" (not (null hist))+>   let deletedId = revId $ last hist+>   contents <- retrieve fs "Aaack!" (Just deletedId) :: IO String+>   assertEqual "contents returned by retrieve" testContents contents++*** Rename a resource:++> renameTest fs = TestCase $ do++    Create a file and verify that it's there.++>   let oldName = "Old Name"+>   let newName = "newdir/New Name.txt"+>   create fs oldName testAuthor "description of change" testContents+>   ind <- index fs+>   assertBool "index contains old name" (oldName `elem` ind) +>   assertBool "index does not contain new name" (newName `notElem` ind)++    Now rename it and verify that it changed names.++>   rename fs oldName newName testAuthor "rename"+>   ind <- index fs+>   assertBool "index does not contain old name" (oldName `notElem` ind) +>   assertBool "index contains new name" (newName `elem` ind)++    Try renaming a file that doesn't exist.++>   catch (rename fs "nonexistent file" "other name" testAuthor "rename" >>+>       assertFailure "rename of nonexistent file did not throw error") $+>       \e -> assertEqual "error status from rename of nonexistent file" NotFound e++    Try to rename a file to a location we shouldn't be able to write in.++>   let badName = "../eek"+>   let cmd = "rename " ++ newName ++ " " ++ badName+>   catch (rename fs newName badName testAuthor "description of change" >>+>          (assertFailure  $ "did not return error from " ++ cmd)) $+>          \e -> assertEqual ("error from " ++ cmd) IllegalResourceName e +++*** Test history and revision++> historyTest fs = TestCase $ do++    Get history for three files++>   hist <- history fs [testTitle, subdirTestTitle, nonasciiTestTitle] (TimeRange Nothing Nothing) Nothing+>   assertBool "history is nonempty" (not (null hist))+>   now <- getCurrentTime+>   rev <- latest fs testTitle >>= revision fs  -- get latest revision+>   assertBool "history contains latest revision" (rev `elem` hist)+>   assertEqual "revAuthor" testAuthor (revAuthor rev)+>   assertBool "revId non-null" (not (null (revId rev)))+>   assertBool "revDescription non-null" (not (null (revDescription rev)))+>   assertEqual "revChanges" [Modified testTitle] (revChanges rev)+>   let revtime = revDateTime rev+>   histNow <- history fs [testTitle] (TimeRange (Just $ addUTCTime (60 * 60 * 24) now) Nothing) Nothing+>   assertBool "history from now + 1 day onwards is empty" (null histNow)+>   histOne <- history fs [testTitle] (TimeRange Nothing Nothing) (Just 1)+>   assertBool "history with limit = 1 contains one item" (length histOne == 1)++*** Test diff++> diffTest fs = TestCase $ do++  Create a file and modiy it.++>   let diffTitle = "difftest.txt"+>   create fs diffTitle testAuthor "description of change" testContents+>   save fs diffTitle testAuthor "removed a line" (unlines . init . lines $ testContents)++>   [secondrev, firstrev] <- history fs [diffTitle] (TimeRange Nothing Nothing) Nothing+>   diff' <- diff fs diffTitle (Just $ revId firstrev) (Just $ revId secondrev)+>   let subtracted' = mapMaybe (\(d,s) -> if d == F then Just s else Nothing) diff'+>   assertEqual "subtracted lines" [[last (lines testContents)]] subtracted'++    Diff from Nothing should be diff from empty document.++>   diff'' <- diff fs diffTitle Nothing (Just $ revId firstrev)+>   let added'' = mapMaybe (\(d,s) -> if d == S then Just s else Nothing) diff''+>   assertEqual "added lines from empty document to first revision" [lines testContents] added''++    Diff to Nothing should be diff to latest.++>   diff''' <- diff fs diffTitle (Just $ revId firstrev) Nothing+>   assertEqual "diff from first revision to latest" diff' diff'''++*** Test search++> searchTest fs = TestCase $ do++    Search for "bing"++>   create fs "foo" testAuthor "my 1st search test doc" "bing\nbong\nbang\nφ"+>   create fs "bar" testAuthor "my 2nd search test doc" "bing BONG" +>   create fs "baz" testAuthor "my 3nd search test doc" "bingbang\nbong"++    Search for "bing" with whole-word matches.++>   res1 <- search fs SearchQuery{queryPatterns = ["bing"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = True}+>   assertEqual "search results 1" [SearchMatch "bar" 1 "bing BONG", SearchMatch "foo" 1 "bing"] res1++    Search for regex "BONG" case-sensitive.++>   res2 <- search fs SearchQuery{queryPatterns = ["BONG"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = False}+>   assertEqual "search results 2" [SearchMatch "bar" 1 "bing BONG"] res2++    Search for "bong" and "φ"++>   res3 <- search fs SearchQuery{queryPatterns = ["bong", "φ"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = True}+>   assertEqual "search results 3" [SearchMatch "foo" 2 "bong", SearchMatch "foo" 4 "φ"] res3++    Search for "bong" and "φ" but without match-all set++>   res4 <- search fs SearchQuery{queryPatterns = ["bong", "φ"], queryWholeWords = True, queryMatchAll = False, queryIgnoreCase = True}+>   assertEqual "search results 4" [SearchMatch "bar" 1 "bing BONG", SearchMatch "baz" 2 "bong", SearchMatch "foo" 2 "bong", SearchMatch "foo" 4 "φ"] res4++    Search for "bing" but without whole-words set++>   res5 <- search fs SearchQuery{queryPatterns = ["bing"], queryWholeWords = False, queryMatchAll = True, queryIgnoreCase = True}+>   assertEqual "search results 5" [SearchMatch "bar" 1 "bing BONG", SearchMatch "baz" 1 "bingbang", SearchMatch "foo" 1 "bing"] res5++*** Test IDs match++> matchTest fs = TestCase $ do++>   assertBool "match with two identical IDs" (idsMatch fs "abcde" "abcde")+>   assertBool "match with nonidentical but matching IDs" (idsMatch fs "abcde" "abcde5553")+>   assertBool "non-match" (not (idsMatch fs "abcde" "abedc"))+