diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,137 @@
+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.
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
@@ -16,7 +16,8 @@
import Control.Exception (throwIO)
import Control.Monad (when)
-import Data.DateTime (toSqlString)
+import Data.Time (formatTime)
+import Data.FileStore.Compat.Locale (defaultTimeLocale)
import Data.List (sort, isPrefixOf)
#ifdef USE_MAXCOUNT
import Data.List (isInfixOf)
@@ -27,11 +28,10 @@
import Data.FileStore.DarcsXml (parseDarcsXML)
import Data.FileStore.Types
-import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, ensureFileExists, grepSearchRepo, withVerifyDir)
-import Codec.Binary.UTF8.String (encodeString)
+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)
+import qualified Data.ByteString.Lazy as B (ByteString, writeFile, null)
-- | Return a filestore implemented using the Darcs distributed revision control system
-- ().
@@ -49,7 +49,7 @@
, 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)
@@ -76,7 +76,7 @@
-- | Save changes (creating the file and directory if needed), add, and commit.
darcsSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO ()
darcsSave repo name author logMsg contents = do
- withSanityCheck repo ["_darcs"] name $ B.writeFile (repo encodeString name) $ 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]
@@ -117,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 -> [FilePath] -> TimeRange -> IO [Revision]
-darcsLog repo names (TimeRange begin end) = do
- let opts = timeOpts begin end
- do (status, err, output) <- runDarcsCommand repo "changes" $ ["--xml-output", "--summary"] ++ names ++ opts
+darcsLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
+darcsLog repo names (TimeRange begin end) mblimit = do
+ (status, err, output) <- runDarcsCommand repo "changes" $ ["--xml-output", "--summary"] ++ names ++ opts
if status == ExitSuccess
then case parseDarcsXML $ toString output of
Nothing -> throwIO ResourceExists
- Just parsed -> return parsed
+ Just parsed -> return $
+#ifdef USE_MAXCOUNT
+ parsed
+#else
+ case mblimit of
+ Just lim -> take lim parsed
+ Nothing -> parsed
+#endif
else throwIO $ UnknownError $ "darcs changes returned error status.\n" ++ err
where
- 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'
@@ -136,6 +150,7 @@
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
@@ -159,7 +174,8 @@
let patchs = parseDarcsXML $ toString output
case patchs of
Nothing -> throwIO NotFound
- Just as -> if null as then throwIO NotFound else return $ revId $ head as
+ Just [] -> throwIO NotFound
+ Just (x:_) -> return $ revId x
-- | Retrieve the contents of a resource.
darcsRetrieve :: Contents a
@@ -168,29 +184,38 @@
-> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest
-> IO a
darcsRetrieve repo name mbId = do
- ensureFileExists repo name
let opts = case mbId of
Nothing -> ["contents", name]
Just revid -> ["contents", "--match=hash " ++ revid, name]
- (status, err, output) <- runDarcsCommand repo "query" opts
+ (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 [FilePath]
darcsIndex repo = withVerifyDir repo $ do
- (status, _errOutput, output) <- runDarcsCommand repo "query" ["files","--no-directories"]
+ (status, _errOutput, output) <- runDarcsCommand repo "show" ["files","--no-directories"]
if status == ExitSuccess
- then return $ map (drop 2) . lines . toString $ output
+ then return . getNames $ output
else return [] -- return empty list if invalid path (see gitIndex)
-- | 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 "query" ["files","--no-directories"]
- (status2, _errOutput2, output2) <- runDarcsCommand repo "query" ["files","--no-files"]
+ (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
diff --git a/Data/FileStore/DarcsXml.hs b/Data/FileStore/DarcsXml.hs
--- a/Data/FileStore/DarcsXml.hs
+++ b/Data/FileStore/DarcsXml.hs
@@ -2,7 +2,8 @@
import Data.Maybe (catMaybes, fromMaybe)
import Data.Char (isSpace)
-import Data.DateTime (parseDateTime)
+import Data.Time.Format (parseTimeM)
+import Data.FileStore.Compat.Locale (defaultTimeLocale)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Text.XML.Light
@@ -28,7 +29,7 @@
-- 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
+ 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)
@@ -56,7 +57,8 @@
| x == "added_lines"
|| x == "modify_file"
|| x == "removed_lines"
- || x == "replaced_tokens" = Just (Modified b)
+ || x == "replaced_tokens"
+ || x == "move" = Just (Modified b)
| otherwise = Nothing
where x = qName . elName $ a
b = takeWhile (/='\n') $ dropWhile isSpace $ strContent a
@@ -69,4 +71,5 @@
|| x == "modify_file"
|| x == "added_lines"
|| x == "removed_lines"
- || x == "replaced_tokens")
+ || 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,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, CPP #-}
{- |
Module : Data.FileStore.Generic
Copyright : Copyright (C) 2009 John MacFarlane, Gwern Branwen, Sebastiaan Visser
@@ -14,7 +14,8 @@
module Data.FileStore.Generic
( modify
, create
- , DI(..)
+ , Diff
+ , PolyDiff(..)
, diff
, searchRevisions
, smartRetrieve
@@ -24,15 +25,14 @@
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 Data.Algorithm.Diff (Diff, PolyDiff (..), getGroupedDiff)
import System.FilePath (())
-import Prelude hiding (catch)
-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.
@@ -43,10 +43,10 @@
-> 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,
@@ -67,13 +67,13 @@
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).
@@ -81,10 +81,10 @@
-> 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
@@ -104,7 +104,7 @@
let matcher = if exact
then (== desc)
else (desc `isInfixOf`)
- revs <- history repo [name] (TimeRange Nothing Nothing)
+ revs <- history repo [name] (TimeRange Nothing Nothing) Nothing
return $ Prelude.filter (matcher . revDescription) revs
-- | Try to retrieve a resource from the repository by name and possibly a
@@ -119,14 +119,14 @@
-> 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
@@ -134,7 +134,7 @@
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)
@@ -142,7 +142,7 @@
-- | 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 = Control.Exception.catch (g r) (\(e :: FileStoreError)-> return ( r, Left . show $ e ) )
+ 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,27 +23,25 @@
)
where
import Data.FileStore.Types
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.List.Split (endByOneOf)
import System.Exit
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, escapeRegexSpecialChars, withVerifyDir)
+import Data.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 (encodeString)
+import qualified Data.ByteString.Lazy.Char8 as B
import Control.Monad (when)
-import System.FilePath (())
+import System.FilePath ((), splitFileName)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, executable, getPermissions, setPermissions)
import Control.Exception (throwIO)
-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
@@ -46,15 +50,20 @@
, revision = gitGetRevision repo
, index = gitIndex repo
, directory = gitDirectory repo
- , search = gitSearch 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)
@@ -69,10 +78,10 @@
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})
-- Set up repo to allow push to current branch
@@ -80,13 +89,15 @@
if status' == ExitSuccess
then return ()
else throwIO $ UnknownError $ "git config failed:\n" ++ err'
- else throwIO $ UnknownError $ "git-init 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 -> [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 ()
@@ -97,12 +108,27 @@
-- | Save changes (creating file and directory if needed), add, and commit.
gitSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO ()
gitSave repo name author logMsg contents = do
- withSanityCheck repo [".git"] name $ B.writeFile (repo encodeString name) $ 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
@@ -118,7 +144,21 @@
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.
@@ -133,7 +173,7 @@
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
- (statusAdd, err, _) <- withSanityCheck repo [".git"] newName $ runGitCommand repo "mv" [oldName, newName]
+ (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
@@ -156,13 +196,9 @@
-- | 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" ["-z","--pretty=format:" ++ gitLogFormat, "--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 a list of all known files inside and managed by a repository.
@@ -212,7 +248,7 @@
else error $ "parseMatchLine: " ++ str
, matchLine = cont}
where (fname,xs) = break (== '\NUL') str
- rest = drop 1 xs
+ 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
@@ -234,68 +270,188 @@
-}
gitLogFormat :: String
-gitLogFormat = "%H%n%ct%n%an%n%ae%n%s%n%x00"
+gitLogFormat = "%x01%H%x00%ct%x00%an%x00%ae%x00%B%n%x00"
-- | Return list of log entries for the given time frame and list of resources.
-- If list of resources is empty, log entries for all resources are returned.
-gitLog :: FilePath -> [FilePath] -> TimeRange -> IO [Revision]
-gitLog repo names (TimeRange mbSince mbUntil) = do
- (status, err, output) <- runGitCommand repo "whatchanged" $
- ["-z","--pretty=format:" ++ gitLogFormat] ++
+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 String
-wholeLine = P.manyTill P.anyChar P.newline
-
-nonblankLine :: P.GenParser Char st String
-nonblankLine = P.notFollowedBy P.newline >> wholeLine
+parseGitLog :: B.ByteString -> IO [Revision]
+parseGitLog = mapM parseLogEntry . splitEntries
-nullChar :: P.GenParser Char st ()
-nullChar = P.satisfy (=='\0') >> return ()
+splitEntries :: B.ByteString -> [B.ByteString]
+splitEntries = dropWhile B.null . B.split '\1' -- occurs just before each hash
-gitLogEntry :: P.Parser Revision
-gitLogEntry = do
- rev <- nonblankLine
- date <- nonblankLine
- author <- wholeLine
- email <- wholeLine
- subject <- P.manyTill P.anyChar nullChar
- P.spaces
- changes <- P.manyTill gitLogChange (P.eof P.<|> nullChar)
- let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse
+parseLogEntry :: B.ByteString -> IO Revision
+parseLogEntry entry = do
+ let (rev : date' : author : email : subject : rest) = B.split '\0' entry
+ date <- case B.readInteger date' of
+ Just (x,_) -> return x
+ Nothing -> throwIO $ UnknownError $ "Could not read date"
+ changes <- parseChanges $ takeWhile (not . B.null) rest
return Revision {
- revId = rev
- , revDateTime = posixSecondsToUTCTime $ realToFrac (read date :: Integer)
- , revAuthor = Author { authorName = author, authorEmail = email }
- , revDescription = stripTrailingNewlines subject
+ revId = toString rev
+ , revDateTime = posixSecondsToUTCTime $ realToFrac date
+ , revAuthor = Author{ authorName = toString author
+ , authorEmail = toString email }
+ , revDescription = toString $ stripTrailingNewlines subject
, revChanges = changes }
-gitLogChange :: P.Parser Change
-gitLogChange = do
- line <- P.manyTill P.anyChar nullChar
- let changeType = take 1 $ reverse line
- file' <- P.manyTill P.anyChar nullChar
- case changeType of
- "A" -> return $ Added file'
- "M" -> return $ Modified file'
- "D" -> return $ Deleted file'
- _ -> return $ Modified file'
+stripTrailingNewlines :: B.ByteString -> B.ByteString
+stripTrailingNewlines = B.reverse . B.dropWhile (=='\n') . B.reverse
+-- | 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 []
+
+pcErr :: forall a. String -> IO a
+pcErr = throwIO . UnknownError . (++) "filestore parseChanges "
+
+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
--- a/Data/FileStore/Mercurial.hs
+++ b/Data/FileStore/Mercurial.hs
@@ -19,19 +19,18 @@
import Data.FileStore.Types
import Data.Maybe (fromJust)
import System.Exit
-import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, withVerifyDir, grepSearchRepo)
+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 Codec.Binary.UTF8.String (encodeString)
import Data.List (nub)
import Control.Monad (when, liftM, unless)
import System.FilePath ((), splitDirectories, takeFileName)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
import Control.Exception (throwIO)
-import System.Locale (defaultTimeLocale)
-import Data.Time (parseTime)
-import Data.Time.Clock (UTCTime)
+import Data.FileStore.Compat.Locale (defaultTimeLocale)
+import Data.Time (parseTimeM, formatTime)
-- | Return a filestore implemented using the mercurial distributed revision control system
-- ().
@@ -51,20 +50,13 @@
, idsMatch = const hashsMatch repo
}
--- | Run a mercurial command and return error status, error output, standard output. The repository
--- is used as working directory.
-runMercurialCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString)
-runMercurialCommand repo command args = do
- (status, err, out) <- runShellCommand repo Nothing "hg" (command : args)
- return (status, toString err, out)
-
-- | Initialize a repository, creating the directory if needed.
mercurialInit :: FilePath -> IO ()
mercurialInit repo = do
exists <- doesDirectoryExist repo
when exists $ withVerifyDir repo $ throwIO RepositoryExists
createDirectoryIfMissing True repo
- (status, err, _) <- runMercurialCommand repo "init" []
+ (status, err, _) <- rawRunMercurialCommand repo "init" []
if status == ExitSuccess
then
-- Add a hook so that changes made remotely via hg will be reflected in
@@ -91,7 +83,7 @@
-- | Save changes (creating file and directory if needed), add, and commit.
mercurialSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO ()
mercurialSave repo name author logMsg contents = do
- withSanityCheck repo [".hg"] name $ B.writeFile (repo encodeString name) $ toByteString contents
+ 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
@@ -208,19 +200,24 @@
-- | Return list of log entries for the given time frame and list of resources.
-- If list of resources is empty, log entries for all resources are returned.
-mercurialLog :: FilePath -> [FilePath] -> TimeRange -> IO [Revision]
-mercurialLog repo names (TimeRange mbSince mbUntil) = do
- (status, err, output) <- runMercurialCommand repo "log" $ ["--template", mercurialLogFormat] ++ revOpts mbSince mbUntil ++ names
+mercurialLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision]
+mercurialLog repo names (TimeRange mbSince mbUntil) mblimit = do
+ (status, err, output) <- runMercurialCommand repo "log" $ ["--template", mercurialLogFormat] ++ revOpts mbSince mbUntil ++ limit ++ names
if status == ExitSuccess
then case P.parse parseMercurialLog "" (toString output) of
Left err' -> throwIO $ UnknownError $ "Error parsing mercurial log.\n" ++ show err'
Right parsed -> return parsed
else throwIO $ UnknownError $ "mercurial log returned error status.\n" ++ err
where revOpts Nothing Nothing = []
- revOpts Nothing (Just u) = ["-d", "<" ++ show u]
- revOpts (Just s) Nothing = ["-d", ">" ++ show s]
- revOpts (Just s) (Just u) = ["-d", show s ++ " to " ++ show u]
+ 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.
--
@@ -254,7 +251,7 @@
let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse
return Revision {
revId = rev
- , revDateTime = fromJust (parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" date :: Maybe UTCTime)
+ , 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
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
@@ -25,16 +25,15 @@
, 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
@@ -59,7 +58,7 @@
data Revision =
Revision {
revId :: RevisionId
- , revDateTime :: DateTime
+ , revDateTime :: UTCTime
, revAuthor :: Author
, revDescription :: Description
, revChanges :: [Change]
@@ -79,8 +78,8 @@
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 =
@@ -151,7 +150,7 @@
initialize :: IO ()
-- | Save contents in the filestore.
- , save :: Contents a
+ , save :: forall a . Contents a
=> FilePath -- Resource to save.
-> Author -- Author of change.
-> Description -- Description of change.
@@ -159,7 +158,7 @@
-> IO ()
-- | Retrieve the contents of the named resource.
- , retrieve :: Contents a
+ , retrieve :: forall a . Contents a
=> FilePath -- Resource to retrieve.
-> Maybe RevisionId -- @Just@ a particular revision ID,
-- or @Nothing@ for latest
@@ -180,10 +179,11 @@
-- | 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.
+ -- 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.
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,7 +15,6 @@
runShellCommand
, mergeContents
, hashsMatch
- , isInsideDir
, escapeRegexSpecialChars
, parseMatchLine
, splitEmailAuthor
@@ -23,25 +23,42 @@
, regsSearchFile
, withSanityCheck
, grepSearchRepo
- , withVerifyDir ) where
+ , withVerifyDir
+ , encodeArg ) where
-import Codec.Binary.UTF8.String (encodeString)
import Control.Exception (throwIO)
-import Control.Monad (liftM, when, unless)
+import Control.Applicative ((<$>))
+import Control.Monad (liftM, liftM2, when, unless)
import Data.ByteString.Lazy.UTF8 (toString)
import Data.Char (isSpace)
import Data.List (intersect, nub, isPrefixOf, isInfixOf)
import Data.List.Split (splitWhen)
import Data.Maybe (isJust)
-import System.Directory (canonicalizePath, doesFileExist, getTemporaryDirectory, removeFile, findExecutable, createDirectoryIfMissing, getDirectoryContents)
+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(..), 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 actually go through \/bin\/sh!
runShellCommand :: FilePath -- ^ Working directory
@@ -50,16 +67,17 @@
-> [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.
@@ -68,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"
@@ -120,11 +138,12 @@
-- | 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.
-isInsideDir :: FilePath -> FilePath -> IO Bool
-isInsideDir name dir = do
- gitDirPathCanon <- canonicalizePath dir
- filenameCanon <- canonicalizePath name
- return (gitDirPathCanon `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
@@ -173,7 +192,7 @@
-- | 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 encodeString name)
+ isFile <- doesFileExist (repo encodeArg name)
unless isFile $ throwIO NotFound
-- | Check that the filename/location is within the given repo, and not inside
@@ -185,10 +204,12 @@
-> IO b
-> IO b
withSanityCheck repo excludes name action = do
- let filename = repo encodeString name
- insideRepo <- filename `isInsideDir` repo
- insideExcludes <- liftM or $ mapM (filename `isInsideDir`) $ map (repo ) excludes
- when (insideExcludes || not insideRepo) $ throwIO IllegalResourceName
+ 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
@@ -219,7 +240,7 @@
-- | 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 =
- catch (liftM head (getDirectoryContents $ encodeString d) >> a) $ \e ->
- if "No such file or directory" `isInfixOf` show e
+ 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,387 +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 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.DateTime
-> import Data.Maybe (mapMaybe)
-> import System.FilePath
-> import System.Process
-> import Data.Algorithm.Diff (DI(..))
-
-> main = do
-> testFileStore (gitFileStore "tmp/gitfs") "Data.FileStore.Git"
-> testFileStore (darcsFileStore "tmp/darcsfs") "Data.FileStore.Darcs"
-> testFileStore (mercurialFileStore "tmp/mercurialfs") "Data.FileStore.Mercurial"
-> removeDirectoryRecursive "tmp"
-
-
-> testFileStore :: FileStore -> String -> IO Counts
-> testFileStore fs fsName = do
-> putStrLn "**********************************"
-> putStrLn $ "Testing " ++ fsName
-> putStrLn "**********************************"
-> runTestTT $ TestList $ map (\(label, testFn) -> TestLabel label $ testFn fs)
-> [ ("pre initialize", preInitializeTest)
-> , ("initialize", initializeTest)
-> , ("create resource", createTest1)
-> , ("create resource in subdirectory", createTest2)
-> , ("create resource with non-ascii name", createTest3)
-> , ("create resource with non-ascii subdirectory", createTest3a)
-> , ("try to create resource outside repo", createTest4)
-> , ("try to create resource in special directory", createTest5 fsName)
-> , ("directory", directoryTest)
-> , ("retrieve resource", retrieveTest1)
-> , ("retrieve resource in a subdirectory", retrieveTest2)
-> , ("retrieve resource with non-ascii name", retrieveTest3)
-> , ("retrieve subdirectory (should raise error)", retrieveTest4)
-> , ("modify resource", modifyTest)
-> , ("delete resource", deleteTest fsName)
-> , ("rename resource", renameTest)
-> , ("test for matching IDs", matchTest)
-> , ("history and revision", historyTest)
-> , ("diff", diffTest)
-> , ("search", searchTest)
-> ]
-
-> testAuthor :: Author
-> testAuthor = Author "Test Suite" "suite@test.org"
-
-> testContents :: String
-> testContents = "Test contents.\nSecond line.\nThird test line with some Greek αβ."
-
-> testTitle :: String
-> testTitle = "New resource.txt"
-
-> subdirTestTitle :: String
-> subdirTestTitle = "subdir/Subdir title.txt"
-
-> nonasciiTestTitle :: String
-> nonasciiTestTitle = "αβγ"
-
-> subdirNonasciiTestTitle :: String
-> subdirNonasciiTestTitle = "Fooé/bar"
-
-*** index and directory for noexisting repository should raise error:
-
-> preInitializeTest fs = TestCase $ do
-> catch (do index fs; assertFailure "preInitialize, uncaught error") $
-> \e -> assertEqual "error status from attempt to get index of nonexistent repo" e NotFound
-> catch (do directory fs "foo"; assertFailure "preInitialize, uncaught error") $
-> \e -> assertEqual "error status from attempt to get directory of nonexistent repo" e NotFound
-
-*** Initialize a repository, check for empty index, and then try to initialize again
-*** in the same directory (should raise an error):
-
-> initializeTest fs = TestCase $ do
-> initialize fs
-> ind <- index fs
-> assertEqual "index of just-initialized repository" ind []
-> catch (initialize fs >> assertFailure "did not return error for existing repository") $
-> \e -> assertEqual "error status from existing repository" e RepositoryExists
-
-*** Create a resource, and check to see that latest returns a revision ID for it:
-
-> createTest1 fs = TestCase $ do
-> create fs testTitle testAuthor "description of change" testContents
-> revid <- latest fs testTitle
-> assertBool "revision returns a revision after create" (not (null revid))
-
-*** Create a resource in a subdirectory, and check to see that revision returns a revision for it:
-
-> createTest2 fs = TestCase $ do
-> create fs subdirTestTitle testAuthor "description of change" testContents
-> revid <- latest fs testTitle
-> assertBool "revision returns a revision after create" (not (null revid))
-> create fs (subdirTestTitle ++ "2") testAuthor "+Second file" testContents
-
-*** Create a resource with a non-ascii title, and check to see that revision returns a revision for it:
-
-> createTest3 fs = TestCase $ do
-> create fs nonasciiTestTitle testAuthor "description of change" testContents
-> revid <- latest fs nonasciiTestTitle
-> assertBool "revision returns a revision after create" (not (null revid))
-> allfiles <- index fs
-> assertBool "index contains file with nonascii name" (nonasciiTestTitle `elem` allfiles)
-
-> createTest3a fs = TestCase $ do
-> create fs subdirNonasciiTestTitle testAuthor "description of change" testContents
-> revid <- latest fs subdirNonasciiTestTitle
-> assertBool "revision returns a revision after create" (not (null revid))
-> allfiles <- index fs
-> assertBool "index contains file with nonascii subdir" (subdirNonasciiTestTitle `elem` allfiles)
-
-*** Try to create a resource outside the repository (should fail with an error and NOT write the file):
-
-> createTest4 fs = TestCase $ do
-> catch (create fs "../oops" testAuthor "description of change" testContents >>
-> assertFailure "did not return error from create ../oops") $
-> \e -> assertEqual "error from create ../oops" IllegalResourceName e
-> exists <- doesFileExist "tmp/oops"
-> assertBool "file ../oops was created outside repository" (not exists)
-
-*** Try to create a resource in special directory (should fail with an error and NOT write the file):
-
-> createTest5 fsName fs = TestCase $ do
-> let (realpath, special) = case fsName of
-> "Data.FileStore.Git" -> ("tmp" "gitfs" ".git" "newfile", ".git/newfile")
-> "Data.FileStore.Darcs" -> ("tmp" "darcsfs" "_darcs" "newfile", "_darcs/newfile")
-> "Data.FileStore.Mercurial" -> ("tmp" "mercurialfs" ".hg" "newfile", ".hg/newfile")
-> _ -> error "Unknown filestore type! Add a test case."
-> catch (create fs special testAuthor "description of change" testContents >>
-> (assertFailure $ "did not return error from create " ++ special)) $
-> \e -> assertEqual ("error from create " ++ special) IllegalResourceName e
-> exists <- doesFileExist realpath
-> assertBool ("file " ++ realpath ++ " was created outside repository") (not exists)
-
-*** Test directory
-
-> directoryTest fs = TestCase $ do
-
- Get directory for top-level
-
-> files <- directory fs ""
-> assertEqual "result of directory on top-level" (sort [FSDirectory (takeDirectory subdirTestTitle), FSFile testTitle, FSFile nonasciiTestTitle, FSDirectory (takeDirectory subdirNonasciiTestTitle)]) (sort files)
-
- Get contents of subdirectory
-
-> subdirFiles <- directory fs "subdir"
-> assertEqual "result of directory on subdir" [FSFile (takeFileName subdirTestTitle), FSFile (takeFileName (subdirTestTitle ++ "2"))] subdirFiles
-
- Try to get contents of nonexistent subdirectory
-
-> catch (do directory fs "foo"; assertFailure "nonexistent subdirectory, uncaught error") $
-> \e -> assertEqual "error status from attempt to get directory listing of nonexistent directory" e NotFound
-
-*** Retrieve latest version of a resource:
-
-> retrieveTest1 fs = TestCase $
-> retrieve fs testTitle Nothing >>=
-> assertEqual "contents returned by retrieve" testContents
-
-*** Retrieve latest version of a resource (in a subdirectory):
-
-> retrieveTest2 fs = TestCase $
-> retrieve fs subdirTestTitle Nothing >>=
-> assertEqual "contents returned by retrieve" testContents
-
-*** Retrieve latest version of a resource with a nonascii name:
-
-> retrieveTest3 fs = TestCase $
-> retrieve fs nonasciiTestTitle Nothing >>=
-> assertEqual "contents returned by retrieve" testContents
-
-*** Retrieve a directory (should fail):
-
-> retrieveTest4 fs = TestCase $
-> catch ((retrieve fs "subdir" Nothing :: IO String) >>
-> assertFailure "did not return error from retrieve from subdir") $
-> \e -> assertEqual "error from retrieve from subdir" NotFound e
-
-*** Modify a resource:
-
-> modifyTest fs = TestCase $ do
-
- Modify a resource. Should return Right ().
-
-> revid <- latest fs testTitle
-> let modifiedContents = unlines $ take 2 $ lines testContents
-> modResult <- modify fs testTitle revid testAuthor "removed third line" modifiedContents
-> assertEqual "results of modify" (Right ()) modResult
-
- Now retrieve the contents and make sure they were changed.
-
-> modifiedContents' <- retrieve fs testTitle Nothing
-> newRevId <- latest fs testTitle
-> newRev <- revision fs newRevId
-> assertEqual "retrieved contents after modify" modifiedContents' modifiedContents
-
- Now try to modify again, using the old revision as base. This should result in a merge with conflicts.
-
-> modResult2 <- modify fs testTitle revid testAuthor "modified from old version" (testContents ++ "\nFourth line")
-> let normModResult2 = Left MergeInfo {mergeRevision = newRev, mergeConflicts = True, mergeText =
-> "Test contents.\nSecond line.\n<<<<<<< edited\nThird test line with some Greek \945\946.\nFourth line\n=======\n>>>>>>> " ++
-> newRevId ++ "\n"}
-> assertEqual "results of modify from old version" normModResult2 modResult2
-
- Now try it again, still using the old version as base, but with contents of the new version.
- This should result in a merge without conflicts.
-
-> modResult3 <- modify fs testTitle revid testAuthor "modified from old version" modifiedContents
-> let normModResult3 = Left MergeInfo {mergeRevision = newRev, mergeConflicts = False, mergeText = modifiedContents}
-> assertEqual "results of modify from old version with new version's contents" normModResult3 modResult3
-
- Now try modifying again, this time using the new version as base. Should succeed with Right ().
-
-> modResult4 <- modify fs testTitle newRevId testAuthor "modified from new version" (modifiedContents ++ "\nThird line")
-> assertEqual "results of modify from new version" (Right ()) modResult4
-
-*** Delete a resource:
-
-> deleteTest fsName fs = TestCase $ do
-
- Create a file and verify that it's there.
-
-> let toBeDeleted = "Aaack!"
-> create fs toBeDeleted testAuthor "description of change" testContents
-> ind <- index fs
-> assertBool "index contains resource to be deleted" (toBeDeleted `elem` ind)
-
- Now delete it and verify that it's gone.
-
-> delete fs toBeDeleted testAuthor "goodbye"
-> ind <- index fs
-> assertBool "index does not contain resource that was deleted" (toBeDeleted `notElem` ind)
-
- Now make sure you can create and delete it again.
-
-> create fs toBeDeleted testAuthor "description of change" testContents
-> ind <- index fs
-> assertBool "index contains re-created resource" (toBeDeleted `elem` ind)
-> delete fs toBeDeleted testAuthor "goodbye"
-> ind <- index fs
-> assertBool "index does not contain resource that was deleted" (toBeDeleted `notElem` ind)
-
- Try to delete a file somewhere we shouldn't be able to delete
-
-> let (realpath, special) = case fsName of
-> "Data.FileStore.Git" -> ("tmp" "gitfs" ".git" "newfile", ".git/newfile")
-> "Data.FileStore.Darcs" -> ("tmp" "darcsfs" "_darcs" "newfile", "_darcs/newfile")
-> "Data.FileStore.Mercurial" -> ("tmp" "mercurialfs" ".hg" "newfile", ".hg/newfile")
-> _ -> error "Unknown filestore type! Add a test case."
-> catch (delete fs special testAuthor "description of change" >>
-> (assertFailure $ "did not return error from delete " ++ special)) $
-> \e -> assertEqual ("error from delete " ++ special) IllegalResourceName e
-
-*** Rename a resource:
-
-> renameTest fs = TestCase $ do
-
- Create a file and verify that it's there.
-
-> let oldName = "Old Name"
-> let newName = "newdir/New Name.txt"
-> create fs oldName testAuthor "description of change" testContents
-> ind <- index fs
-> assertBool "index contains old name" (oldName `elem` ind)
-> assertBool "index does not contain new name" (newName `notElem` ind)
-
- Now rename it and verify that it changed names.
-
-> rename fs oldName newName testAuthor "rename"
-> ind <- index fs
-> assertBool "index does not contain old name" (oldName `notElem` ind)
-> assertBool "index contains new name" (newName `elem` ind)
-
- Try renaming a file that doesn't exist.
-
-> catch (rename fs "nonexistent file" "other name" testAuthor "rename" >>
-> assertFailure "rename of nonexistent file did not throw error") $
-> \e -> assertEqual "error status from rename of nonexistent file" NotFound e
-
- Try to rename a file to a location we shouldn't be able to write in.
-
-> let badName = "../eek"
-> let cmd = "rename " ++ newName ++ " " ++ badName
-> catch (rename fs newName badName testAuthor "description of change" >>
-> (assertFailure $ "did not return error from " ++ cmd)) $
-> \e -> assertEqual ("error from " ++ cmd) IllegalResourceName e
-
-
-*** Test history and revision
-
-> historyTest fs = TestCase $ do
-
- Get history for three files
-
-> hist <- history fs [testTitle, subdirTestTitle, nonasciiTestTitle] (TimeRange Nothing Nothing)
-> assertBool "history is nonempty" (not (null hist))
-> now <- getCurrentTime
-> rev <- latest fs testTitle >>= revision fs -- get latest revision
-> assertBool "history contains latest revision" (rev `elem` hist)
-> assertEqual "revAuthor" testAuthor (revAuthor rev)
-> assertBool "revId non-null" (not (null (revId rev)))
-> assertBool "revDescription non-null" (not (null (revDescription rev)))
-> assertEqual "revChanges" [Modified testTitle] (revChanges rev)
-> let revtime = revDateTime rev
-> histNow <- history fs [testTitle] (TimeRange (Just $ 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,8 +1,7 @@
Name: filestore
-Version: 0.3.4.3
-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
@@ -14,15 +13,13 @@
License-File: LICENSE
Author: John MacFarlane, Gwern Branwen, Sebastiaan Visser
Maintainer: jgm@berkeley.edu
-Homepage: http://johnmacfarlane.net/repos/filestore
+Bug-Reports: https://github.com/jgm/filestore/issues
-Data-Files: extra/post-update, CHANGES
-Extra-source-files: Tests.lhs
+Extra-Source-Files: CHANGES
--- Commented out until Cabal 1.6 becomes common.
--- Source-repository head
--- Type: darcs
--- Location: http://johnmacfarlane.net/repos/filestore
+Source-repository head
+ type: git
+ location: https://github.com/jgm/filestore.git
Flag maxcount
default: True
@@ -31,19 +28,51 @@
older version of Darcs, or 'latest' will raise an error.
Library
- Build-depends: base >= 4 && < 5, bytestring, utf8-string, filepath, directory, datetime,
- parsec >= 2 && < 3, process, time, datetime, xml, split, Diff, old-locale
-
- Exposed-modules: Data.FileStore, Data.FileStore.Types, Data.FileStore.Git, Data.FileStore.Darcs, Data.FileStore.Mercurial,
- -- Data.FileStore.Sqlite3,
- Data.FileStore.Utils, Data.FileStore.Generic
- Other-modules: Paths_filestore, Data.FileStore.DarcsXml
+ 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
- if flag(maxcount)
+ 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
- extensions: CPP
if impl(ghc >= 6.12)
Ghc-Options: -Wall -fno-warn-unused-do-bind
else
Ghc-Options: -Wall
- Ghc-Prof-Options: -auto-all
+ 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"))