diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -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
diff --git a/Data/FileStore.hs b/Data/FileStore.hs
--- a/Data/FileStore.hs
+++ b/Data/FileStore.hs
@@ -19,6 +19,7 @@
, module Data.FileStore.Generic
, module Data.FileStore.Git
, module Data.FileStore.Darcs
+ , module Data.FileStore.Mercurial
)
where
@@ -26,3 +27,4 @@
import Data.FileStore.Generic
import Data.FileStore.Git
import Data.FileStore.Darcs
+import Data.FileStore.Mercurial
diff --git a/Data/FileStore/Compat/Locale.hs b/Data/FileStore/Compat/Locale.hs
new file mode 100644
--- /dev/null
+++ b/Data/FileStore/Compat/Locale.hs
@@ -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
diff --git a/Data/FileStore/Darcs.hs b/Data/FileStore/Darcs.hs
--- a/Data/FileStore/Darcs.hs
+++ b/Data/FileStore/Darcs.hs
@@ -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
-- ().
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 \" 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 " ~> (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
diff --git a/Data/FileStore/DarcsXml.hs b/Data/FileStore/DarcsXml.hs
new file mode 100644
--- /dev/null
+++ b/Data/FileStore/DarcsXml.hs
@@ -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")
diff --git a/Data/FileStore/Generic.hs b/Data/FileStore/Generic.hs
--- a/Data/FileStore/Generic.hs
+++ b/Data/FileStore/Generic.hs
@@ -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)
diff --git a/Data/FileStore/Git.hs b/Data/FileStore/Git.hs
--- a/Data/FileStore/Git.hs
+++ b/Data/FileStore/Git.hs
@@ -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
-- ().
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: ", 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"
diff --git a/Data/FileStore/Mercurial.hs b/Data/FileStore/Mercurial.hs
new file mode 100644
--- /dev/null
+++ b/Data/FileStore/Mercurial.hs
@@ -0,0 +1,275 @@
+{- |
+ Module : Data.FileStore.Mercurial
+ Copyright : Copyright (C) 2009 John MacFarlane
+ License : BSD 3
+
+ Maintainer : John MacFarlane
+ Stability : alpha
+ Portability : GHC 6.10 required
+
+ A versioned filestore implemented using mercurial.
+ Normally this module should not be imported: import
+ "Data.FileStore" instead.
+-}
+
+module Data.FileStore.Mercurial
+ ( mercurialFileStore
+ )
+where
+import Data.FileStore.Types
+import Data.Maybe (fromJust)
+import System.Exit
+import Data.FileStore.Utils (withSanityCheck, hashsMatch, 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
+-- ().
+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
+ }
+-}
diff --git a/Data/FileStore/MercurialCommandServer.hs b/Data/FileStore/MercurialCommandServer.hs
new file mode 100644
--- /dev/null
+++ b/Data/FileStore/MercurialCommandServer.hs
@@ -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
+ 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
diff --git a/Data/FileStore/Types.hs b/Data/FileStore/Types.hs
--- a/Data/FileStore/Types.hs
+++ b/Data/FileStore/Types.hs
@@ -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]
}
-
diff --git a/Data/FileStore/Utils.hs b/Data/FileStore/Utils.hs
--- a/Data/FileStore/Utils.hs
+++ b/Data/FileStore/Utils.hs
@@ -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 \" 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 " ~> (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
diff --git a/Setup.lhs b/Setup.lhs
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -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
diff --git a/Tests.lhs b/Tests.lhs
deleted file mode 100644
--- a/Tests.lhs
+++ /dev/null
@@ -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"))
-
diff --git a/extra/post-update b/extra/post-update
deleted file mode 100644
--- a/extra/post-update
+++ /dev/null
@@ -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
diff --git a/filestore.cabal b/filestore.cabal
--- a/filestore.cabal
+++ b/filestore.cabal
@@ -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
diff --git a/tests/Tests.hs b/tests/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Tests.hs
@@ -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"))