From 571318218c5598ad841cc3dff73c9fee2c7216ef Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Dec 2015 21:05:00 -0400 Subject: merge from git-annex withTmpDir security fix in git-annex merged Fix potential denial of service attack when creating temp dirs. withTmpDir now makes directory mode 700. AFAICS, propellor didn't leak any info with the old permissions, and no uses of withTmpDir in propellor are broken by the new permissions. --- src/Utility/Exception.hs | 15 ++++++++------- src/Utility/Tmp.hs | 48 ++++++++++++++++++++++++++++++++---------------- 2 files changed, 40 insertions(+), 23 deletions(-) diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs index 13000e03..8b110ae6 100644 --- a/src/Utility/Exception.hs +++ b/src/Utility/Exception.hs @@ -20,7 +20,8 @@ module Utility.Exception ( catchNonAsync, tryNonAsync, tryWhenExists, - catchHardwareFault, + catchIOErrorType, + IOErrorType(..) ) where import Control.Monad.Catch as X hiding (Handler) @@ -88,11 +89,11 @@ tryWhenExists a = do v <- tryJust (guard . isDoesNotExistError) a return (eitherToMaybe v) -{- Catches only exceptions caused by hardware faults. - - Ie, disk IO error. -} -catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a -catchHardwareFault a onhardwareerr = catchIO a onlyhw +{- Catches only IO exceptions of a particular type. + - Ie, use HardwareFault to catch disk IO errors. -} +catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a +catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching where - onlyhw e - | ioeGetErrorType e == HardwareFault = onhardwareerr e + onlymatching e + | ioeGetErrorType e == errtype = onmatchingerr e | otherwise = throwM e diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs index de970fe5..7610f6cc 100644 --- a/src/Utility/Tmp.hs +++ b/src/Utility/Tmp.hs @@ -15,6 +15,9 @@ import System.Directory import Control.Monad.IfElse import System.FilePath import Control.Monad.IO.Class +#ifndef mingw32_HOST_OS +import System.Posix.Temp (mkdtemp) +#endif import Utility.Exception import Utility.FileSystemEncoding @@ -64,32 +67,45 @@ withTmpFileIn tmpdir template a = bracket create remove use - directory and all its contents. -} withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do - tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory - withTmpDirIn tmpdir template a + topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory +#ifndef mingw32_HOST_OS + -- Use mkdtemp to create a temp directory securely in /tmp. + bracket + (liftIO $ mkdtemp $ topleveltmpdir template) + removeTmpDir + a +#else + withTmpDirIn topleveltmpdir template a +#endif {- Runs an action with a tmp directory located within a specified directory, - then removes the tmp directory and all its contents. -} withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a -withTmpDirIn tmpdir template = bracketIO create remove +withTmpDirIn tmpdir template = bracketIO create removeTmpDir where - remove d = whenM (doesDirectoryExist d) $ do -#if mingw32_HOST_OS - -- Windows will often refuse to delete a file - -- after a process has just written to it and exited. - -- Because it's crap, presumably. So, ignore failure - -- to delete the temp directory. - _ <- tryIO $ removeDirectoryRecursive d - return () -#else - removeDirectoryRecursive d -#endif create = do createDirectoryIfMissing True tmpdir makenewdir (tmpdir template) (0 :: Int) makenewdir t n = do let dir = t ++ "." ++ show n - either (const $ makenewdir t $ n + 1) (const $ return dir) - =<< tryIO (createDirectory dir) + catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do + createDirectory dir + return dir + +{- Deletes the entire contents of the the temporary directory, if it + - exists. -} +removeTmpDir :: MonadIO m => FilePath -> m () +removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do +#if mingw32_HOST_OS + -- Windows will often refuse to delete a file + -- after a process has just written to it and exited. + -- Because it's crap, presumably. So, ignore failure + -- to delete the temp directory. + _ <- tryIO $ removeDirectoryRecursive tmpdir + return () +#else + removeDirectoryRecursive tmpdir +#endif {- It's not safe to use a FilePath of an existing file as the template - for openTempFile, because if the FilePath is really long, the tmpfile -- cgit v1.2.3 From 47a2b72bed3770d3dfb26c4142479c436a11ce55 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Dec 2015 21:08:22 -0400 Subject: Merged Utility changes from git-annex. --- debian/changelog | 1 + src/Propellor/Property/File.hs | 1 - src/Utility/Directory.hs | 31 +++++++++++++++++++++---------- src/Utility/FileMode.hs | 29 +++++++++++++++++++++++------ src/Utility/FileSystemEncoding.hs | 5 +++-- src/Utility/Path.hs | 12 ++++++------ src/Utility/SafeCommand.hs | 11 ++++++----- 7 files changed, 60 insertions(+), 30 deletions(-) diff --git a/debian/changelog b/debian/changelog index d7f29c31..d9e9bead 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,6 +4,7 @@ propellor (2.15.1) UNRELEASED; urgency=medium Thanks, Sean Whitton. * Added User.systemAccountFor and User.systemAccountFor' properties. Thanks, FĂ©lix Sipma. + * Merged Utility changes from git-annex. -- Joey Hess Tue, 08 Dec 2015 11:59:43 -0400 diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 56066b5b..3021617c 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -4,7 +4,6 @@ import Propellor.Base import Utility.FileMode import System.Posix.Files -import System.PosixCompat.Types import System.Exit type Line = String diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs index 7322cd85..fae33b5c 100644 --- a/src/Utility/Directory.hs +++ b/src/Utility/Directory.hs @@ -13,7 +13,6 @@ module Utility.Directory where import System.IO.Error import System.Directory import Control.Monad -import Control.Monad.IfElse import System.FilePath import Control.Applicative import Control.Concurrent @@ -25,10 +24,11 @@ import Prelude import qualified System.Win32 as Win32 #else import qualified System.Posix as Posix +import Utility.SafeCommand +import Control.Monad.IfElse #endif import Utility.PosixFiles -import Utility.SafeCommand import Utility.Tmp import Utility.Exception import Utility.Monad @@ -107,21 +107,32 @@ moveFile src dest = tryIO (rename src dest) >>= onrename onrename (Left e) | isPermissionError e = rethrow | isDoesNotExistError e = rethrow - | otherwise = do - -- copyFile is likely not as optimised as - -- the mv command, so we'll use the latter. - -- But, mv will move into a directory if - -- dest is one, which is not desired. - whenM (isdir dest) rethrow - viaTmp mv dest "" + | otherwise = viaTmp mv dest "" where rethrow = throwM e + mv tmp _ = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. +#ifndef mingw32_HOST_OS + -- If dest is a directory, mv would move the file + -- into it, which is not desired. + whenM (isdir dest) rethrow ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + let e' = e +#else + r <- tryIO $ copyFile src tmp + let (ok, e') = case r of + Left err -> (False, err) + Right _ -> (True, e) +#endif unless ok $ do -- delete any partial _ <- tryIO $ removeFile tmp - rethrow + throwM e' isdir f = do r <- tryIO $ getFileStatus f diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs index fdf1b56b..efef5fa2 100644 --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -7,7 +7,10 @@ {-# LANGUAGE CPP #-} -module Utility.FileMode where +module Utility.FileMode ( + module Utility.FileMode, + FileMode, +) where import System.IO import Control.Monad @@ -17,17 +20,31 @@ import Utility.PosixFiles import System.Posix.Files #endif import Foreign (complement) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Catch import Utility.Exception {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () -modifyFileMode f convert = do +modifyFileMode f convert = void $ modifyFileMode' f convert + +modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' f convert = do s <- getFileStatus f let old = fileMode s let new = convert old when (new /= old) $ setFileMode f new + return old + +{- 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 {- Adds the specified FileModes to the input mode, leaving the rest - unchanged. -} @@ -92,7 +109,7 @@ isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 {- Runs an action without that pesky umask influencing it, unless the - passed FileMode is the standard one. -} -noUmask :: FileMode -> IO a -> IO a +noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS noUmask mode a | mode == stdFileMode = a @@ -101,12 +118,12 @@ noUmask mode a noUmask _ a = a #endif -withUmask :: FileMode -> IO a -> IO a +withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS withUmask umask a = bracket setup cleanup go where - setup = setFileCreationMask umask - cleanup = setFileCreationMask + setup = liftIO $ setFileCreationMask umask + cleanup = liftIO . setFileCreationMask go _ = a #else withUmask _ a = a diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index 2d9691d5..67341d37 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -29,6 +29,7 @@ import System.IO.Unsafe import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils +import Data.List import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS @@ -125,12 +126,12 @@ decodeW8 = s2w8 . _encodeFilePath {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul) +encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) where nul = ['\NUL'] decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul +decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul where nul = ['\NUL'] diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs index 8e3c2bdd..f3290d8d 100644 --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -30,8 +30,8 @@ import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo -{- Simplifies a path, removing any ".." or ".", and removing the trailing - - path separator. +{- Simplifies a path, removing any "." component, collapsing "dir/..", + - 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 @@ -50,7 +50,8 @@ simplifyPath path = dropTrailingPathSeparator $ norm c [] = reverse c norm c (p:ps) - | p' == ".." = norm (drop 1 c) ps + | p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = + norm (drop 1 c) ps | p' == "." = norm c ps | otherwise = norm (p:c) ps where @@ -88,7 +89,7 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive (join s $ init dirs) + | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir @@ -148,7 +149,7 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to - | otherwise = join s $ dotdots ++ uncommon + | otherwise = intercalate s $ dotdots ++ uncommon where s = [pathSeparator] pfrom = split s from @@ -287,7 +288,6 @@ fileNameLengthLimit dir = do if l <= 0 then return 255 else return $ minimum [l, 255] - where #endif {- Given a string that we'd like to use as the basis for FilePath, but that diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs index 9102b726..5ce17a84 100644 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -14,6 +14,7 @@ import Utility.Process import Data.String.Utils import System.FilePath import Data.Char +import Data.List import Control.Applicative import Prelude @@ -85,7 +86,7 @@ shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' - escaped = join "'\"'\"'" $ split "'" f + escaped = intercalate "'\"'\"'" $ split "'" f -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] @@ -105,10 +106,10 @@ shellUnEscape s = word : shellUnEscape rest | 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 +prop_isomorphic_shellEscape :: String -> Bool +prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s +prop_isomorphic_shellEscape_multiword :: [String] -> Bool +prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s -- | Segments a list of filenames into groups that are all below the maximum -- command-line length limit. -- cgit v1.2.3