filestore-0.6.0.6/0000755000000000000000000000000012507277577012066 5ustar0000000000000000filestore-0.6.0.6/CHANGES0000644000000000000000000002045512507277577013067 0ustar0000000000000000Version 0.6.0.6 released 2 April 2014 * Added compatibility module Data.FileStore.Compat.Locale so that filestore will compile against time 1.5. Version 0.6.0.5 released 2 April 2014 * Mark post-update as a bash script (not a generic shell script). * Bump version bounds for dependencies. Version 0.6.0.4 released 31 Oct 2014 * Fixed test suite so that it returns error status if tests fail (#16). Version 0.6.0.3 released 26 Jul 2014 * Disable the broken mercurial command server on Windows, falling back on direct running of each command (Alan Brooks). * Added a script demonstrating use of filestore to query darcs repositories (gwern). Version 0.6.0.2 released 08 Apr 2014 * Bumped version for process so it will compile with GHC 7.8.1. Version 0.6.0.1 released 20 Mar 2013 * runProcess now allows access to the current environment, instead of running in a bare environment. This fixes problems for those who have git in a nonstandard path. (Jochen Keil) * Allow latest Diff. * Reconfigured cabal file to use new Cabal test framework. Run tests with `cabal configure --enable-tests && cabal build && cabal test`. * Set environment variable HGENCODING for mercurial. Closes #6. Version 0.6 released 31 Dec 2012 * Updated to use Diff 0.2. This involves an API change: diff now returns [Diff [String]] rather than [(DI, String)]. Thanks to markwright for the patch. * Test revDescription more thoroughly (Ben Millwood). * Fixed error handling in withVerifyDir. Version 0.5.0.1 released 21 Oct 2012 * Bumped version limits on dependencies. * Upgraded Utils to use Control.Exception. Version 0.5 released 30 Apr 2012 * Added 'limit' parameter to 'history', so that in large repositories you don't need to generate and parse the entire log. * Revised the git log parser, so it is faster and lazy. This is helpful for applications where we may not need to parse the whole history. It would be good to make similar modifications to the hg and darcs log parsers in the future. Version 0.3.4.3 released 26 Sep 2010 * runShellCommand: reverted to older version with temp files. The new version caused lazy-IO related problems with large files. Thanks to Pavel Perikov diagnosing the problem. Version 0.3.4.2 released 03 Aug 2010 * gitInit: Set up repository to allow push to the current branch. This is needed for recent versions of git, which don't allow a push to the master branch. Resolves Issue #104. * New version of runShellCommand that does not require temp files, using runInteractiveProcess. * Suppress "unused do bind" warnings in build. Version 0.3.4.1 released 22 Jan 2010 * Rewrote splitEmailAuthor with list fns not regexes. Also removed regex-posix from cabal build-depends. * Corrected error message for richDirectory * Improved git search: + Previously git search would fail in some cases, with an error in parseMatchLine (for example, with unicode search term). + We replaced the regex with a simpler match-line parser using Preface functions. + We also now use --null to force a NUL separator in git grep. + The test case that previously failed now passes. Version 0.3.4 released 10 Dec 2009 * Added Mercurial module and associated tests. Thanks to John Lenz for the patch. * Added test case for nonascii directory name * gitLatestRevId - added check to make sure resource hasn't been removed. Without this, you get a ResourceExists error when creating a file that has been previously deleted from the repo. * Use -z with git ls-tree. This resolves Issue #77. When 'git ls-tree' is used with -z, it prints regular UTF8 instead of octal encoding it. So we can avoid the problem we were having with filenames like Foo\230\331/Bar. * Use -z for 'git whatchanged'. This allows us to remove the kludgy 'convertEncoded' function, which parsed encoded filenames. Version 0.3.3.1 released 22 Nov 2009 * Raise an IllegalResourceName error if the user tries to delete a file inside .git or _darcs subdirectory. * Have gitSearch return no matches, instead of raising an error, if error status = 1. Recent versions of git-grep return 1 if no matches found. * Fix git log parsing so that it allows log comments to start with ':' Thanks to thorben for uncovering the bug. Version 0.3.3 released 06 Nov 2009 * isInsideDir is again exported. Version 0.3.2.2 released 06 Nov 2009 * Raise an IllegalResourceName error if the user tries to create a file inside the .git or _darcs subdirectory. Previously the file would be written (or overwritten) before the error was caught in the add/commit phase. This introduced the risk of corrupting the repository or, worse, overwriting hooks. * isInsideDir is no longer exported. * checkAndWriteFile has been replaced with withSanityCheck, to avoid code duplication between create and rename functions. Version 0.3.2.1 released 24 Oct 2009 * Convert pathname to UTF8 in withVerifyDir. Version 0.3.2 released 22 Aug 2009 * Made maxcount default to True, as '--max-count' is supported by the latest released version of darcs (2.3.0). Print an informative error message if the version of darcs being used does not support --max-count. * Made 'initialize' throw RepoExists error only if the repo exists; catch permission or other errors separately. (Thomas Hartmann) * Made 'index' throw an error if the directory is not present or there are insufficient permissions. (Thomas Hartmann) * Improved error message for search match helper. Version 0.3.1 released 04 Jul 2009 * Added -I flag to grep in regSearchFiles. Ignore binary files in the repository when searching. * Added maxcount Cabal flag, defaulting to False. When true, this flag causes 'latest' to run 'darcs changes' with the flag '--max-count=1', which dramatically increases performance. (Without this, filestore has to retrieve the entire changelog just to get the latest revision ID.) '--max-count' is at this point only in development versions of darcs. * Removed quoting from --match=hash in Darcs module (since it doesn't go through /bin/sh). Thanks to Ganesh Sittampalam. * Efficiency improvements and refactoring in Darcs module. * Moved darcs utility functions to Util module. Version 0.3 released 08 Apr 2009 * Added new 'directory' function, which returns a list of resources given a directory name. Resources are marked as either FSFile or FSDirectory. Thanks to Thomas Hartman for showing the need for 'directory', and for distinguishing explicitly between files and directories. In 'index' the distinction was previously left implicit, which worked for git but not darcs: 'index' provided no way of distinguishing an empty directory from a file. * In 'directory' and 'index', git ls-tree is used instead of git ls-files; this guarantees that only files that have been committed are returned. 'index' now lists only files, and no longer includes empty directories even in darcs. * Added new richDirectory function to Data.FileStore.Generic. richDirectory returns a directory that includes information about the latest revision of each file. Thanks to Thomas Hartman for the patch. * Replaced ResourceName type with FilePath. * Added repository information to cabal file. Version 0.2 released 08 Feb 2009 * Changed diff to do a line-by-line rather than word-by-word diff. The word-by-word diff led to excessive memory usage and confusing output in some cases. NOTE: diff now returns lists of lines, not including newlines. So calling programs may need to be changed. diff also now skips calling getGroupedDiff when the left document is empty, for better performance. * Added ghc-prof-options to cabal file. * Clean up code in gitRetrieve. * Added ensureFileExists to Darcs module. Added checks to ensure that file exists in darcsLatestRevId and darcsRetrieve. If not, return NotFound. * gitRetrieve: check to make sure object is a file before retrieving. Also, if Nothing is the revision ID, use gitLatestRevId rather than going directly to the file system. This is a step in the direction of making filestore compatible with bare repositories. * Test suite has been wired into Setup.lhs: 'cabal test' now runs tests. * Added new test case for attempting to retrieve a subdirectory, and for creating a second file in a subdirectory. * Minor code cleanup. * Added CHANGES. Version 0.1 released 24 Jan 2009 * Initial release. filestore-0.6.0.6/Setup.lhs0000644000000000000000000000011412507277577013672 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain filestore-0.6.0.6/filestore.cabal0000644000000000000000000000602412507277577015050 0ustar0000000000000000Name: filestore Version: 0.6.0.6 Cabal-Version: >= 1.10 Build-type: Custom 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 Git, Darcs, and Mercurial modules are provided, and other VCSs or databases could be added. Category: Data Stability: Experimental License: BSD3 License-File: LICENSE Author: John MacFarlane, Gwern Branwen, Sebastiaan Visser Maintainer: jgm@berkeley.edu Bug-Reports: https://github.com/jgm/filestore/issues Data-Files: extra/post-update, CHANGES Source-repository head type: git location: git://github.com/jgm/filestore.git Flag maxcount default: True description: Make use of a recent (>= 2.3.0) Darcs feature which vastly improves the performance of 'latest'. You should disable this flag if you plan to use gitit with an older version of Darcs, or 'latest' will raise an error. Library Build-depends: base >= 4 && < 5, bytestring >= 0.9 && < 1.0, containers >= 0.3 && < 0.6, utf8-string >= 0.3 && < 1.1, filepath >= 1.1 && < 1.5, directory >= 1.0 && < 1.3, parsec >= 2 && < 3.2, process >= 1.0 && < 1.3, time >= 1.1 && < 1.6, xml >= 1.3 && < 1.4, split >= 0.1 && < 0.3, Diff >= 0.2 && < 0.4, old-locale >= 1.0 && < 1.1 Exposed-modules: Data.FileStore, Data.FileStore.Types, Data.FileStore.Git, Data.FileStore.Darcs, Data.FileStore.Mercurial, -- Data.FileStore.Sqlite3, Data.FileStore.Utils, Data.FileStore.Generic Other-modules: Paths_filestore, Data.FileStore.DarcsXml, Data.FileStore.MercurialCommandServer, Data.FileStore.Compat.Locale Default-Extensions: FlexibleInstances, CPP Default-Language: Haskell98 if flag(maxcount) cpp-options: -DUSE_MAXCOUNT if impl(ghc >= 6.12) Ghc-Options: -Wall -fno-warn-unused-do-bind else Ghc-Options: -Wall Ghc-Prof-Options: -auto-all Test-suite test-filestore Type: exitcode-stdio-1.0 Hs-source-dirs: tests Main-is: Tests.hs Default-Language: Haskell98 Build-depends: base >= 4 && < 5, HUnit >= 1.2 && < 1.3, mtl, time, Diff >= 0.2 && < 0.4, filepath >= 1.1 && < 1.5, directory >= 1.1 && < 1.3, filestore filestore-0.6.0.6/LICENSE0000644000000000000000000000261612507277577013100 0ustar0000000000000000All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. filestore-0.6.0.6/Data/0000755000000000000000000000000012507277577012737 5ustar0000000000000000filestore-0.6.0.6/Data/FileStore.hs0000644000000000000000000000160412507277577015170 0ustar0000000000000000{-# LANGUAGE Rank2Types, FlexibleContexts #-} {- | Module : Data.FileStore Copyright : Copyright (C) 2009 John MacFarlane, Gwern Branwen, Sebastiaan Visser License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : GHC 6.10 required Abstract interface to a versioned file store, which can be implemented using a revision-control system or database. Based on ideas from Sebastiaan Visser's "Network.Orchid.Core.Backend". -} module Data.FileStore ( module Data.FileStore.Types , module Data.FileStore.Generic , module Data.FileStore.Git , module Data.FileStore.Darcs , module Data.FileStore.Mercurial ) where import Data.FileStore.Types import Data.FileStore.Generic import Data.FileStore.Git import Data.FileStore.Darcs import Data.FileStore.Mercurial filestore-0.6.0.6/Data/FileStore/0000755000000000000000000000000012507277577014633 5ustar0000000000000000filestore-0.6.0.6/Data/FileStore/DarcsXml.hs0000644000000000000000000000724212507277577016711 0ustar0000000000000000module Data.FileStore.DarcsXml (parseDarcsXML) where import Data.Maybe (catMaybes, fromMaybe) import Data.Char (isSpace) import Data.Time.Format (parseTime) import Data.FileStore.Compat.Locale (defaultTimeLocale) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Text.XML.Light import Data.FileStore.Types (Change(..), Revision(..), Author(..)) import Data.FileStore.Utils (splitEmailAuthor) -- | Take a String presumed to be a Darcs-generated changelog in XML format; -- discard all tags, initializations, etc, leaving only actual patches; -- then convert each patch entry into FileStore's homebrew 'Revision' type. parseDarcsXML :: String -> Maybe [Revision] parseDarcsXML str = do changelog <- parseXMLDoc str let patches = filterChildrenName (\(QName n _ _) -> n == "patch") changelog return $ map parseIntoRevision patches parseIntoRevision :: Element -> Revision parseIntoRevision a = Revision { revId = hashXML a, revDateTime = date a, revAuthor = Author { authorName=authorXML a, authorEmail=emailXML a }, revDescription = descriptionXML a, revChanges = catMaybes $ changesXML a } where -- If we can't get a date from the XML, we default to the beginning of the POSIX era. -- This at least makes it easy for someone to filter out bad dates, as obviously no real DVCSs -- were in operation then. :) -- date :: Element -> UTCTime date = fromMaybe (posixSecondsToUTCTime $ realToFrac (0::Int)) . parseTime defaultTimeLocale "%c" . dateXML authorXML, dateXML, descriptionXML, emailXML, hashXML :: Element -> String authorXML = snd . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing) emailXML = fromMaybe "" . fst . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing) dateXML = fromMaybe "" . findAttr (QName "local_date" Nothing Nothing) hashXML = fromMaybe "" . findAttr (QName "hash" Nothing Nothing) descriptionXML = fromMaybe "" . fmap strContent . findChild (QName "name" Nothing Nothing) -- Perhaps there was no '--summary' option used, in which case there is no 'Change' information we -- can extract. changesXML :: Element -> [Maybe Change] changesXML a = case (changes a) of Just b -> analyze $ filterSummary b Nothing -> [] -- | Extract the file-modification fields changes :: Element -> Maybe Element changes = findElement (QName "summary" Nothing Nothing) analyze :: [Element] -> [Maybe Change] analyze s = map convert s where convert a | x == "add_directory" || x == "add_file" = Just (Added b) | x == "remove_file" || x == "remove_directory" = Just (Deleted b) | x == "added_lines" || x == "modify_file" || x == "removed_lines" || x == "replaced_tokens" || x == "move" = Just (Modified b) | otherwise = Nothing where x = qName . elName $ a b = takeWhile (/='\n') $ dropWhile isSpace $ strContent a filterSummary :: Element -> [Element] filterSummary = filterElementsName (\(QName {qName = x}) -> x == "add_file" || x == "add_directory" || x == "remove_file" || x == "remove_directory" || x == "modify_file" || x == "added_lines" || x == "removed_lines" || x == "replaced_tokens" || x == "move") filestore-0.6.0.6/Data/FileStore/Mercurial.hs0000644000000000000000000003133312507277577017115 0ustar0000000000000000{- | Module : Data.FileStore.Mercurial Copyright : Copyright (C) 2009 John MacFarlane License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : GHC 6.10 required A versioned filestore implemented using mercurial. Normally this module should not be imported: import "Data.FileStore" instead. -} module Data.FileStore.Mercurial ( mercurialFileStore ) where import Data.FileStore.Types import Data.Maybe (fromJust) import System.Exit import Data.FileStore.Utils (withSanityCheck, hashsMatch, withVerifyDir, grepSearchRepo, encodeArg) import Data.FileStore.MercurialCommandServer import Data.ByteString.Lazy.UTF8 (toString) import qualified Data.ByteString.Lazy as B import qualified Text.ParserCombinators.Parsec as P import Data.List (nub) import Control.Monad (when, liftM, unless) import System.FilePath ((), splitDirectories, takeFileName) import System.Directory (createDirectoryIfMissing, doesDirectoryExist) import Control.Exception (throwIO) import Data.FileStore.Compat.Locale (defaultTimeLocale) import Data.Time (parseTime, formatTime) -- | Return a filestore implemented using the mercurial distributed revision control system -- (). mercurialFileStore :: FilePath -> FileStore mercurialFileStore repo = FileStore { initialize = mercurialInit repo , save = mercurialSave repo , retrieve = mercurialRetrieve repo , delete = mercurialDelete repo , rename = mercurialMove repo , history = mercurialLog repo , latest = mercurialLatestRevId repo , revision = mercurialGetRevision repo , index = mercurialIndex repo , directory = mercurialDirectory repo , search = mercurialSearch repo , idsMatch = const hashsMatch repo } -- | Initialize a repository, creating the directory if needed. mercurialInit :: FilePath -> IO () mercurialInit repo = do exists <- doesDirectoryExist repo when exists $ withVerifyDir repo $ throwIO RepositoryExists createDirectoryIfMissing True repo (status, err, _) <- rawRunMercurialCommand repo "init" [] if status == ExitSuccess then -- Add a hook so that changes made remotely via hg will be reflected in -- the working directory. See: -- http://mercurial.selenic.com/wiki/FAQ#FAQ.2BAC8-CommonProblems.Any_way_to_.27hg_push.27_and_have_an_automatic_.27hg_update.27_on_the_remote_server.3F B.writeFile (repo ".hg" "hgrc") $ toByteString "[hooks]\nchangegroup = hg update >&2\n" else throwIO $ UnknownError $ "mercurial init failed:\n" ++ err -- | Commit changes to a resource. Raise 'Unchanged' exception if there were -- no changes. mercurialCommit :: FilePath -> [FilePath] -> Author -> String -> IO () mercurialCommit repo names author logMsg = do let email = authorEmail author email' = if not (null email) then " <" ++ email ++ ">" else "" (statusCommit, errCommit, _) <- runMercurialCommand repo "commit" $ ["--user", authorName author ++ email', "-m", logMsg] ++ names unless (statusCommit == ExitSuccess) $ do throwIO $ if null errCommit then Unchanged else UnknownError $ "Could not hg commit " ++ unwords names ++ "\n" ++ errCommit -- | Save changes (creating file and directory if needed), add, and commit. mercurialSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO () mercurialSave repo name author logMsg contents = do withSanityCheck repo [".hg"] name $ B.writeFile (repo encodeArg name) $ toByteString contents (statusAdd, errAdd, _) <- runMercurialCommand repo "add" ["path:" ++ name] if statusAdd == ExitSuccess then mercurialCommit repo [name] author logMsg else throwIO $ UnknownError $ "Could not hg add '" ++ name ++ "'\n" ++ errAdd -- | Retrieve contents from resource. -- Mercurial does not track directories so catting from a directory returns all files mercurialRetrieve :: Contents a => FilePath -> FilePath -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest -> IO a mercurialRetrieve repo name revid = do let revname = case revid of Nothing -> "tip" Just rev -> rev (statcheck, _, _) <- runMercurialCommand repo "locate" ["-r", revname, "-X", "glob:" ++ name "*", "path:" ++ name] when (statcheck /= ExitSuccess) $ throwIO NotFound (status, err, output) <- runMercurialCommand repo "cat" ["-r", revname, "-X", "glob:" ++ name "*", "path:" ++ name] if status == ExitSuccess then return $ fromByteString output else throwIO $ UnknownError $ "Error in mercurial cat:\n" ++ err -- | Delete a resource from the repository. mercurialDelete :: FilePath -> FilePath -> Author -> Description -> IO () mercurialDelete repo name author logMsg = withSanityCheck repo [".hg"] name $ do (statusAdd, errRm, _) <- runMercurialCommand repo "remove" ["path:" ++ name] if statusAdd == ExitSuccess then mercurialCommit repo [name] author logMsg else throwIO $ UnknownError $ "Could not hg rm '" ++ name ++ "'\n" ++ errRm -- | Change the name of a resource. mercurialMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO () mercurialMove repo oldName newName author logMsg = do mercurialLatestRevId repo oldName -- will throw a NotFound error if oldName doesn't exist (statusAdd, err, _) <- withSanityCheck repo [".hg"] newName $ runMercurialCommand repo "mv" [oldName, newName] if statusAdd == ExitSuccess then mercurialCommit repo [oldName, newName] author logMsg else throwIO $ UnknownError $ "Could not hg mv " ++ oldName ++ " " ++ newName ++ "\n" ++ err -- | Return revision ID for latest commit for a resource. mercurialLatestRevId :: FilePath -> FilePath -> IO RevisionId mercurialLatestRevId repo name = do (status, _, output) <- runMercurialCommand repo "log" ["--template", "{node}\\n{file_dels}\\n", "--limit", "1", "--removed", "path:" ++ name] if status == ExitSuccess then do let result = lines $ toString output if null result || name `elem` drop 1 result then throwIO NotFound else return $ head result else throwIO NotFound -- | Get revision information for a particular revision ID, or latest revision. mercurialGetRevision :: FilePath -> RevisionId -> IO Revision mercurialGetRevision repo revid = do (status, _, output) <- runMercurialCommand repo "log" ["--template", mercurialLogFormat, "--limit", "1", "-r", revid] if status == ExitSuccess then case P.parse parseMercurialLog "" (toString output) of Left err' -> throwIO $ UnknownError $ "error parsing mercurial log: " ++ show err' Right [r] -> return r Right [] -> throwIO NotFound Right xs -> throwIO $ UnknownError $ "mercurial log returned more than one result: " ++ show xs else throwIO NotFound -- | Get a list of all known files inside and managed by a repository. mercurialIndex :: FilePath ->IO [FilePath] mercurialIndex repo = withVerifyDir repo $ do (status, _err, output) <- runMercurialCommand repo "manifest" ["-r", "tip"] if status == ExitSuccess then return $ lines $ toString $ output else return [] -- if error, will return empty list -- | Get list of resources in one directory of the repository. Mercurial does not store or track directories, -- so the locate command does not return any directories. Instead we first list all the files, then list all -- files in subdirectories of the given directory and use that to contruct the list of directories. mercurialDirectory :: FilePath -> FilePath -> IO [Resource] mercurialDirectory repo dir = withVerifyDir (repo dir) $ do (status, _, output) <- runMercurialCommand repo "locate" ["-r", "tip", "glob:" ++ (dir "*")] let files = if status == ExitSuccess then map (FSFile . takeFileName . removePrefix dir) $ lines $ toString output else [] (status2, _, output2) <- runMercurialCommand repo "locate" ["-r", "tip", "glob:" ++ (dir "*" "*")] let dirs = if status2 == ExitSuccess then map FSDirectory $ nub $ map (head . splitDirectories . removePrefix dir) $ lines $ toString output2 else [] return $ files ++ dirs where removePrefix d = drop $ length d -- | Use generic grep to search mercurialSearch :: FilePath -> SearchQuery -> IO [SearchMatch] mercurialSearch = grepSearchRepo mercurialIndex {- The following code goes not work because of a bug in mercurial. If the final line of a file does not end with a newline and you search for a word in the final line, hg does not display the line from the file correctly. In the results, the last character line is not printed. mercurialSearch repo query = do let patterns = map escapeRegexSpecialChars $ queryPatterns query pattern = if queryWholeWords query then "(\\b" ++ foldr1 (\a b -> a ++ "\\b|\\b" ++ b) patterns ++ "\\b)" else "(" ++ foldr1 (\a b -> a ++ "|" ++ b) patterns ++ ")" (status, errOutput, output) <- runMercurialCommand repo "grep" (["--ignore-case" | queryIgnoreCase query] ++ ["-n", "-0", pattern]) case status of ExitSuccess -> do putStrLn $ show output case P.parse parseMercurialSearch "" (toString output) of Left err' -> throwIO $ UnknownError $ "Error parsing mercurial search results.\n" ++ show err' Right parsed -> return parsed ExitFailure 1 -> return [] -- status of 1 means no matches ExitFailure _ -> throwIO $ UnknownError $ "mercurial grep returned error status.\n" ++ errOutput -} mercurialLogFormat :: String mercurialLogFormat = "{node}\\n{date|rfc822date}\\n{author|person}\\n{author|email}\\n{desc}\\x00{file_adds}\\x00{file_mods}\\x00{file_dels}\\x00" -- | Return list of log entries for the given time frame and list of resources. -- If list of resources is empty, log entries for all resources are returned. mercurialLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision] mercurialLog repo names (TimeRange mbSince mbUntil) mblimit = do (status, err, output) <- runMercurialCommand repo "log" $ ["--template", mercurialLogFormat] ++ revOpts mbSince mbUntil ++ limit ++ names if status == ExitSuccess then case P.parse parseMercurialLog "" (toString output) of Left err' -> throwIO $ UnknownError $ "Error parsing mercurial log.\n" ++ show err' Right parsed -> return parsed else throwIO $ UnknownError $ "mercurial log returned error status.\n" ++ err where revOpts Nothing Nothing = [] revOpts Nothing (Just u) = ["-d", "<" ++ showTime u] revOpts (Just s) Nothing = ["-d", ">" ++ showTime s] revOpts (Just s) (Just u) = ["-d", showTime s ++ " to " ++ showTime u] showTime = formatTime defaultTimeLocale "%F %X" limit = case mblimit of Just lim -> ["--limit", show lim] Nothing -> [] -- -- Parsers to parse mercurial log into Revisions. -- parseMercurialLog :: P.Parser [Revision] parseMercurialLog = P.manyTill mercurialLogEntry P.eof wholeLine :: P.GenParser Char st String wholeLine = P.manyTill P.anyChar P.newline nonblankLine :: P.GenParser Char st String nonblankLine = P.notFollowedBy P.newline >> wholeLine nullStr :: P.GenParser Char st String nullStr = P.manyTill P.anyChar (P.satisfy (=='\x00')) mercurialLogEntry :: P.Parser Revision mercurialLogEntry = do rev <- nonblankLine date <- nonblankLine author <- nonblankLine email <- wholeLine subject <- nullStr P.spaces file_add <- liftM (map Added . lines) $ nullStr P.spaces file_mod <- liftM (map Modified . lines) $ nullStr P.spaces file_del <- liftM (map Deleted . lines) $ nullStr P.spaces let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse return Revision { revId = rev , revDateTime = fromJust (parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" date :: Maybe UTCTime) , revAuthor = Author { authorName = author, authorEmail = email } , revDescription = stripTrailingNewlines subject , revChanges = file_add ++ file_mod ++ file_del } {- parseMercurialSearch :: P.Parser [SearchMatch] parseMercurialSearch = P.manyTill mercurialSearchFormat P.eof mercurialSearchFormat :: P.Parser SearchMatch mercurialSearchFormat = do fname <- nullStr nullStr -- revision number lineNum <- nullStr txt <- nullStr return SearchMatch { matchResourceName = fname , matchLineNumber = read lineNum , matchLine = txt } -} filestore-0.6.0.6/Data/FileStore/Types.hs0000644000000000000000000001715512507277577016304 0ustar0000000000000000{-# LANGUAGE Rank2Types, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances #-} {- | Module : Data.FileStore.Types Copyright : Copyright (C) 2009 John MacFarlane License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : GHC 6.10 required Type definitions for "Data.FileStore". -} module Data.FileStore.Types ( RevisionId , Resource(..) , Author(..) , Change(..) , Description , Revision(..) , Contents(..) , TimeRange(..) , MergeInfo(..) , FileStoreError(..) , SearchMatch(..) , SearchQuery(..) , defaultSearchQuery , UTCTime , FileStore (..) ) where import Data.ByteString.Lazy (ByteString) import Data.Typeable import Data.ByteString.Lazy.UTF8 (toString, fromString) import Data.Time (UTCTime) import Control.Exception (Exception) type RevisionId = String data Resource = FSFile FilePath | FSDirectory FilePath deriving (Show, Read, Eq, Typeable, Ord) data Author = Author { authorName :: String , authorEmail :: String } deriving (Show, Read, Eq, Typeable) data Change = Added FilePath | Deleted FilePath | Modified FilePath deriving (Show, Read, Eq, Typeable) type Description = String data Revision = Revision { revId :: RevisionId , revDateTime :: UTCTime , revAuthor :: Author , revDescription :: Description , revChanges :: [Change] } deriving (Show, Read, Eq, Typeable) class Contents a where fromByteString :: ByteString -> a toByteString :: a -> ByteString instance Contents ByteString where toByteString = id fromByteString = id instance Contents String where toByteString = fromString fromByteString = toString data TimeRange = TimeRange { timeFrom :: Maybe UTCTime -- ^ @Nothing@ means no lower bound , timeTo :: Maybe UTCTime -- ^ @Nothing@ means no upper bound } deriving (Show, Read, Eq, Typeable) data MergeInfo = MergeInfo { mergeRevision :: Revision -- ^ The revision w/ which changes were merged , mergeConflicts :: Bool -- ^ @True@ if there were merge conflicts , mergeText :: String -- ^ The merged text, w/ conflict markers } deriving (Show, Read, Eq, Typeable) data FileStoreError = RepositoryExists -- ^ Tried to initialize a repo that exists | ResourceExists -- ^ Tried to create a resource that exists | NotFound -- ^ Requested resource was not found | IllegalResourceName -- ^ The specified resource name is illegal | Unchanged -- ^ The resource was not modified, -- because the contents were unchanged | UnsupportedOperation | NoMaxCount -- ^ The darcs version used does not support -- --max-count | UnknownError String deriving (Read, Eq, Typeable) instance Show FileStoreError where show RepositoryExists = "RepositoryExists" show ResourceExists = "ResourceExists" show NotFound = "NotFound" show IllegalResourceName = "IllegalResourceName" show Unchanged = "Unchanged" show UnsupportedOperation = "UnsupportedOperation" show NoMaxCount = "NoMaxCount:\n" ++ "filestore was compiled with the maxcount flag, but your version of\n" ++ "darcs does not support the --max-count option. You should either\n" ++ "upgrade to darcs >= 2.3.0 (recommended) or compile filestore without\n" ++ "the maxcount flag (cabal install filestore -f-maxcount)." show (UnknownError s) = "UnknownError: " ++ s instance Exception FileStoreError data SearchQuery = SearchQuery { queryPatterns :: [String] -- ^ Patterns to match , queryWholeWords :: Bool -- ^ Match patterns only with whole words? , queryMatchAll :: Bool -- ^ Return matches only from files in which -- all patterns match? , queryIgnoreCase :: Bool -- ^ Make matches case-insensitive? } deriving (Show, Read, Eq, Typeable) defaultSearchQuery :: SearchQuery defaultSearchQuery = SearchQuery { queryPatterns = [] , queryWholeWords = True , queryMatchAll = True , queryIgnoreCase = True } data SearchMatch = SearchMatch { matchResourceName :: FilePath , matchLineNumber :: Integer , matchLine :: String } deriving (Show, Read, Eq, Typeable) -- | A versioning filestore, which can be implemented using the -- file system, a database, or revision-control software. data FileStore = FileStore { -- | Initialize a new filestore. initialize :: IO () -- | Save contents in the filestore. , save :: Contents a => FilePath -- Resource to save. -> Author -- Author of change. -> Description -- Description of change. -> a -- New contents of resource. -> IO () -- | Retrieve the contents of the named resource. , retrieve :: Contents a => FilePath -- Resource to retrieve. -> Maybe RevisionId -- @Just@ a particular revision ID, -- or @Nothing@ for latest -> IO a -- | Delete a named resource, providing author and log message. , delete :: FilePath -- Resource to delete. -> Author -- Author of change. -> Description -- Description of change. -> IO () -- | Rename a resource, providing author and log message. , rename :: FilePath -- Resource original name. -> FilePath -- Resource new name. -> Author -- Author of change. -> Description -- Description of change. -> IO () -- | Get history for a list of named resources in a (possibly openended) -- time range. If the list is empty, history for all resources will -- be returned. If the TimeRange is 2 Nothings, history for all dates will be returned. , history :: [FilePath] -- List of resources to get history for -- or @[]@ for all. -> TimeRange -- Time range in which to get history. -> Maybe Int -- Maybe max number of entries. -> IO [Revision] -- | Return the revision ID of the latest change for a resource. -- Raises 'NotFound' if the resource is not found. , latest :: FilePath -- Resource to get revision ID for. -> IO RevisionId -- | Return information about a revision, given the ID. -- Raises 'NotFound' if there is no such revision. , revision :: RevisionId -- Revision ID to get information for. -> IO Revision -- | Return a list of resources in the filestore. , index :: IO [FilePath] -- | Return a list of resources in a directory of the filestore. , directory :: FilePath -- Directory to list (empty for root) -> IO [Resource] -- | @True@ if the revision IDs match, in the sense that the -- can be treated as specifying the same revision. , idsMatch :: RevisionId -> RevisionId -> Bool -- | Search the filestore for patterns. , search :: SearchQuery -> IO [SearchMatch] } filestore-0.6.0.6/Data/FileStore/MercurialCommandServer.hs0000644000000000000000000002454712507277577021614 0ustar0000000000000000{-# 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 filestore-0.6.0.6/Data/FileStore/Generic.hs0000644000000000000000000001441612507277577016551 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Data.FileStore.Generic Copyright : Copyright (C) 2009 John MacFarlane, Gwern Branwen, Sebastiaan Visser License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : GHC 6.10 required Generic utility functions for working with filestores. -} module Data.FileStore.Generic ( modify , create , Diff(..) , diff , searchRevisions , smartRetrieve , richDirectory ) where import Data.FileStore.Types import Control.Exception as E import Data.FileStore.Utils import Data.List (isInfixOf) import Data.Algorithm.Diff (Diff(..), getGroupedDiff) import System.FilePath (()) handleUnknownError :: E.SomeException -> IO a handleUnknownError = E.throwIO . UnknownError . show -- | Like save, but first verify that the resource name is new. If not, throws a 'ResourceExists' -- error. create :: Contents a => FileStore -> FilePath -- ^ Resource to create. -> Author -- ^ Author of change. -> Description -- ^ Description of change. -> a -- ^ Contents of resource. -> IO () 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 E.throwIO e) -- | Modify a named resource in the filestore. Like save, except that a revision ID -- must be specified. If the resource has been modified since the specified revision, -- @Left@ merge information is returned. Otherwise, @Right@ the new contents are saved. modify :: Contents a => FileStore -> FilePath -- ^ Resource to create. -> RevisionId -- ^ ID of previous revision that is being modified. -> Author -- ^ Author of change. -> Description -- ^ Description of change. -> a -- ^ Contents of resource. -> IO (Either MergeInfo ()) modify fs name originalRevId author msg contents = do latestRevId <- latest fs name latestRev <- revision fs latestRevId if idsMatch fs originalRevId latestRevId then save fs name author msg contents >> return (Right ()) else do latestContents <- retrieve fs name (Just latestRevId) originalContents <- retrieve fs name (Just originalRevId) (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 @[(Diff, [String])]@, where -- @DI@ is @F@ (in first document only), @S@ (in second only), -- or @B@ (in both), and the list is a list of lines (without -- newlines at the end). diff :: FileStore -> 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 [Diff [String]] diff fs name Nothing id2 = do contents2 <- retrieve fs name id2 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 return $ getGroupedDiff (lines contents1) (lines contents2) -- | Return a list of all revisions that are saved with the given -- description or with a part of this description. searchRevisions :: FileStore -> Bool -- ^ When true the description must -- match exactly, when false partial -- hits are allowed. -> FilePath -- ^ The resource to search history for. -> Description -- ^ Revision description to search for. -> IO [Revision] searchRevisions repo exact name desc = do let matcher = if exact then (== desc) else (desc `isInfixOf`) 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 -- revision identifier. When retrieving a resource by revision identifier fails -- this function will try to fetch the latest revision for which the -- description matches the given string. smartRetrieve :: Contents a => FileStore -> Bool -- ^ @True@ for exact description match, @False@ for partial match. -> FilePath -- ^ Resource name to retrieve. -> Maybe String -- ^ @Just@ revision ID or description, or @Nothing@ for empty. -> IO a smartRetrieve fs exact name mrev = do edoc <- 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) -> E.throwIO (e :: FileStoreError) -- Retrieval failed, we can try fetching a revision by the description. (Left _, Just rev) -> do revs <- searchRevisions fs exact name rev if Prelude.null revs -- No revisions containing this description. then E.throwIO NotFound -- Retrieve resource for latest matching revision. else retrieve fs name (Just $ revId $ Prelude.head revs) -- | Like 'directory', but returns information about the latest revision. richDirectory :: FileStore -> FilePath -> IO [(Resource, Either String Revision)] richDirectory fs fp = directory fs fp >>= mapM f where f r = E.catch (g r) (\(e :: FileStoreError)-> return ( r, Left . show $ e ) ) g r@(FSDirectory _dir) = return (r,Left "richDirectory, we don't care about revision info for directories") g res@(FSFile file) = do rev <- revision fs =<< latest fs ( fp file ) return (res,Right rev) filestore-0.6.0.6/Data/FileStore/Utils.hs0000644000000000000000000003014312507277577016270 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables #-} {- | Module : Data.FileStore.Utils Copyright : Copyright (C) 2009 John MacFarlane, Gwern Branwen License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : portable Utility functions for running external processes. -} module Data.FileStore.Utils ( runShellCommand , mergeContents , hashsMatch , escapeRegexSpecialChars , parseMatchLine , splitEmailAuthor , ensureFileExists , regSearchFiles , regsSearchFile , withSanityCheck , grepSearchRepo , withVerifyDir , encodeArg ) where import Control.Exception (throwIO) 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 (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 -> Maybe [(String, String)] -- ^ Environment -> String -- ^ Command -> [String] -- ^ Arguments -> IO (ExitCode, B.ByteString, B.ByteString) runShellCommand workingDir environment command optionList = do tempPath <- E.catch getTemporaryDirectory (\(_ :: E.SomeException) -> return ".") (outputPath, hOut) <- openTempFile tempPath "out" (errorPath, hErr) <- openTempFile tempPath "err" env <- liftM2 (++) environment . Just <$> getEnvironment hProcess <- runProcess (encodeArg command) (map encodeArg optionList) (Just workingDir) env Nothing (Just hOut) (Just hErr) status <- waitForProcess hProcess errorOutput <- S.readFile errorPath output <- S.readFile outputPath removeFile errorPath removeFile outputPath 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. mergeContents :: (String, B.ByteString) -- ^ (label, contents) of edited version -> (String, B.ByteString) -- ^ (label, contents) of original revision -> (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 <- E.catch getTemporaryDirectory (\(_ :: E.SomeException) -> return ".") (originalPath, hOriginal) <- openTempFile tempPath "orig" (latestPath, hLatest) <- openTempFile tempPath "latest" (newPath, hNew) <- openTempFile tempPath "new" B.hPutStr hOriginal originalContents >> hClose hOriginal B.hPutStr hLatest latestContents >> hClose hLatest B.hPutStr hNew newContents >> hClose hNew gitExists <- liftM isJust (findExecutable "git") (conflicts, mergedContents) <- if gitExists then do (status, err, out) <- runShellCommand tempPath Nothing "git" ["merge-file", "--stdout", "-L", newLabel, "-L", originalLabel, "-L", latestLabel, newPath, originalPath, latestPath] case status of ExitSuccess -> return (False, out) ExitFailure n | n >= 0 -> return (True, out) _ -> error $ "merge failed: " ++ toString err else do mergeExists <- liftM isJust (findExecutable "merge") if mergeExists then do (status, err, out) <- runShellCommand tempPath Nothing "merge" ["-p", "-q", "-L", newLabel, "-L", originalLabel, "-L", latestLabel, newPath, originalPath, latestPath] case status of ExitSuccess -> return (False, out) ExitFailure 1 -> return (True, out) _ -> error $ "merge failed: " ++ toString err else error "mergeContents requires 'git' or 'merge', and neither was found in the path." removeFile originalPath removeFile latestPath removeFile newPath return (conflicts, toString mergedContents) escapeRegexSpecialChars :: String -> String escapeRegexSpecialChars = backslashEscape "?*+{}[]\\^$.()" where backslashEscape chars (x:xs) | x `elem` chars = '\\' : x : backslashEscape chars xs backslashEscape chars (x:xs) = x : backslashEscape chars xs backslashEscape _ [] = [] -- | A number of VCS systems uniquely identify a particular revision or change via a -- cryptographic hash of some sort. These hashs can be very long, and so systems like -- Git and Darcs don't require the entire hash - a *unique prefix*. Thus a definition -- of hash equality is '==', certainly, but also simply whether either is a prefix of the -- other. If both are reasonably long, then the likelihood the shorter one is not a unique -- prefix of the longer (that is, clashes with another hash) is small. -- The burden of proof is on the caller to not pass a uselessly short short-hash like '1', however. hashsMatch :: (Eq a) => [a] -> [a] -> Bool hashsMatch r1 r2 = r1 `isPrefixOf` r2 || r2 `isPrefixOf` r1 -- | 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. -- 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 -- 3 fields: the filename, the line number, and then the matching line itself. Note that this -- is for use on only strings meeting that format - if it goes "file:match", this will throw -- a pattern-match exception. -- -- > parseMatchLine "foo:10:bar baz quux" ~> -- > SearchMatch {matchResourceName = "foo", matchLineNumber = 10, matchLine = "bar baz quux"} parseMatchLine :: String -> SearchMatch parseMatchLine str = let (fn:n:res:_) = splitWhen (==':') str in SearchMatch{matchResourceName = fn, matchLineNumber = read n, matchLine = res} -- | Our policy is: if the input is clearly a "name \" input, then we return "(Just Address, Name)" -- If there is no '<' in the input, then it clearly can't be of that format, and so we just return "(Nothing, Name)" -- -- > splitEmailAuthor "foo bar baz@gmail.com" ~> (Nothing,"foo bar baz@gmail.com") -- > splitEmailAuthor "foo bar " ~> (Just "baz@gmail.com","foo bar") splitEmailAuthor :: String -> (Maybe String, String) splitEmailAuthor x = (mbEmail, trim name) where (name, rest) = break (=='<') x mbEmail = if null rest then Nothing else Just $ takeWhile (/='>') $ drop 1 rest -- | Trim leading and trailing spaces trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace -- | Search multiple files with a single regexp. -- This calls out to grep, and so supports the regular expressions grep does. regSearchFiles :: FilePath -> [String] -> String -> IO [String] regSearchFiles repo filesToCheck pattern = do (_, _, result) <- runShellCommand repo Nothing "grep" $ ["--line-number", "-I", "-l", "-E", "-e", pattern] ++ filesToCheck let results = intersect filesToCheck $ lines $ toString result return results -- | Search a single file with multiple regexps. regsSearchFile :: [String] -> FilePath -> [String] -> String -> IO [String] regsSearchFile os repo patterns file = do res <- mapM (run file) patterns return $ nub $ concat res where run f p = do (_,_,r) <- runShellCommand repo Nothing "grep" (os ++ [p, f]) return $ lines $ toString r -- | If name doesn't exist in repo or is not a file, throw 'NotFound' exception. ensureFileExists :: FilePath -> FilePath -> IO () ensureFileExists repo name = do isFile <- doesFileExist (repo encodeArg name) unless isFile $ throwIO NotFound -- | Check that the filename/location is within the given repo, and not inside -- any of the (relative) paths in @excludes@. Create the directory if needed. -- If everything checks out, then perform the specified action. withSanityCheck :: FilePath -> [FilePath] -> FilePath -> IO b -> IO b withSanityCheck repo excludes name action = do let filename = repo encodeArg name let insideRepo = filename `isInsideDir` repo let insideExcludes = or $ map (filename `isInsideDir`) $ map (repo ) excludes when (insideExcludes || not insideRepo) $ throwIO IllegalResourceName createDirectoryIfMissing True $ takeDirectory filename action -- | Uses grep to search a file-based repository. Note that this calls out to grep; and so -- is generic over repos like git or darcs-based repos. (The git FileStore instance doesn't -- use this because git has builtin grep functionality.) -- Expected usage is to specialize this function with a particular backend's 'index'. grepSearchRepo :: (FilePath -> IO [String]) -> FilePath -> SearchQuery -> IO [SearchMatch] grepSearchRepo indexer repo query = do let opts = ["-I", "--line-number", "--with-filename"] ++ ["-i" | queryIgnoreCase query] ++ (if queryWholeWords query then ["--word-regexp"] else ["-E"]) let regexps = map escapeRegexSpecialChars $ queryPatterns query files <- indexer repo if queryMatchAll query then do filesMatchingAllPatterns <- liftM (foldr1 intersect) $ mapM (regSearchFiles repo files) regexps output <- mapM (regsSearchFile opts repo regexps) filesMatchingAllPatterns return $ map parseMatchLine $ concat output else do (_status, _errOutput, output) <- runShellCommand repo Nothing "grep" $ opts ++ concatMap (\term -> ["-e", term]) regexps ++ files let results = lines $ toString output return $ map parseMatchLine results -- | we don't actually need the contents, just want to check that the directory exists and we have enough permissions withVerifyDir :: FilePath -> IO a -> IO a withVerifyDir d a = E.catch (liftM head (getDirectoryContents $ encodeArg d) >> a) $ \(e :: E.IOException) -> if isDoesNotExistError e then throwIO NotFound else throwIO . UnknownError . show $ e filestore-0.6.0.6/Data/FileStore/Git.hs0000644000000000000000000003273312507277577015722 0ustar0000000000000000{- | Module : Data.FileStore.Git Copyright : Copyright (C) 2009 John MacFarlane License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : GHC 6.10 required A versioned filestore implemented using git. Normally this module should not be imported: import "Data.FileStore" instead. -} module Data.FileStore.Git ( gitFileStore ) where import Data.FileStore.Types import Data.Maybe (mapMaybe) import Data.List.Split (endByOneOf) import System.Exit import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, escapeRegexSpecialChars, withVerifyDir, encodeArg) import Data.ByteString.Lazy.UTF8 (toString) import qualified Data.ByteString.Lazy.Char8 as B import Control.Monad (when) import System.FilePath (()) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, executable, getPermissions, setPermissions) import Control.Exception (throwIO) import Paths_filestore -- | Return a filestore implemented using the git distributed revision control system -- (). gitFileStore :: FilePath -> FileStore gitFileStore repo = FileStore { initialize = gitInit repo , save = gitSave repo , retrieve = gitRetrieve repo , delete = gitDelete repo , rename = gitMove repo , history = gitLog repo , latest = gitLatestRevId repo , revision = gitGetRevision repo , index = gitIndex repo , directory = gitDirectory repo , search = gitSearch repo , idsMatch = const hashsMatch repo } -- | Run a git command and return error status, error output, standard output. The repository -- is used as working directory. runGitCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString) runGitCommand repo command args = do let env = Just [("GIT_DIFF_OPTS","-u100000")] (status, err, out) <- runShellCommand repo env "git" (command : args) return (status, toString err, out) -- | Initialize a repository, creating the directory if needed. gitInit :: FilePath -> IO () gitInit repo = do exists <- doesDirectoryExist repo when exists $ withVerifyDir repo $ throwIO RepositoryExists createDirectoryIfMissing True repo (status, err, _) <- runGitCommand repo "init" [] if status == ExitSuccess then do -- Add the post-update hook, so that changes made remotely via git -- will be reflected in the working directory. postupdatepath <- getDataFileName $ "extra" "post-update" postupdatecontents <- B.readFile postupdatepath let postupdate = repo ".git" "hooks" "post-update" B.writeFile postupdate postupdatecontents perms <- getPermissions postupdate setPermissions postupdate (perms {executable = True}) -- Set up repo to allow push to current branch (status', err', _) <- runGitCommand repo "config" ["receive.denyCurrentBranch","ignore"] if status' == ExitSuccess then return () else throwIO $ UnknownError $ "git config failed:\n" ++ err' else throwIO $ UnknownError $ "git-init failed:\n" ++ err -- | Commit changes to a resource. Raise 'Unchanged' exception if there were -- no changes. gitCommit :: FilePath -> [FilePath] -> Author -> String -> IO () gitCommit repo names author logMsg = do (statusCommit, errCommit, _) <- runGitCommand repo "commit" $ ["--author", authorName author ++ " <" ++ authorEmail author ++ ">", "-m", logMsg] ++ names if statusCommit == ExitSuccess then return () else throwIO $ if null errCommit then Unchanged else UnknownError $ "Could not git commit " ++ unwords names ++ "\n" ++ errCommit -- | Save changes (creating file and directory if needed), add, and commit. gitSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO () gitSave repo name author logMsg contents = do 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 -- | Retrieve contents from resource. gitRetrieve :: Contents a => FilePath -> FilePath -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest -> IO a gitRetrieve repo name revid = do let objectName = case revid of Nothing -> "HEAD:" ++ name Just rev -> rev ++ ":" ++ name -- Check that the object is a file (blob), not a directory (tree) (_, _, output) <- runGitCommand repo "cat-file" ["-t", objectName] when (take 4 (toString output) /= "blob") $ throwIO NotFound (status', err', output') <- runGitCommand repo "cat-file" ["-p", objectName] if status' == ExitSuccess then return $ fromByteString output' else throwIO $ UnknownError $ "Error in git cat-file:\n" ++ err' -- | Delete a resource from the repository. gitDelete :: FilePath -> FilePath -> Author -> Description -> IO () gitDelete repo name author logMsg = withSanityCheck repo [".git"] name $ do (statusAdd, errRm, _) <- runGitCommand repo "rm" [name] if statusAdd == ExitSuccess then gitCommit repo [name] author logMsg else throwIO $ UnknownError $ "Could not git rm '" ++ name ++ "'\n" ++ errRm -- | Change the name of a resource. gitMove :: FilePath -> 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] if statusAdd == ExitSuccess then gitCommit repo [oldName, newName] author logMsg else throwIO $ UnknownError $ "Could not git mv " ++ oldName ++ " " ++ newName ++ "\n" ++ err -- | Return revision ID for latest commit for a resource. gitLatestRevId :: FilePath -> FilePath -> IO RevisionId gitLatestRevId repo name = do (revListStatus, _, output) <- runGitCommand repo "rev-list" ["--max-count=1", "HEAD", "--", name] -- we need to check separately to make sure the resource hasn't been removed -- from the repository: (catStatus,_, _) <- runGitCommand repo "cat-file" ["-e", "HEAD:" ++ name] if revListStatus == ExitSuccess && catStatus == ExitSuccess then do let result = takeWhile (`notElem` "\n\r \t") $ toString output if null result then throwIO NotFound else return result else throwIO NotFound -- | 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] if status == ExitSuccess 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. gitIndex :: FilePath ->IO [FilePath] gitIndex repo = withVerifyDir repo $ do (status, _err, output) <- runGitCommand repo "ls-tree" ["-r","-t","-z","HEAD"] if status == ExitSuccess then return $ mapMaybe (lineToFilename . words) . endByOneOf ['\0'] . toString $ output else return [] -- if error, will return empty list -- note: on a newly initialized repo, 'git ls-tree HEAD' returns an error where lineToFilename (_:"blob":_:rest) = Just $ unwords rest lineToFilename _ = Nothing -- | Get list of resources in one directory of the repository. gitDirectory :: FilePath -> FilePath -> IO [Resource] gitDirectory repo dir = withVerifyDir (repo dir) $ do (status, _err, output) <- runGitCommand repo "ls-tree" ["-z","HEAD:" ++ dir] if status == ExitSuccess then return $ map (lineToResource . words) $ endByOneOf ['\0'] $ toString output else return [] -- if error, this will return empty list -- note: on a newly initialized repo, 'git ls-tree HEAD:' returns an error where lineToResource (_:"blob":_:rest) = FSFile $ unwords rest lineToResource (_:"tree":_:rest) = FSDirectory $ unwords rest lineToResource _ = error "Encountered an item that is neither blob nor tree in git ls-tree" -- | Uses git-grep to search repository. Escape regex special characters, so the pattern -- is interpreted as an ordinary string. gitSearch :: FilePath -> SearchQuery -> IO [SearchMatch] gitSearch repo query = do let opts = ["-I","-n","--null"] ++ ["--ignore-case" | queryIgnoreCase query] ++ ["--all-match" | queryMatchAll query] ++ ["--word-regexp" | queryWholeWords query] (status, errOutput, output) <- runGitCommand repo "grep" (opts ++ concatMap (\term -> ["-e", escapeRegexSpecialChars term]) (queryPatterns query)) case status of ExitSuccess -> return $ map parseMatchLine $ lines $ toString output ExitFailure 1 -> return [] -- status of 1 means no matches in recent versions of git ExitFailure _ -> throwIO $ UnknownError $ "git grep returned error status.\n" ++ errOutput -- Auxiliary function for searchResults parseMatchLine :: String -> SearchMatch parseMatchLine str = SearchMatch{ matchResourceName = fname , matchLineNumber = if not (null ln) then read ln else error $ "parseMatchLine: " ++ str , matchLine = cont} where (fname,xs) = break (== '\NUL') str rest = drop 1 xs -- for some reason, NUL is used after line number instead of -- : when --match-all is passed to git-grep. (ln,ys) = span (`elem` ['0'..'9']) rest cont = drop 1 ys -- drop : or NUL after line number {- -- | Uses git-diff to get a dif between two revisions. gitDiff :: FilePath -> FilePath -> RevisionId -> RevisionId -> IO String gitDiff repo name from to = do (status, _, output) <- runGitCommand repo "diff" [from, to, name] if status == ExitSuccess then return $ toString output else do -- try it without the path, since the error might be "not in working tree" for a deleted file (status', err', output') <- runGitCommand repo "diff" [from, to] if status' == ExitSuccess then return $ toString output' else throwIO $ UnknownError $ "git diff returned error:\n" ++ err' -} gitLogFormat :: String gitLogFormat = "%x01%H%x00%ct%x00%an%x00%ae%x00%B%n%x00" -- | Return list of log entries for the given time frame and list of resources. -- If list of resources is empty, log entries for all resources are returned. gitLog :: FilePath -> [FilePath] -> TimeRange -> Maybe Int -> IO [Revision] gitLog repo names (TimeRange mbSince mbUntil) mblimit = do (status, err, output) <- runGitCommand repo "whatchanged" $ ["-z","--pretty=format:" ++ gitLogFormat] ++ (case mbSince of Just since -> ["--since='" ++ show since ++ "'"] Nothing -> []) ++ (case mbUntil of Just til -> ["--until='" ++ show til ++ "'"] Nothing -> []) ++ (case mblimit of Just lim -> ["-n", show lim] Nothing -> []) ++ ["--"] ++ names if status == ExitSuccess then parseGitLog output else throwIO $ UnknownError $ "git whatchanged returned error status.\n" ++ err -- -- Parsers to parse git log into Revisions. -- parseGitLog :: B.ByteString -> IO [Revision] parseGitLog = mapM parseLogEntry . splitEntries splitEntries :: B.ByteString -> [B.ByteString] splitEntries = dropWhile B.null . B.split '\1' -- occurs just before each hash 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 = toString rev , revDateTime = posixSecondsToUTCTime $ realToFrac date , revAuthor = Author{ authorName = toString author , authorEmail = toString email } , revDescription = toString $ stripTrailingNewlines subject , revChanges = changes } stripTrailingNewlines :: B.ByteString -> B.ByteString stripTrailingNewlines = B.reverse . B.dropWhile (=='\n') . B.reverse parseChanges :: [B.ByteString] -> IO [Change] parseChanges (x:y:zs) = do when (B.null x) $ throwIO $ UnknownError "parseChanges found empty change description" let changeType = B.last x let file' = toString y let next = case changeType of 'A' -> Added file' 'M' -> Modified file' 'D' -> Deleted file' _ -> Modified file' rest <- parseChanges zs return (next:rest) parseChanges [_] = throwIO $ UnknownError $ "parseChanges encountered odd number of fields" parseChanges [] = return [] filestore-0.6.0.6/Data/FileStore/Darcs.hs0000644000000000000000000002461612507277577016234 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : Data.FileStore.Darcs Copyright : Copyright (C) 2009 Gwern Branwen License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : GHC 6.10 required A versioned filestore implemented using darcs. Normally this module should not be imported: import "Data.FileStore" instead. -} module Data.FileStore.Darcs ( darcsFileStore ) where import Control.Exception (throwIO) import Control.Monad (when) import Data.Time (formatTime) import Data.FileStore.Compat.Locale (defaultTimeLocale) import Data.List (sort, isPrefixOf) #ifdef USE_MAXCOUNT import Data.List (isInfixOf) #endif import System.Exit (ExitCode(..)) import System.Directory (doesDirectoryExist, createDirectoryIfMissing) import System.FilePath ((), dropFileName, addTrailingPathSeparator) import Data.FileStore.DarcsXml (parseDarcsXML) import Data.FileStore.Types import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, ensureFileExists, grepSearchRepo, withVerifyDir, encodeArg) import Data.ByteString.Lazy.UTF8 (toString) import qualified Data.ByteString.Lazy as B (ByteString, writeFile, null) -- | Return a filestore implemented using the Darcs distributed revision control system -- (). darcsFileStore :: FilePath -> FileStore darcsFileStore repo = FileStore { initialize = darcsInit repo , save = darcsSave repo , retrieve = darcsRetrieve repo , delete = darcsDelete repo , rename = darcsMove repo , history = darcsLog repo , latest = darcsLatestRevId repo , revision = darcsGetRevision repo , index = darcsIndex repo , directory = darcsDirectory repo , search = darcsSearch repo , idsMatch = const hashsMatch repo } -- | Run a darcs command and return error status, error output, standard output. The repository -- is used as working directory. runDarcsCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, B.ByteString) runDarcsCommand repo command args = do (status, err, out) <- runShellCommand repo Nothing "darcs" (command : args) return (status, toString err, out) --------------------------- -- End utility functions and types -- Begin repository creation & modification --------------------------- -- | Initialize a repository, creating the directory if needed. darcsInit :: FilePath -> IO () darcsInit repo = do exists <- doesDirectoryExist repo when exists $ withVerifyDir repo $ throwIO RepositoryExists createDirectoryIfMissing True repo (status, err, _) <- runDarcsCommand repo "init" [] if status == ExitSuccess then return () else throwIO $ UnknownError $ "darcs init failed:\n" ++ err -- | 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 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] darcsCommit repo [name] author logMsg -- | Commit changes to a resource. Raise 'Unchanged' exception if there were none. -- This is not for creating a new file; see 'darcsSave'. This is just for updating. darcsCommit :: FilePath -> [FilePath] -> Author -> Description -> IO () darcsCommit repo names author logMsg = do let args = ["--all", "-A", (authorName author ++ " <" ++ authorEmail author ++ ">"), "-m", logMsg] ++ names (statusCommit, errCommit, _) <- runDarcsCommand repo "record" args if statusCommit == ExitSuccess then return () else throwIO $ if null errCommit then Unchanged else UnknownError $ "Could not darcs record " ++ unwords names ++ "\n" ++ errCommit -- | Change the name of a resource. darcsMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO () darcsMove repo oldName newName author logMsg = do withSanityCheck repo ["_darcs"] newName $ do (statusAdd, _, _) <- runDarcsCommand repo "add" [dropFileName newName] (statusAdd', _,_) <- runDarcsCommand repo "mv" [oldName, newName] if statusAdd == ExitSuccess && statusAdd' == ExitSuccess then darcsCommit repo [oldName, newName] author logMsg else throwIO NotFound -- | Delete a resource from the repository. darcsDelete :: FilePath -> FilePath -> Author -> Description -> IO () darcsDelete repo name author logMsg = withSanityCheck repo ["_darcs"] name $ do runShellCommand repo Nothing "rm" [name] darcsCommit repo [name] author logMsg --------------------------- -- End repository creation & modification -- Begin repository & history queries -------------------------- -- | 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 -> 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 $ #ifdef USE_MAXCOUNT parsed #else case mblimit of Just lim -> take lim parsed Nothing -> parsed #endif else throwIO $ UnknownError $ "darcs changes returned error status.\n" ++ err where opts = timeOpts begin end ++ limit limit = case mblimit of #ifdef USE_MAXCOUNT Just lim -> ["--max-count",show lim] #else Just _ -> [] #endif Nothing -> [] timeOpts :: Maybe UTCTime -> Maybe UTCTime ->[String] timeOpts b e = case (b,e) of (Nothing,Nothing) -> [] (Just b', Just e') -> from b' ++ to e' (Just b', Nothing) -> from b' (Nothing, Just e') -> to e' where from z = ["--match=date \"after " ++ undate z ++ "\""] to z = ["--to-match=date \"before " ++ undate z ++ "\""] undate = toSqlString toSqlString = formatTime defaultTimeLocale "%FT%X" -- | Get revision information for a particular revision ID, or latest revision. darcsGetRevision :: FilePath -> RevisionId -> IO Revision darcsGetRevision repo hash = do (_,_,output) <- runDarcsCommand repo "changes" ["--xml-output", "--summary", "--match=hash " ++ hash] let hists = parseDarcsXML $ toString output case hists of Nothing -> throwIO NotFound Just a -> return $ head a -- | Return revision ID for latest commit for a resource. darcsLatestRevId :: FilePath -> FilePath -> IO RevisionId darcsLatestRevId repo name = do ensureFileExists repo name #ifdef USE_MAXCOUNT (status, err, output) <- runDarcsCommand repo "changes" ["--xml-output", "--max-count=1", name] when (status /= ExitSuccess && "unrecognized option" `isInfixOf` err) $ throwIO NoMaxCount #else (_, _, output) <- runDarcsCommand repo "changes" ["--xml-output", name] #endif let patchs = parseDarcsXML $ toString output case patchs of Nothing -> throwIO NotFound Just [] -> throwIO NotFound Just (x:_) -> return $ revId x -- | Retrieve the contents of a resource. darcsRetrieve :: Contents a => FilePath -> FilePath -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest -> IO a darcsRetrieve repo name mbId = do let opts = case mbId of Nothing -> ["contents", name] Just revid -> ["contents", "--match=hash " ++ revid, name] (status, err, output) <- runDarcsCommand repo "query" opts if B.null output then do (_, _, out) <- runDarcsCommand repo "query" (["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"] if status == ExitSuccess 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"] if status1 == ExitSuccess && status2 == ExitSuccess then do let files = adhocParsing dir' . lines . toString $ output1 -- We need to do 'drop $ length dir' + 3' because Darcs returns files like ["./foo/foobar"]. let dirs = adhocParsing dir' . drop 1 . lines . toString $ output2 -- We need the drop 1 to eliminate the root directory, which appears first. -- Now, select the ones that are in THIS directory and convert to Resources: let files' = map FSFile $ filter ('/' `notElem`) files let dirs' = map FSDirectory $ filter ('/' `notElem`) dirs return $ sort (files' ++ dirs') else return [] -- returns empty list for invalid path (see gitDirectory) where adhocParsing d = map (drop $ length d + 2) . filter (("." d) `isPrefixOf`) -- Use the generic grep-based search of a repo. darcsSearch :: FilePath -> SearchQuery -> IO [SearchMatch] darcsSearch = grepSearchRepo darcsIndex filestore-0.6.0.6/Data/FileStore/Compat/0000755000000000000000000000000012507277577016056 5ustar0000000000000000filestore-0.6.0.6/Data/FileStore/Compat/Locale.hs0000644000000000000000000000033712507277577017614 0ustar0000000000000000{-# 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 filestore-0.6.0.6/tests/0000755000000000000000000000000012507277577013230 5ustar0000000000000000filestore-0.6.0.6/tests/Tests.hs0000644000000000000000000004205312507277577014672 0ustar0000000000000000import 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(..)) import System.Exit data FileStoreType = Darcs | Git | Mercurial deriving (Show, Eq) main = do 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 = "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 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")) filestore-0.6.0.6/extra/0000755000000000000000000000000012507277577013211 5ustar0000000000000000filestore-0.6.0.6/extra/post-update0000644000000000000000000000400612507277577015401 0ustar0000000000000000#!/bin/bash # # 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