diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Directory.hs | 20 | ||||
| -rw-r--r-- | Utility/Env.hs | 18 | ||||
| -rw-r--r-- | Utility/FileMode.hs | 4 | ||||
| -rw-r--r-- | Utility/Misc.hs | 9 | ||||
| -rw-r--r-- | Utility/Path.hs | 84 | ||||
| -rw-r--r-- | Utility/PosixFiles.hs | 33 | ||||
| -rw-r--r-- | Utility/QuickCheck.hs | 6 | ||||
| -rw-r--r-- | Utility/Tmp.hs | 5 |
8 files changed, 148 insertions, 31 deletions
diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 6caee7e..f1bcfad 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,6 +1,6 @@ {- directory manipulation - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,7 +10,6 @@ module Utility.Directory where import System.IO.Error -import System.PosixCompat.Files import System.Directory import Control.Exception (throw) import Control.Monad @@ -19,10 +18,12 @@ import System.FilePath import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) +import Utility.PosixFiles import Utility.SafeCommand import Utility.Tmp import Utility.Exception import Utility.Monad +import Utility.Applicative dirCruft :: FilePath -> Bool dirCruft "." = True @@ -73,6 +74,21 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] ) _ -> skip +{- Gets the directory tree from a point, recursively and lazily, + - with leaf directories **first**, skipping any whose basenames + - match the skipdir. Does not follow symlinks. -} +dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] + where + go c [] = return c + go c (dir:dirs) + | skipdir (takeFileName dir) = go c dirs + | otherwise = unsafeInterleaveIO $ do + subdirs <- go c + =<< filterM (isDirectory <$$> getSymbolicLinkStatus) + =<< catchDefaultIO [] (dirContents dir) + go (subdirs++[dir]) dirs + {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: FilePath -> FilePath -> IO () diff --git a/Utility/Env.hs b/Utility/Env.hs index cb73873..90ed58f 100644 --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -61,3 +61,21 @@ unsetEnv var = do #else unsetEnv _ = return False #endif + +{- Adds the environment variable to the input environment. If already + - present in the list, removes the old value. + - + - This does not really belong here, but Data.AssocList is for some reason + - buried inside hxt. + -} +addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)] +addEntry k v l = ( (k,v) : ) $! delEntry k l + +addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)] +addEntries = foldr (.) id . map (uncurry addEntry) . reverse + +delEntry :: Eq k => k -> [(k, v)] -> [(k, v)] +delEntry _ [] = [] +delEntry k (x@(k1,_) : rest) + | k == k1 = rest + | otherwise = ( x : ) $! delEntry k rest diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 46c6a31..b17cadc 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -133,10 +133,8 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - as writeFile. -} writeFileProtected :: FilePath -> String -> IO () -writeFileProtected file content = do - h <- openFile file WriteMode +writeFileProtected file content = withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes [groupReadMode, otherReadMode] hPutStr h content - hClose h diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 68199c8..20007ad 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -33,13 +33,20 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s -{- Reads a file strictly, and using the FileSystemEncofing, so it will +{- Reads a file strictly, and using the FileSystemEncoding, so it will - never crash on a badly encoded file. -} readFileStrictAnyEncoding :: FilePath -> IO String readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do fileEncoding h hClose h `after` hGetContentsStrict h +{- Writes a file, using the FileSystemEncoding so it will never crash + - on a badly encoded content string. -} +writeFileAnyEncoding :: FilePath -> String -> IO () +writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do + fileEncoding h + hPutStr h content + {- Like break, but the item matching the condition is not included - in the second result list. - diff --git a/Utility/Path.hs b/Utility/Path.hs index 44ac72f..e22d0c3 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,6 +1,6 @@ {- path manipulation - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,28 +21,60 @@ import Control.Applicative import Data.Char import qualified System.FilePath.Posix as Posix #else -import qualified "MissingH" System.Path as MissingH import System.Posix.Files #endif +import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo -{- Makes a path absolute if it's not already. +{- Simplifies a path, removing any ".." or ".", and removing the trailing + - path separator. + - + - On Windows, preserves whichever style of path separator might be used in + - the input FilePaths. This is done because some programs in Windows + - demand a particular path separator -- and which one actually varies! + - + - This does not guarantee that two paths that refer to the same location, + - and are both relative to the same location (or both absolute) will + - yeild the same result. Run both through normalise from System.FilePath + - to ensure that. + -} +simplifyPath :: FilePath -> FilePath +simplifyPath path = dropTrailingPathSeparator $ + joinDrive drive $ joinPath $ norm [] $ splitPath path' + where + (drive, path') = splitDrive path + + norm c [] = reverse c + norm c (p:ps) + | p' == ".." = norm (drop 1 c) ps + | p' == "." = norm c ps + | otherwise = norm (p:c) ps + where + p' = dropTrailingPathSeparator p + +{- Makes a path absolute. + - - The first parameter is a base directory (ie, the cwd) to use if the path - is not already absolute. - - - On Unix, collapses and normalizes ".." etc in the path. May return Nothing - - if the path cannot be normalized. - - - - MissingH's absNormPath does not work on Windows, so on Windows - - no normalization is done. + - Does not attempt to deal with edge cases or ensure security with + - untrusted inputs. -} -absNormPath :: FilePath -> FilePath -> Maybe FilePath +absPathFrom :: FilePath -> FilePath -> FilePath +absPathFrom dir path = simplifyPath (combine dir path) + +{- On Windows, this converts the paths to unix-style, in order to run + - MissingH's absNormPath on them. Resulting path will use / separators. -} +absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS -absNormPath dir path = MissingH.absNormPath dir path +absNormPathUnix dir path = MissingH.absNormPath dir path #else -absNormPath dir path = Just $ combine dir path +absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) + where + fromdos = replace "\\" "/" + todos = replace "/" "\\" #endif {- Returns the parent directory of a path. @@ -72,13 +104,13 @@ prop_parentDir_basics dir - are all equivilant. -} dirContains :: FilePath -> FilePath -> Bool -dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b' +dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b' where - norm p = fromMaybe "" $ absNormPath p "." a' = norm a b' = norm b + norm = normalise . simplifyPath -{- Converts a filename into a normalized, absolute path. +{- Converts a filename into an absolute path. - - Unlike Directory.canonicalizePath, this does not require the path - already exists. -} @@ -87,13 +119,6 @@ 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: @@ -105,7 +130,7 @@ relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f {- Constructs a relative path from a directory to a file. - - - Both must be absolute, and normalized (eg with absNormpath). + - Both must be absolute, and cannot contain .. etc. (eg use absPath first). -} relPathDirToFile :: FilePath -> FilePath -> FilePath relPathDirToFile from to = join s $ dotdots ++ uncommon @@ -252,3 +277,18 @@ sanitizeFilePath = map sanitize | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c + +{- Similar to splitExtensions, but knows that some things in FilePaths + - after a dot are too long to be extensions. -} +splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" +splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' maxextension = go [] + where + go c f + | len > 0 && len <= maxextension && not (null base) = + go (ext:c) base + | otherwise = (f, c) + where + (base, ext) = splitExtension f + len = length ext diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs new file mode 100644 index 0000000..23edc25 --- /dev/null +++ b/Utility/PosixFiles.hs @@ -0,0 +1,33 @@ +{- POSIX files (and compatablity wrappers). + - + - This is like System.PosixCompat.Files, except with a fixed rename. + - + - Copyright 2014 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.PosixFiles ( + module X, + rename +) where + +import System.PosixCompat.Files as X hiding (rename) + +#ifndef mingw32_HOST_OS +import System.Posix.Files (rename) +#else +import qualified System.Win32.File as Win32 +#endif + +{- System.PosixCompat.Files.rename on Windows calls renameFile, + - so cannot rename directories. + - + - Instead, use Win32 moveFile, which can. It needs to be told to overwrite + - any existing file. -} +#ifdef mingw32_HOST_OS +rename :: FilePath -> FilePath -> IO () +rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING +#endif diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 82af09f..e2539f3 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,11 +17,15 @@ import Test.QuickCheck as X import Data.Time.Clock.POSIX import System.Posix.Types import qualified Data.Map as M +import qualified Data.Set as S import Control.Applicative instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where arbitrary = M.fromList <$> arbitrary +instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where + arbitrary = S.fromList <$> arbitrary + {- Times before the epoch are excluded. -} instance Arbitrary POSIXTime where arbitrary = nonNegative arbitrarySizedIntegral diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 891ce50..f46e1a5 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -13,10 +13,11 @@ import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse +import System.FilePath import Utility.Exception -import System.FilePath import Utility.FileSystemEncoding +import Utility.PosixFiles type Template = String @@ -30,7 +31,7 @@ viaTmp a file content = do (tmpfile, handle) <- openTempFile dir (base ++ ".tmp") hClose handle a tmpfile content - renameFile tmpfile file + rename tmpfile file {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} |