Skip to content
Browse files

merge from git-annex

  • Loading branch information...
1 parent 4f28979 commit 29dde3e37a6ffa82052aee01a2e1636f1dc075f9 @joeyh committed Apr 23, 2012
Showing with 116 additions and 26 deletions.
  1. +2 −2 Git/Command.hs
  2. +4 −0 Git/Config.hs
  3. +1 −1 Git/Construct.hs
  4. +29 −0 Git/Ref.hs
  5. +2 −1 Utility/Directory.hs
  6. +1 −4 Utility/Exception.hs
  7. +65 −18 Utility/FileMode.hs
  8. +12 −0 Utility/Monad.hs
View
4 Git/Command.hs
@@ -79,5 +79,5 @@ pipeNullSplit params repo =
reap :: IO ()
reap = do
-- throws an exception when there are no child processes
- r <- catchDefaultIO (getAnyProcessStatus False True) Nothing
- maybe (return ()) (const reap) r
+ catchDefaultIO (getAnyProcessStatus False True) Nothing
+ >>= maybe noop (const reap)
View
4 Git/Config.hs
@@ -20,6 +20,10 @@ import qualified Git.Construct
get :: String -> String -> Repo -> String
get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
+{- Returns a list with each line of a multiline config setting. -}
+getList :: String -> Repo -> [String]
+getList key repo = M.findWithDefault [] key (fullconfig repo)
+
{- Returns a single git config setting, if set. -}
getMaybe :: String -> Repo -> Maybe String
getMaybe key repo = M.lookup key (config repo)
View
2 Git/Construct.hs
@@ -48,7 +48,7 @@ import qualified Git.Url as Url
fromCurrent :: IO Repo
fromCurrent = do
r <- maybe fromCwd fromPath =<< getEnv "GIT_DIR"
- maybe (return ()) changeWorkingDirectory =<< getEnv "GIT_WORK_TREE"
+ maybe noop changeWorkingDirectory =<< getEnv "GIT_WORK_TREE"
unsetEnv "GIT_DIR"
unsetEnv "GIT_WORK_TREE"
return r
View
29 Git/Ref.hs
@@ -11,6 +11,8 @@ import Common
import Git
import Git.Command
+import Data.Char (chr)
+
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
describe = show . base
@@ -61,3 +63,30 @@ matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
matchingUniq ref repo = nubBy uniqref <$> matching ref repo
where
uniqref (a, _) (b, _) = a == b
+
+{- Checks if a String is a legal git ref name.
+ -
+ - The rules for this are complex; see git-check-ref-format(1) -}
+legal :: Bool -> String -> Bool
+legal allowonelevel s = all (== False) illegal
+ where
+ illegal =
+ [ any ("." `isPrefixOf`) pathbits
+ , any (".lock" `isSuffixOf`) pathbits
+ , not allowonelevel && length pathbits < 2
+ , contains ".."
+ , any (\c -> contains [c]) illegalchars
+ , begins "/"
+ , ends "/"
+ , contains "//"
+ , ends "."
+ , contains "@{"
+ , null s
+ ]
+ contains v = v `isInfixOf` s
+ ends v = v `isSuffixOf` s
+ begins v = v `isPrefixOf` s
+
+ pathbits = split "/" s
+ illegalchars = " ~^:?*[\\" ++ controlchars
+ controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
View
3 Utility/Directory.hs
@@ -19,6 +19,7 @@ import Control.Applicative
import Utility.SafeCommand
import Utility.TempFile
import Utility.Exception
+import Utility.Monad
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
@@ -34,7 +35,7 @@ dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d
moveFile :: FilePath -> FilePath -> IO ()
moveFile src dest = tryIO (rename src dest) >>= onrename
where
- onrename (Right _) = return ()
+ onrename (Right _) = noop
onrename (Left e)
| isPermissionError e = rethrow
| isDoesNotExistError e = rethrow
View
5 Utility/Exception.hs
@@ -25,10 +25,7 @@ catchDefaultIO a def = catchIO a (const $ return def)
{- Catches IO errors and returns the error message. -}
catchMsgIO :: IO a -> IO (Either String a)
-catchMsgIO a = dispatch <$> tryIO a
- where
- dispatch (Left e) = Left $ show e
- dispatch (Right v) = Right v
+catchMsgIO a = either (Left . show) Right <$> tryIO a
{- catch specialized for IO errors only -}
catchIO :: IO a -> (IOException -> IO a) -> IO a
View
83 Utility/FileMode.hs
@@ -1,43 +1,90 @@
{- File mode utilities.
-
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.FileMode where
-import System.Posix.Files
+import Common
+
+import Control.Exception (bracket)
import System.Posix.Types
import Foreign (complement)
-{- Removes a FileMode from a file.
- - For example, call with otherWriteMode to chmod o-w -}
-unsetFileMode :: FilePath -> FileMode -> IO ()
-unsetFileMode f m = do
+{- Applies a conversion function to a file's mode. -}
+modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode f convert = void $ modifyFileMode' f convert
+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' f convert = do
s <- getFileStatus f
- setFileMode f $ fileMode s `intersectFileModes` complement m
+ let old = fileMode s
+ let new = convert old
+ when (new /= old) $
+ setFileMode f new
+ return old
+
+{- Adds the specified FileModes to the input mode, leaving the rest
+ - unchanged. -}
+addModes :: [FileMode] -> FileMode -> FileMode
+addModes ms m = combineModes (m:ms)
+
+{- Removes the specified FileModes from the input mode. -}
+removeModes :: [FileMode] -> FileMode -> FileMode
+removeModes ms m = m `intersectFileModes` complement (combineModes ms)
+
+{- Runs an action after changing a file's mode, then restores the old mode. -}
+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode file convert a = bracket setup cleanup go
+ where
+ setup = modifyFileMode' file convert
+ cleanup oldmode = modifyFileMode file (const oldmode)
+ go _ = a
+
+writeModes :: [FileMode]
+writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
+
+readModes :: [FileMode]
+readModes = [ownerReadMode, groupReadMode, otherReadMode]
{- Removes the write bits from a file. -}
preventWrite :: FilePath -> IO ()
-preventWrite f = unsetFileMode f writebits
- where
- writebits = foldl unionFileModes ownerWriteMode
- [groupWriteMode, otherWriteMode]
+preventWrite f = modifyFileMode f $ removeModes writeModes
-{- Turns a file's write bit back on. -}
+{- Turns a file's owner write bit back on. -}
allowWrite :: FilePath -> IO ()
-allowWrite f = do
- s <- getFileStatus f
- setFileMode f $ fileMode s `unionFileModes` ownerWriteMode
+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
+
+{- Allows owner and group to read and write to a file. -}
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ addModes
+ [ ownerWriteMode, groupWriteMode
+ , ownerReadMode, groupReadMode
+ ]
{- Checks if a file mode indicates it's a symlink. -}
isSymLink :: FileMode -> Bool
isSymLink mode = symbolicLinkMode `intersectFileModes` mode == symbolicLinkMode
{- Checks if a file has any executable bits set. -}
isExecutable :: FileMode -> Bool
-isExecutable mode = ebits `intersectFileModes` mode /= 0
+isExecutable mode = combineModes ebits `intersectFileModes` mode /= 0
where
- ebits = ownerExecuteMode `unionFileModes`
- groupExecuteMode `unionFileModes` otherExecuteMode
+ ebits = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
+
+{- Runs an action without that pesky umask influencing it, unless the
+ - passed FileMode is the standard one. -}
+noUmask :: FileMode -> IO a -> IO a
+noUmask mode a
+ | mode == stdFileMode = a
+ | otherwise = bracket setup cleanup go
+ where
+ setup = setFileCreationMask nullFileMode
+ cleanup = setFileCreationMask
+ go _ = a
+
+combineModes :: [FileMode] -> FileMode
+combineModes [] = undefined
+combineModes [m] = m
+combineModes (m:ms) = foldl unionFileModes m ms
View
12 Utility/Monad.hs
@@ -31,6 +31,14 @@ ifM cond (thenclause, elseclause) = do
c <- cond
if c then thenclause else elseclause
+{- short-circuiting monadic || -}
+(<||>) :: Monad m => m Bool -> m Bool -> m Bool
+ma <||> mb = ifM ma ( return True , mb )
+
+{- short-circuiting monadic && -}
+(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
+ma <&&> mb = ifM ma ( mb , return False )
+
{- Runs an action, passing its value to an observer before returning it. -}
observe :: Monad m => (a -> m b) -> m a -> m a
observe observer a = do
@@ -41,3 +49,7 @@ observe observer a = do
{- b `after` a runs first a, then b, and returns the value of a -}
after :: Monad m => m b -> m a -> m a
after = observe . const
+
+{- do nothing -}
+noop :: Monad m => m ()
+noop = return ()

0 comments on commit 29dde3e

Please sign in to comment.
Something went wrong with that request. Please try again.