filestore (empty) → 0.1
raw patch · 11 files changed
+1523/−0 lines, 11 filesdep +Diffdep +basedep +bytestringsetup-changed
Dependencies added: Diff, base, bytestring, datetime, directory, filepath, parsec, process, regex-posix, split, time, utf8-string, xml
Files
- Data/FileStore.hs +28/−0
- Data/FileStore/Darcs.hs +292/−0
- Data/FileStore/Generic.hs +143/−0
- Data/FileStore/Git.hs +299/−0
- Data/FileStore/Types.hs +199/−0
- Data/FileStore/Utils.hs +132/−0
- LICENSE +28/−0
- Setup.lhs +3/−0
- Tests.lhs +289/−0
- extra/post-update +85/−0
- filestore.cabal +25/−0
+ Data/FileStore.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE Rank2Types, FlexibleContexts #-}+{- |+ Module : Data.FileStore+ Copyright : Copyright (C) 2009 John MacFarlane, Gwern Brandwen, Sebastiaan Visser+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ 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+ )+where++import Data.FileStore.Types+import Data.FileStore.Generic+import Data.FileStore.Git+import Data.FileStore.Darcs
+ Data/FileStore/Darcs.hs view
@@ -0,0 +1,292 @@+{- |+ Module : Data.FileStore.Darcs+ Copyright : Copyright (C) 2009 Gwern Brandwen+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ 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 Codec.Binary.UTF8.String (encodeString)+import Control.Exception (throwIO)+import Control.Monad (liftM, unless, when)+import Data.ByteString.Lazy.UTF8 (toString)+import Data.Char (isSpace)+import Data.DateTime (parseDateTime, toSqlString)+import Data.FileStore.Types+import Data.FileStore.Utils (hashsMatch, isInsideRepo, parseMatchLine, runShellCommand, escapeRegexSpecialChars)+import Data.List (intersect, nub)+import Data.Maybe (fromMaybe, fromJust)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import System.Directory (doesDirectoryExist, createDirectoryIfMissing)+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath ((</>), takeDirectory, dropFileName)+import System.IO.Error (isDoesNotExistError)+import Text.Regex.Posix ((=~))+import Text.XML.Light+import qualified Data.ByteString.Lazy as B (ByteString, readFile, writeFile)++-- | Return a filestore implemented using the Darcs distributed revision control system+-- (<http://darcs.net/>).+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+ , 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)++parseDarcsXML :: String -> Maybe [Revision]+parseDarcsXML str = do changelog <- parseXMLDoc str+ let patches = filterChildrenName (\(QName n _ _) -> n == "patch") changelog+ return $ map parseIntoRevision patches++parseIntoRevision :: Element -> Revision+parseIntoRevision a = Revision { revId = hashXML a,+ revDateTime = date a,+ revAuthor = Author { authorName=authorXML a, authorEmail=emailXML a },+ revDescription = descriptionXML a,+ revChanges = changesXML a }+ where+ -- If we can't get a date from the XML, we default to the beginning of the POSIX era.+ -- This at least makes it easy for someone to filter out bad dates, as obviously no real DVCSs+ -- were in operation then. :)+ -- date :: Element -> UTCTime+ date = fromMaybe (posixSecondsToUTCTime $ realToFrac (0::Int)) . parseDateTime "%c" . dateXML++authorXML, dateXML, descriptionXML, emailXML, hashXML :: Element -> String+authorXML = snd . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)+emailXML = fromMaybe"" . fst . splitEmailAuthor . fromMaybe "" . findAttr (QName "author" Nothing Nothing)+dateXML = fromMaybe "" . findAttr (QName "local_date" Nothing Nothing)+hashXML = fromMaybe "" . findAttr (QName "hash" Nothing Nothing)+descriptionXML = fromMaybe "" . liftM strContent . findChild (QName "name" Nothing Nothing)++changesXML :: Element -> [Change]+changesXML = analyze . filterSummary . changes++-- | Our policy is: if the input is clearly a "name \<e\@mail.com\>" input, then we return "(Just Address, Name)"+-- If there is no '<' in the input, then it clearly can't be of that format, and so we just return "(Nothing, Name)"+--+-- > splitEmailAuthor "foo bar baz@gmail.com" ~> (Nothing,"foo bar baz@gmail.com")+-- > splitEmailAuthor "foo bar <baz@gmail.com>" ~> (Just "baz@gmail.com","foo bar")+splitEmailAuthor :: String -> (Maybe String, String)+splitEmailAuthor x = if '<' `elem` x then (Just (tail $ init c), reverse . dropWhile isSpace $ reverse b)+ else (Nothing,x)+ -- Will still need to trim the '<>' brackets in the email, and whitespace at the end of name+ where (_,b,c) = x =~ "[^<]*" :: (String,String,String)++changes :: Element -> Element+changes = fromJust . findElement (QName "summary" Nothing Nothing)++analyze :: [Element] -> [Change]+analyze s = map convert s+ where convert a+ | x == "add_directory" || x == "add_file" = Added b+ | x == "remove_file" || x == "remove_directory" = Deleted b+ | x == "added_lines"+ || x == "modify_file"+ || x == "removed_lines"+ || x == "replaced_tokens" = Modified b+ | otherwise = error "Unknown change type"+ where x = qName . elName $ a+ b = takeWhile (/='\n') $ dropWhile isSpace $ strContent a++filterSummary :: Element -> [Element]+filterSummary = filterElementsName (\(QName {qName = x}) -> x == "add_file"+ || x == "add_directory"+ || x == "remove_file"+ || x == "remove_directory"+ || x == "modify_file"+ || x == "added_lines"+ || x == "removed_lines"+ || x == "replaced_tokens")++-- Following are for 'darcsSearch'++-- | Search multiple files with a single regexp+go :: FilePath -> [String] -> String -> IO [String]+go repo filesToCheck pattern = do (_, _, result) <- runShellCommand repo+ Nothing "grep" $ ["--line-number", "-l", "-E", "-e", pattern] ++ filesToCheck+ let results = intersect filesToCheck $ lines $ toString result+ return results++-- | Search a single file with multiple regexps+go' :: [String] -> FilePath -> [String] -> String -> IO [String]+go' os repo patterns file = do res <- mapM (\x -> run file x) patterns+ return $ nub $ concat res+ where run f p = do (_,_,r) <- runShellCommand repo Nothing "grep" $+ os ++ [p, f]+ return $ lines $ toString r++---------------------------+-- 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 $ 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 -> ResourceName -> Author -> Description -> a -> IO ()+darcsSave repo name author logMsg contents = do+ let filename = repo </> encodeString name+ inside <- isInsideRepo repo filename+ unless inside $ throwIO IllegalResourceName+ createDirectoryIfMissing True $ takeDirectory filename+ B.writeFile filename $ toByteString contents+ -- 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 -> [ResourceName] -> 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 -> ResourceName -> ResourceName -> Author -> Description -> IO ()+darcsMove repo oldName newName author logMsg = do+ let newPath = repo </> newName+ inside <- isInsideRepo repo newPath+ unless inside $ throwIO IllegalResourceName+ -- create destination directory if missing+ createDirectoryIfMissing True $ takeDirectory newPath+ (statusAdd,_,_) <- runDarcsCommand repo "add" [dropFileName newName]+ (statusAdd',_,_) <- runDarcsCommand repo "mv" [oldName, newName]+ if statusAdd == ExitSuccess && statusAdd' == ExitSuccess+ then darcsCommit repo [oldName, newName] author logMsg+ else throwIO NotFound++-- | Delete a resource from the repository.+darcsDelete :: FilePath -> ResourceName -> Author -> Description -> IO ()+darcsDelete repo name author logMsg = 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 -> [ResourceName] -> TimeRange -> IO [Revision]+darcsLog repo names (TimeRange begin end) = do+ let opts = timeOpts begin end+ do (status, err, output) <- runDarcsCommand repo "changes" $ ["--xml-output", "--summary"] ++ names ++ opts+ if status == ExitSuccess+ then case parseDarcsXML $ toString output of+ Nothing -> throwIO ResourceExists+ Just parsed -> return parsed+ else throwIO $ UnknownError $ "darcs changes returned error status.\n" ++ err+ where+ timeOpts :: Maybe DateTime -> Maybe DateTime ->[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++-- | Get revision information for a particular revision ID, or latest revision.+darcsGetRevision :: FilePath -> RevisionId -> IO Revision+darcsGetRevision repo hash = do hists <- darcsLog repo [] (TimeRange Nothing Nothing)+ let hist = filter (\x -> hashsMatch (revId x) hash) hists+ let result = if null hist then hists else hist+ return $ head result++-- | Return revision ID for latest commit for a resource.+darcsLatestRevId :: FilePath -> ResourceName -> IO RevisionId+darcsLatestRevId repo name = do+ -- changes always succeeds, so no need to check error+ (_, _, output) <- runDarcsCommand repo "changes" ["--xml-output", "--summary", name]+ let patchs = parseDarcsXML $ toString output+ case patchs of+ Nothing -> throwIO NotFound+ Just as -> if null as then throwIO NotFound else return $ revId $ head as++-- | Retrieve the (text) contents of a resource.+darcsRetrieve :: Contents a+ => FilePath+ -> ResourceName+ -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest+ -> IO a+-- If called with Nothing, go straight to the file system+darcsRetrieve repo name Nothing = do+ let filename = repo </> encodeString name+ catch (liftM fromByteString $ B.readFile filename) $+ \e -> if isDoesNotExistError e then throwIO NotFound else throwIO e+darcsRetrieve repo name (Just revid) = do+ let opts = ["contents", "--match=hash " ++ revid, name]+ (status, err, output) <- runDarcsCommand repo "query" opts+ if status == ExitSuccess+ then return $ fromByteString output+ else throwIO $ UnknownError $ "Error in darcs query contents:\n" ++ err++-- | Get a list of all known files inside and managed by a repository.+darcsIndex :: FilePath ->IO [ResourceName]+darcsIndex repo = do+ (status, errOutput, output) <- runDarcsCommand repo "query" ["manifest"]+ if status == ExitSuccess+ -- We need to do 'drop 2' because Darcs returns files like ["./foobar"], and+ -- the ./ is always present & always not wanted.+ then return (map (drop 2) . lines . toString $ output)+ else error $ "'darcs query manifest' returned error status.\n" ++ errOutput++-- | Uses grep to search repository.+darcsSearch :: FilePath -> SearchQuery -> IO [SearchMatch]+darcsSearch repo query = do+ let opts = ["--line-number", "--with-filename"] +++ (if queryIgnoreCase query then ["-i"] else []) +++ (if queryWholeWords query then ["--word-regexp"] else ["-E"])+ let regexps = map escapeRegexSpecialChars $ queryPatterns query+ files <- darcsIndex repo+ if queryMatchAll query then do+ filesMatchingAllPatterns <- liftM (foldr1 intersect) $ mapM (go repo files) regexps+ output <- mapM (go' opts repo regexps) filesMatchingAllPatterns+ return $ map parseMatchLine $ concat output+ else do (_status, _errOutput, output) <-+ runShellCommand repo Nothing "grep" $ opts +++ concatMap (\term -> ["-e", term]) regexps +++ files+ let results = lines $ toString output+ return $ map parseMatchLine results+
+ Data/FileStore/Generic.hs view
@@ -0,0 +1,143 @@+{- |+ Module : Data.FileStore.Generic+ Copyright : Copyright (C) 2009 John MacFarlane, Gwern Brandwen, Sebastiaan Visser+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : GHC 6.10 required++ Generic utility functions for working with filestores.+-}++module Data.FileStore.Generic+ ( modify+ , create+ , DI(..)+ , diff+ , searchRevisions+ , smartRetrieve+ )++where+import Data.FileStore.Types++import Control.Exception (throwIO, catch, SomeException, try)+import Data.FileStore.Utils+import Data.Maybe (isNothing)+import Data.List (isInfixOf)+import qualified Data.List.Split as S (whenElt, split)+import Data.Char (isSpace)+import Data.Algorithm.Diff (DI(..), getGroupedDiff)+import Prelude hiding (catch)++handleUnknownError :: SomeException -> IO a+handleUnknownError = throwIO . UnknownError . show++-- | Like save, but first verify that the resource name is new. If not, throws a 'ResourceExists'+-- error.+create :: Contents a+ => FileStore+ -> ResourceName -- ^ Resource to create.+ -> Author -- ^ Author of change.+ -> Description -- ^ Description of change.+ -> a -- ^ Contents of resource.+ -> IO ()+create fs name author logMsg contents = catch (latest fs name >> throwIO ResourceExists)+ (\e -> if e == NotFound+ then save fs name author logMsg contents+ else throwIO e)++-- | Modify a named resource in the filestore. Like save, except that a revision ID+-- must be specified. If the resource has been modified since the specified revision,+-- @Left@ merge information is returned. Otherwise, @Right@ the new contents are saved. +modify :: Contents a+ => FileStore+ -> ResourceName -- ^ Resource to create.+ -> 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) <- catch + (mergeContents ("edited", toByteString contents) (originalRevId, originalContents) (latestRevId, latestContents))+ handleUnknownError+ return $ Left (MergeInfo latestRev conflicts mergedText)++-- | Split a string at spaces (but include the spaces in the list of results).+splitOnSpaces :: String -> [String]+splitOnSpaces = S.split (S.whenElt isSpace) ++-- | Return a unified diff of two revisions of a named resource, using an external @diff@+-- program.+diff :: FileStore+ -> ResourceName -- ^ Resource name to get diff for.+ -> Maybe RevisionId -- ^ @Just@ old revision ID, or @Nothing@ for empty.+ -> Maybe RevisionId -- ^ @Just@ oew revision ID, or @Nothing@ for latest.+ -> IO [(DI, [String])]+diff fs name id1 id2 = do+ contents1 <- if isNothing id1+ then return ""+ else retrieve fs name id1+ contents2 <- retrieve fs name id2+ let words1 = splitOnSpaces contents1+ let words2 = splitOnSpaces contents2+ return $ getGroupedDiff words1 words2++-- | 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.+ -> ResourceName -- ^ 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)+ 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.+ -> ResourceName -- ^ Resource name to retrieve.+ -> Maybe String -- ^ @Just@ revision ID or description, or @Nothing@ for empty.+ -> IO a+smartRetrieve fs exact name mrev = do+ edoc <- try (retrieve fs name mrev)+ case (edoc, mrev) of+ + -- Regular retrieval using revision identifier succeeded, use this doc.+ (Right doc, _) -> return doc++ -- Retrieval of latest revision failed, nothing we can do about this.+ (Left e, Nothing) -> throwIO (e :: FileStoreError)++ -- 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 throwIO NotFound++ -- Retrieve resource for latest matching revision.+ else retrieve fs name (Just $ revId $ Prelude.head revs)+
+ Data/FileStore/Git.hs view
@@ -0,0 +1,299 @@+{- |+ Module : Data.FileStore.Git+ Copyright : Copyright (C) 2009 John MacFarlane+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : GHC 6.10 required++ A versioned filestore implemented using git.+ Normally this module should not be imported: import+ "Data.FileStore" instead.+-}++module Data.FileStore.Git+ ( gitFileStore+ )+where+import Data.FileStore.Types+import System.Exit+import System.IO.Error (isDoesNotExistError)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.FileStore.Utils (hashsMatch, isInsideRepo, runShellCommand, escapeRegexSpecialChars) +import Data.ByteString.Lazy.UTF8 (toString)+import qualified Data.ByteString.Lazy as B+import qualified Text.ParserCombinators.Parsec as P+import Codec.Binary.UTF8.String (decodeString)+import Data.Char (chr)+import Control.Monad (liftM, when)+import System.FilePath ((</>), takeDirectory)+import System.Directory (doesDirectoryExist, createDirectoryIfMissing)+import Codec.Binary.UTF8.String (encodeString)+import Control.Exception (throwIO)+import Control.Monad (unless)+import Text.Regex.Posix ((=~))+import System.Directory (getPermissions, setPermissions, executable)+import Paths_filestore++-- | Return a filestore implemented using the git distributed revision control system+-- (<http://git-scm.com/>).+gitFileStore :: FilePath -> FileStore+gitFileStore repo = FileStore {+ initialize = gitInit repo+ , save = gitSave repo + , retrieve = gitRetrieve repo+ , delete = gitDelete repo+ , rename = gitMove repo+ , history = gitLog repo+ , latest = gitLatestRevId repo+ , revision = gitGetRevision repo+ , index = gitIndex 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 $ 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})+ return ()+ else throwIO $ UnknownError $ "git-init failed:\n" ++ err ++-- | Commit changes to a resource. Raise 'Unchanged' exception if there were+-- no changes.+gitCommit :: FilePath -> [ResourceName] -> Author -> String -> IO ()+gitCommit 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 -> ResourceName -> Author -> Description -> a -> IO ()+gitSave repo name author logMsg contents = do+ let filename = repo </> encodeString name+ inside <- isInsideRepo repo filename+ unless inside $ throwIO IllegalResourceName+ createDirectoryIfMissing True $ takeDirectory filename+ B.writeFile filename $ toByteString contents+ (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+ -> ResourceName+ -> Maybe RevisionId -- ^ @Just@ revision ID, or @Nothing@ for latest+ -> IO a+gitRetrieve repo name Nothing = do+ -- If called with Nothing, go straight to the file system+ let filename = repo </> encodeString name+ catch (liftM fromByteString $ B.readFile filename) $+ \e -> if isDoesNotExistError e then throwIO NotFound else throwIO e+gitRetrieve repo name (Just revid) = do+ (status, err, output) <- runGitCommand repo "cat-file" ["-p", revid ++ ":" ++ name]+ 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 -> ResourceName -> Author -> Description -> IO ()+gitDelete repo name author logMsg = do+ (statusAdd, errRm, _) <- runGitCommand repo "rm" [name]+ if statusAdd == ExitSuccess+ then gitCommit repo [name] author logMsg+ else throwIO $ UnknownError $ "Could not git rm '" ++ name ++ "'\n" ++ errRm++-- | Change the name of a resource.+gitMove :: FilePath -> ResourceName -> ResourceName -> Author -> Description -> IO ()+gitMove repo oldName newName author logMsg = do+ gitLatestRevId repo oldName -- will throw a NotFound error if oldName doesn't exist+ let newPath = repo </> encodeString newName+ inside <- isInsideRepo repo newPath+ unless inside $ throwIO IllegalResourceName+ -- create destination directory if missing+ createDirectoryIfMissing True $ takeDirectory newPath+ (statusAdd, err, _) <- runGitCommand repo "mv" [oldName, newName]+ if statusAdd == ExitSuccess+ then gitCommit repo [oldName, newName] author logMsg+ else throwIO $ UnknownError $ "Could not git mv " ++ oldName ++ " " ++ newName ++ "\n" ++ err++-- | Return revision ID for latest commit for a resource.+gitLatestRevId :: FilePath -> ResourceName -> IO RevisionId+gitLatestRevId repo name = do+ (status, _, output) <- runGitCommand repo "rev-list" ["--max-count=1", "HEAD", "--", name]+ if status == 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" ["--pretty=format:%h%n%ct%n%an%n%ae%n%s%n", "--max-count=1", revid]+ if status == ExitSuccess+ then case P.parse parseGitLog "" (toString output) of+ Left err' -> throwIO $ UnknownError $ "error parsing git log: " ++ show err'+ Right [r] -> return r+ Right [] -> throwIO NotFound+ Right xs -> throwIO $ UnknownError $ "git rev-list returned more than one result: " ++ show xs+ else throwIO NotFound++-- | Get list of files in repository.+gitIndex :: FilePath -> IO [ResourceName]+gitIndex repo = do+ (status, errOutput, output) <- runGitCommand repo "ls-files" []+ if status == ExitSuccess+ then return $ map convertEncoded $ lines $ toString output+ else error $ "git ls-files returned error status.\n" ++ errOutput++-- | 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"] +++ ["--ignore-case" | queryIgnoreCase query] +++ ["--all-match" | queryMatchAll query] +++ ["--word-regexp" | queryWholeWords query]+ (status, errOutput, output) <- runGitCommand repo "grep" (opts +++ concatMap (\term -> ["-e", escapeRegexSpecialChars term]) (queryPatterns query))+ if status == ExitSuccess+ then return $ map parseMatchLine $ lines $ toString output+ else error $ "git grep returned error status.\n" ++ errOutput++-- Auxiliary function for searchResults+parseMatchLine :: String -> SearchMatch+parseMatchLine str =+ let (_,_,_,[fname,_,ln,cont]) = str =~ "^(([^:]|:[^0-9])*):([0-9]*):(.*)$" :: (String, String, String, [String])+ in SearchMatch{matchResourceName = fname, matchLineNumber = read ln, matchLine = cont}++{-+-- | Uses git-diff to get a dif between two revisions.+gitDiff :: FilePath -> ResourceName -> 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'+-}++-- | Return list of log entries for the given time frame and list of resources.+-- If list of resources is empty, log entries for all resources are returned.+gitLog :: FilePath -> [ResourceName] -> TimeRange -> IO [Revision]+gitLog repo names (TimeRange mbSince mbUntil) = do+ (status, err, output) <- runGitCommand repo "whatchanged" $+ ["--pretty=format:%h%n%ct%n%an%n%ae%n%s%n"] +++ (case mbSince of+ Just since -> ["--since='" ++ show since ++ "'"]+ Nothing -> []) +++ (case mbUntil of+ Just til -> ["--until='" ++ show til ++ "'"]+ Nothing -> []) +++ ["--"] ++ names + if status == ExitSuccess+ then case P.parse parseGitLog "" (toString output) of+ Left err' -> throwIO $ UnknownError $ "Error parsing git log.\n" ++ show err'+ Right parsed -> return parsed+ else throwIO $ UnknownError $ "git whatchanged returned error status.\n" ++ err++--+-- Parsers to parse git log into Revisions.+--++parseGitLog :: P.Parser [Revision]+parseGitLog = P.manyTill gitLogEntry P.eof++wholeLine :: P.GenParser Char st [Char]+wholeLine = P.manyTill P.anyChar P.newline++nonblankLine :: P.GenParser Char st [Char]+nonblankLine = P.notFollowedBy P.newline >> wholeLine++gitLogEntry :: P.Parser Revision+gitLogEntry = do+ rev <- nonblankLine+ date <- nonblankLine+ author <- wholeLine+ email <- wholeLine+ subject <- liftM unlines (P.manyTill wholeLine (P.eof P.<|> (P.lookAhead (P.char ':') >> return ())))+ P.spaces+ changes <- P.many gitLogChange+ P.spaces+ let stripTrailingNewlines = reverse . dropWhile (=='\n') . reverse+ return Revision {+ revId = rev+ , revDateTime = posixSecondsToUTCTime $ realToFrac (read date :: Integer)+ , revAuthor = Author { authorName = author, authorEmail = email }+ , revDescription = stripTrailingNewlines subject+ , revChanges = changes }++gitLogChange :: P.Parser Change+gitLogChange = do+ P.char ':'+ line <- nonblankLine+ let (changeType : fileWords) = drop 4 $ words line+ let file' = convertEncoded $ unwords fileWords+ case changeType of+ "A" -> return $ Added file'+ "M" -> return $ Modified file'+ "D" -> return $ Deleted file'+ _ -> return $ Modified file'++-- | git ls-files returns UTF-8 filenames in quotes, with characters octal-escaped.+-- like this: "\340\244\226.page"+-- This function decodes these.+convertEncoded :: String -> String+convertEncoded s =+ case P.parse pEncodedString s s of+ Left _ -> s+ Right res -> res++pEncodedString :: P.GenParser Char st [Char]+pEncodedString = do+ P.char '"'+ res <- P.many1 (pOctalChar P.<|> P.anyChar)+ if last res == '"'+ then return $ decodeString $ init res+ else fail "No ending quotation mark."++pOctalChar :: P.GenParser Char st Char+pOctalChar = P.try $ do+ P.char '\\'+ ds <- P.count 3 (P.oneOf "01234567")+ let num = read $ "0o" ++ ds+ return $ chr num
+ Data/FileStore/Types.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE Rank2Types, TypeSynonymInstances, DeriveDataTypeable #-}+{- |+ Module : Data.FileStore.Types+ Copyright : Copyright (C) 2009 John MacFarlane+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : GHC 6.10 required++ Type definitions for "Data.FileStore".+-}++module Data.FileStore.Types+ ( RevisionId+ , ResourceName+ , Author(..)+ , Change(..)+ , Description+ , Revision(..)+ , Contents(..)+ , TimeRange(..)+ , MergeInfo(..)+ , FileStoreError(..)+ , SearchMatch(..)+ , SearchQuery(..)+ , defaultSearchQuery+ , DateTime+ , FileStore (..) )++where+import Data.ByteString.Lazy (ByteString)+import Data.Typeable+import Data.ByteString.Lazy.UTF8 (toString, fromString)+import Data.DateTime (DateTime)+import Control.Exception (Exception)+import Prelude hiding (catch)++type RevisionId = String++type ResourceName = String++data Author =+ Author {+ authorName :: String+ , authorEmail :: String+ } deriving (Show, Read, Eq, Typeable)++data Change =+ Added ResourceName+ | Deleted ResourceName+ | Modified ResourceName+ deriving (Show, Read, Eq, Typeable)++type Description = String++data Revision =+ Revision {+ revId :: RevisionId+ , revDateTime :: DateTime+ , 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 DateTime -- ^ @Nothing@ means no lower bound+ , timeTo :: Maybe DateTime -- ^ @Nothing@ means no upper bound+ } deriving (Show, Read, Eq, Typeable)++data MergeInfo =+ MergeInfo {+ mergeRevision :: Revision -- ^ The revision with which changes were merged+ , mergeConflicts :: Bool -- ^ @True@ if there were merge conflicts+ , mergeText :: String -- ^ The merged text, including conflict markers+ } deriving (Show, Read, Eq, Typeable)++data FileStoreError =+ RepositoryExists -- ^ Tried to initialize a repository that already exists+ | ResourceExists -- ^ Tried to create a resource that already exists+ | 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+ | 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 (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 :: ResourceName+ , 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+ => ResourceName -- Resource to save.+ -> Author -- Author of change.+ -> Description -- Description of change.+ -> a -- New contents of resource.+ -> IO ()+ + -- | Retrieve the contents of the named resource.+ , retrieve :: Contents a+ => ResourceName -- Resource to retrieve.+ -> Maybe RevisionId -- @Just@ a particular revision ID, or @Nothing@ for latest+ -> IO a++ -- | Delete a named resource, providing author and log message.+ , delete :: ResourceName -- Resource to delete.+ -> Author -- Author of change.+ -> Description -- Description of change.+ -> IO ()++ -- | Rename a resource, providing author and log message.+ , rename :: ResourceName -- Resource original name.+ -> ResourceName -- Resource new name.+ -> Author -- Author of change.+ -> Description -- Description of change.+ -> IO ()++ -- | Get history for a list of named resources in a (possibly openended) time range.+ -- If the list is empty, history for all resources will be returned. + , history :: [ResourceName] -- List of resources to get history for, or @[]@ for all.+ -> TimeRange -- Time range within which to get history.+ -> IO [Revision]++ -- | Return the revision ID of the latest change for a resource. Raises 'NotFound'+ -- if the resource is not found.+ , latest :: ResourceName -- Resource to get revision ID for.+ -> IO RevisionId++ -- | Return information about a revision, given the ID. Raises 'NotFound' if there is+ -- no such revision.+ , revision :: RevisionId -- Revision ID to get revision information for.+ -> IO Revision++ -- | Return a list of resources in the filestore.+ , index :: IO [ResourceName]++ -- | @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]++ }+
+ Data/FileStore/Utils.hs view
@@ -0,0 +1,132 @@+{- |+ Module : Data.FileStore.Utils+ Copyright : Copyright (C) 2009 John MacFarlane, Gwern Brandwen+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : portable++ Utility functions for running external processes.+-}++module Data.FileStore.Utils (+ runShellCommand+ , mergeContents+ , hashsMatch+ , isInsideRepo+ , escapeRegexSpecialChars+ , parseMatchLine ) where+++import Codec.Binary.UTF8.String (encodeString)+import Control.Monad (liftM)+import Data.ByteString.Lazy.UTF8 (toString)+import Data.List (isPrefixOf)+import Data.List.Split (splitWhen)+import Data.Maybe (isJust)+import System.Directory (canonicalizePath)+import System.Directory (getTemporaryDirectory, removeFile, findExecutable)+import System.Exit (ExitCode(..))+import System.IO (openTempFile, hClose)+import System.Process (runProcess, waitForProcess)+import qualified Data.ByteString.Lazy as B++import Data.FileStore.Types (SearchMatch(..))++-- | Run shell command and return error status, standard output, and error output. Assumes+-- UTF-8 locale. Note that this does not actuall go through \/bin\/sh!+runShellCommand :: FilePath -- ^ Working directory+ -> Maybe [(String, String)] -- ^ Environment+ -> String -- ^ Command+ -> [String] -- ^ Arguments+ -> IO (ExitCode, B.ByteString, B.ByteString)+runShellCommand workingDir environment command optionList = do+ tempPath <- catch getTemporaryDirectory (\_ -> return ".")+ (outputPath, hOut) <- openTempFile tempPath "out"+ (errorPath, hErr) <- openTempFile tempPath "err"+ hProcess <- runProcess (encodeString command) (map encodeString optionList) (Just workingDir) environment Nothing (Just hOut) (Just hErr)+ status <- waitForProcess hProcess+ errorOutput <- B.readFile errorPath+ output <- B.readFile outputPath+ removeFile errorPath+ removeFile outputPath+ return (status, errorOutput, 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 <- catch getTemporaryDirectory (\_ -> 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 repository whether another file lies within its ambit.+-- This is basically asking whether the file is 'above' the repository in the filesystems's+-- directory tree. Useful for checking the legality of a filename.+isInsideRepo :: FilePath -> FilePath -> IO Bool+isInsideRepo repo name = do+ gitRepoPathCanon <- canonicalizePath repo+ filenameCanon <- canonicalizePath name+ return (gitRepoPathCanon `isPrefixOf` filenameCanon)++-- | 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}
+ LICENSE view
@@ -0,0 +1,28 @@+All 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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Tests.lhs view
@@ -0,0 +1,289 @@+#!/usr/bin/env runghc++This program runs tests for the filestore modules.+Invoke it with:++ runghc Tests.lhs++> import Data.FileStore+> import Test.HUnit+> import System.Directory (removeDirectoryRecursive)+> import Control.Monad (forM)+> import Prelude hiding (catch)+> import Control.Exception (catch)+> import Data.DateTime+> import Data.Maybe (mapMaybe)+> import System.Directory (doesFileExist)+> import System.Process+> import Data.Algorithm.Diff (DI(..))++> main = do+> testFileStore (gitFileStore "tmp/gitfs") "Data.FileStore.Git"+> testFileStore (darcsFileStore "tmp/darcsfs") "Data.FileStore.Darcs"+> removeDirectoryRecursive "tmp"++> testFileStore :: FileStore -> String -> IO Counts +> testFileStore fs fsName = do+> putStrLn $ "**********************************"+> putStrLn $ "Testing " ++ fsName+> putStrLn $ "**********************************"+> runTestTT $ TestList $ map (\(label, testFn) -> TestLabel label $ testFn fs) +> [ ("initialize", initializeTest)+> , ("create resource", createTest1)+> , ("create resource in subdirectory", createTest2)+> , ("create resource with non-ascii name", createTest3)+> , ("try to create resource outside repo", createTest4)+> , ("retrieve resource", retrieveTest1)+> , ("retrieve resource in a subdirectory", retrieveTest2)+> , ("retrieve resource with non-ascii name", retrieveTest3)+> , ("modify resource", modifyTest)+> , ("delete resource", deleteTest)+> , ("rename resource", renameTest)+> , ("test for matching IDs", matchTest)+> , ("history and revision", historyTest)+> , ("diff", diffTest)+> , ("search", searchTest)+> ]++> testAuthor :: Author+> testAuthor = Author "Test Suite" "suite@test.org"++> testContents :: String+> testContents = "Test contents.\nSecond line.\nThird test line with some Greek αβ."++> testTitle :: String+> testTitle = "New resource.txt"++> subdirTestTitle :: String+> subdirTestTitle = "subdir/Subdir title.txt"++> nonasciiTestTitle :: String+> nonasciiTestTitle = "αβγ"++*** Initialize a repository, check for empty index, and then try to initialize again+*** in the same directory (should raise an error):++> initializeTest fs = TestCase $ do+> initialize fs+> ind <- index fs+> assertEqual "index of just-initialized repository" ind []+> catch (initialize fs >> assertFailure "did not return error for existing repository") $+> \e -> assertEqual "error status from existing repository" e RepositoryExists++*** Create a resource, and check to see that latest returns a revision ID for it:++> createTest1 fs = TestCase $ do+> create fs testTitle testAuthor "description of change" testContents+> revid <- latest fs testTitle+> assertBool "revision returns a revision after create" (not (null revid))++*** Create a resource in a subdirectory, and check to see that revision returns a revision for it:++> createTest2 fs = TestCase $ do+> create fs subdirTestTitle testAuthor "description of change" testContents+> revid <- latest fs testTitle+> assertBool "revision returns a revision after create" (not (null revid))++*** Create a resource with a non-ascii title, and check to see that revision returns a revision for it:++> createTest3 fs = TestCase $ do+> create fs nonasciiTestTitle testAuthor "description of change" testContents+> revid <- latest fs testTitle+> assertBool "revision returns a revision after create" (not (null revid))++*** Try to create a resource outside the repository (should fail with an error and NOT write the file):++> createTest4 fs = TestCase $ do+> catch (create fs "../oops" testAuthor "description of change" testContents >>+> assertFailure "did not return error from create ../oops") $+> \e -> assertEqual "error from create ../oops" IllegalResourceName e +> exists <- doesFileExist "tmp/oops"+> assertBool "file ../oops was created outside repository" (not exists)++*** Retrieve latest version of a resource:++> retrieveTest1 fs = TestCase $ do+> cont <- retrieve fs testTitle Nothing+> assertEqual "contents returned by retrieve" testContents cont ++*** Retrieve latest version of a resource (in a subdirectory):++> retrieveTest2 fs = TestCase $ do+> cont <- retrieve fs subdirTestTitle Nothing+> assertEqual "contents returned by retrieve" testContents cont ++*** Retrieve latest version of a resource with a nonascii name:++> retrieveTest3 fs = TestCase $ do+> cont <- retrieve fs nonasciiTestTitle Nothing+> assertEqual "contents returned by retrieve" testContents cont ++*** Modify a resource:++> modifyTest fs = TestCase $ do++ Modify a resource. Should return Right ().++> revid <- latest fs testTitle+> let modifiedContents = unlines $ take 2 $ lines testContents+> modResult <- modify fs testTitle revid testAuthor "removed third line" modifiedContents+> assertEqual "results of modify" (Right ()) modResult++ Now retrieve the contents and make sure they were changed.++> modifiedContents' <- retrieve fs testTitle Nothing+> newRevId <- latest fs testTitle+> newRev <- revision fs newRevId+> assertEqual "retrieved contents after modify" modifiedContents' modifiedContents++ Now try to modify again, using the old revision as base. This should result in a merge with conflicts.++> modResult2 <- modify fs testTitle revid testAuthor "modified from old version" (testContents ++ "\nFourth line")+> let normModResult2 = Left (MergeInfo {mergeRevision = newRev, mergeConflicts = True, mergeText =+> "Test contents.\nSecond line.\n<<<<<<< edited\nThird test line with some Greek \945\946.\nFourth line\n=======\n>>>>>>> " +++> newRevId ++ "\n"})+> assertEqual "results of modify from old version" normModResult2 modResult2++ Now try it again, still using the old version as base, but with contents of the new version.+ This should result in a merge without conflicts.++> modResult3 <- modify fs testTitle revid testAuthor "modified from old version" modifiedContents+> let normModResult3 = Left (MergeInfo {mergeRevision = newRev, mergeConflicts = False, mergeText = modifiedContents})+> assertEqual "results of modify from old version with new version's contents" normModResult3 modResult3++ Now try modifying again, this time using the new version as base. Should succeed with Right ().++> modResult4 <- modify fs testTitle newRevId testAuthor "modified from new version" (modifiedContents ++ "\nThird line")+> assertEqual "results of modify from new version" (Right ()) modResult4 ++*** Delete a resource:++> deleteTest fs = TestCase $ do++ Create a file and verify that it's there.++> let toBeDeleted = "Aaack!"+> create fs toBeDeleted testAuthor "description of change" testContents+> ind <- index fs+> assertBool "index contains resource to be deleted" (toBeDeleted `elem` ind) ++ Now delete it and verify that it's gone.++> delete fs toBeDeleted testAuthor "goodbye"+> ind <- index fs+> assertBool "index does not contain resource that was deleted" (not (toBeDeleted `elem` ind))++*** Rename a resource:++> renameTest fs = TestCase $ do++ Create a file and verify that it's there.++> let oldName = "Old Name"+> let newName = "newdir/New Name.txt"+> create fs oldName testAuthor "description of change" testContents+> ind <- index fs+> assertBool "index contains old name" (oldName `elem` ind) +> assertBool "index does not contain new name" (newName `notElem` ind)++ Now rename it and verify that it changed names.++> rename fs oldName newName testAuthor "rename"+> ind <- index fs+> assertBool "index does not contain old name" (oldName `notElem` ind) +> assertBool "index contains new name" (newName `elem` ind)++ Try renaming a file that doesn't exist.++> catch (rename fs "nonexistent file" "other name" testAuthor "rename" >>+> assertFailure "rename of nonexistent file did not throw error") $+> \e -> assertEqual "error status from rename of nonexistent file" NotFound e++*** Test history and revision++> historyTest fs = TestCase $ do++ Get history for three files++> hist <- history fs [testTitle, subdirTestTitle, nonasciiTestTitle] (TimeRange Nothing Nothing)+> assertBool "history is nonempty" (not (null hist))+> now <- getCurrentTime+> rev <- latest fs testTitle >>= revision fs -- get latest revision+> assertBool "history contains latest revision" (rev `elem` hist)+> assertEqual "revAuthor" testAuthor (revAuthor rev)+> assertBool "revId non-null" (not (null (revId rev)))+> assertBool "revDescription non-null" (not (null (revDescription rev)))+> assertEqual "revChanges" [Modified testTitle] (revChanges rev)+> let revtime = revDateTime rev+> histNow <- history fs [testTitle] (TimeRange (Just $ addMinutes (60 * 24) now) Nothing)+> assertBool "history from now + 1 day onwards is empty" (null histNow)++*** Test diff++> diffTest fs = TestCase $ do++ Create a file and modiy it.++> let diffTitle = "difftest.txt"+> create fs diffTitle testAuthor "description of change" testContents+> save fs diffTitle testAuthor "removed a line" (unlines . init . lines $ testContents)++> [secondrev, firstrev] <- history fs [diffTitle] (TimeRange Nothing Nothing)+> diff' <- diff fs diffTitle (Just $ revId firstrev) (Just $ revId secondrev)+> let subtracted' = mapMaybe (\(d,s) -> if d == F then Just (concat s) else Nothing) diff'+> assertEqual "subtracted lines" [last (lines testContents)] subtracted'++ Diff from Nothing should be diff from empty document.++> diff'' <- diff fs diffTitle Nothing (Just $ revId firstrev)+> let added'' = mapMaybe (\(d,s) -> if d == S then Just (concat s) else Nothing) diff''+> assertEqual "added lines from empty document to first revision" [testContents] added''++ Diff to Nothing should be diff to latest.++> diff''' <- diff fs diffTitle (Just $ revId firstrev) Nothing+> assertEqual "diff from first revision to latest" diff' diff'''++*** Test search++> searchTest fs = TestCase $ do++ Search for "bing"++> create fs "foo" testAuthor "my 1st search test doc" "bing\nbong\nbang\nφ"+> create fs "bar" testAuthor "my 2nd search test doc" "bing BONG" +> create fs "baz" testAuthor "my 3nd search test doc" "bingbang\nbong"++ Search for "bing" with whole-word matches.++> res1 <- search fs SearchQuery{queryPatterns = ["bing"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = True}+> assertEqual "search results 1" [SearchMatch "bar" 1 "bing BONG", SearchMatch "foo" 1 "bing"] res1++ Search for regex "BONG" case-sensitive.++> res2 <- search fs SearchQuery{queryPatterns = ["BONG"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = False}+> assertEqual "search results 2" [SearchMatch "bar" 1 "bing BONG"] res2++ Search for "bong" and "φ"++> res3 <- search fs SearchQuery{queryPatterns = ["bong", "φ"], queryWholeWords = True, queryMatchAll = True, queryIgnoreCase = True}+> assertEqual "search results 3" [SearchMatch "foo" 2 "bong", SearchMatch "foo" 4 "φ"] res3++ Search for "bong" and "φ" but without match-all set++> res4 <- search fs SearchQuery{queryPatterns = ["bong", "φ"], queryWholeWords = True, queryMatchAll = False, queryIgnoreCase = True}+> assertEqual "search results 4" [SearchMatch "bar" 1 "bing BONG", SearchMatch "baz" 2 "bong", SearchMatch "foo" 2 "bong", SearchMatch "foo" 4 "φ"] res4++ Search for "bing" but without whole-words set++> res5 <- search fs SearchQuery{queryPatterns = ["bing"], queryWholeWords = False, queryMatchAll = True, queryIgnoreCase = True}+> assertEqual "search results 5" [SearchMatch "bar" 1 "bing BONG", SearchMatch "baz" 1 "bingbang", SearchMatch "foo" 1 "bing"] res5++*** Test IDs match++> matchTest fs = TestCase $ do++> assertBool "match with two identical IDs" (idsMatch fs "abcde" "abcde")+> assertBool "match with nonidentical but matching IDs" (idsMatch fs "abcde" "abcde5553")+> assertBool "non-match" (not (idsMatch fs "abcde" "abedc"))+
+ extra/post-update view
@@ -0,0 +1,85 @@+#!/bin/sh+#+# This hook does two things:+#+# 1. update the "info" files that allow the list of references to be+# queries over dumb transports such as http+#+# 2. if this repository looks like it is a non-bare repository, and+# the checked-out branch is pushed to, then update the working copy.+# This makes "push" function somewhat similarly to darcs and bzr.+#+# To enable this hook, make this file executable by "chmod +x post-update".++git-update-server-info++is_bare=$(git-config --get --bool core.bare)++if [ -z "$is_bare" ]+then+ # for compatibility's sake, guess+ git_dir_full=$(cd $GIT_DIR; pwd)+ case $git_dir_full in */.git) is_bare=false;; *) is_bare=true;; esac+fi++update_wc() {+ ref=$1+ echo "Push to checked out branch $ref" >&2+ if [ ! -f $GIT_DIR/logs/HEAD ]+ then+ echo "E:push to non-bare repository requires a HEAD reflog" >&2+ exit 1+ fi+ if (cd $GIT_WORK_TREE; git-diff-files -q --exit-code >/dev/null)+ then+ wc_dirty=0+ else+ echo "W:unstaged changes found in working copy" >&2+ wc_dirty=1+ desc="working copy"+ fi+ if git diff-index --cached HEAD@{1} >/dev/null+ then+ index_dirty=0+ else+ echo "W:uncommitted, staged changes found" >&2+ index_dirty=1+ if [ -n "$desc" ]+ then+ desc="$desc and index"+ else+ desc="index"+ fi+ fi+ if [ "$wc_dirty" -ne 0 -o "$index_dirty" -ne 0 ]+ then+ new=$(git rev-parse HEAD)+ echo "W:stashing dirty $desc - see git-stash(1)" >&2+ ( trap 'echo trapped $$; git symbolic-ref HEAD "'"$ref"'"' 2 3 13 15 ERR EXIT+ git-update-ref --no-deref HEAD HEAD@{1}+ cd $GIT_WORK_TREE+ git stash save "dirty $desc before update to $new";+ git-symbolic-ref HEAD "$ref"+ )+ fi++ # eye candy - show the WC updates :)+ echo "Updating working copy" >&2+ (cd $GIT_WORK_TREE+ git-diff-index -R --name-status HEAD >&2+ git-reset --hard HEAD)+}++if [ "$is_bare" = "false" ]+then+ active_branch=`git-symbolic-ref HEAD`+ export GIT_DIR=$(cd $GIT_DIR; pwd)+ GIT_WORK_TREE=${GIT_WORK_TREE-..}+ for ref+ do+ if [ "$ref" = "$active_branch" ]+ then+ update_wc $ref+ fi+ done+fi
+ filestore.cabal view
@@ -0,0 +1,25 @@+Name: filestore+Version: 0.1+Cabal-version: >= 1.2+Build-type: Simple+Tested-with: GHC==6.10.1+Synopsis: Interface for versioning file stores.+Description: The filestore library provides an abstract interface for a versioning+ file store, and modules that instantiate this interface. Currently+ only Git & Darcs modules are provided, but other VCSs or databases could be+ added.+Category: Data+Stability: Experimental+License: BSD3+License-File: LICENSE+Author: John MacFarlane, Gwern Branwen, Sebastiaan Visser+Maintainer: jgm@berkeley.edu+Build-depends: base >= 4, bytestring, utf8-string, filepath, directory, datetime,+ parsec >= 2 && < 3, process, time, datetime, regex-posix, xml, split, Diff+Extra-source-files: Tests.lhs+Exposed-modules: Data.FileStore, Data.FileStore.Types, Data.FileStore.Git, Data.FileStore.Darcs,+ -- Data.FileStore.Sqlite3,+ Data.FileStore.Utils, Data.FileStore.Generic+Other-modules: Paths_filestore+Data-Files: extra/post-update+Ghc-Options: -Wall