diff options
| author |  Joey Hess <joey@kitenet.net> | 2011-08-22 16:14:12 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2011-08-22 16:14:12 -0400 |
| commit | 203148363f459635b1be40b8c6ed376073230dda (patch) | |
| tree | 422df5684fc77663c6a3c7fd601c1eff27b3758b | |
| parent | 4c73d77b42e97ad740d5731ad73c40a31c0c84f9 (diff) | |
split groups of related functions out of Utility
47 files changed, 312 insertions, 265 deletions
diff --git a/.gitignore b/.gitignore index 1fdad216d..7d2504de6 100644 --- a/.gitignore +++ b/.gitignore @@ -13,7 +13,7 @@ doc/.ikiwiki html *.tix .hpc -Touch.hs -StatFS.hs +Utility/Touch.hs +Utility/StatFS.hs Remote/S3.hs dist diff --git a/AnnexQueue.hs b/AnnexQueue.hs index 56d71f323..d155a7b81 100644 --- a/AnnexQueue.hs +++ b/AnnexQueue.hs @@ -17,7 +17,7 @@ import Control.Monad (when, unless) import Annex import Messages import qualified Git.Queue -import Utility +import Utility.SafeCommand {- Adds a git command to the queue. -} add :: String -> [CommandParam] -> [FilePath] -> Annex () diff --git a/Backend/SHA.hs b/Backend/SHA.hs index b8a0d254b..ed2a47db9 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -23,7 +23,7 @@ import Content import Types import Types.Backend import Types.Key -import Utility +import Utility.SafeCommand import qualified Build.SysConfig as SysConfig type SHASize = Int @@ -37,6 +37,8 @@ import qualified Git import qualified Git.UnionMerge import qualified Annex import Utility +import Utility.Conditional +import Utility.SafeCommand import Types import Messages import Locations diff --git a/Command/Add.hs b/Command/Add.hs index 407a36093..579c4171b 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -23,8 +23,9 @@ import LocationLog import Types import Content import Messages -import Utility +import Utility.Conditional import Utility.Touch +import Utility.SafeCommand import Locations command :: [Command] diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 72a6b671d..55e51100c 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -23,7 +23,7 @@ import Messages import Content import PresenceLog import Locations -import Utility +import Utility.Path command :: [Command] command = [repoCommand "addurl" paramPath seek "add urls to annex"] diff --git a/Command/Drop.hs b/Command/Drop.hs index 14f098349..6e688d663 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -15,6 +15,7 @@ import Types import Content import Messages import Utility +import Utility.Conditional import Trust import Config diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 41bcd6aa7..4ad2aa85b 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -22,7 +22,7 @@ import qualified Command.Move import qualified Remote import qualified Git import Types.Key -import Utility +import Utility.Conditional type UnusedMap = M.Map String Key diff --git a/Command/Find.hs b/Command/Find.hs index 9d760ff5a..0716c5297 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -11,7 +11,7 @@ import Control.Monad.State (liftIO) import Command import Content -import Utility +import Utility.Conditional command :: [Command] command = [repoCommand "find" (paramOptional $ paramRepeating paramPath) seek diff --git a/Command/Fix.hs b/Command/Fix.hs index 47b0c4c9a..b24f8e33c 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -13,7 +13,8 @@ import System.Directory import Command import qualified AnnexQueue -import Utility +import Utility.Path +import Utility.SafeCommand import Content import Messages diff --git a/Command/FromKey.hs b/Command/FromKey.hs index d59f1de39..89c3f4e91 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -14,10 +14,11 @@ import Control.Monad (unless) import Command import qualified AnnexQueue -import Utility +import Utility.SafeCommand import Content import Messages import Types.Key +import Utility.Path command :: [Command] command = [repoCommand "fromkey" paramPath seek diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 0d3ecb58f..6ccec05fb 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -27,6 +27,7 @@ import LocationLog import Locations import Trust import Utility.DataUnits +import Utility.Path import Config command :: [Command] diff --git a/Command/Lock.hs b/Command/Lock.hs index d39df5f33..77d1ff94f 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -13,7 +13,7 @@ import System.Directory import Command import Messages import qualified AnnexQueue -import Utility +import Utility.SafeCommand command :: [Command] command = [repoCommand "lock" paramPath seek "undo unlock command"] diff --git a/Command/Map.hs b/Command/Map.hs index 3fd6e42a1..ef8e04d90 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -19,7 +19,7 @@ import qualified Annex import qualified Git import Messages import Types -import Utility +import Utility.SafeCommand import UUID import Trust import Utility.Ssh diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 5ae835440..25227ae16 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -20,7 +20,7 @@ import Locations import Types import Content import Messages -import Utility +import Utility.Conditional import qualified Command.Add command :: [Command] diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index e2f7c74ab..be6163558 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -13,8 +13,8 @@ import System.Exit import Command import CmdLine import Content -import Utility import Utility.RsyncFile +import Utility.Conditional command :: [Command] command = [repoCommand "recvkey" paramKey seek diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 02fedb349..f676ae947 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -14,8 +14,8 @@ import Locations import qualified Annex import Command import Content -import Utility import Utility.RsyncFile +import Utility.Conditional import Messages command :: [Command] diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 807cbd5b9..2f6f9ea9e 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -10,7 +10,7 @@ module Command.SetKey where import Control.Monad.State (liftIO) import Command -import Utility +import Utility.SafeCommand import LocationLog import Content import Messages diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 960f99722..54ef2fc68 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -16,7 +16,8 @@ import Command import qualified Command.Drop import qualified Annex import qualified AnnexQueue -import Utility +import Utility.SafeCommand +import Utility.Path import LocationLog import Types import Content diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 195246aa8..fadae0e5a 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -12,7 +12,7 @@ import System.Directory import System.Exit import Command -import Utility +import Utility.SafeCommand import qualified Git import qualified Annex import qualified Command.Unannex diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 280eff9de..0daf1b321 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -16,8 +16,9 @@ import Types import Messages import Locations import Content +import Utility.Conditional import Utility.CopyFile -import Utility +import Utility.Path command :: [Command] command = @@ -16,6 +16,7 @@ import qualified Git import qualified Annex import Types import Utility +import Utility.SafeCommand type ConfigKey = String diff --git a/Content.hs b/Content.hs index e89f4c45a..ba99f1330 100644 --- a/Content.hs +++ b/Content.hs @@ -41,7 +41,9 @@ import qualified Annex import qualified AnnexQueue import qualified Branch import Utility +import Utility.Conditional import Utility.StatFS +import Utility.Path import Types.Key import Utility.DataUnits import Config @@ -48,6 +48,7 @@ import Types.Key import Types.Remote import Utility import Utility.Base64 +import Utility.SafeCommand import Types.Crypto {- The first half of a Cipher is used for HMAC; the remainder @@ -85,6 +85,9 @@ import System.Exit import System.Posix.Env (setEnv, unsetEnv, getEnv) import Utility +import Utility.Path +import Utility.Conditional +import Utility.SafeCommand {- There are two types of repositories; those on local disk and those - accessed via an URL. -} diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 23b383a09..1ecbb029b 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -16,7 +16,7 @@ module Git.LsFiles ( ) where import Git -import Utility +import Utility.SafeCommand {- Scans for files that are checked into git at the specified locations. -} inRepo :: Repo -> [FilePath] -> IO [FilePath] diff --git a/Git/Queue.hs b/Git/Queue.hs index 0016be472..25b9ffad0 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -19,15 +19,15 @@ import System.IO import System.Cmd.Utils import Data.String.Utils import Control.Monad (forM_) -import Utility +import Utility.SafeCommand import Git {- An action to perform in a git repository. The file to act on - is not included, and must be able to be appended after the params. -} -data Action = Action { - getSubcommand :: String, - getParams :: [CommandParam] +data Action = Action + { getSubcommand :: String + , getParams :: [CommandParam] } deriving (Show, Eq, Ord) {- A queue of actions to perform (in any order) on a git repository, diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index b0da07170..a5bcbeac4 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -18,7 +18,7 @@ import Data.Maybe import Data.String.Utils import Git -import Utility +import Utility.SafeCommand {- Performs a union merge between two branches, staging it in the index. - Any previously staged changes in the index will be lost. @@ -22,6 +22,7 @@ import Version import Messages import Types import Utility +import Utility.Conditional import UUID initialize :: Annex () diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 069209792..ebb4b10a5 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -29,6 +29,8 @@ import UUID import Locations import Config import Utility +import Utility.Conditional +import Utility.SafeCommand import Messages import Utility.Ssh import Remote.Helper.Special diff --git a/Remote/Directory.hs b/Remote/Directory.hs index fd227f85d..7ddb60462 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -27,6 +27,8 @@ import Utility.CopyFile import Config import Content import Utility +import Utility.Conditional +import Utility.Path import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto diff --git a/Remote/Git.hs b/Remote/Git.hs index 80ba8a153..fadd48a03 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -26,6 +26,8 @@ import Messages import Utility.CopyFile import Utility.RsyncFile import Utility.Ssh +import Utility.SafeCommand +import Utility.Path import qualified Utility.Url as Url import Config import Init diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index c302a0ff5..b842588c0 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -17,7 +17,7 @@ import Types.Remote import qualified Git import qualified Annex import UUID -import Utility +import Utility.SafeCommand {- Special remotes don't have a configured url, so Git.Repo does not - automatically generate remotes for them. This looks for a different diff --git a/Remote/Hook.hs b/Remote/Hook.hs index ef52d0482..54b9806ff 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -28,6 +28,7 @@ import Locations import Config import Content import Utility +import Utility.SafeCommand import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index eba67e3fd..3707966ad 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -26,11 +26,14 @@ import Locations import Config import Content import Utility +import Utility.Conditional import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto import Messages import Utility.RsyncFile +import Utility.SafeCommand +import Utility.Path type RsyncUrl = String diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 160d9309f..b4567a0b7 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -31,6 +31,8 @@ import Backend import Messages import Version import Utility +import Utility.SafeCommand +import Utility.Path import qualified Upgrade.V2 -- v2 adds hashing of filenames of content and location log files. diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 0b1d69f8e..ffd0f0653 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -20,6 +20,8 @@ import qualified Git import qualified Branch import Messages import Utility +import Utility.Conditional +import Utility.SafeCommand import LocationLog import Content diff --git a/Utility.hs b/Utility.hs index 8a332601b..788dc4103 100644 --- a/Utility.hs +++ b/Utility.hs @@ -6,20 +6,8 @@ -} module Utility ( - CommandParam(..), - toCommand, hGetContentsStrict, readFileStrict, - parentDir, - absPath, - absPathFrom, - relPathCwdToFile, - relPathDirToFile, - boolSystem, - boolSystemEnv, - executeFile, - shellEscape, - shellUnEscape, unsetFileMode, readMaybe, viaTmp, @@ -27,125 +15,19 @@ module Utility ( dirContains, dirContents, myHomeDir, - catchBool, - whenM, - (>>?), - unlessM, - (>>!), - - prop_idempotent_shellEscape, - prop_idempotent_shellEscape_multiword, - prop_parentDir_basics, - prop_relPathDirToFile_basics + catchBool ) where import IO (bracket) import System.IO -import System.Exit -import qualified System.Posix.Process import System.Posix.Process hiding (executeFile) -import System.Posix.Signals import System.Posix.Files import System.Posix.Types import System.Posix.User -import Data.String.Utils -import System.Path import System.FilePath import System.Directory import Foreign (complement) -import Data.List -import Data.Maybe -import Control.Monad (liftM2, when, unless) -import System.Log.Logger - -{- A type for parameters passed to a shell command. A command can - - be passed either some Params (multiple parameters can be included, - - whitespace-separated, or a single Param (for when parameters contain - - whitespace), or a File. - -} -data CommandParam = Params String | Param String | File FilePath - deriving (Eq, Show, Ord) - -{- Used to pass a list of CommandParams to a function that runs - - a command and expects Strings. -} -toCommand :: [CommandParam] -> [String] -toCommand = (>>= unwrap) - where - unwrap (Param s) = [s] - unwrap (Params s) = filter (not . null) (split " " s) - -- Files that start with a dash are modified to avoid - -- the command interpreting them as options. - unwrap (File s@('-':_)) = ["./" ++ s] - unwrap (File s) = [s] - -{- Run a system command, and returns True or False - - if it succeeded or failed. - - - - SIGINT(ctrl-c) is allowed to propigate and will terminate the program. - -} -boolSystem :: FilePath -> [CommandParam] -> IO Bool -boolSystem command params = boolSystemEnv command params Nothing - -boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -boolSystemEnv command params env = do - -- Going low-level because all the high-level system functions - -- block SIGINT etc. We need to block SIGCHLD, but allow - -- SIGINT to do its default program termination. - let sigset = addSignal sigCHLD emptySignalSet - oldint <- installHandler sigINT Default Nothing - oldset <- getSignalMask - blockSignals sigset - childpid <- forkProcess $ childaction oldint oldset - mps <- getProcessStatus True False childpid - restoresignals oldint oldset - case mps of - Just (Exited ExitSuccess) -> return True - _ -> return False - where - restoresignals oldint oldset = do - _ <- installHandler sigINT oldint Nothing - setSignalMask oldset - childaction oldint oldset = do - restoresignals oldint oldset - executeFile command True (toCommand params) env - -{- executeFile with debug logging -} -executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO () -executeFile c path p e = do - debugM "Utility.executeFile" $ - "Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e - System.Posix.Process.executeFile c path p e - -{- Escapes a filename or other parameter to be safely able to be exposed to - - the shell. -} -shellEscape :: String -> String -shellEscape f = "'" ++ escaped ++ "'" - where - -- replace ' with '"'"' - escaped = join "'\"'\"'" $ split "'" f - -{- Unescapes a set of shellEscaped words or filenames. -} -shellUnEscape :: String -> [String] -shellUnEscape [] = [] -shellUnEscape s = word : shellUnEscape rest - where - (word, rest) = findword "" s - findword w [] = (w, "") - findword w (c:cs) - | c == ' ' = (w, cs) - | c == '\'' = inquote c w cs - | c == '"' = inquote c w cs - | otherwise = findword (w++[c]) cs - inquote _ w [] = (w, "") - inquote q w (c:cs) - | c == q = findword w cs - | otherwise = inquote q (w++[c]) cs - -{- For quickcheck. -} -prop_idempotent_shellEscape :: String -> Bool -prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s -prop_idempotent_shellEscape_multiword :: [String] -> Bool -prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s +import Utility.Path {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} @@ -156,82 +38,6 @@ hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s readFileStrict :: FilePath -> IO String readFileStrict f = readFile f >>= \s -> length s `seq` return s -{- Returns the parent directory of a path. Parent of / is "" -} -parentDir :: FilePath -> FilePath -parentDir dir = - if not $ null dirs - then slash ++ join s (take (length dirs - 1) dirs) - else "" - where - dirs = filter (not . null) $ split s dir - slash = if isAbsolute dir then s else "" - s = [pathSeparator] - -prop_parentDir_basics :: FilePath -> Bool -prop_parentDir_basics dir - | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir - where - p = parentDir dir - -{- Checks if the first FilePath is, or could be said to contain the second. - - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc - - are all equivilant. - -} -dirContains :: FilePath -> FilePath -> Bool -dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b' - where - norm p = fromMaybe "" $ absNormPath p "." - a' = norm a - b' = norm b - -{- Converts a filename into a normalized, absolute path. -} -absPath :: FilePath -> IO FilePath -absPath file = do - cwd <- getCurrentDirectory - return $ absPathFrom cwd file - -{- Converts a filename into a normalized, absolute path - - from the specified cwd. -} -absPathFrom :: FilePath -> FilePath -> FilePath -absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file - where - bad = error $ "unable to normalize " ++ file - -{- Constructs a relative path from the CWD to a file. - - - - For example, assuming CWD is /tmp/foo/bar: - - relPathCwdToFile "/tmp/foo" == ".." - - relPathCwdToFile "/tmp/foo/bar" == "" - -} -relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = liftM2 relPathDirToFile getCurrentDirectory (absPath f) - -{- Constructs a relative path from a directory to a file. - - - - Both must be absolute, and normalized (eg with absNormpath). - -} -relPathDirToFile :: FilePath -> FilePath -> FilePath -relPathDirToFile from to = path - where - s = [pathSeparator] - pfrom = split s from - pto = split s to - common = map fst $ filter same $ zip pfrom pto - same (c,d) = c == d - uncommon = drop numcommon pto - dotdots = replicate (length pfrom - numcommon) ".." - numcommon = length common - path = join s $ dotdots ++ uncommon - -prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool -prop_relPathDirToFile_basics from to - | from == to = null r - | otherwise = not (null r) - where - r = relPathDirToFile from to - {- Removes a FileMode from a file. - For example, call with otherWriteMode to chmod o-w -} unsetFileMode :: FilePath -> FileMode -> IO () @@ -288,20 +94,3 @@ myHomeDir = do {- Catches IO errors and returns a Bool -} catchBool :: IO Bool -> IO Bool catchBool = flip catch (const $ return False) - -{- when with a monadic conditional -} -whenM :: Monad m => m Bool -> m () -> m () -whenM c a = c >>= flip when a - -unlessM :: Monad m => m Bool -> m () -> m () -unlessM c a = c >>= flip unless a - -(>>?) :: Monad m => m Bool -> m () -> m () -(>>?) = whenM - -(>>!) :: Monad m => m Bool -> m () -> m () -(>>!) = unlessM - --- low fixity allows eg, foo bar >>! error $ "failed " ++ meep -infixr 0 >>? -infixr 0 >>! diff --git a/Utility/Conditional.hs b/Utility/Conditional.hs new file mode 100644 index 000000000..85e39ec64 --- /dev/null +++ b/Utility/Conditional.hs @@ -0,0 +1,26 @@ +{- monadic conditional operators + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Conditional where + +import Control.Monad (when, unless) + +whenM :: Monad m => m Bool -> m () -> m () +whenM c a = c >>= flip when a + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM c a = c >>= flip unless a + +(>>?) :: Monad m => m Bool -> m () -> m () +(>>?) = whenM + +(>>!) :: Monad m => m Bool -> m () -> m () +(>>!) = unlessM + +-- low fixity allows eg, foo bar >>! error $ "failed " ++ meep +infixr 0 >>? +infixr 0 >>! diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index befb00f8f..901935719 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -9,7 +9,8 @@ module Utility.CopyFile (copyFile) where import System.Directory (doesFileExist, removeFile) -import Utility +import Utility.Conditional +import Utility.SafeCommand import qualified Build.SysConfig as SysConfig {- The cp command is used, because I hate reinventing the wheel, diff --git a/Utility/Path.hs b/Utility/Path.hs new file mode 100644 index 000000000..517c175bc --- /dev/null +++ b/Utility/Path.hs @@ -0,0 +1,92 @@ +{- path manipulation + - + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Path where + +import Data.String.Utils +import System.Path +import System.FilePath +import System.Directory +import Data.List +import Data.Maybe +import Control.Monad (liftM2) + +{- Returns the parent directory of a path. Parent of / is "" -} +parentDir :: FilePath -> FilePath +parentDir dir = + if not $ null dirs + then slash ++ join s (take (length dirs - 1) dirs) + else "" + where + dirs = filter (not . null) $ split s dir + slash = if isAbsolute dir then s else "" + s = [pathSeparator] + +prop_parentDir_basics :: FilePath -> Bool +prop_parentDir_basics dir + | null dir = True + | dir == "/" = parentDir dir == "" + | otherwise = p /= dir + where + p = parentDir dir + +{- Checks if the first FilePath is, or could be said to contain the second. + - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc + - are all equivilant. + -} +dirContains :: FilePath -> FilePath -> Bool +dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b' + where + norm p = fromMaybe "" $ absNormPath p "." + a' = norm a + b' = norm b + +{- Converts a filename into a normalized, absolute path. -} +absPath :: FilePath -> IO FilePath +absPath file = do + cwd <- getCurrentDirectory + return $ absPathFrom cwd file + +{- Converts a filename into a normalized, absolute path + - from the specified cwd. -} +absPathFrom :: FilePath -> FilePath -> FilePath +absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file + where + bad = error $ "unable to normalize " ++ file + +{- Constructs a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: FilePath -> IO FilePath +relPathCwdToFile f = liftM2 relPathDirToFile getCurrentDirectory (absPath f) + +{- Constructs a relative path from a directory to a file. + - + - Both must be absolute, and normalized (eg with absNormpath). + -} +relPathDirToFile :: FilePath -> FilePath -> FilePath +relPathDirToFile from to = path + where + s = [pathSeparator] + pfrom = split s from + pto = split s to + common = map fst $ filter same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common + path = join s $ dotdots ++ uncommon + +prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool +prop_relPathDirToFile_basics from to + | from == to = null r + | otherwise = not (null r) + where + r = relPathDirToFile from to diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs index 6e21ba063..b6c2267e8 100644 --- a/Utility/RsyncFile.hs +++ b/Utility/RsyncFile.hs @@ -9,7 +9,7 @@ module Utility.RsyncFile where import Data.String.Utils -import Utility +import Utility.SafeCommand {- Generates parameters to make rsync use a specified command as its remote - shell. -} diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs new file mode 100644 index 000000000..ba9362603 --- /dev/null +++ b/Utility/SafeCommand.hs @@ -0,0 +1,104 @@ +{- safely running shell commands + - + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.SafeCommand where + +import System.Exit +import qualified System.Posix.Process +import System.Posix.Process hiding (executeFile) +import System.Posix.Signals +import Data.String.Utils +import System.Log.Logger + +{- A type for parameters passed to a shell command. A command can + - be passed either some Params (multiple parameters can be included, + - whitespace-separated, or a single Param (for when parameters contain + - whitespace), or a File. + -} +data CommandParam = Params String | Param String | File FilePath + deriving (Eq, Show, Ord) + +{- Used to pass a list of CommandParams to a function that runs + - a command and expects Strings. -} +toCommand :: [CommandParam] -> [String] +toCommand = (>>= unwrap) + where + unwrap (Param s) = [s] + unwrap (Params s) = filter (not . null) (split " " s) + -- Files that start with a dash are modified to avoid + -- the command interpreting them as options. + unwrap (File s@('-':_)) = ["./" ++ s] + unwrap (File s) = [s] + +{- Run a system command, and returns True or False + - if it succeeded or failed. + - + - SIGINT(ctrl-c) is allowed to propigate and will terminate the program. + -} +boolSystem :: FilePath -> [CommandParam] -> IO Bool +boolSystem command params = boolSystemEnv command params Nothing + +boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +boolSystemEnv command params env = do + -- Going low-level because all the high-level system functions + -- block SIGINT etc. We need to block SIGCHLD, but allow + -- SIGINT to do its default program termination. + let sigset = addSignal sigCHLD emptySignalSet + oldint <- installHandler sigINT Default Nothing + oldset <- getSignalMask + blockSignals sigset + childpid <- forkProcess $ childaction oldint oldset + mps <- getProcessStatus True False childpid + restoresignals oldint oldset + case mps of + Just (Exited ExitSuccess) -> return True + _ -> return False + where + restoresignals oldint oldset = do + _ <- installHandler sigINT oldint Nothing + setSignalMask oldset + childaction oldint oldset = do + restoresignals oldint oldset + executeFile command True (toCommand params) env + +{- executeFile with debug logging -} +executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO () +executeFile c path p e = do + debugM "Utility.SafeCommand.executeFile" $ + "Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e + System.Posix.Process.executeFile c path p e + +{- Escapes a filename or other parameter to be safely able to be exposed to + - the shell. -} +shellEscape :: String -> String +shellEscape f = "'" ++ escaped ++ "'" + where + -- replace ' with '"'"' + escaped = join "'\"'\"'" $ split "'" f + +{- Unescapes a set of shellEscaped words or filenames. -} +shellUnEscape :: String -> [String] +shellUnEscape [] = [] +shellUnEscape s = word : shellUnEscape rest + where + (word, rest) = findword "" s + findword w [] = (w, "") + findword w (c:cs) + | c == ' ' = (w, cs) + | c == '\'' = inquote c w cs + | c == '"' = inquote c w cs + | otherwise = findword (w++[c]) cs + inquote _ w [] = (w, "") + inquote q w (c:cs) + | c == q = findword w cs + | otherwise = inquote q (w++[c]) cs + +{- For quickcheck. -} +prop_idempotent_shellEscape :: String -> Bool +prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s +prop_idempotent_shellEscape_multiword :: [String] -> Bool +prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s diff --git a/Utility/Ssh.hs b/Utility/Ssh.hs index 6cbc362a0..05269552c 100644 --- a/Utility/Ssh.hs +++ b/Utility/Ssh.hs @@ -10,7 +10,7 @@ module Utility.Ssh where import Control.Monad.State (liftIO) import qualified Git -import Utility +import Utility.SafeCommand import Types import Config diff --git a/Utility/Url.hs b/Utility/Url.hs index 5954e0ff7..69b53c34c 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -19,7 +19,7 @@ import Network.URI import Types import Messages -import Utility +import Utility.SafeCommand type URLString = String diff --git a/git-annex-shell.hs b/git-annex-shell.hs index 29ac63aea..1fb928f9d 100644 --- a/git-annex-shell.hs +++ b/git-annex-shell.hs @@ -11,7 +11,8 @@ import Data.List import qualified Git import CmdLine import Command -import Utility +import Utility.Conditional +import Utility.SafeCommand import Options import qualified Command.ConfigList @@ -24,11 +24,12 @@ import qualified Data.Map as M import System.Path (recurseDir) import System.IO.HVFS (SystemFS(..)) +import Utility.SafeCommand + import qualified Annex import qualified Backend import qualified Git import qualified Locations -import qualified Utility import qualified Types.Backend import qualified Types import qualified GitAnnex @@ -42,6 +43,7 @@ import qualified Command.DropUnused import qualified Types.Key import qualified Config import qualified Crypto +import qualified Utility.Path -- for quickcheck instance Arbitrary Types.Key.Key where @@ -72,11 +74,12 @@ quickcheck = TestLabel "quickcheck" $ TestList [ qctest "prop_idempotent_deencode" Git.prop_idempotent_deencode , qctest "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey , qctest "prop_idempotent_key_read_show" Types.Key.prop_idempotent_key_read_show - , qctest "prop_idempotent_shellEscape" Utility.prop_idempotent_shellEscape - , qctest "prop_idempotent_shellEscape_multiword" Utility.prop_idempotent_shellEscape_multiword + , qctest "prop_idempotent_shellEscape" Utility.SafeCommand.prop_idempotent_shellEscape + , qctest "prop_idempotent_shellEscape_multiword" Utility.SafeCommand.prop_idempotent_shellEscape_multiword , qctest "prop_idempotent_configEscape" RemoteLog.prop_idempotent_configEscape - , qctest "prop_parentDir_basics" Utility.prop_parentDir_basics - , qctest "prop_relPathDirToFile_basics" Utility.prop_relPathDirToFile_basics + , qctest "prop_parentDir_basics" Utility.Path.prop_parentDir_basics + + , qctest "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics , qctest "prop_cost_sane" Config.prop_cost_sane , qctest "prop_hmacWithCipher_sane" Crypto.prop_hmacWithCipher_sane ] @@ -117,8 +120,8 @@ test_add = "git-annex add" ~: TestList [basic, sha1dup, subdirs] git_annex "add" ["-q", annexedfile] @? "add failed" annexed_present annexedfile writeFile ingitfile $ content ingitfile - Utility.boolSystem "git" [Utility.Param "add", Utility.File ingitfile] @? "git add failed" - Utility.boolSystem "git" [Utility.Params "commit -q -a -m commit"] @? "git commit failed" + boolSystem "git" [Param "add", File ingitfile] @? "git add failed" + boolSystem "git" [Params "commit -q -a -m commit"] @? "git commit failed" git_annex "add" ["-q", ingitfile] @? "add ingitfile should be no-op" unannexed ingitfile sha1dup = TestCase $ intmpclonerepo $ do @@ -145,7 +148,7 @@ test_setkey = "git-annex setkey/fromkey" ~: TestCase $ inmainrepo $ do let key = show $ fromJust r git_annex "setkey" ["-q", "--key", key, tmp] @? "setkey failed" git_annex "fromkey" ["-q", "--key", key, sha1annexedfile] @? "fromkey failed" - Utility.boolSystem "git" [Utility.Params "commit -q -a -m commit"] @? "git commit failed" + boolSystem "git" [Params "commit -q -a -m commit"] @? "git commit failed" annexed_present sha1annexedfile where tmp = "tmpfile" @@ -172,7 +175,7 @@ test_drop = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote] where noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do git_annex "get" ["-q", annexedfile] @? "get failed" - Utility.boolSystem "git" [Utility.Params "remote rm origin"] + boolSystem "git" [Params "remote rm origin"] @? "git remote rm origin failed" r <- git_annex "drop" ["-q", annexedfile] not r @? "drop wrongly succeeded with no known copy of file" @@ -303,12 +306,12 @@ test_edit = "git-annex edit/commit" ~: TestList [t False, t True] then do -- pre-commit depends on the file being -- staged, normally git commit does this - Utility.boolSystem "git" [Utility.Param "add", Utility.File annexedfile] + boolSystem "git" [Param "add", File annexedfile] @? "git add of edited file failed" git_annex "pre-commit" ["-q"] @? "pre-commit failed" else do - Utility.boolSystem "git" [Utility.Params "commit -q -a -m contentchanged"] + boolSystem "git" [Params "commit -q -a -m contentchanged"] @? "git commit of edited file failed" runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile @@ -326,7 +329,7 @@ test_fix = "git-annex fix" ~: intmpclonerepo $ do git_annex "fix" ["-q", annexedfile] @? "fix of present file failed" annexed_present annexedfile createDirectory subdir - Utility.boolSystem "git" [Utility.Param "mv", Utility.File annexedfile, Utility.File subdir] + boolSystem "git" [Param "mv", File annexedfile, File subdir] @? "git mv failed" git_annex "fix" ["-q", newfile] @? "fix of moved file failed" runchecks [checklink, checkunwritable] newfile @@ -364,9 +367,9 @@ test_fsck = "git-annex fsck" ~: TestList [basicfsck, withlocaluntrusted, withrem where basicfsck = TestCase $ intmpclonerepo $ do git_annex "fsck" ["-q"] @? "fsck failed" - Utility.boolSystem "git" [Utility.Params "config annex.numcopies 2"] @? "git config failed" + boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" fsck_should_fail "numcopies unsatisfied" - Utility.boolSystem "git" [Utility.Params "config annex.numcopies 1"] @? "git config failed" + boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed" corrupt annexedfile corrupt sha1annexedfile withlocaluntrusted = TestCase $ intmpclonerepo $ do @@ -377,7 +380,7 @@ test_fsck = "git-annex fsck" ~: TestList [basicfsck, withlocaluntrusted, withrem git_annex "trust" ["-q", "."] @? "trust of current repo failed" git_annex "fsck" ["-q", annexedfile] @? "fsck failed on file present in trusted repo" withremoteuntrusted = TestCase $ intmpclonerepo $ do - Utility.boolSystem "git" [Utility.Params "config annex.numcopies 2"] @? "git config failed" + boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" git_annex "get" ["-q", annexedfile] @? "get failed" git_annex "get" ["-q", sha1annexedfile] @? "get failed" git_annex "fsck" ["-q"] @? "fsck failed with numcopies=2 and 2 copies" @@ -448,9 +451,9 @@ test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do git_annex "get" ["-q", annexedfile] @? "get of file failed" git_annex "get" ["-q", sha1annexedfile] @? "get of file failed" checkunused [] - Utility.boolSystem "git" [Utility.Params "rm -q", Utility.File annexedfile] @? "git rm failed" + boolSystem "git" [Params "rm -q", File annexedfile] @? "git rm failed" checkunused [annexedfilekey] - Utility.boolSystem "git" [Utility.Params "rm -q", Utility.File sha1annexedfile] @? "git rm failed" + boolSystem "git" [Params "rm -q", File sha1annexedfile] @? "git rm failed" checkunused [annexedfilekey, sha1annexedfilekey] -- good opportunity to test dropkey also @@ -526,10 +529,10 @@ setuprepo :: FilePath -> IO FilePath setuprepo dir = do cleanup dir ensuretmpdir - Utility.boolSystem "git" [Utility.Params "init -q", Utility.File dir] @? "git init failed" + boolSystem "git" [Params "init -q", File dir] @? "git init failed" indir dir $ do - Utility.boolSystem "git" [Utility.Params "config user.name", Utility.Param "Test User"] @? "git config failed" - Utility.boolSystem "git" [Utility.Params "config user.email test@example.com"] @? "git config failed" + boolSystem "git" [Params "config user.name", Param "Test User"] @? "git config failed" + boolSystem "git" [Params "config user.email test@example.com"] @? "git config failed" return dir -- clones are always done as local clones; we cannot test ssh clones @@ -537,7 +540,7 @@ clonerepo :: FilePath -> FilePath -> IO FilePath clonerepo old new = do cleanup new ensuretmpdir - Utility.boolSystem "git" [Utility.Params "clone -q", Utility.File old, Utility.File new] @? "git clone failed" + boolSystem "git" [Params "clone -q", File old, File new] @? "git clone failed" indir new $ git_annex "init" ["-q", new] @? "git annex init failed" return new |