filestore 0.2 → 0.6.5.1
raw patch · 16 files changed
Files
- CHANGES +279/−0
- Data/FileStore.hs +2/−0
- Data/FileStore/Compat/Locale.hs +9/−0
- Data/FileStore/Darcs.hs +112/−174
- Data/FileStore/DarcsXml.hs +75/−0
- Data/FileStore/Generic.hs +32/−21
- Data/FileStore/Git.hs +287/−129
- Data/FileStore/Mercurial.hs +275/−0
- Data/FileStore/MercurialCommandServer.hs +248/−0
- Data/FileStore/Types.hs +58/−41
- Data/FileStore/Utils.hs +137/−23
- Setup.lhs +1/−9
- Tests.lhs +0/−298
- extra/post-update +0/−85
- filestore.cabal +68/−16
- tests/Tests.hs +406/−0
CHANGES view
@@ -1,3 +1,280 @@+Version 0.6.5.1 released 23 Aug 2025++* Call `git log --raw` instead of `git whatchanged`, as the latter+ will be removed from git in a future release (Jack Kelly).+* Raise bounds for `filepath` and `time` (Jack Kelly).+* Raise `Diff` upper bound (kokobd).+* Support containers 0.7 (kokobd).+* Fix darcs arguments for file and directory listings (tauli).+* Update GitHub repository URL to use https (Felix Yan).++Version 0.6.5 released 28 Aug 2020++* Removed data files in extra.+* Add git post-update script as a ByteString literal in+ Data.FileStore.Git (Justus Adam). This will facilitate+ making gitit independent of data files.++Version 0.6.4 released 21 Nov 2019++* Data.File.Generic now exports PolyDiff(..) as well as Diff,+ and we require Diff >= 0.4. Fixes jgm/gitit#637.++Version 0.6.3.5 released 16 Nov 2019++* Compatibility with Diff-0.4.0 (Galen Huntington).++Version 0.6.3.4 released 21 Dec 2018++* Document git version requirement (#4).+* Fix test suite failure when git not configured (#16).+* Relax containers version bounds to support 0.6.* (Phil Ruffwind).++Version 0.6.3.3 released 14 May 2018++* Use build-type Simple (hvr).++Version 0.6.3.2 released 10 Apr 2018++* Update version bounds for dependencies.+* Tweaked tests. We no longer run darcs tests; they seem to+ depend too much on the details of the system and the darcs+ version.++Version 0.6.3.1 released 13 Feb 2017++* Bump to 0.6.3.1, raise directory upper bound.+* Fix false-positive on travis.+* Fix bug in 'revision' for git (changes were not obtained).++Version 0.6.3 released 23 Jan 2017++* Handle git rename changes (as a Deleted+Added) (#10, Kevin Quick).++Version 0.6.2 released 13 Jun 2016++* Set committer name and email when committing (#19, Phil Ruffwind).++* Fixes for compatibility with ghc 8 (Sergei Trofimovich).++Version 0.6.1 released 27 July 2015++* Create `.git/hooks` directory if missing on initialize+ (jgm/gitit#505).++* Set git username, email.++* Added preliminary symlink handling (Jeffrey David Johnson).++Version 0.6.0.6 released 2 April 2015++* Added compatibility module Data.FileStore.Compat.Locale+ so that filestore will compile against time 1.5.++Version 0.6.0.5 released 2 April 2015++* Mark post-update as a bash script (not a generic shell script).++* Bump version bounds for dependencies.++Version 0.6.0.4 released 31 Oct 2014++* Fixed test suite so that it returns error status if tests fail (#16).++Version 0.6.0.3 released 26 Jul 2014++* Disable the broken mercurial command server on Windows, falling back+ on direct running of each command (Alan Brooks).++* Added a script demonstrating use of filestore to query darcs repositories+ (gwern).++Version 0.6.0.2 released 08 Apr 2014++* Bumped version for process so it will compile with GHC 7.8.1.++Version 0.6.0.1 released 20 Mar 2013++* runProcess now allows access to the current environment, instead of+ running in a bare environment. This fixes problems for those who have+ git in a nonstandard path. (Jochen Keil)++* Allow latest Diff.++* Reconfigured cabal file to use new Cabal test framework. Run tests with+ `cabal configure --enable-tests && cabal build && cabal test`.++* Set environment variable HGENCODING for mercurial. Closes #6.++Version 0.6 released 31 Dec 2012++* Updated to use Diff 0.2. This involves an API change:+ diff now returns [Diff [String]] rather than [(DI, String)].+ Thanks to markwright for the patch.++* Test revDescription more thoroughly (Ben Millwood).++* Fixed error handling in withVerifyDir.++Version 0.5.0.1 released 21 Oct 2012++* Bumped version limits on dependencies.++* Upgraded Utils to use Control.Exception.++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.+ The new version caused lazy-IO related problems with large+ files. Thanks to Pavel Perikov diagnosing the problem.++Version 0.3.4.2 released 03 Aug 2010++* gitInit: Set up repository to allow push to the current+ branch. This is needed for recent versions of git,+ which don't allow a push to the master branch. Resolves+ Issue #104.++* New version of runShellCommand that does not require+ temp files, using runInteractiveProcess.++* Suppress "unused do bind" warnings in build.++Version 0.3.4.1 released 22 Jan 2010++* Rewrote splitEmailAuthor with list fns not regexes.+ Also removed regex-posix from cabal build-depends.++* Corrected error message for richDirectory++* Improved git search:+ + Previously git search would fail in some cases, with an error+ in parseMatchLine (for example, with unicode search term).+ + We replaced the regex with a simpler match-line parser using+ Preface functions.+ + We also now use --null to force a NUL separator in git grep.+ + The test case that previously failed now passes.++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+ delete a file inside .git or _darcs subdirectory.++* Have gitSearch return no matches, instead of raising an error,+ if error status = 1. Recent versions of git-grep return 1 if+ no matches found.++* Fix git log parsing so that it allows log comments to start with ':'+ Thanks to thorben for uncovering the bug.++Version 0.3.3 released 06 Nov 2009++* isInsideDir is again exported.++Version 0.3.2.2 released 06 Nov 2009++* Raise an IllegalResourceName error if the user tries to create+ a file inside the .git or _darcs subdirectory. Previously the+ file would be written (or overwritten) before the error was caught+ in the add/commit phase. This introduced the risk of corrupting+ the repository or, worse, overwriting hooks.++* isInsideDir is no longer exported.++* checkAndWriteFile has been replaced with withSanityCheck, to avoid+ code duplication between create and rename functions.++Version 0.3.2.1 released 24 Oct 2009++* Convert pathname to UTF8 in withVerifyDir.++Version 0.3.2 released 22 Aug 2009++* Made maxcount default to True, as '--max-count' is supported by+ the latest released version of darcs (2.3.0). Print an informative+ error message if the version of darcs being used does not support+ --max-count.++* Made 'initialize' throw RepoExists error only if the repo+ exists; catch permission or other errors separately. (Thomas Hartmann)++* Made 'index' throw an error if the directory is not present or+ there are insufficient permissions. (Thomas Hartmann)++* Improved error message for search match helper.++Version 0.3.1 released 04 Jul 2009++* Added -I flag to grep in regSearchFiles. Ignore binary files+ in the repository when searching.++* Added maxcount Cabal flag, defaulting to False. When true,+ this flag causes 'latest' to run 'darcs changes' with the+ flag '--max-count=1', which dramatically increases performance.+ (Without this, filestore has to retrieve the entire changelog+ just to get the latest revision ID.) '--max-count' is at this+ point only in development versions of darcs.++* Removed quoting from --match=hash in Darcs module (since it doesn't+ go through /bin/sh). Thanks to Ganesh Sittampalam.++* Efficiency improvements and refactoring in Darcs module.++* Moved darcs utility functions to Util module.++Version 0.3 released 08 Apr 2009++* Added new 'directory' function, which returns a list of resources given+ a directory name. Resources are marked as either FSFile or+ FSDirectory. Thanks to Thomas Hartman for showing the need for+ 'directory', and for distinguishing explicitly between files and+ directories. In 'index' the distinction was previously left implicit,+ which worked for git but not darcs: 'index' provided no way of+ distinguishing an empty directory from a file.++* In 'directory' and 'index', git ls-tree is used instead of git ls-files;+ this guarantees that only files that have been committed are returned.+ 'index' now lists only files, and no longer includes empty directories+ even in darcs.++* Added new richDirectory function to Data.FileStore.Generic.+ richDirectory returns a directory that includes information+ about the latest revision of each file. Thanks to Thomas Hartman for+ the patch.++* Replaced ResourceName type with FilePath.++* Added repository information to cabal file.+ Version 0.2 released 08 Feb 2009 * Changed diff to do a line-by-line rather than word-by-word diff.@@ -27,6 +304,8 @@ and for creating a second file in a subdirectory. * Minor code cleanup.++* Added CHANGES. Version 0.1 released 24 Jan 2009
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/Compat/Locale.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}+module Data.FileStore.Compat.Locale ( defaultTimeLocale )+ where++#if MIN_VERSION_time(1,5,0)+import Data.Time.Format ( defaultTimeLocale )+#else+import System.Locale ( defaultTimeLocale )+#endif
Data/FileStore/Darcs.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {- | Module : Data.FileStore.Darcs Copyright : Copyright (C) 2009 Gwern Branwen@@ -9,29 +10,29 @@ A versioned filestore implemented using darcs. Normally this module should not be imported: import- "Data.FileStore" instead.--}+ "Data.FileStore" instead. -} module Data.FileStore.Darcs ( darcsFileStore ) where -import Codec.Binary.UTF8.String (encodeString) import Control.Exception (throwIO)-import Control.Monad (liftM, unless, when)-import Data.ByteString.Lazy.UTF8 (toString)-import Data.Char (isSpace)-import Data.DateTime (parseDateTime, toSqlString)+import Control.Monad (when)+import Data.Time (formatTime)+import Data.FileStore.Compat.Locale (defaultTimeLocale)+import Data.List (sort, isPrefixOf)+#ifdef USE_MAXCOUNT+import Data.List (isInfixOf)+#endif+import System.Exit (ExitCode(..))+import System.Directory (doesDirectoryExist, createDirectoryIfMissing)+import System.FilePath ((</>), dropFileName, addTrailingPathSeparator)++import Data.FileStore.DarcsXml (parseDarcsXML) import Data.FileStore.Types-import Data.FileStore.Utils (hashsMatch, isInsideRepo, parseMatchLine, runShellCommand, escapeRegexSpecialChars)-import Data.List (intersect, nub)-import Data.Maybe (fromMaybe, fromJust)-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import System.Directory (doesFileExist, doesDirectoryExist, createDirectoryIfMissing)-import System.Exit (ExitCode(ExitSuccess))-import System.FilePath ((</>), takeDirectory, dropFileName)-import Text.Regex.Posix ((=~))-import Text.XML.Light-import qualified Data.ByteString.Lazy as B (ByteString, writeFile)+import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, ensureFileExists, grepSearchRepo, withVerifyDir, encodeArg) +import Data.ByteString.Lazy.UTF8 (toString)+import qualified Data.ByteString.Lazy as B (ByteString, writeFile, null)+ -- | Return a filestore implemented using the Darcs distributed revision control system -- (<http://darcs.net/>). darcsFileStore :: FilePath -> FileStore@@ -45,9 +46,10 @@ , latest = darcsLatestRevId repo , revision = darcsGetRevision repo , index = darcsIndex repo+ , directory = darcsDirectory repo , search = darcsSearch repo , idsMatch = const hashsMatch repo }- + -- | Run a darcs command and return error status, error output, standard output. The repository -- is used as working directory. runDarcsCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)@@ -55,94 +57,6 @@ (status, err, out) <- runShellCommand repo Nothing "darcs" (command : args) return (status, toString err, out) -parseDarcsXML :: String -> Maybe [Revision]-parseDarcsXML str = do changelog <- parseXMLDoc str- let patches = filterChildrenName (\(QName n _ _) -> n == "patch") changelog- return $ map parseIntoRevision patches--parseIntoRevision :: Element -> Revision-parseIntoRevision a = Revision { revId = hashXML a,- revDateTime = date a,- revAuthor = Author { authorName=authorXML a, authorEmail=emailXML a },- revDescription = descriptionXML a,- revChanges = changesXML a }- where- -- If we can't get a date from the XML, we default to the beginning of the POSIX era.- -- This at least makes it easy for someone to filter out bad dates, as obviously no real DVCSs- -- were in operation then. :)- -- date :: Element -> UTCTime- date = fromMaybe (posixSecondsToUTCTime $ realToFrac (0::Int)) . parseDateTime "%c" . dateXML--authorXML, dateXML, descriptionXML, emailXML, hashXML :: Element -> String-authorXML = snd . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)-emailXML = fromMaybe"" . fst . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)-dateXML = fromMaybe "" . findAttr (QName "local_date" Nothing Nothing)-hashXML = fromMaybe "" . findAttr (QName "hash" Nothing Nothing)-descriptionXML = fromMaybe "" . liftM strContent . findChild (QName "name" Nothing Nothing)--changesXML :: Element -> [Change]-changesXML = analyze . filterSummary . changes---- | Our policy is: if the input is clearly a "name \<e\@mail.com\>" input, then we return "(Just Address, Name)"--- If there is no '<' in the input, then it clearly can't be of that format, and so we just return "(Nothing, Name)"------ > splitEmailAuthor "foo bar baz@gmail.com" ~> (Nothing,"foo bar baz@gmail.com")--- > splitEmailAuthor "foo bar <baz@gmail.com>" ~> (Just "baz@gmail.com","foo bar")-splitEmailAuthor :: String -> (Maybe String, String)-splitEmailAuthor x = if '<' `elem` x then (Just (tail $ init c), reverse . dropWhile isSpace $ reverse b)- else (Nothing,x)- -- Will still need to trim the '<>' brackets in the email, and whitespace at the end of name- where (_,b,c) = x =~ "[^<]*" :: (String,String,String)--changes :: Element -> Element-changes = fromJust . findElement (QName "summary" Nothing Nothing)--analyze :: [Element] -> [Change]-analyze s = map convert s- where convert a- | x == "add_directory" || x == "add_file" = Added b- | x == "remove_file" || x == "remove_directory" = Deleted b- | x == "added_lines"- || x == "modify_file"- || x == "removed_lines"- || x == "replaced_tokens" = Modified b- | otherwise = error "Unknown change type"- where x = qName . elName $ a- b = takeWhile (/='\n') $ dropWhile isSpace $ strContent a--filterSummary :: Element -> [Element]-filterSummary = filterElementsName (\(QName {qName = x}) -> x == "add_file"- || x == "add_directory"- || x == "remove_file"- || x == "remove_directory"- || x == "modify_file"- || x == "added_lines"- || x == "removed_lines"- || x == "replaced_tokens")---- Following are for 'darcsSearch'---- | Search multiple files with a single regexp-go :: FilePath -> [String] -> String -> IO [String]-go repo filesToCheck pattern = do (_, _, result) <- runShellCommand repo- Nothing "grep" $ ["--line-number", "-l", "-E", "-e", pattern] ++ filesToCheck- let results = intersect filesToCheck $ lines $ toString result- return results---- | Search a single file with multiple regexps-go' :: [String] -> FilePath -> [String] -> String -> IO [String]-go' os repo patterns file = do res <- mapM (\x -> run file x) patterns- return $ nub $ concat res- where run f p = do (_,_,r) <- runShellCommand repo Nothing "grep" $- os ++ [p, f]- return $ lines $ toString r---- | If name doesn't exist in repo or is not a file, throw NotFound-ensureFileExists :: FilePath -> ResourceName -> IO ()-ensureFileExists repo name = do- isFile <- doesFileExist (repo </> encodeString name)- when (not isFile) $ throwIO NotFound- --------------------------- -- End utility functions and types -- Begin repository creation & modification@@ -152,7 +66,7 @@ darcsInit :: FilePath -> IO () darcsInit repo = do exists <- doesDirectoryExist repo- when exists $ throwIO RepositoryExists+ when exists $ withVerifyDir repo $ throwIO RepositoryExists createDirectoryIfMissing True repo (status, err, _) <- runDarcsCommand repo "init" [] if status == ExitSuccess@@ -160,13 +74,9 @@ else throwIO $ UnknownError $ "darcs init failed:\n" ++ err -- | Save changes (creating the file and directory if needed), add, and commit.-darcsSave :: Contents a => FilePath -> ResourceName -> Author -> Description -> a -> IO ()+darcsSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO () darcsSave repo name author logMsg contents = do- let filename = repo </> encodeString name- inside <- isInsideRepo repo filename- unless inside $ throwIO IllegalResourceName- createDirectoryIfMissing True $ takeDirectory filename- B.writeFile filename $ toByteString contents+ withSanityCheck repo ["_darcs"] name $ B.writeFile (repo </> encodeArg name) $ toByteString contents -- Just in case it hasn't been added yet; we ignore failures since darcs will -- fail if the file doesn't exist *and* if the file exists but has been added already. runDarcsCommand repo "add" [name]@@ -174,7 +84,7 @@ -- | Commit changes to a resource. Raise 'Unchanged' exception if there were none. -- This is not for creating a new file; see 'darcsSave'. This is just for updating.-darcsCommit :: FilePath -> [ResourceName] -> Author -> Description -> IO ()+darcsCommit :: FilePath -> [FilePath] -> Author -> Description -> IO () darcsCommit repo names author logMsg = do let args = ["--all", "-A", (authorName author ++ " <" ++ authorEmail author ++ ">"), "-m", logMsg] ++ names (statusCommit, errCommit, _) <- runDarcsCommand repo "record" args@@ -185,22 +95,18 @@ else UnknownError $ "Could not darcs record " ++ unwords names ++ "\n" ++ errCommit -- | Change the name of a resource.-darcsMove :: FilePath -> ResourceName -> ResourceName -> Author -> Description -> IO ()+darcsMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO () darcsMove repo oldName newName author logMsg = do- let newPath = repo </> newName- inside <- isInsideRepo repo newPath- unless inside $ throwIO IllegalResourceName- -- create destination directory if missing- createDirectoryIfMissing True $ takeDirectory newPath- (statusAdd,_,_) <- runDarcsCommand repo "add" [dropFileName newName]- (statusAdd',_,_) <- runDarcsCommand repo "mv" [oldName, newName]- if statusAdd == ExitSuccess && statusAdd' == ExitSuccess- then darcsCommit repo [oldName, newName] author logMsg- else throwIO NotFound+ withSanityCheck repo ["_darcs"] newName $ do+ (statusAdd, _, _) <- runDarcsCommand repo "add" [dropFileName newName]+ (statusAdd', _,_) <- runDarcsCommand repo "mv" [oldName, newName]+ if statusAdd == ExitSuccess && statusAdd' == ExitSuccess+ then darcsCommit repo [oldName, newName] author logMsg+ else throwIO NotFound -- | Delete a resource from the repository.-darcsDelete :: FilePath -> ResourceName -> Author -> Description -> IO ()-darcsDelete repo name author logMsg = do+darcsDelete :: FilePath -> FilePath -> Author -> Description -> IO ()+darcsDelete repo name author logMsg = withSanityCheck repo ["_darcs"] name $ do runShellCommand repo Nothing "rm" [name] darcsCommit repo [name] author logMsg @@ -211,17 +117,31 @@ -- | 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 -> [ResourceName] -> TimeRange -> IO [Revision]-darcsLog repo names (TimeRange begin end) = do- let opts = timeOpts begin end- do (status, err, output) <- runDarcsCommand repo "changes" $ ["--xml-output", "--summary"] ++ names ++ opts+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- timeOpts :: Maybe DateTime -> Maybe DateTime ->[String]+ 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) -> [] (Just b', Just e') -> from b' ++ to e'@@ -230,67 +150,85 @@ where from z = ["--match=date \"after " ++ undate z ++ "\""] to z = ["--to-match=date \"before " ++ undate z ++ "\""] undate = toSqlString+ toSqlString = formatTime defaultTimeLocale "%FT%X" -- | Get revision information for a particular revision ID, or latest revision. darcsGetRevision :: FilePath -> RevisionId -> IO Revision-darcsGetRevision repo hash = do hists <- darcsLog repo [] (TimeRange Nothing Nothing)- let hist = filter (\x -> hashsMatch (revId x) hash) hists- let result = if null hist then hists else hist- return $ head result+darcsGetRevision repo hash = do (_,_,output) <- runDarcsCommand repo "changes"+ ["--xml-output", "--summary", "--match=hash " ++ hash]+ let hists = parseDarcsXML $ toString output+ case hists of+ Nothing -> throwIO NotFound+ Just a -> return $ head a -- | Return revision ID for latest commit for a resource.-darcsLatestRevId :: FilePath -> ResourceName -> IO RevisionId+darcsLatestRevId :: FilePath -> FilePath -> IO RevisionId darcsLatestRevId repo name = do ensureFileExists repo name- -- changes always succeeds, so no need to check error- (_, _, output) <- runDarcsCommand repo "changes" ["--xml-output", "--summary", name]+#ifdef USE_MAXCOUNT+ (status, err, output) <- runDarcsCommand repo "changes" ["--xml-output", "--max-count=1", name]+ when (status /= ExitSuccess && "unrecognized option" `isInfixOf` err) $ throwIO NoMaxCount+#else+ (_, _, output) <- runDarcsCommand repo "changes" ["--xml-output", name]+#endif let patchs = parseDarcsXML $ toString output case patchs of Nothing -> throwIO NotFound- Just as -> if null as then throwIO NotFound else return $ revId $ head as+ Just [] -> throwIO NotFound+ Just (x:_) -> return $ revId x -- | Retrieve the contents of a resource. darcsRetrieve :: Contents a => FilePath- -> ResourceName+ -> FilePath -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest -> IO a-darcsRetrieve repo name Nothing =- darcsLatestRevId repo name >>= darcsRetrieve repo name . Just-darcsRetrieve repo name (Just revid) = do- ensureFileExists repo name- let opts = ["contents", "--match=hash " ++ revid, name]- (status, err, output) <- runDarcsCommand repo "query" opts+darcsRetrieve repo name mbId = do+ let opts = case mbId of+ Nothing -> ["contents", name]+ Just revid -> ["contents", "--match=hash " ++ revid, name]+ (status, err, output) <- runDarcsCommand repo "show" opts+ if B.null output+ then do+ (_, _, out) <- runDarcsCommand repo "show" (["files", "--no-directories"] ++ opts)+ if B.null out || null (filter (== name) . getNames $ output)+ then throwIO NotFound+ else return ()+ else return () if status == ExitSuccess then return $ fromByteString output else throwIO $ UnknownError $ "Error in darcs query contents:\n" ++ err+ +getNames :: B.ByteString -> [String]+getNames = map (drop 2) . lines . toString -- | Get a list of all known files inside and managed by a repository.-darcsIndex :: FilePath ->IO [ResourceName]-darcsIndex repo = do- (status, errOutput, output) <- runDarcsCommand repo "query" ["manifest"]- if status == ExitSuccess- -- We need to do 'drop 2' because Darcs returns files like ["./foobar"], and- -- the ./ is always present & always not wanted.- then return (map (drop 2) . lines . toString $ output)- else error $ "'darcs query manifest' returned error status.\n" ++ errOutput+darcsIndex :: FilePath ->IO [FilePath]+darcsIndex repo = withVerifyDir repo $ do+ (status, _errOutput, output) <- runDarcsCommand repo "show" ["files","--no-directories"]+ if status == ExitSuccess+ then return . getNames $ output+ else return [] -- return empty list if invalid path (see gitIndex) --- | Uses grep to search repository.-darcsSearch :: FilePath -> SearchQuery -> IO [SearchMatch]-darcsSearch repo query = do- let opts = ["--line-number", "--with-filename"] ++- (if queryIgnoreCase query then ["-i"] else []) ++- (if queryWholeWords query then ["--word-regexp"] else ["-E"])- let regexps = map escapeRegexSpecialChars $ queryPatterns query- files <- darcsIndex repo- if queryMatchAll query then do- filesMatchingAllPatterns <- liftM (foldr1 intersect) $ mapM (go repo files) regexps- output <- mapM (go' opts repo regexps) filesMatchingAllPatterns- return $ map parseMatchLine $ concat output- else do (_status, _errOutput, output) <-- runShellCommand repo Nothing "grep" $ opts ++- concatMap (\term -> ["-e", term]) regexps ++- files- let results = lines $ toString output- return $ map parseMatchLine results+-- | Get a list of all resources inside a directory in the repository.+darcsDirectory :: FilePath -> FilePath -> IO [Resource]+darcsDirectory repo dir = withVerifyDir (repo </> dir) $ do+ let dir' = if null dir then "" else addTrailingPathSeparator dir+ (status1, _errOutput1, output1) <- runDarcsCommand repo "show" ["files","--no-directories"]+ (status2, _errOutput2, output2) <- runDarcsCommand repo "show" ["files","--no-files"]+ if status1 == ExitSuccess && status2 == ExitSuccess+ then do+ let files = adhocParsing dir' . lines . toString $ output1+ -- We need to do 'drop $ length dir' + 3' because Darcs returns files like ["./foo/foobar"].+ let dirs = adhocParsing dir' . drop 1 . lines . toString $ output2+ -- We need the drop 1 to eliminate the root directory, which appears first.+ -- Now, select the ones that are in THIS directory and convert to Resources:+ let files' = map FSFile $ filter ('/' `notElem`) files+ let dirs' = map FSDirectory $ filter ('/' `notElem`) dirs+ return $ sort (files' ++ dirs') + else return [] -- returns empty list for invalid path (see gitDirectory)+ where adhocParsing d = map (drop $ length d + 2) . filter (("." </> d) `isPrefixOf`) +-- Use the generic grep-based search of a repo.+darcsSearch :: FilePath -> SearchQuery -> IO [SearchMatch]+darcsSearch = grepSearchRepo darcsIndex
+ Data/FileStore/DarcsXml.hs view
@@ -0,0 +1,75 @@+module Data.FileStore.DarcsXml (parseDarcsXML) where++import Data.Maybe (catMaybes, fromMaybe)+import Data.Char (isSpace)+import Data.Time.Format (parseTimeM)+import Data.FileStore.Compat.Locale (defaultTimeLocale)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Text.XML.Light++import Data.FileStore.Types (Change(..), Revision(..), Author(..))+import Data.FileStore.Utils (splitEmailAuthor)++-- | Take a String presumed to be a Darcs-generated changelog in XML format;+-- discard all tags, initializations, etc, leaving only actual patches;+-- then convert each patch entry into FileStore's homebrew 'Revision' type.+parseDarcsXML :: String -> Maybe [Revision]+parseDarcsXML str = do changelog <- parseXMLDoc str+ let patches = filterChildrenName (\(QName n _ _) -> n == "patch") changelog+ return $ map parseIntoRevision patches++parseIntoRevision :: Element -> Revision+parseIntoRevision a = Revision { revId = hashXML a,+ revDateTime = date a,+ revAuthor = Author { authorName=authorXML a, authorEmail=emailXML a },+ revDescription = descriptionXML a,+ revChanges = catMaybes $ changesXML a }+ where+ -- If we can't get a date from the XML, we default to the beginning of the POSIX era.+ -- This at least makes it easy for someone to filter out bad dates, as obviously no real DVCSs+ -- were in operation then. :)+ -- date :: Element -> UTCTime+ date = fromMaybe (posixSecondsToUTCTime $ realToFrac (0::Int)) . parseTimeM True defaultTimeLocale "%c" . dateXML++authorXML, dateXML, descriptionXML, emailXML, hashXML :: Element -> String+authorXML = snd . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)+emailXML = fromMaybe "" . fst . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)+dateXML = fromMaybe "" . findAttr (QName "local_date" Nothing Nothing)+hashXML = fromMaybe "" . findAttr (QName "hash" Nothing Nothing)+descriptionXML = fromMaybe "" . fmap strContent . findChild (QName "name" Nothing Nothing)++-- Perhaps there was no '--summary' option used, in which case there is no 'Change' information we+-- can extract.+changesXML :: Element -> [Maybe Change]+changesXML a = case (changes a) of+ Just b -> analyze $ filterSummary b+ Nothing -> []++-- | Extract the file-modification fields+changes :: Element -> Maybe Element+changes = findElement (QName "summary" Nothing Nothing)++analyze :: [Element] -> [Maybe Change]+analyze s = map convert s+ where convert a+ | x == "add_directory" || x == "add_file" = Just (Added b)+ | x == "remove_file" || x == "remove_directory" = Just (Deleted b)+ | x == "added_lines"+ || x == "modify_file"+ || x == "removed_lines"+ || x == "replaced_tokens"+ || x == "move" = Just (Modified b)+ | otherwise = Nothing+ where x = qName . elName $ a+ b = takeWhile (/='\n') $ dropWhile isSpace $ strContent a++filterSummary :: Element -> [Element]+filterSummary = filterElementsName (\(QName {qName = x}) -> x == "add_file"+ || x == "add_directory"+ || x == "remove_file"+ || x == "remove_directory"+ || x == "modify_file"+ || x == "added_lines"+ || x == "removed_lines"+ || x == "replaced_tokens"+ || x == "move")
Data/FileStore/Generic.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables, CPP #-} {- | Module : Data.FileStore.Generic Copyright : Copyright (C) 2009 John MacFarlane, Gwern Branwen, Sebastiaan Visser@@ -13,44 +14,46 @@ module Data.FileStore.Generic ( modify , create- , DI(..)+ , Diff+ , PolyDiff(..) , diff , searchRevisions , smartRetrieve+ , richDirectory ) where import Data.FileStore.Types -import Control.Exception (throwIO, catch, SomeException, try)+import Control.Exception as E import Data.FileStore.Utils import Data.List (isInfixOf)-import Data.Algorithm.Diff (DI(..), getGroupedDiff)-import Prelude hiding (catch)+import Data.Algorithm.Diff (Diff, PolyDiff (..), getGroupedDiff)+import System.FilePath ((</>)) -handleUnknownError :: SomeException -> IO a-handleUnknownError = throwIO . UnknownError . show+handleUnknownError :: E.SomeException -> IO a+handleUnknownError = E.throwIO . UnknownError . show -- | Like save, but first verify that the resource name is new. If not, throws a 'ResourceExists' -- error. create :: Contents a => FileStore- -> ResourceName -- ^ Resource to create.+ -> FilePath -- ^ Resource to create. -> Author -- ^ Author of change. -> Description -- ^ Description of change. -> a -- ^ Contents of resource. -> IO ()-create fs name author logMsg contents = catch (latest fs name >> throwIO ResourceExists)+create fs name author logMsg contents = E.catch (latest fs name >> E.throwIO ResourceExists) (\e -> if e == NotFound then save fs name author logMsg contents- else throwIO e)+ else E.throwIO e) -- | Modify a named resource in the filestore. Like save, except that a revision ID -- must be specified. If the resource has been modified since the specified revision, -- @Left@ merge information is returned. Otherwise, @Right@ the new contents are saved. modify :: Contents a => FileStore- -> ResourceName -- ^ Resource to create.+ -> FilePath -- ^ Resource to create. -> RevisionId -- ^ ID of previous revision that is being modified. -> Author -- ^ Author of change. -> Description -- ^ Description of change.@@ -64,24 +67,24 @@ else do latestContents <- retrieve fs name (Just latestRevId) originalContents <- retrieve fs name (Just originalRevId)- (conflicts, mergedText) <- catch + (conflicts, mergedText) <- E.catch (mergeContents ("edited", toByteString contents) (originalRevId, originalContents) (latestRevId, latestContents)) handleUnknownError return $ Left (MergeInfo latestRev conflicts mergedText) -- | Return a unified diff of two revisions of a named resource.--- Format of the diff is a list @[(DI, [String])]@, where+-- Format of the diff is a list @[(Diff, [String])]@, where -- @DI@ is @F@ (in first document only), @S@ (in second only), -- or @B@ (in both), and the list is a list of lines (without -- newlines at the end). diff :: FileStore- -> ResourceName -- ^ Resource name to get diff for.+ -> FilePath -- ^ Resource name to get diff for. -> Maybe RevisionId -- ^ @Just@ old revision ID, or @Nothing@ for empty. -> Maybe RevisionId -- ^ @Just@ oew revision ID, or @Nothing@ for latest.- -> IO [(DI, [String])]+ -> IO [Diff [String]] diff fs name Nothing id2 = do contents2 <- retrieve fs name id2- return [(S, lines contents2)] -- no need to run getGroupedDiff here - diff vs empty document + return [Second (lines contents2) ] -- no need to run getGroupedDiff here - diff vs empty document diff fs name id1 id2 = do contents1 <- retrieve fs name id1 contents2 <- retrieve fs name id2@@ -93,7 +96,7 @@ -> Bool -- ^ When true the description must -- match exactly, when false partial -- hits are allowed.- -> ResourceName -- ^ The resource to search history for.+ -> FilePath -- ^ The resource to search history for. -> Description -- ^ Revision description to search for. -> IO [Revision] @@ -101,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@@ -112,18 +115,18 @@ :: Contents a => FileStore -> Bool -- ^ @True@ for exact description match, @False@ for partial match.- -> ResourceName -- ^ Resource name to retrieve.+ -> FilePath -- ^ Resource name to retrieve. -> Maybe String -- ^ @Just@ revision ID or description, or @Nothing@ for empty. -> IO a smartRetrieve fs exact name mrev = do- edoc <- try (retrieve fs name mrev)+ edoc <- E.try (retrieve fs name mrev) case (edoc, mrev) of -- Regular retrieval using revision identifier succeeded, use this doc. (Right doc, _) -> return doc -- Retrieval of latest revision failed, nothing we can do about this.- (Left e, Nothing) -> throwIO (e :: FileStoreError)+ (Left e, Nothing) -> E.throwIO (e :: FileStoreError) -- Retrieval failed, we can try fetching a revision by the description. (Left _, Just rev) -> do@@ -131,8 +134,16 @@ if Prelude.null revs -- No revisions containing this description.- then throwIO NotFound+ then E.throwIO NotFound -- Retrieve resource for latest matching revision. else retrieve fs name (Just $ revId $ Prelude.head revs)++-- | Like 'directory', but returns information about the latest revision.+richDirectory :: FileStore -> FilePath -> IO [(Resource, Either String Revision)]+richDirectory fs fp = directory fs fp >>= mapM f+ where f r = E.catch (g r) (\(e :: FileStoreError)-> return ( r, Left . show $ e ) )+ g r@(FSDirectory _dir) = return (r,Left "richDirectory, we don't care about revision info for directories")+ g res@(FSFile file) = do rev <- revision fs =<< latest fs ( fp </> file )+ return (res,Right rev)
Data/FileStore/Git.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DoAndIfThenElse #-}+ {- | Module : Data.FileStore.Git Copyright : Copyright (C) 2009 John MacFarlane@@ -10,6 +13,9 @@ A versioned filestore implemented using git. Normally this module should not be imported: import "Data.FileStore" instead.++ It is assumed that git >= 1.7.2 is available on+ the system path. -} module Data.FileStore.Git@@ -17,30 +23,25 @@ ) where import Data.FileStore.Types+import Data.Maybe (fromMaybe, mapMaybe)+import Data.List.Split (endByOneOf) import System.Exit import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.FileStore.Utils (hashsMatch, isInsideRepo, runShellCommand, escapeRegexSpecialChars) +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 Codec.Binary.UTF8.String (decodeString)-import Data.Char (chr)-import Control.Monad (liftM, when)-import System.FilePath ((</>), takeDirectory)-import System.Directory (doesDirectoryExist, createDirectoryIfMissing)-import Codec.Binary.UTF8.String (encodeString)+import qualified Data.ByteString.Lazy.Char8 as B+import Control.Monad (when)+import System.FilePath ((</>), splitFileName)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, executable, getPermissions, setPermissions) import Control.Exception (throwIO)-import Control.Monad (unless)-import Text.Regex.Posix ((=~))-import System.Directory (getPermissions, setPermissions, executable)-import Paths_filestore+import qualified Control.Exception as E -- | Return a filestore implemented using the git distributed revision control system -- (<http://git-scm.com/>). gitFileStore :: FilePath -> FileStore gitFileStore repo = FileStore { initialize = gitInit repo- , save = gitSave repo + , save = gitSave repo , retrieve = gitRetrieve repo , delete = gitDelete repo , rename = gitMove repo@@ -48,15 +49,21 @@ , latest = gitLatestRevId repo , revision = gitGetRevision repo , index = gitIndex repo- , search = gitSearch repo + , directory = gitDirectory repo+ , search = gitSearch repo , idsMatch = const hashsMatch repo } -- | Run a git command and return error status, error output, standard output. The repository -- is used as working directory. runGitCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)-runGitCommand repo command args = do- let env = Just [("GIT_DIFF_OPTS","-u100000")]+runGitCommand = runGitCommandWithEnv []++-- | Run a git command with the given environment and return error status, error output, standard+-- output. The repository is used as working directory.+runGitCommandWithEnv :: [(String, String)] -> FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)+runGitCommandWithEnv givenEnv repo command args = do+ let env = Just ([("GIT_DIFF_OPTS", "-u100000")] ++ givenEnv) (status, err, out) <- runShellCommand repo env "git" (command : args) return (status, toString err, out) @@ -64,27 +71,33 @@ gitInit :: FilePath -> IO () gitInit repo = do exists <- doesDirectoryExist repo- when exists $ throwIO RepositoryExists+ when exists $ withVerifyDir repo $ throwIO RepositoryExists createDirectoryIfMissing True repo (status, err, _) <- runGitCommand repo "init" [] if status == ExitSuccess then do -- Add the post-update hook, so that changes made remotely via git -- will be reflected in the working directory.- postupdatepath <- getDataFileName $ "extra" </> "post-update"- postupdatecontents <- B.readFile postupdatepath- let postupdate = repo </> ".git" </> "hooks" </> "post-update"- B.writeFile postupdate postupdatecontents+ let postupdatedir = repo </> ".git" </> "hooks"+ createDirectoryIfMissing True postupdatedir+ let postupdate = postupdatedir </> "post-update"+ B.writeFile postupdate postUpdate perms <- getPermissions postupdate setPermissions postupdate (perms {executable = True})- return ()- else throwIO $ UnknownError $ "git-init failed:\n" ++ err + -- Set up repo to allow push to current branch+ (status', err', _) <- runGitCommand repo "config" ["receive.denyCurrentBranch","ignore"]+ if status' == ExitSuccess+ then return ()+ else throwIO $ UnknownError $ "git config failed:\n" ++ err'+ else throwIO $ UnknownError $ "git-init failed:\n" ++ err -- | Commit changes to a resource. Raise 'Unchanged' exception if there were -- no changes.-gitCommit :: FilePath -> [ResourceName] -> Author -> String -> IO ()+gitCommit :: FilePath -> [FilePath] -> Author -> String -> IO () gitCommit repo names author logMsg = do- (statusCommit, errCommit, _) <- runGitCommand repo "commit" $ ["--author", authorName author ++ " <" +++ let env = [("GIT_COMMITTER_NAME", authorName author),+ ("GIT_COMMITTER_EMAIL", authorEmail author)]+ (statusCommit, errCommit, _) <- runGitCommandWithEnv env repo "commit" $ ["--author", authorName author ++ " <" ++ authorEmail author ++ ">", "-m", logMsg] ++ names if statusCommit == ExitSuccess then return ()@@ -93,22 +106,33 @@ else UnknownError $ "Could not git commit " ++ unwords names ++ "\n" ++ errCommit -- | Save changes (creating file and directory if needed), add, and commit.-gitSave :: Contents a => FilePath -> ResourceName -> Author -> Description -> a -> IO ()+gitSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO () gitSave repo name author logMsg contents = do- let filename = repo </> encodeString name- inside <- isInsideRepo repo filename- unless inside $ throwIO IllegalResourceName- createDirectoryIfMissing True $ takeDirectory filename- B.writeFile filename $ toByteString contents+ withSanityCheck repo [".git"] name $ B.writeFile (repo </> encodeArg name) $ toByteString contents (statusAdd, errAdd, _) <- runGitCommand repo "add" [name] if statusAdd == ExitSuccess then gitCommit repo [name] author logMsg else throwIO $ UnknownError $ "Could not git add '" ++ name ++ "'\n" ++ errAdd +isSymlink :: FilePath -> FilePath -> Maybe RevisionId -> IO Bool+isSymlink repo name revid = do+ (_, _, out) <- runGitCommand repo "ls-tree" [fromMaybe "HEAD" revid, name]+ -- see http://stackoverflow.com/questions/737673+ return $ (take 6 $ B.unpack out) == "120000"++targetContents :: Contents a => FilePath -> FilePath -> a -> IO (Maybe a)+targetContents repo linkName linkContent = do+ let (dirName, _) = splitFileName linkName+ targetName = repo </> dirName </> (B.unpack $ toByteString linkContent)+ result <- E.try $ B.readFile targetName+ case result of+ Left (_ :: E.SomeException) -> return Nothing+ Right contents -> return $ Just (fromByteString contents)+ -- | Retrieve contents from resource. gitRetrieve :: Contents a => FilePath- -> ResourceName+ -> FilePath -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest -> IO a gitRetrieve repo name revid = do@@ -120,36 +144,48 @@ when (take 4 (toString output) /= "blob") $ throwIO NotFound (status', err', output') <- runGitCommand repo "cat-file" ["-p", objectName] if status' == ExitSuccess- then return $ fromByteString output'+ then do+ isLink <- isSymlink repo name revid+ if isLink+ then do+ contents <- targetContents repo name output'+ case contents of+ -- ideal output on Nothing would be something like+ -- "broken symlink: <output'>", but I couldn't figure+ -- out the bytestring types to do that.+ -- also didn't bother trying to get the browser+ -- to display the error as text if the symlink is to some+ -- other format.+ Nothing -> return $ fromByteString output'+ Just bs -> return $ fromByteString bs+ else return $ fromByteString output' else throwIO $ UnknownError $ "Error in git cat-file:\n" ++ err' -- | Delete a resource from the repository.-gitDelete :: FilePath -> ResourceName -> Author -> Description -> IO ()-gitDelete repo name author logMsg = do+gitDelete :: FilePath -> FilePath -> Author -> Description -> IO ()+gitDelete repo name author logMsg = withSanityCheck repo [".git"] name $ do (statusAdd, errRm, _) <- runGitCommand repo "rm" [name] if statusAdd == ExitSuccess then gitCommit repo [name] author logMsg else throwIO $ UnknownError $ "Could not git rm '" ++ name ++ "'\n" ++ errRm -- | Change the name of a resource.-gitMove :: FilePath -> ResourceName -> ResourceName -> Author -> Description -> IO ()+gitMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO () gitMove repo oldName newName author logMsg = do- gitLatestRevId repo oldName -- will throw a NotFound error if oldName doesn't exist- let newPath = repo </> encodeString newName- inside <- isInsideRepo repo newPath- unless inside $ throwIO IllegalResourceName- -- create destination directory if missing- createDirectoryIfMissing True $ takeDirectory newPath- (statusAdd, err, _) <- runGitCommand repo "mv" [oldName, newName]+ _ <- gitLatestRevId repo oldName -- will throw a NotFound error if oldName doesn't exist+ (statusAdd, err, _) <- withSanityCheck repo [".git"] newName $ runGitCommand repo "mv" [oldName, newName] if statusAdd == ExitSuccess then gitCommit repo [oldName, newName] author logMsg else throwIO $ UnknownError $ "Could not git mv " ++ oldName ++ " " ++ newName ++ "\n" ++ err -- | Return revision ID for latest commit for a resource.-gitLatestRevId :: FilePath -> ResourceName -> IO RevisionId+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@@ -160,46 +196,67 @@ -- | 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:%h%n%ct%n%an%n%ae%n%s%n", "--max-count=1", revid]+ (status, _, output) <- runGitCommand repo "log" ["--raw","-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 list of files in repository.-gitIndex :: FilePath -> IO [ResourceName]-gitIndex repo = do- (status, errOutput, output) <- runGitCommand repo "ls-files" []+-- | 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","-z","HEAD"] if status == ExitSuccess- then return $ map convertEncoded $ lines $ toString output- else error $ "git ls-files returned error status.\n" ++ errOutput+ 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 $ 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" ["-z","HEAD:" ++ dir]+ if status == ExitSuccess+ 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 $ 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 -- is interpreted as an ordinary string. gitSearch :: FilePath -> SearchQuery -> IO [SearchMatch] gitSearch repo query = do- let opts = ["-I","-n"] +++ let opts = ["-I","-n","--null"] ++ ["--ignore-case" | queryIgnoreCase query] ++ ["--all-match" | queryMatchAll query] ++ ["--word-regexp" | queryWholeWords query] (status, errOutput, output) <- runGitCommand repo "grep" (opts ++ concatMap (\term -> ["-e", escapeRegexSpecialChars term]) (queryPatterns query))- if status == ExitSuccess- then return $ map parseMatchLine $ lines $ toString output- else error $ "git grep returned error status.\n" ++ errOutput+ case status of+ ExitSuccess -> return $ map parseMatchLine $ lines $ toString output+ ExitFailure 1 -> return [] -- status of 1 means no matches in recent versions of git+ ExitFailure _ -> throwIO $ UnknownError $ "git grep returned error status.\n" ++ errOutput -- Auxiliary function for searchResults parseMatchLine :: String -> SearchMatch parseMatchLine str =- let (_,_,_,[fname,_,ln,cont]) = str =~ "^(([^:]|:[^0-9])*):([0-9]*):(.*)$" :: (String, String, String, [String])- in SearchMatch{matchResourceName = fname, matchLineNumber = read ln, matchLine = cont}+ SearchMatch{ matchResourceName = fname+ , matchLineNumber = if not (null ln)+ then read ln+ else error $ "parseMatchLine: " ++ str+ , matchLine = cont}+ where (fname,xs) = break (== '\NUL') str+ rest = drop 1 xs+ -- for some reason, NUL is used after line number instead of+ -- : when --match-all is passed to git-grep.+ (ln,ys) = span (`elem` ['0'..'9']) rest+ cont = drop 1 ys -- drop : or NUL after line number {- -- | Uses git-diff to get a dif between two revisions.-gitDiff :: FilePath -> ResourceName -> RevisionId -> RevisionId -> IO String+gitDiff :: FilePath -> FilePath -> RevisionId -> RevisionId -> IO String gitDiff repo name from to = do (status, _, output) <- runGitCommand repo "diff" [from, to, name] if status == ExitSuccess@@ -212,88 +269,189 @@ else throwIO $ UnknownError $ "git diff returned error:\n" ++ err' -} +gitLogFormat :: String+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 -> [ResourceName] -> TimeRange -> IO [Revision]-gitLog repo names (TimeRange mbSince mbUntil) = do- (status, err, output) <- runGitCommand repo "whatchanged" $- ["--pretty=format:%h%n%ct%n%an%n%ae%n%s%n"] +++gitLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]+gitLog repo names (TimeRange mbSince mbUntil) mblimit = do+ (status, err, output) <- runGitCommand repo "log" $+ ["--raw","-z","--pretty=format:" ++ gitLogFormat] ++ (case mbSince of Just since -> ["--since='" ++ show since ++ "'"] Nothing -> []) ++ (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- else throwIO $ UnknownError $ "git whatchanged returned error status.\n" ++ err+ then parseGitLog output+ else throwIO $ UnknownError $ "git log --raw 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 [Char]-wholeLine = P.manyTill P.anyChar P.newline+parseGitLog :: B.ByteString -> IO [Revision]+parseGitLog = mapM parseLogEntry . splitEntries -nonblankLine :: P.GenParser Char st [Char]-nonblankLine = P.notFollowedBy P.newline >> wholeLine+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 <- liftM unlines (P.manyTill wholeLine (P.eof P.<|> (P.lookAhead (P.char ':') >> return ())))- P.spaces- changes <- P.many gitLogChange- P.spaces- 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- P.char ':'- line <- nonblankLine- let (changeType : fileWords) = drop 4 $ words line- let file' = convertEncoded $ unwords fileWords- 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 --- | 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+-- | This function converts the git "log" %B (raw body) format into a+-- list of Change items (e.g. `Added FilePath`, `Modified FilePath`,+-- or `Deleted FilePath`). The raw body format is normally pairs of+-- ByteStrings, like:+--+-- ":000000 100644 0000000... 9cf8bba... A", "path/to/file.foo"+--+-- where the last letter of the first element is the type of change.+-- Git can track renames however, and those are noted by a triple of+-- ByteStrings; for example:+--+-- ":100644 100644 6c2c6e2... d333ad0... R063",+-- "old/file/path/name.foo",+-- "new/file/path/newname.bar"+--+-- Since filestore does not track renames, these are converted to+-- a remove of the first file and an add of the second.+--+-- n.b. without reading git sources, it's not clear what the raw body+-- format details are; specifically, the three digits following the R+-- are ignored.+parseChanges :: [B.ByteString] -> IO [Change]+parseChanges (x:y:zs) = do+ when (B.null x) $ pcErr "found empty change description"+ let changeType = B.head $ last $ B.words x+ let file' = toString y+ if changeType == 'R'+ then parseChanges (tail zs) >>=+ return . (++) (Deleted file' : Added (toString $ head zs) : [])+ else+ do next <- case changeType of+ 'A' -> return $ Added file'+ 'M' -> return $ Modified file'+ 'D' -> return $ Deleted file'+ _ -> pcErr ("found unknown changeType '" +++ (show changeType) +++ "' in: " ++ (show x) +++ " on " ++ (show y))+ rest <- parseChanges zs+ return (next:rest)+parseChanges [_] =+ pcErr "encountered odd number of fields"+parseChanges [] = return [] -pEncodedString :: P.GenParser Char st [Char]-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."+pcErr :: forall a. String -> IO a+pcErr = throwIO . UnknownError . (++) "filestore parseChanges " -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+postUpdate :: B.ByteString+postUpdate =+ B.pack+ "#!/bin/bash\n\+ \#\n\+ \# This hook does two things:\n\+ \#\n\+ \# 1. update the \"info\" files that allow the list of references to be\n\+ \# queries over dumb transports such as http\n\+ \#\n\+ \# 2. if this repository looks like it is a non-bare repository, and\n\+ \# the checked-out branch is pushed to, then update the working copy.\n\+ \# This makes \"push\" function somewhat similarly to darcs and bzr.\n\+ \#\n\+ \# To enable this hook, make this file executable by \"chmod +x post-update\".\n\+ \\n\+ \git-update-server-info\n\+ \\n\+ \is_bare=$(git-config --get --bool core.bare)\n\+ \\n\+ \if [ -z \"$is_bare\" ]\n\+ \then\n\+ \ # for compatibility's sake, guess\n\+ \ git_dir_full=$(cd $GIT_DIR; pwd)\n\+ \ case $git_dir_full in */.git) is_bare=false;; *) is_bare=true;; esac\n\+ \fi\n\+ \\n\+ \update_wc() {\n\+ \ ref=$1\n\+ \ echo \"Push to checked out branch $ref\" >&2\n\+ \ if [ ! -f $GIT_DIR/logs/HEAD ]\n\+ \ then\n\+ \ echo \"E:push to non-bare repository requires a HEAD reflog\" >&2\n\+ \ exit 1\n\+ \ fi\n\+ \ if (cd $GIT_WORK_TREE; git-diff-files -q --exit-code >/dev/null)\n\+ \ then\n\+ \ wc_dirty=0\n\+ \ else\n\+ \ echo \"W:unstaged changes found in working copy\" >&2\n\+ \ wc_dirty=1\n\+ \ desc=\"working copy\"\n\+ \ fi\n\+ \ if git diff-index --cached HEAD@{1} >/dev/null\n\+ \ then\n\+ \ index_dirty=0\n\+ \ else\n\+ \ echo \"W:uncommitted, staged changes found\" >&2\n\+ \ index_dirty=1\n\+ \ if [ -n \"$desc\" ]\n\+ \ then\n\+ \ desc=\"$desc and index\"\n\+ \ else\n\+ \ desc=\"index\"\n\+ \ fi\n\+ \ fi\n\+ \ if [ \"$wc_dirty\" -ne 0 -o \"$index_dirty\" -ne 0 ]\n\+ \ then\n\+ \ new=$(git rev-parse HEAD)\n\+ \ echo \"W:stashing dirty $desc - see git-stash(1)\" >&2\n\+ \ ( trap 'echo trapped $$; git symbolic-ref HEAD \"'\"$ref\"'\"' 2 3 13 15 ERR EXIT\n\+ \ git-update-ref --no-deref HEAD HEAD@{1}\n\+ \ cd $GIT_WORK_TREE\n\+ \ git stash save \"dirty $desc before update to $new\";\n\+ \ git-symbolic-ref HEAD \"$ref\"\n\+ \ )\n\+ \ fi\n\+ \\n\+ \ # eye candy - show the WC updates :)\n\+ \ echo \"Updating working copy\" >&2\n\+ \ (cd $GIT_WORK_TREE\n\+ \ git-diff-index -R --name-status HEAD >&2\n\+ \ git-reset --hard HEAD)\n\+ \}\n\+ \\n\+ \if [ \"$is_bare\" = \"false\" ]\n\+ \then\n\+ \ active_branch=`git-symbolic-ref HEAD`\n\+ \ export GIT_DIR=$(cd $GIT_DIR; pwd)\n\+ \ GIT_WORK_TREE=${GIT_WORK_TREE-..}\n\+ \ for ref\n\+ \ do\n\+ \ if [ \"$ref\" = \"$active_branch\" ]\n\+ \ then\n\+ \ update_wc $ref\n\+ \ fi\n\+ \ done\n\+ \fi"
+ Data/FileStore/Mercurial.hs view
@@ -0,0 +1,275 @@+{- |+ 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, withVerifyDir, grepSearchRepo, encodeArg)+import Data.FileStore.MercurialCommandServer+import Data.ByteString.Lazy.UTF8 (toString)+import qualified Data.ByteString.Lazy as B+import qualified Text.ParserCombinators.Parsec as P+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 Data.FileStore.Compat.Locale (defaultTimeLocale)+import Data.Time (parseTimeM, formatTime)++-- | 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+ }++-- | 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, _) <- rawRunMercurialCommand 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 </> encodeArg 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 -> 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'+ Right parsed -> return parsed+ else throwIO $ UnknownError $ "mercurial log returned error status.\n" ++ err+ where revOpts Nothing Nothing = []+ revOpts Nothing (Just u) = ["-d", "<" ++ showTime u]+ 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 -> []+++--+-- 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 (parseTimeM True 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+ }+-}
+ Data/FileStore/MercurialCommandServer.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE DeriveDataTypeable #-}+{- |+ Module : Data.FileStore.MercurialCommandServer+ Copyright : Copyright (C) 2011 John Lenz (lenz@math.uic.edu)+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : GHC 6.10 required++ In version 1.9, mercurial introduced a command server which allows+ a single instance of mercurial to be launched and multiple commands+ can be executed without requiring mercurial to start and stop. See+ http://mercurial.selenic.com/wiki/CommandServer+-}++module Data.FileStore.MercurialCommandServer+ ( runMercurialCommand+ , rawRunMercurialCommand+ )+where++import Control.Applicative ((<$>))+import Control.Exception (Exception, onException, throwIO)+import Control.Monad (when)+import Data.Bits (shiftL, shiftR, (.|.))+import Data.Char (isLower, isUpper)+import Data.FileStore.Utils (runShellCommand)+import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)+import Data.List (intercalate, isPrefixOf)+import Data.List.Split (splitOn)+import Data.Typeable (Typeable)+import Data.Word (Word32)+import System.Exit (ExitCode(..))+import System.IO (Handle, hClose, hPutStr, hFlush)+import System.IO.Unsafe (unsafePerformIO)+import System.Process (runInteractiveProcess)++import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.Map as M+import qualified System.Info as SI++-- | Maximum number of servers to keep around+maxPoolSize :: Int+maxPoolSize = 2++-- | 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, BL.ByteString)+runMercurialCommand repo command args = do+ server <- getServer repo+ case server of+ Nothing -> rawRunMercurialCommand repo command args+ Just h -> do ret <- runMercurialServer command args h `onException` cleanupServer h+ putServer repo h+ return ret++-- | Run a mercurial command directly without using the server.+rawRunMercurialCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, BL.ByteString)+rawRunMercurialCommand repo command args = do+ let env = [("HGENCODING","utf8")]+ (status, err, out) <- runShellCommand repo (Just env) "hg" (command : args)+ return (status, LUTF8.toString err, out)++-- | Create a new command server for the given repository+createServer :: FilePath -> IO (Handle,Handle,Handle)+createServer repo = do+ (hin,hout,herr,_) <- runInteractiveProcess "hg" ["serve", "--cmdserver", "pipe"] (Just repo) Nothing+ hello <- readMessage hout+ case hello of+ MessageO _ -> return (hin,hout,herr)+ MessageE x -> throwIO $ MercurialServerException (UTF8.toString x)+ _ -> throwIO $ MercurialServerException "unknown hello message"++-- | Cleanup a command sever. Mercurial will automatically exit itself+-- when the handles are closed.+cleanupServer :: (Handle,Handle,Handle) -> IO ()+cleanupServer (hin,hout,herr) = hClose hin >> hClose hout >> hClose herr++-- | format a command for sending to the server+formatCommand :: String -> [String] -> B.ByteString+formatCommand cmd args = UTF8.fromString $ intercalate "\0" $ cmd : args++-- | run a command using the mercurial server+runMercurialServer :: String -> [String] -> (Handle,Handle,Handle) -> IO (ExitCode, String, BL.ByteString)+runMercurialServer cmd args (hin,hout,herr) = do+ hPutStr hin "runcommand\n"+ let fcmd = formatCommand cmd args+ hWriteWord32be hin $ fromIntegral $ B.length fcmd+ B.hPut hin fcmd+ hFlush hin+ processUntilR hout herr++-- | Read messages from the server until the command finishes or an error message appears+processUntilR :: Handle -> Handle -> IO (ExitCode, String, BL.ByteString)+processUntilR hout _ = loop BL.empty BL.empty+ where loop out err =+ do m <- readMessage hout+ case m of+ MessageO x -> loop (BL.append out $ BL.fromChunks [x]) err+ MessageE x -> loop out (BL.append err $ BL.fromChunks [x])+ MessageR c -> if c == 0+ then return (ExitSuccess, "", out)+ else return (ExitFailure c, LUTF8.toString err, out)++data MercurialMessage = MessageO B.ByteString+ | MessageE B.ByteString+ | MessageR Int++data MercurialServerException = MercurialServerException String+ deriving (Show,Typeable)+instance Exception MercurialServerException++-- | Read a single message+readMessage :: Handle -> IO MercurialMessage+readMessage hout = do+ buf <- B.hGet hout 1+ when (buf == B.empty) $+ throwIO $ MercurialServerException "Unknown channel"+ let c = B8.head buf+ -- Mercurial says unknown lower case channels can be ignored, but upper case channels+ -- must be handled. Currently there are two upper case channels, 'I' and 'L' which+ -- are both used for user input/output. So error on any upper case channel.+ when (isUpper c) $+ throwIO $ MercurialServerException $ "Unknown channel " ++ show c+ len <- hReadWord32be hout+ bdata <- B.hGet hout len+ when (B.length bdata /= len) $+ throwIO $ MercurialServerException "Mercurial did not produce enough output"+ case c of+ 'r' | len >= 4 -> return $ MessageR $ bsReadWord32be bdata+ 'r' -> throwIO $ MercurialServerException $ "return value is fewer than 4 bytes"+ 'o' -> return $ MessageO bdata+ 'e' -> return $ MessageE bdata+ _ | isLower c -> readMessage hout -- skip this message+ _ -> throwIO $ MercurialServerException $ "Unknown channel " ++ show c++-- | Read a 32-bit big-endian into an Int+hReadWord32be :: Handle -> IO Int+hReadWord32be h = do+ s <- B.hGet h 4+ when (B.length s /= 4) $+ throwIO $ MercurialServerException "unable to read int"+ return $ bsReadWord32be s++-- | Read a 32-bit big-endian from a bytestring into an Int+bsReadWord32be :: B.ByteString -> Int+bsReadWord32be s = (fromIntegral (s `B.index` 0) `shiftL` 24) .|.+ (fromIntegral (s `B.index` 1) `shiftL` 16) .|.+ (fromIntegral (s `B.index` 2) `shiftL` 8) .|.+ (fromIntegral (s `B.index` 3) )++-- | Write a Word32 in big-endian to the handle+hWriteWord32be :: Handle -> Word32 -> IO ()+hWriteWord32be h w = B.hPut h buf+ where buf = B.pack [ -- fromIntegeral to convert to Word8+ fromIntegral (w `shiftR` 24),+ fromIntegral (w `shiftR` 16),+ fromIntegral (w `shiftR` 8),+ fromIntegral w+ ]++-------------------------------------------------------------------+-- Maintain a pool of mercurial servers. Currently stored in a+-- global IORef. The code must provide two functions, to get+-- and put a server from the pool. The code above takes care of+-- cleaning up if an exception occurs.+-------------------------------------------------------------------++data MercurialGlobalState = MercurialGlobalState {+ useCommandServer :: Maybe Bool+ , serverHandles :: M.Map FilePath [(Handle,Handle,Handle)]+} deriving (Show)++-- | See http://www.haskell.org/haskellwiki/Top_level_mutable_state+mercurialGlobalVar :: IORef MercurialGlobalState+{-# NOINLINE mercurialGlobalVar #-}+mercurialGlobalVar = unsafePerformIO (newIORef (MercurialGlobalState Nothing M.empty))++-- | Pull a server out of the pool. Returns nothing if the mercurial version+-- does not support servers.+getServer :: FilePath -> IO (Maybe (Handle, Handle, Handle))+getServer repo = do+ use <- useCommandServer <$> readIORef mercurialGlobalVar+ case use of+ Just False -> return Nothing+ Nothing -> do isok <- checkVersion+ atomicModifyIORef mercurialGlobalVar $ \state ->+ (state { useCommandServer = Just isok }, ())+ getServer repo+ Just True -> allocateServer repo++-- | Helper function called once we know that mercurial supports servers+allocateServer :: FilePath -> IO (Maybe (Handle, Handle, Handle))+allocateServer repo = do+ ret <- atomicModifyIORef mercurialGlobalVar $ \state ->+ case M.lookup repo (serverHandles state) of+ Just (x:xs) -> (state { serverHandles = M.insert repo xs (serverHandles state)}, Right x)+ _ -> (state, Left ())+ case ret of+ Right x -> return $ Just x+ Left () -> Just <$> createServer repo++-- | Puts a server back in the pool if the pool is not full,+-- otherwise closes the server.+putServer :: FilePath -> (Handle,Handle,Handle) -> IO ()+putServer repo h = do+ ret <- atomicModifyIORef mercurialGlobalVar $ \state -> do+ case M.lookup repo (serverHandles state) of+ Just xs | length xs >= maxPoolSize -> (state, Right ())+ Just xs -> (state { serverHandles = M.insert repo (h:xs) (serverHandles state)}, Left ())+ Nothing -> (state { serverHandles = M.insert repo [h] (serverHandles state)}, Left ())+ case ret of+ Right () -> cleanupServer h+ Left () -> return ()++-- | Check if the mercurial version supports servers+-- On windows, don't even try because talking to hg over a pipe does not+-- currently work correctly.+checkVersion :: IO Bool+checkVersion+ | isOperatingSystem "mingw32" = return False+ | otherwise = do+ (status,_,out) <- runShellCommand "." Nothing "hg" ["version", "-q"]+ case status of+ ExitFailure _ -> return False+ ExitSuccess -> return $ parseVersion (LUTF8.toString out) >= [2,0]++-- | Helps to find out what operating system we are on+-- Example usage:+-- isOperatingSystem "mingw32" (on windows)+-- isOperatingSystem "darwin"+-- isOperatingSystem "linux"+isOperatingSystem :: String -> Bool+isOperatingSystem sys = SI.os == sys++-- | hg version -q returns something like "Mercurial Distributed SCM (version 1.9.1)"+-- This function returns the list [1,9,1]+parseVersion :: String -> [Int]+parseVersion b = if starts then verLst else [0]+ where msg = "Mercurial Distributed SCM (version "+ starts = isPrefixOf msg b+ ver = takeWhile (/= ')') $ drop (length msg) b+ verLst = map read $ splitOn "." ver
Data/FileStore/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, TypeSynonymInstances, DeriveDataTypeable #-}+{-# LANGUAGE Rank2Types, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances #-} {- | Module : Data.FileStore.Types Copyright : Copyright (C) 2009 John MacFarlane@@ -13,7 +13,7 @@ module Data.FileStore.Types ( RevisionId- , ResourceName+ , Resource(..) , Author(..) , Change(..) , Description@@ -25,20 +25,21 @@ , SearchMatch(..) , SearchQuery(..) , defaultSearchQuery- , DateTime+ , UTCTime , FileStore (..) ) where import Data.ByteString.Lazy (ByteString) import Data.Typeable import Data.ByteString.Lazy.UTF8 (toString, fromString)-import Data.DateTime (DateTime)+import Data.Time (UTCTime) import Control.Exception (Exception)-import Prelude hiding (catch) type RevisionId = String -type ResourceName = String+data Resource = FSFile FilePath+ | FSDirectory FilePath+ deriving (Show, Read, Eq, Typeable, Ord) data Author = Author {@@ -47,9 +48,9 @@ } deriving (Show, Read, Eq, Typeable) data Change =- Added ResourceName- | Deleted ResourceName- | Modified ResourceName+ Added FilePath+ | Deleted FilePath+ | Modified FilePath deriving (Show, Read, Eq, Typeable) type Description = String@@ -57,7 +58,7 @@ data Revision = Revision { revId :: RevisionId- , revDateTime :: DateTime+ , revDateTime :: UTCTime , revAuthor :: Author , revDescription :: Description , revChanges :: [Change]@@ -77,24 +78,27 @@ data TimeRange = TimeRange {- timeFrom :: Maybe DateTime -- ^ @Nothing@ means no lower bound- , timeTo :: Maybe DateTime -- ^ @Nothing@ means no upper bound+ timeFrom :: Maybe UTCTime -- ^ @Nothing@ means no lower bound+ , timeTo :: Maybe UTCTime -- ^ @Nothing@ means no upper bound } deriving (Show, Read, Eq, Typeable) data MergeInfo = MergeInfo {- mergeRevision :: Revision -- ^ The revision with which changes were merged+ mergeRevision :: Revision -- ^ The revision w/ which changes were merged , mergeConflicts :: Bool -- ^ @True@ if there were merge conflicts- , mergeText :: String -- ^ The merged text, including conflict markers+ , mergeText :: String -- ^ The merged text, w/ conflict markers } deriving (Show, Read, Eq, Typeable) data FileStoreError =- RepositoryExists -- ^ Tried to initialize a repository that already exists- | ResourceExists -- ^ Tried to create a resource that already exists+ RepositoryExists -- ^ Tried to initialize a repo that exists+ | ResourceExists -- ^ Tried to create a resource that exists | NotFound -- ^ Requested resource was not found | IllegalResourceName -- ^ The specified resource name is illegal- | Unchanged -- ^ The resource was not modified, because the contents were unchanged+ | Unchanged -- ^ The resource was not modified,+ -- because the contents were unchanged | UnsupportedOperation+ | NoMaxCount -- ^ The darcs version used does not support+ -- --max-count | UnknownError String deriving (Read, Eq, Typeable) @@ -105,6 +109,11 @@ show IllegalResourceName = "IllegalResourceName" show Unchanged = "Unchanged" show UnsupportedOperation = "UnsupportedOperation"+ show NoMaxCount = "NoMaxCount:\n"+ ++ "filestore was compiled with the maxcount flag, but your version of\n"+ ++ "darcs does not support the --max-count option. You should either\n"+ ++ "upgrade to darcs >= 2.3.0 (recommended) or compile filestore without\n"+ ++ "the maxcount flag (cabal install filestore -f-maxcount)." show (UnknownError s) = "UnknownError: " ++ s instance Exception FileStoreError@@ -113,7 +122,8 @@ SearchQuery { queryPatterns :: [String] -- ^ Patterns to match , queryWholeWords :: Bool -- ^ Match patterns only with whole words?- , queryMatchAll :: Bool -- ^ Return matches only from files in which all patterns match?+ , queryMatchAll :: Bool -- ^ Return matches only from files in which+ -- all patterns match? , queryIgnoreCase :: Bool -- ^ Make matches case-insensitive? } deriving (Show, Read, Eq, Typeable) @@ -127,7 +137,7 @@ data SearchMatch = SearchMatch {- matchResourceName :: ResourceName+ matchResourceName :: FilePath , matchLineNumber :: Integer , matchLine :: String } deriving (Show, Read, Eq, Typeable)@@ -140,60 +150,67 @@ initialize :: IO () -- | Save contents in the filestore.- , save :: Contents a- => ResourceName -- Resource to save.+ , save :: forall a . Contents a+ => FilePath -- Resource to save. -> Author -- Author of change. -> Description -- Description of change. -> a -- New contents of resource. -> IO ()- + -- | Retrieve the contents of the named resource.- , retrieve :: Contents a- => ResourceName -- Resource to retrieve.- -> Maybe RevisionId -- @Just@ a particular revision ID, or @Nothing@ for latest+ , retrieve :: forall a . Contents a+ => FilePath -- Resource to retrieve.+ -> Maybe RevisionId -- @Just@ a particular revision ID,+ -- or @Nothing@ for latest -> IO a -- | Delete a named resource, providing author and log message.- , delete :: ResourceName -- Resource to delete.+ , delete :: FilePath -- Resource to delete. -> Author -- Author of change. -> Description -- Description of change. -> IO () -- | Rename a resource, providing author and log message.- , rename :: ResourceName -- Resource original name.- -> ResourceName -- Resource new name.+ , rename :: FilePath -- Resource original name.+ -> FilePath -- Resource new name. -> Author -- Author of change. -> Description -- Description of change. -> IO () - -- | Get history for a list of named resources in a (possibly openended) time range.- -- If the list is empty, history for all resources will be returned. - , history :: [ResourceName] -- List of resources to get history for, or @[]@ for all.- -> TimeRange -- Time range within which to get history.+ -- | Get history for a list of named resources in a (possibly openended)+ -- time range. If the list is empty, history for all resources will+ -- be returned. If the TimeRange is 2 Nothings, history for all dates will be returned.+ , 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. Raises 'NotFound'- -- if the resource is not found.- , latest :: ResourceName -- Resource to get revision ID for.+ -- | Return the revision ID of the latest change for a resource.+ -- Raises 'NotFound' if the resource is not found.+ , latest :: FilePath -- Resource to get revision ID for. -> IO RevisionId - -- | Return information about a revision, given the ID. Raises 'NotFound' if there is- -- no such revision.- , revision :: RevisionId -- Revision ID to get revision information for.+ -- | Return information about a revision, given the ID.+ -- Raises 'NotFound' if there is no such revision.+ , revision :: RevisionId -- Revision ID to get information for. -> IO Revision -- | Return a list of resources in the filestore.- , index :: IO [ResourceName]+ , index :: IO [FilePath] + -- | Return a list of resources in a directory of the filestore.+ , directory :: FilePath -- Directory to list (empty for root)+ -> IO [Resource]+ -- | @True@ if the revision IDs match, in the sense that the -- can be treated as specifying the same revision. , idsMatch :: RevisionId -> RevisionId -> Bool - -- | Search the filestore for patterns. + -- | Search the filestore for patterns. , search :: SearchQuery -> IO [SearchMatch] }-
Data/FileStore/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-} {- | Module : Data.FileStore.Utils Copyright : Copyright (C) 2009 John MacFarlane, Gwern Branwen@@ -14,44 +15,69 @@ runShellCommand , mergeContents , hashsMatch- , isInsideRepo , escapeRegexSpecialChars- , parseMatchLine ) where-+ , parseMatchLine+ , splitEmailAuthor+ , ensureFileExists+ , regSearchFiles+ , regsSearchFile+ , withSanityCheck+ , grepSearchRepo + , withVerifyDir+ , encodeArg ) where -import Codec.Binary.UTF8.String (encodeString)-import Control.Monad (liftM)+import Control.Exception (throwIO)+import Control.Applicative ((<$>))+import Control.Monad (liftM, liftM2, when, unless) import Data.ByteString.Lazy.UTF8 (toString)-import Data.List (isPrefixOf)+import Data.Char (isSpace)+import Data.List (intersect, nub, isPrefixOf, isInfixOf) import Data.List.Split (splitWhen) import Data.Maybe (isJust)-import System.Directory (canonicalizePath)-import System.Directory (getTemporaryDirectory, removeFile, findExecutable)+import System.Directory (doesFileExist, getTemporaryDirectory, removeFile, findExecutable, createDirectoryIfMissing, getDirectoryContents) import System.Exit (ExitCode(..))+import System.FilePath ((</>), takeDirectory) import System.IO (openTempFile, hClose)+import System.IO.Error (isDoesNotExistError) import System.Process (runProcess, waitForProcess)+import System.Environment (getEnvironment) import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as S+import qualified Control.Exception as E+#if MIN_VERSION_base(4,5,0)+#else+import Codec.Binary.UTF8.String (encodeString)+#endif -import Data.FileStore.Types (SearchMatch(..))+import Data.FileStore.Types (SearchMatch(..), FileStoreError(IllegalResourceName, NotFound, UnknownError), SearchQuery(..)) +-- | Encode argument for raw command.+encodeArg :: String -> String+#if MIN_VERSION_base(4,5,0)+encodeArg = id+#else+encodeArg = encodeString+#endif+ -- | Run shell command and return error status, standard output, and error output. Assumes--- UTF-8 locale. Note that this does not actuall go through \/bin\/sh!+-- UTF-8 locale. Note that this does not actually go through \/bin\/sh! runShellCommand :: FilePath -- ^ Working directory -> Maybe [(String, String)] -- ^ Environment -> String -- ^ Command -> [String] -- ^ Arguments -> IO (ExitCode, B.ByteString, B.ByteString) runShellCommand workingDir environment command optionList = do- tempPath <- catch getTemporaryDirectory (\_ -> return ".")+ tempPath <- E.catch getTemporaryDirectory (\(_ :: E.SomeException) -> return ".") (outputPath, hOut) <- openTempFile tempPath "out" (errorPath, hErr) <- openTempFile tempPath "err"- hProcess <- runProcess (encodeString command) (map encodeString optionList) (Just workingDir) environment Nothing (Just hOut) (Just hErr)+ env <- liftM2 (++) environment . Just <$> getEnvironment+ hProcess <- runProcess (encodeArg command) (map encodeArg optionList) (Just workingDir) env Nothing (Just hOut) (Just hErr) status <- waitForProcess hProcess- errorOutput <- B.readFile errorPath- output <- B.readFile outputPath+ errorOutput <- S.readFile errorPath+ output <- S.readFile outputPath removeFile errorPath removeFile outputPath- return (status, errorOutput, output)+ return (status, B.fromChunks [errorOutput], B.fromChunks [output]) -- | Do a three way merge, using either git merge-file or RCS merge. Assumes -- that either @git@ or @merge@ is in the system path. Assumes UTF-8 locale.@@ -60,7 +86,7 @@ -> (String, B.ByteString) -- ^ (label, contents) of latest version -> IO (Bool, String) -- ^ (were there conflicts?, merged contents) mergeContents (newLabel, newContents) (originalLabel, originalContents) (latestLabel, latestContents) = do- tempPath <- catch getTemporaryDirectory (\_ -> return ".")+ tempPath <- E.catch getTemporaryDirectory (\(_ :: E.SomeException) -> return ".") (originalPath, hOriginal) <- openTempFile tempPath "orig" (latestPath, hLatest) <- openTempFile tempPath "latest" (newPath, hNew) <- openTempFile tempPath "new"@@ -109,14 +135,15 @@ hashsMatch :: (Eq a) => [a] -> [a] -> Bool hashsMatch r1 r2 = r1 `isPrefixOf` r2 || r2 `isPrefixOf` r1 --- | Inquire of a certain repository whether another file lies within its ambit.--- This is basically asking whether the file is 'above' the repository in the filesystems's+-- | Inquire of a certain directory whether another file lies within its ambit.+-- This is basically asking whether the file is 'above' the directory in the filesystems's -- directory tree. Useful for checking the legality of a filename.-isInsideRepo :: FilePath -> FilePath -> IO Bool-isInsideRepo repo name = do- gitRepoPathCanon <- canonicalizePath repo- filenameCanon <- canonicalizePath name- return (gitRepoPathCanon `isPrefixOf` filenameCanon)+-- Note: due to changes in canonicalizePath in ghc 7, we no longer have+-- a reliable way to do this; so isInsideDir is False whenever either+-- the file or the directory contains "..".+isInsideDir :: FilePath -> FilePath -> Bool+isInsideDir name dir = dir `isPrefixOf` name+ && not (".." `isInfixOf` dir) && not (".." `isInfixOf` name) -- | A parser function. This is intended for use on strings which are output by grep programs -- or programs which mimic the standard grep output - which uses colons as delimiters and has@@ -130,3 +157,90 @@ parseMatchLine str = let (fn:n:res:_) = splitWhen (==':') str in SearchMatch{matchResourceName = fn, matchLineNumber = read n, matchLine = res}++-- | Our policy is: if the input is clearly a "name \<e\@mail.com\>" input, then we return "(Just Address, Name)"+-- If there is no '<' in the input, then it clearly can't be of that format, and so we just return "(Nothing, Name)"+--+-- > splitEmailAuthor "foo bar baz@gmail.com" ~> (Nothing,"foo bar baz@gmail.com")+-- > splitEmailAuthor "foo bar <baz@gmail.com>" ~> (Just "baz@gmail.com","foo bar")+splitEmailAuthor :: String -> (Maybe String, String)+splitEmailAuthor x = (mbEmail, trim name)+ where (name, rest) = break (=='<') x+ mbEmail = if null rest+ then Nothing+ else Just $ takeWhile (/='>') $ drop 1 rest++-- | Trim leading and trailing spaces+trim :: String -> String+trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- | Search multiple files with a single regexp.+-- This calls out to grep, and so supports the regular expressions grep does.+regSearchFiles :: FilePath -> [String] -> String -> IO [String]+regSearchFiles repo filesToCheck pattern = do (_, _, result) <- runShellCommand repo+ Nothing "grep" $ ["--line-number", "-I", "-l", "-E", "-e", pattern] ++ filesToCheck+ let results = intersect filesToCheck $ lines $ toString result+ return results++-- | Search a single file with multiple regexps.+regsSearchFile :: [String] -> FilePath -> [String] -> String -> IO [String]+regsSearchFile os repo patterns file = do res <- mapM (run file) patterns+ return $ nub $ concat res+ where run f p = do (_,_,r) <- runShellCommand repo Nothing "grep" (os ++ [p, f])+ return $ lines $ toString r++-- | If name doesn't exist in repo or is not a file, throw 'NotFound' exception.+ensureFileExists :: FilePath -> FilePath -> IO ()+ensureFileExists repo name = do+ isFile <- doesFileExist (repo </> encodeArg name)+ unless isFile $ throwIO NotFound++-- | Check that the filename/location is within the given repo, and not inside+-- any of the (relative) paths in @excludes@. Create the directory if needed.+-- If everything checks out, then perform the specified action.+withSanityCheck :: FilePath+ -> [FilePath]+ -> FilePath+ -> IO b + -> IO b+withSanityCheck repo excludes name action = do+ let filename = repo </> encodeArg name+ let insideRepo = filename `isInsideDir` repo+ let insideExcludes = or $ map (filename `isInsideDir`)+ $ map (repo </>) excludes+ when (insideExcludes || not insideRepo)+ $ throwIO IllegalResourceName+ createDirectoryIfMissing True $ takeDirectory filename+ action++-- | Uses grep to search a file-based repository. Note that this calls out to grep; and so+-- is generic over repos like git or darcs-based repos. (The git FileStore instance doesn't+-- use this because git has builtin grep functionality.)+-- Expected usage is to specialize this function with a particular backend's 'index'.+grepSearchRepo :: (FilePath -> IO [String]) -> FilePath -> SearchQuery -> IO [SearchMatch]+grepSearchRepo indexer repo query = do+ let opts = ["-I", "--line-number", "--with-filename"] +++ ["-i" | queryIgnoreCase query] +++ (if queryWholeWords query then ["--word-regexp"] else ["-E"])+ let regexps = map escapeRegexSpecialChars $ queryPatterns query+ files <- indexer repo+ if queryMatchAll query+ then do+ filesMatchingAllPatterns <- liftM (foldr1 intersect) $ mapM (regSearchFiles repo files) regexps+ output <- mapM (regsSearchFile opts repo regexps) filesMatchingAllPatterns+ return $ map parseMatchLine $ concat output+ else do+ (_status, _errOutput, output) <-+ runShellCommand repo Nothing "grep" $ opts +++ concatMap (\term -> ["-e", term]) regexps +++ files+ let results = lines $ toString output+ return $ map parseMatchLine results++-- | we don't actually need the contents, just want to check that the directory exists and we have enough permissions+withVerifyDir :: FilePath -> IO a -> IO a+withVerifyDir d a =+ E.catch (liftM head (getDirectoryContents $ encodeArg d) >> a) $ \(e :: E.IOException) ->+ if isDoesNotExistError e+ then throwIO NotFound+ else throwIO . UnknownError . show $ e
Setup.lhs view
@@ -1,11 +1,3 @@ #!/usr/bin/env runhaskell > import Distribution.Simple-> import System.Process-> import System.Exit--> main = defaultMainWithHooks $ simpleUserHooks { runTests = runTestSuite }--Run test suite.--> runTestSuite _ _ _ _ = runCommand "runghc -idist/build/autogen Tests.lhs" >>= waitForProcess >>= exitWith-+> main = defaultMain
− Tests.lhs
@@ -1,298 +0,0 @@-#!/usr/bin/env runghc--This program runs tests for the filestore modules.-Invoke it with:-- runghc -idist/build/autogen Tests.lhs--> import Data.FileStore-> import Test.HUnit-> import System.Directory (removeDirectoryRecursive)-> import Control.Monad (forM)-> import Prelude hiding (catch)-> import Control.Exception (catch)-> import Data.DateTime-> import Data.Maybe (mapMaybe)-> import System.Directory (doesFileExist)-> import System.Process-> import Data.Algorithm.Diff (DI(..))--> main = do-> testFileStore (gitFileStore "tmp/gitfs") "Data.FileStore.Git"-> testFileStore (darcsFileStore "tmp/darcsfs") "Data.FileStore.Darcs"-> 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) -> [ ("initialize", initializeTest)-> , ("create resource", createTest1)-> , ("create resource in subdirectory", createTest2)-> , ("create resource with non-ascii name", createTest3)-> , ("try to create resource outside repo", createTest4)-> , ("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)-> , ("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 = "αβγ"--*** 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 "subdir/Subdir title2.txt" 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 testTitle-> assertBool "revision returns a revision after create" (not (null revid))--*** 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)--*** Retrieve latest version of a resource:--> retrieveTest1 fs = TestCase $ do-> cont <- retrieve fs testTitle Nothing-> assertEqual "contents returned by retrieve" testContents cont --*** Retrieve latest version of a resource (in a subdirectory):--> retrieveTest2 fs = TestCase $ do-> cont <- retrieve fs subdirTestTitle Nothing-> assertEqual "contents returned by retrieve" testContents cont --*** Retrieve latest version of a resource with a nonascii name:--> retrieveTest3 fs = TestCase $ do-> cont <- retrieve fs nonasciiTestTitle Nothing-> assertEqual "contents returned by retrieve" testContents cont --*** Retrieve a directory (should fail):--> retrieveTest4 fs = TestCase $ do-> 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 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" (not (toBeDeleted `elem` ind))--*** 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--*** 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 $ addMinutes (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"))-
− extra/post-update
@@ -1,85 +0,0 @@-#!/bin/sh-#-# This hook does two things:-#-# 1. update the "info" files that allow the list of references to be-# queries over dumb transports such as http-#-# 2. if this repository looks like it is a non-bare repository, and-# the checked-out branch is pushed to, then update the working copy.-# This makes "push" function somewhat similarly to darcs and bzr.-#-# To enable this hook, make this file executable by "chmod +x post-update".--git-update-server-info--is_bare=$(git-config --get --bool core.bare)--if [ -z "$is_bare" ]-then- # for compatibility's sake, guess- git_dir_full=$(cd $GIT_DIR; pwd)- case $git_dir_full in */.git) is_bare=false;; *) is_bare=true;; esac-fi--update_wc() {- ref=$1- echo "Push to checked out branch $ref" >&2- if [ ! -f $GIT_DIR/logs/HEAD ]- then- echo "E:push to non-bare repository requires a HEAD reflog" >&2- exit 1- fi- if (cd $GIT_WORK_TREE; git-diff-files -q --exit-code >/dev/null)- then- wc_dirty=0- else- echo "W:unstaged changes found in working copy" >&2- wc_dirty=1- desc="working copy"- fi- if git diff-index --cached HEAD@{1} >/dev/null- then- index_dirty=0- else- echo "W:uncommitted, staged changes found" >&2- index_dirty=1- if [ -n "$desc" ]- then- desc="$desc and index"- else- desc="index"- fi- fi- if [ "$wc_dirty" -ne 0 -o "$index_dirty" -ne 0 ]- then- new=$(git rev-parse HEAD)- echo "W:stashing dirty $desc - see git-stash(1)" >&2- ( trap 'echo trapped $$; git symbolic-ref HEAD "'"$ref"'"' 2 3 13 15 ERR EXIT- git-update-ref --no-deref HEAD HEAD@{1}- cd $GIT_WORK_TREE- git stash save "dirty $desc before update to $new";- git-symbolic-ref HEAD "$ref"- )- fi-- # eye candy - show the WC updates :)- echo "Updating working copy" >&2- (cd $GIT_WORK_TREE- git-diff-index -R --name-status HEAD >&2- git-reset --hard HEAD)-}--if [ "$is_bare" = "false" ]-then- active_branch=`git-symbolic-ref HEAD`- export GIT_DIR=$(cd $GIT_DIR; pwd)- GIT_WORK_TREE=${GIT_WORK_TREE-..}- for ref- do- if [ "$ref" = "$active_branch" ]- then- update_wc $ref- fi- done-fi
filestore.cabal view
@@ -1,26 +1,78 @@ Name: filestore-Version: 0.2-Cabal-version: >= 1.2-Build-type: Custom-Tested-with: GHC==6.10.1+Version: 0.6.5.1+Cabal-Version: >= 1.10+Build-type: Simple 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 License-File: LICENSE Author: John MacFarlane, Gwern Branwen, Sebastiaan Visser Maintainer: jgm@berkeley.edu-Build-depends: base >= 4, bytestring, utf8-string, filepath, directory, datetime,- parsec >= 2 && < 3, process, time, datetime, regex-posix, xml, split, Diff-Extra-source-files: Tests.lhs-Exposed-modules: Data.FileStore, Data.FileStore.Types, Data.FileStore.Git, Data.FileStore.Darcs,- -- Data.FileStore.Sqlite3,- Data.FileStore.Utils, Data.FileStore.Generic-Other-modules: Paths_filestore-Data-Files: extra/post-update, CHANGES-Ghc-Options: -Wall-Ghc-Prof-Options: -auto-all+Bug-Reports: https://github.com/jgm/filestore/issues++Extra-Source-Files: CHANGES++Source-repository head+ type: git+ location: https://github.com/jgm/filestore.git++Flag maxcount+ default: True+ description: Make use of a recent (>= 2.3.0) Darcs feature which vastly improves the performance+ of 'latest'. You should disable this flag if you plan to use gitit with an+ older version of Darcs, or 'latest' will raise an error.++Library+ Build-depends: base >= 4 && < 5,+ bytestring >= 0.9 && < 1.0,+ containers >= 0.3 && < 0.9,+ utf8-string >= 0.3 && < 1.1,+ filepath >= 1.1 && < 1.6,+ directory >= 1.0 && < 1.4,+ parsec >= 2 && < 3.2,+ process >= 1.0 && < 1.7,+ time >= 1.5 && < 1.16,+ xml >= 1.3 && < 1.4,+ split >= 0.1 && < 0.3,+ Diff >= 0.4 && < 0.6 || >= 1.0 && < 1.1,+ old-locale >= 1.0 && < 1.1++ 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: Data.FileStore.DarcsXml+ Data.FileStore.MercurialCommandServer+ Data.FileStore.Compat.Locale+ Default-Extensions: FlexibleInstances+ Default-Language: Haskell98+ if flag(maxcount)+ cpp-options: -DUSE_MAXCOUNT+ if impl(ghc >= 6.12)+ Ghc-Options: -Wall -fno-warn-unused-do-bind+ else+ Ghc-Options: -Wall+ Ghc-Prof-Options: -fprof-auto-exported++Test-suite test-filestore+ Type: exitcode-stdio-1.0+ Hs-source-dirs: tests+ Main-is: Tests.hs+ Default-Language: Haskell98+ Build-depends: base >= 4.7 && < 5,+ HUnit >= 1.2 && < 1.7,+ mtl,+ time,+ Diff >= 0.4 && < 0.6 || >= 1.0 && < 1.1,+ filepath >= 1.1 && < 1.6,+ directory >= 1.1 && < 1.4,+ filestore
+ tests/Tests.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE CPP #-}+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 (Diff+#if MIN_VERSION_Diff(0,4,0)+ , PolyDiff+#endif+ (..))+import System.Exit+import System.Environment (setEnv)++data FileStoreType = Darcs | Git | Mercurial deriving (Show, Eq)++main = do+ setEnv "GIT_AUTHOR_NAME" "Fake Name"+ setEnv "GIT_AUTHOR_EMAIL" "fake.email@example.com"+ gc <- testFileStore (gitFileStore "tmp/gitfs") Git+ -- dc <- testFileStore (darcsFileStore "tmp/darcsfs") Darcs+ mc <- testFileStore (mercurialFileStore "tmp/mercurialfs") Mercurial+ removeDirectoryRecursive "tmp"+ let counts = Counts{ cases = cases gc {- + cases dc -} + cases mc,+ tried = tried gc {- + tried dc -} + tried mc,+ failures = failures gc {- + failures dc -}+ + failures mc,+ errors = errors gc {- + errors dc -} + errors mc }+ let errorCode = failures counts + errors counts+ putStrLn $ "Total " ++ showCounts counts+ exitWith $ if errorCode == 0+ then ExitSuccess+ else ExitFailure errorCode++testFileStore :: FileStore -> FileStoreType -> IO Counts+testFileStore fs fsName = do+ runTestTT $ TestList $ map (\(label, testFn) ->+ TestLabel (show fsName ++ " (" ++ 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 = "α/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+ Git -> ("tmp" </> "gitfs" </> ".git" </> "newfile", ".git/newfile")+ Darcs -> ("tmp" </> "darcsfs" </> "_darcs" </> "newfile", "_darcs/newfile")+ Mercurial -> ("tmp" </> "mercurialfs" </> ".hg" </> "newfile", ".hg/newfile")+ 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+ Git -> ("tmp" </> "gitfs" </> ".git" </> "newfile", ".git/newfile")+ Darcs -> ("tmp" </> "darcsfs" </> "_darcs" </> "newfile", "_darcs/newfile")+ Mercurial -> ("tmp" </> "mercurialfs" </> ".hg" </> "newfile", ".hg/newfile")+ 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+ let testDescription = "history test message"+ save fs testTitle testAuthor testDescription testContents++ -- 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)))+ assertEqual "revDescription" testDescription (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' = [s | First s <- 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'' = concat [x | Second x <- 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"))