-- #hide module HsShellScript.Misc where import Control.Exception import Control.Monad import Data.Bits import Data.Typeable import Foreign import Foreign.C import Foreign.C.Error import Foreign.C.String import Foreign.Ptr import GHC.IO hiding (finally, bracket) import GHC.IO.Exception import HsShellScript.ProcErr import Prelude hiding (catch) import System.Directory import System.IO import System.IO.Error hiding (catch) import System.Posix hiding (removeDirectory) import System.Random -- | -- Format an @Int@ with leading zeros. If the string representation of the @Inŧ@ is longer than the number of characters to fill up, this produces as -- many characters as needed. zeros :: Int -- ^ How many characters to fill up -> Int -- ^ Value to represent as a string -> String -- ^ String representation of the value, using the specified number of characters zeros stellen z = let txt = show z auff = stellen - length txt n = take (if auff >= 0 then auff else 0) (repeat '0') in n ++ txt -- | -- Remove trailing newlines. This is silimar to perl's @chomp@ procedure. chomp :: String -- ^ String to be chomped -> String -- ^ Same string, except for no newline characters at the end chomp "" = "" chomp "\n" = "" chomp [x] = [x] chomp (x:xs) = let xs' = chomp xs in if xs' == "" && x == '\n' then "" else x:xs' {- | Get contents of a file or of @stdin@. This is a simple frontend to @hGetContents@. A file name of @\"-\"@ designates stdin. The contents are read lazily as the string is evaluated. (The handle which we read from will be in semi-closed state. Once all input has read, it is closed automatically (Haskell Library Report 11.2.1). Therefore we don't need to return it). >lazy_contents path = do > h <- if path == "-" then return stdin else openFile path ReadMode > hGetContents h -} lazy_contents :: String -- ^ Either the name of a file, or @\"-\"@ -> IO String -- ^ The lazily read contents of the file or @stdin@. lazy_contents path = do h <- if path == "-" then return stdin else openFile path ReadMode hGetContents h -- | -- Get contents of a file or of @stdin@ eagerly. This is the -- same as @lazy_contents@, except for the contents being -- read immediately. contents :: String -- ^ either the name of a file, or @\"-\"@ for @stdin@ -> IO String -- ^ the contents of the file or of standard input contents pfad = do txt <- lazy_contents pfad seq (length txt) (return ()) return txt -- | -- Test for the existence of a path. This is the disjunction of -- @Directory.doesDirectoryExist@ and @Directory.doesFileExist@. For an dangling symlink, this will return @False@. path_exists :: String -- ^ Path -> IO Bool -- ^ Whether the path exists in the file system path_exists pfad = do de <- doesDirectoryExist pfad fe <- doesFileExist pfad return (de || fe) -- | -- Test for the existence of a path. This uses @System.Posix.Files.getFileStatus@ to determine whether the path exists in any form in the file system. -- For a dangling symlink, the result is @True@. path_exists' :: String -- ^ Path -> IO Bool -- ^ Whether the path exists in the file system path_exists' path = catch (do getSymbolicLinkStatus path return True) (\(ioe :: IOError) -> if isDoesNotExistError ioe then return False else ioError ioe) -- | -- Test if path points to a directory. This will return @True@ for a symlink pointing to a directory. It's a shortcut for -- @Directory.doesDirectoryExist@. is_dir :: String -- ^ Path -> IO Bool -- ^ Whether the path exists and points to a directory. is_dir = doesDirectoryExist -- | -- Test if path points to a file. This is a shortcut for -- @Directory.doesFileExist@. is_file :: String -- ^ Path -> IO Bool -- ^ Whether the path exists and points to a file. is_file = doesFileExist -- | -- This is the @System.Posix.Files.getFileStatus@ function from the GHC libraries, with improved error reporting. The GHC function doesn't include the -- file name in the @IOError@ when the call fails, making error messages much less useful. @getFileStatus\'@ rectifies this. -- -- See 'System.Posix.Files.getFileStatus'. getFileStatus' :: FilePath -- ^ Path of the file, whose status is to be queried -> IO FileStatus -- ^ Status of the file getFileStatus' path = getFileStatus path `catch` (\ioe -> ioError (ioe { ioe_filename = Just path })) -- | -- This is the @System.Posix.Files.fileAccess@ function from the GHC libraries, with improved error reporting. The GHC function doesn't include the -- file name in the @IOError@ when the call fails, making error messages much less useful. @fileAccess\'@ rectifies this. -- -- See 'System.Posix.Files.fileAccess'. fileAccess' :: FilePath -> Bool -> Bool -> Bool -> IO Bool fileAccess' p b c d = fileAccess p b c d `catch` (\ioe -> ioError (ioe { ioe_filename = Just p })) -- | -- Create a temporary file. This will create a new, empty file, with a path which did not previously exist in the file system. The path consists -- of the specified prefix, a sequence of random characters (digits and letters), and the specified suffix. The file is created with read-write -- permissions for the user, and no permissons for the group and others. The ownership is set to the effective user ID of the process. The group -- ownership is set either to the effective group ID of the process or to the group ID of the parent directory (depending on filesystem type and mount -- options on Linux - see @open(2)@ for details). -- -- See 'tmp_file', 'temp_dir', 'with_temp_file'. temp_file :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't already -- exist. -> String -- ^ Prefix for the path to generate. -> String -- ^ Suffix for the path to generate. -> IO FilePath -- ^ Path of the created file. temp_file nr prefix suffix = do (fd, path) <- untilIO (do path <- temp_path nr prefix suffix fd <- withCString path $ \cpath -> {#call hsshellscript_open_nonvariadic#} cpath (o_CREAT .|. o_EXCL) 0o600 return (fd, path) ) (\(fd, path) -> if fd == -1 then do errno <- getErrno when (errno /= eEXIST) $ throwErrno' "temp_file" Nothing (Just path) return False else return True ) res <- {# call close as c_close #} fd when (res == -1) $ throwErrno' "temp_file" Nothing (Just path) return path -- | -- Create a temporary directory. This will create a new directory, with a path which did not previously exist in the file system. The path consists -- of the specified prefix, a sequence of random characters (digits and letters), and the specified suffix. The directory is normally created with -- read-write-execute permissions for the user, and no permissons for the group and others. But this may be further restricted by the process's umask -- in the usual way. -- -- The newly created directory will be owned by the effective uid of the process. If the directory containing the it has the set group -- id bit set, or if the filesystem is mounted with BSD group semantics, the new directory will inherit the group ownership from its parent; -- otherwise it will be owned by the effective gid of the process. (See @mkdir(2)@) -- -- See 'tmp_dir', 'temp_file', 'with_temp_dir'. temp_dir :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't already -- exist. -> String -- ^ Prefix for the path to generate. -> String -- ^ Suffix for the path to generate. -> IO FilePath -- ^ Generated path. temp_dir nr prefix suffix = do (_, path) <- untilIO (do path <- temp_path nr prefix suffix ret <- withCString path $ \cpath -> {#call mkdir as c_mkdir#} cpath 0o700 return (ret, path) ) (\(ret, path) -> if ret == -1 then do errno <- getErrno when (errno /= eEXIST) $ throwErrno' "temp_dir" Nothing (Just path) return False else return True ) return path -- | -- Create a temporary file. This will create a new, empty file, with read-write permissions for the user, and no permissons for the group and others. -- The path consists of the specified prefix, a dot, and six random characters (digits and letters). -- -- @tmp_file prefix = temp_file 6 (prefix ++ \".\") \"\"@ -- -- See 'temp_file', 'tmp_dir', 'with_tmp_file'. tmp_file :: String -- ^ Prefix for the path to generate. -> IO FilePath -- ^ Path of the created file. tmp_file prefix = temp_file 6 (prefix ++ ".") "" -- | -- Create a temporary directory. This will create a new directory, with read-write-execute permissions for the user (unless further restricted by the -- process's umask), and no permissons for the group and others. -- The path consists of the specified prefix, a dot, and six random characters (digits and letters). -- -- @tmp_dir prefix = temp_dir 6 (prefix ++ \".\") \"\"@ -- -- See 'temp_dir', 'tmp_file', 'with_tmp_dir'. tmp_dir :: String -- ^ Prefix for the path to generate. -> IO FilePath -- ^ Path of the created directory. tmp_dir prefix = temp_dir 6 (prefix ++ ".") "" -- | -- Create and open a temporary file, perform some action with it, and delete it afterwards. This is a front end to the 'temp_file' function. The file -- and its path are created in the same way. The IO action is passed a handle of the new file. When it finishes - normally or with an exception - -- the file is deleted. -- -- See 'temp_file', 'with_tmp_file', 'with_temp_dir'. with_temp_file :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't -- already exist. -> String -- ^ Prefix for the path to generate. -> String -- ^ Suffix for the path to generate. -> (Handle -> IO a) -- ^ Action to perform. -> IO a -- ^ Returns the value returned by the action. with_temp_file nr prefix suffix io = bracket (do path <- temp_file nr prefix suffix h <- openFile path ReadWriteMode return (path, h) ) (\(path,h) -> do hClose h removeFile path ) (\(path,h) -> io h ) -- | -- Create a temporary directory, perform some action with it, and delete it afterwards. This is a front end to the 'temp_dir' function. The directory -- and its path are created in the same way. The IO action is passed the path of the new directory. When it finishes - normally or with an exception - -- the directory is deleted. -- -- The action must clean up any files it creates inside the directory by itself. @with_temp_dir@ doesn't delete any files inside, so the directory -- could be removed. If the directory isn't empty, an @IOError@ results (with the path filled in). When the action throws an exception, and the -- temporary directory cannot be removed, then the exception is passed through, rather than replacing it with the IOError. (This is because it's -- probably exactly because of that exception that the directory isn't empty and can't be removed). -- -- See 'temp_dir', 'with_tmp_dir', 'with_temp_file'. with_temp_dir :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't -- already exist. -> String -- ^ Prefix for the path to generate. -> String -- ^ Suffix for the path to generate. -> (FilePath -> IO a) -- ^ Action to perform. -> IO a -- ^ Returns the value returned by the action. with_temp_dir nr prefix suffix io = do path <- temp_dir nr prefix suffix a <- catch (io path) (\e -> do remove path `catch` (\(e::SomeException) -> return ()) throw (e :: SomeException) ) remove path return a where remove path = removeDirectory path `catch` (\ioe -> ioError (ioe { ioe_filename = Just path })) -- | -- Create and open a temporary file, perform some action with it, and delete it afterwards. This is a front end to the 'tmp_file' function. The file -- and its path are created in the same way. The IO action is passed a handle of the new file. When it finishes - normally or with an exception - -- the file is deleted. -- -- See 'tmp_file', 'with_temp_file', 'with_tmp_dir'. with_tmp_file :: String -- ^ Prefix for the path to generate. -> (Handle -> IO a) -- ^ Action to perform. -> IO a -- ^ Returns the value returned by the action. with_tmp_file prefix io = bracket (do path <- tmp_file prefix h <- openFile path ReadWriteMode return (path, h) ) (\(path,h) -> do hClose h removeFile path ) (\(path,h) -> do e <- io h return e ) -- | -- Create a temporary directory, perform some action with it, and delete it afterwards. This is a front end to the 'tmp_dir' function. The directory -- and its path are created in the same way. The IO action is passed the path of the new directory. When it finishes - normally or with an exception - -- the directory is deleted. -- -- The action must clean up any files it creates inside the directory by itself. @with_temp_dir@ doesn't delete any files inside, so the directory -- could be removed. If the directory isn't empty, an @IOError@ results (with the path filled in). When the action throws an exception, and the -- temporary directory cannot be removed, then the exception is passed through, rather than replacing it with the IOError. (This is because it's -- probably exactly because of that exception that the directory isn't empty and can't be removed). -- -- >with_tmp_dir prefix io = with_temp_dir 6 (prefix ++ ".") "" io -- -- See 'tmp_dir', 'with_temp_dir', 'with_tmp_file'. with_tmp_dir :: String -- ^ Prefix for the path to generate. -> (FilePath -> IO a) -- ^ Action to perform. -> IO a -- ^ Returns the value returned by the action. with_tmp_dir prefix io = with_temp_dir 6 (prefix ++ ".") "" io -- | -- Create a temporary path. This will generate a path which does not yet exist in the file system. It consists of the specified prefix, a -- sequence of random characters (digits and letters), and the specified suffix. -- -- /Avoid relying on the generated path not to exist in the file system./ Or else you'll get a potential race condition, since some other process might -- create the path after @temp_path@, before you use it. This is a security risk. The global random number generator (@Random.randomRIO@) is used to -- generate the random characters. These might not be that random after all, and could potentially be guessed. Rather use @temp_file@ or @temp_dir@. -- -- See 'temp_file', 'temp_dir'. temp_path :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't already -- exist. -> String -- ^ Prefix for the path to generate. -> String -- ^ Suffix for the path to generate. -> IO FilePath -- ^ Generated path. temp_path nr prefix suffix = do untilIO (do rand <- sequence (take nr (repeat (fmap char (randomRIO (0, 10+2*26 - 1))))) return (prefix ++ rand ++ suffix) ) (\path -> fmap not (path_exists' path)) where char nr = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" !! nr -- Execute action until condition is met. untilIO io cond = do res <- io u <- cond res if u then return res else untilIO io cond {- | One entry of mount information. This is the same as @struct mntent@ from @\@. A list of these is returned by the functions which read mount information. See 'read_mounts', 'read_mtab', 'read_fstab'. -} data Mntent = Mntent { mnt_fsname :: String -- ^ Device file (\"name of mounted file system\") , mnt_dir :: String -- ^ Mount point , mnt_type :: String -- ^ Which kind of file system (\"see mntent.h\") , mnt_opts :: String -- ^ Mount options (\"see mntent.h\") , mnt_freq :: Int -- ^ Dump frequency in days , mnt_passno :: Int -- ^ \"Pass number on parallel fsck\" } deriving (Read, Show, Typeable, Eq) {- | Read mount information. This is a front end to the @setmntent(3)@, @getmntent(3)@, @endmntent(3)@ system library functions. When the @setmntent@ call fails, the @errno@ value is converted to an @IOError@ and thrown. See 'read_mtab', 'read_fstab'. -} read_mounts :: String -- ^ File to read (typically @\/etc\/mtab@ or @\/etc\/fstab@) -> IO [Mntent] -- ^ Mount information in that file read_mounts path = do h <- withCString path $ \cpath -> withCString "r" $ \r -> {#call setmntent#} cpath r when (h == nullPtr) $ throwErrno' "setmntent(3) in read_mounts" Nothing (Just path) mntent <- getmntent h [] {#call endmntent#} h return mntent where getmntent h l = do ptr <- {#call getmntent as c_getmntent#} h if (ptr == nullPtr) then return l else do mnt_fsname_str <- {#get mntent.mnt_fsname#} ptr >>= peekCString mnt_dir_str <- {#get mntent.mnt_dir#} ptr >>= peekCString mnt_type_str <- {#get mntent.mnt_type#} ptr >>= peekCString mnt_opts_str <- {#get mntent.mnt_opts#} ptr >>= peekCString mnt_freq_int <- fmap fromEnum $ {#get mntent.mnt_freq#} ptr mnt_passno_int <- fmap fromEnum $ {#get mntent.mnt_passno#} ptr getmntent h (l ++ [Mntent { mnt_fsname = mnt_fsname_str , mnt_dir = mnt_dir_str , mnt_type = mnt_type_str , mnt_opts = mnt_opts_str , mnt_freq = mnt_freq_int , mnt_passno = mnt_passno_int }]) {- | Get the currently mounted file systems. >read_mtab = read_mounts "/etc/mtab" See 'read_mounts'. -} read_mtab :: IO [Mntent] read_mtab = read_mounts "/etc/mtab" {- | Get the system wide file system table. >read_fstab = read_mounts "/etc/fstab" See 'read_mounts'. -} read_fstab :: IO [Mntent] read_fstab = read_mounts "/etc/fstab" -- Taken from the source code of the GHC 6 libraries (in System.Posix.Internals). It isn't exported from there. "HsBase.h" belongs to the files which -- are visible to users of GHC, but it isn't documented. The comment at the beginning says "Definitions for package `base' which are visible in -- Haskell land.". foreign import ccall unsafe "HsBase.h __hscore_o_creat" o_CREAT :: CInt foreign import ccall unsafe "HsBase.h __hscore_o_excl" o_EXCL :: CInt -- | Change the working directory temporarily. This executes the specified IO action with a new working directory, and restores it afterwards -- (exception-safely). with_wd :: FilePath -- ^ New working directory -> IO a -- ^ Action to run -> IO a with_wd wd io = bracket (do cwd <- getCurrentDirectory setCurrentDirectory wd return cwd) (\cwd -> setCurrentDirectory cwd) (const io) -- | This is an interface to the POSIX @glob@ function, which does wildcard expansion -- in paths. The list of matched paths is returned. It's empty -- for no match (rather than the original pattern). In case anything goes wrong -- (such as permission denied), an IOError is thrown. -- -- This does /not/ do tilde expansion, which is done (among many unwanted other -- things) by @wordexp@. The only flag used for the call to @glob@ is @GLOB_ERR@. -- -- The behaviour in case of non-existing path components is inconsistent in the -- GNU version of the underlying @glob@ function. @glob "\/doesnt_exist\/foo"@ will return -- the empty list, whereas @glob "\/doesnt_exist\/*"@ causes a "No such file or directory" -- IOError. -- -- See man pages @glob(3)@ and @wordexp(3)@. glob :: String -- ^ Pattern -> IO [String] -- ^ Sorted list of matching paths glob pattern = do withCString pattern $ \pattern_ptr -> allocaBytes {#sizeof glob_t#} $ \buf_ptr -> do res <- {#call do_glob#} buf_ptr pattern_ptr case res of 0 -> -- success do pptr <- {#get glob_t->gl_pathv#} buf_ptr len <- lengthArray0 nullPtr pptr cstrs <- peekArray len pptr mapM peekCString cstrs 1 -> -- GLOB_ABORTED throwErrno' "glob" Nothing (Just pattern) 2 -> -- GLOB_NOSPACE ioError (ioeSetErrorString (mkIOError ResourceExhausted "glob" Nothing (Just pattern)) "Out of memory") 3 -> -- GLOB_NOMATCH return [] `finally` (do pptr <- {#get glob_t->gl_pathv#} buf_ptr when (pptr /= nullPtr) $ {#call globfree#} buf_ptr ) #c /* #include #include #include #include #include */ #include #include #include int close(int fd); /* open(2) is defined in fcntl.h as "extern int open (__const char *__file, int __oflag, ...)", with variable number of arguments, which isn's supported by the FFI. */ int hsshellscript_open_nonvariadic(const char *pathname, int flags, mode_t mode); int do_glob(void* buf, const char* pattern); #endc