diff --git a/Data/FileStore.hs b/Data/FileStore.hs new file mode 100644 --- /dev/null +++ b/Data/FileStore.hs @@ -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 + 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 diff --git a/Data/FileStore/Darcs.hs b/Data/FileStore/Darcs.hs new file mode 100644 --- /dev/null +++ b/Data/FileStore/Darcs.hs @@ -0,0 +1,292 @@ +{- | + Module : Data.FileStore.Darcs + Copyright : Copyright (C) 2009 Gwern Brandwen + 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 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 +-- (). +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 \" input, then we return "(Just Address, Name)" +-- If there is no '<' in the input, then it clearly can't be of that format, and so we just return "(Nothing, Name)" +-- +-- > splitEmailAuthor "foo bar baz@gmail.com" ~> (Nothing,"foo bar baz@gmail.com") +-- > splitEmailAuthor "foo bar " ~> (Just "baz@gmail.com","foo bar") +splitEmailAuthor :: String -> (Maybe String, String) +splitEmailAuthor x = if '<' `elem` x then (Just (tail $ init c), reverse . dropWhile isSpace $ reverse b) + else (Nothing,x) + -- Will still need to trim the '<>' brackets in the email, and whitespace at the end of name + where (_,b,c) = x =~ "[^<]*" :: (String,String,String) + +changes :: Element -> Element +changes = fromJust . findElement (QName "summary" Nothing Nothing) + +analyze :: [Element] -> [Change] +analyze s = map convert s + where convert a + | x == "add_directory" || x == "add_file" = Added b + | x == "remove_file" || x == "remove_directory" = Deleted b + | x == "added_lines" + || x == "modify_file" + || x == "removed_lines" + || x == "replaced_tokens" = Modified b + | otherwise = error "Unknown change type" + where x = qName . elName $ a + b = takeWhile (/='\n') $ dropWhile isSpace $ strContent a + +filterSummary :: Element -> [Element] +filterSummary = filterElementsName (\(QName {qName = x}) -> x == "add_file" + || x == "add_directory" + || x == "remove_file" + || x == "remove_directory" + || x == "modify_file" + || x == "added_lines" + || x == "removed_lines" + || x == "replaced_tokens") + +-- Following are for 'darcsSearch' + +-- | Search multiple files with a single regexp +go :: FilePath -> [String] -> String -> IO [String] +go repo filesToCheck pattern = do (_, _, result) <- runShellCommand repo + Nothing "grep" $ ["--line-number", "-l", "-E", "-e", pattern] ++ filesToCheck + let results = intersect filesToCheck $ lines $ toString result + return results + +-- | Search a single file with multiple regexps +go' :: [String] -> FilePath -> [String] -> String -> IO [String] +go' os repo patterns file = do res <- mapM (\x -> run file x) patterns + return $ nub $ concat res + where run f p = do (_,_,r) <- runShellCommand repo Nothing "grep" $ + os ++ [p, f] + return $ lines $ toString r + +--------------------------- +-- 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 + diff --git a/Data/FileStore/Generic.hs b/Data/FileStore/Generic.hs new file mode 100644 --- /dev/null +++ b/Data/FileStore/Generic.hs @@ -0,0 +1,143 @@ +{- | + Module : Data.FileStore.Generic + Copyright : Copyright (C) 2009 John MacFarlane, Gwern Brandwen, 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 + , 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) + diff --git a/Data/FileStore/Git.hs b/Data/FileStore/Git.hs new file mode 100644 --- /dev/null +++ b/Data/FileStore/Git.hs @@ -0,0 +1,299 @@ +{- | + 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 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 +-- (). +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 diff --git a/Data/FileStore/Types.hs b/Data/FileStore/Types.hs new file mode 100644 --- /dev/null +++ b/Data/FileStore/Types.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE Rank2Types, TypeSynonymInstances, DeriveDataTypeable #-} +{- | + 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 + , 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] + + } + diff --git a/Data/FileStore/Utils.hs b/Data/FileStore/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/FileStore/Utils.hs @@ -0,0 +1,132 @@ +{- | + Module : Data.FileStore.Utils + Copyright : Copyright (C) 2009 John MacFarlane, Gwern Brandwen + License : BSD 3 + + Maintainer : John MacFarlane + 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} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Tests.lhs b/Tests.lhs new file mode 100644 --- /dev/null +++ b/Tests.lhs @@ -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")) + diff --git a/extra/post-update b/extra/post-update new file mode 100644 --- /dev/null +++ b/extra/post-update @@ -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 diff --git a/filestore.cabal b/filestore.cabal new file mode 100644 --- /dev/null +++ b/filestore.cabal @@ -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