filestore 0.3.2.1 → 0.3.2.2

raw patch · 6 files changed

+67/−44 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGES +13/−0
• Data/FileStore/Darcs.hs +12/−15
• Data/FileStore/Git.hs +5/−10
• Data/FileStore/Utils.hs +22/−18
• Tests.lhs +14/−0
• filestore.cabal +1/−1

@@ -1,3 +1,16 @@+Version 0.3.2.2 released 06 Nov 2009++* Raise an IllegalResourceName error if the user tries to create+  a file inside the .git or _darcs subdirectory.  Previously the+  file would be written (or overwritten) before the error was caught+  in the add/commit phase.  This introduced the risk of corrupting+  the repository or, worse, overwriting hooks.++* isInsideDir is no longer exported.++* checkAndWriteFile has been replaced with withSanityCheck, to avoid+  code duplication between create and rename functions.+ Version 0.3.2.1 released 24 Oct 2009  * Convert pathname to UTF8 in withVerifyDir.

@@ -15,7 +15,7 @@ module Data.FileStore.Darcs ( darcsFileStore ) where  import Control.Exception (throwIO)-import Control.Monad (unless, when)+import Control.Monad (when) import Data.DateTime (toSqlString) import Data.List (sort, isPrefixOf) #ifdef USE_MAXCOUNT@@ -23,14 +23,15 @@ #endif import System.Exit (ExitCode(..)) import System.Directory (doesDirectoryExist, createDirectoryIfMissing)-import System.FilePath ((</>), takeDirectory, dropFileName, addTrailingPathSeparator)+import System.FilePath ((</>), dropFileName, addTrailingPathSeparator)  import Data.FileStore.DarcsXml (parseDarcsXML) import Data.FileStore.Types-import Data.FileStore.Utils (checkAndWriteFile, hashsMatch, isInsideRepo, runShellCommand, ensureFileExists, grepSearchRepo, withVerifyDir)+import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, ensureFileExists, grepSearchRepo, withVerifyDir)+import Codec.Binary.UTF8.String (encodeString)  import Data.ByteString.Lazy.UTF8 (toString)-import qualified Data.ByteString.Lazy as B (ByteString)+import qualified Data.ByteString.Lazy as B (ByteString, writeFile)  -- | Return a filestore implemented using the Darcs distributed revision control system -- (<http://darcs.net/>).@@ -75,7 +76,7 @@ -- | Save changes (creating the file and directory if needed), add, and commit. darcsSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO () darcsSave repo name author logMsg contents = do-  checkAndWriteFile repo name contents+  withSanityCheck repo ["_darcs"] name $ B.writeFile (repo </> encodeString name) $ toByteString contents   -- Just in case it hasn't been added yet; we ignore failures since darcs will   -- fail if the file doesn't exist *and* if the file exists but has been added already.   runDarcsCommand repo "add" [name]@@ -96,16 +97,12 @@ -- | Change the name of a resource. darcsMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO () darcsMove repo oldName newName author logMsg = do-  let newPath = repo </> newName-  inside <- isInsideRepo repo newPath-  unless inside $ throwIO IllegalResourceName-  -- create destination directory if missing-  createDirectoryIfMissing True $ takeDirectory newPath-  (statusAdd,_,_) <- runDarcsCommand repo "add" [dropFileName newName]-  (statusAdd',_,_) <- runDarcsCommand repo "mv" [oldName, newName]-  if statusAdd == ExitSuccess && statusAdd' == ExitSuccess-     then darcsCommit repo [oldName, newName] author logMsg-     else throwIO NotFound+  withSanityCheck repo ["_darcs"] newName $ do+    (statusAdd, _, _) <- runDarcsCommand repo "add" [dropFileName newName]+    (statusAdd', _,_) <- runDarcsCommand repo "mv" [oldName, newName]+    if statusAdd == ExitSuccess && statusAdd' == ExitSuccess+       then darcsCommit repo [oldName, newName] author logMsg+       else throwIO NotFound  -- | Delete a resource from the repository. darcsDelete :: FilePath -> FilePath -> Author -> Description -> IO ()

@@ -20,14 +20,14 @@ import Data.Maybe (mapMaybe) import System.Exit import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.FileStore.Utils (checkAndWriteFile, hashsMatch, isInsideRepo, runShellCommand, escapeRegexSpecialChars, withVerifyDir) +import Data.FileStore.Utils (withSanityCheck, hashsMatch, runShellCommand, escapeRegexSpecialChars, withVerifyDir)  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, encodeString) import Data.Char (chr)-import Control.Monad (liftM, unless, when)-import System.FilePath ((</>), takeDirectory)+import Control.Monad (liftM, when)+import System.FilePath ((</>)) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, executable, getPermissions, setPermissions) import Control.Exception (throwIO) import Text.Regex.Posix ((=~))@@ -94,7 +94,7 @@ -- | Save changes (creating file and directory if needed), add, and commit. gitSave :: Contents a => FilePath -> FilePath -> Author -> Description -> a -> IO () gitSave repo name author logMsg contents = do-  checkAndWriteFile repo name contents+  withSanityCheck repo [".git"] name $ B.writeFile (repo </> encodeString name) $ toByteString contents   (statusAdd, errAdd, _) <- runGitCommand repo "add" [name]   if statusAdd == ExitSuccess      then gitCommit repo [name] author logMsg@@ -130,12 +130,7 @@ gitMove :: FilePath -> FilePath -> FilePath -> Author -> Description -> IO () gitMove repo oldName newName author logMsg = do   gitLatestRevId repo oldName   -- will throw a NotFound error if oldName doesn't exist-  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]+  (statusAdd, err, _) <- withSanityCheck repo [".git"] newName $ runGitCommand repo "mv" [oldName, newName]    if statusAdd == ExitSuccess      then gitCommit repo [oldName, newName] author logMsg      else throwIO $ UnknownError $ "Could not git mv " ++ oldName ++ " " ++ newName ++ "\n" ++ err

@@ -14,20 +14,19 @@           runShellCommand         , mergeContents         , hashsMatch-        , isInsideRepo         , escapeRegexSpecialChars         , parseMatchLine         , splitEmailAuthor         , ensureFileExists         , regSearchFiles         , regsSearchFile-        , checkAndWriteFile+        , withSanityCheck         , grepSearchRepo          , withVerifyDir ) where  import Codec.Binary.UTF8.String (encodeString) import Control.Exception (throwIO)-import Control.Monad (liftM, unless)+import Control.Monad (liftM, when, unless) import Data.ByteString.Lazy.UTF8 (toString) import Data.Char (isSpace) import Data.List (intersect, nub, isPrefixOf, isInfixOf)@@ -41,8 +40,7 @@ import Text.Regex.Posix ((=~)) import qualified Data.ByteString.Lazy as B -import Data.FileStore.Types (toByteString, Contents, SearchMatch(..), -                              FileStoreError(IllegalResourceName, NotFound, UnknownError), SearchQuery(..))+import Data.FileStore.Types (SearchMatch(..), FileStoreError(IllegalResourceName, NotFound, UnknownError), SearchQuery(..))  -- | Run shell command and return error status, standard output, and error output.  Assumes -- UTF-8 locale. Note that this does not actually go through \/bin\/sh!@@ -119,14 +117,14 @@ hashsMatch :: (Eq a) => [a] -> [a] -> Bool hashsMatch r1 r2 = r1 `isPrefixOf` r2 || r2 `isPrefixOf` r1 --- | Inquire of a certain repository whether another file lies within its ambit.---   This is basically asking whether the file is 'above' the repository in the filesystems's+-- | Inquire of a certain directory whether another file lies within its ambit.+--   This is basically asking whether the file is 'above' the directory in the filesystems's --   directory tree. Useful for checking the legality of a filename.-isInsideRepo :: FilePath -> FilePath -> IO Bool-isInsideRepo repo name = do-  gitRepoPathCanon <- canonicalizePath repo+isInsideDir :: FilePath -> FilePath -> IO Bool+isInsideDir name dir = do+  gitDirPathCanon <- canonicalizePath dir   filenameCanon <- canonicalizePath name-  return (gitRepoPathCanon `isPrefixOf` filenameCanon)+  return (gitDirPathCanon `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@@ -173,15 +171,21 @@   isFile <- doesFileExist (repo </> encodeString name)   unless isFile $ throwIO NotFound --- | Write out a file with given contents. We do sanity checking first, and make sure that the---   filename/location is within the given repo.-checkAndWriteFile :: (Data.FileStore.Types.Contents a) =>FilePath -> String -> a -> IO ()-checkAndWriteFile repo name contents = do+-- | Check that the filename/location is within the given repo, and not inside+-- any of the (relative) paths in @excludes@.  Create the directory if needed.+-- If everything checks out, then perform the specified action.+withSanityCheck :: FilePath+                -> [FilePath]+                -> FilePath+                -> IO b +                -> IO b+withSanityCheck repo excludes name action = do   let filename = repo </> encodeString name-  inside <- isInsideRepo repo filename-  unless inside $ throwIO IllegalResourceName+  insideRepo <- filename `isInsideDir` repo+  insideExcludes <- liftM or $ mapM (filename `isInsideDir`) $ map (repo </>) excludes+  when (insideExcludes || not insideRepo) $ throwIO IllegalResourceName   createDirectoryIfMissing True $ takeDirectory filename-  B.writeFile filename $ toByteString contents+  action  -- | Uses grep to search a file-based repository. Note that this calls out to grep; and so --   is generic over repos like git or darcs-based repos. (The git FileStore instance doesn't

@@ -36,6 +36,7 @@ >     , ("create resource in subdirectory", createTest2) >     , ("create resource with non-ascii name", createTest3) >     , ("try to create resource outside repo", createTest4)+>     , ("try to create resource in special directory", createTest5 fsName) >     , ("directory", directoryTest) >     , ("retrieve resource", retrieveTest1) >     , ("retrieve resource in a subdirectory", retrieveTest2)@@ -113,6 +114,19 @@ >          \e -> assertEqual "error from create ../oops" IllegalResourceName e  >   exists <- doesFileExist "tmp/oops" >   assertBool "file ../oops was created outside repository" (not exists)++*** Try to create a resource in special directory (should fail with an error and NOT write the file):++> createTest5 fsName fs = TestCase $ do+>   let (realpath, special) = case fsName of+>                             "Data.FileStore.Git"   -> ("tmp" </> "gitfs" </> ".git" </> "newfile", ".git/newfile")+>                             "Data.FileStore.Darcs" -> ("tmp" </> "darcsfs" </> "_darcs" </> "newfile", "_darcs/newfile")+>                             _                      -> error "Unknown filestore type!  Add a test case."+>   catch (create fs special testAuthor "description of change" testContents >>+>          (assertFailure  $ "did not return error from create " ++ special)) $+>          \e -> assertEqual ("error from create " ++ special) IllegalResourceName e +>   exists <- doesFileExist realpath+>   assertBool ("file " ++ realpath ++ " was created outside repository") (not exists)  *** Test directory 

@@ -1,5 +1,5 @@ Name:                filestore-Version:             0.3.2.1+Version:             0.3.2.2 Cabal-version:       >= 1.2 Build-type:          Custom Tested-with:         GHC==6.10.1