diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,63 @@ +This library (libraries/base) is derived from code from two +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + +The full text of these licenses is reproduced below. Both of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks defaultUserHooks diff --git a/System/Directory.hs b/System/Directory.hs new file mode 100644 --- /dev/null +++ b/System/Directory.hs @@ -0,0 +1,1060 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Directory +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- System-independent interface to directory manipulation. +-- +----------------------------------------------------------------------------- + +module System.Directory + ( + -- $intro + + -- * Actions on directories + createDirectory -- :: FilePath -> IO () + , createDirectoryIfMissing -- :: Bool -> FilePath -> IO () + , removeDirectory -- :: FilePath -> IO () + , removeDirectoryRecursive -- :: FilePath -> IO () + , renameDirectory -- :: FilePath -> FilePath -> IO () + + , getDirectoryContents -- :: FilePath -> IO [FilePath] + , getCurrentDirectory -- :: IO FilePath + , setCurrentDirectory -- :: FilePath -> IO () + + -- * Pre-defined directories + , getHomeDirectory + , getAppUserDataDirectory + , getUserDocumentsDirectory + , getTemporaryDirectory + + -- * Actions on files + , removeFile -- :: FilePath -> IO () + , renameFile -- :: FilePath -> FilePath -> IO () + , copyFile -- :: FilePath -> FilePath -> IO () + + , canonicalizePath + , makeRelativeToCurrentDirectory + , findExecutable + + -- * Existence tests + , doesFileExist -- :: FilePath -> IO Bool + , doesDirectoryExist -- :: FilePath -> IO Bool + + -- * Permissions + + -- $permissions + + , Permissions( + Permissions, + readable, -- :: Permissions -> Bool + writable, -- :: Permissions -> Bool + executable, -- :: Permissions -> Bool + searchable -- :: Permissions -> Bool + ) + + , getPermissions -- :: FilePath -> IO Permissions + , setPermissions -- :: FilePath -> Permissions -> IO () + + -- * Timestamps + + , getModificationTime -- :: FilePath -> IO ClockTime + ) where + +import Prelude hiding ( catch ) + +import System.Environment ( getEnv ) +import System.FilePath +import System.IO.Error hiding ( catch, try ) +import Control.Monad ( when, unless ) +import Control.Exception + +#ifdef __NHC__ +import Directory +import System (system) +#endif /* __NHC__ */ + +#ifdef __HUGS__ +import Hugs.Directory +#endif /* __HUGS__ */ + +import Foreign +import Foreign.C + +{-# CFILES cbits/directory.c #-} + +#ifdef __GLASGOW_HASKELL__ +import System.Posix.Types +import System.Posix.Internals +import System.Time ( ClockTime(..) ) +import System.IO + +import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) + +{- $intro +A directory contains a series of entries, each of which is a named +reference to a file system object (file, directory etc.). Some +entries may be hidden, inaccessible, or have some administrative +function (e.g. `.' or `..' under POSIX +), but in +this standard all such entries are considered to form part of the +directory contents. Entries in sub-directories are not, however, +considered to form part of the directory contents. + +Each file system object is referenced by a /path/. There is +normally at least one absolute path to each file system object. In +some operating systems, it may also be possible to have paths which +are relative to the current directory. +-} + +----------------------------------------------------------------------------- +-- Permissions + +{- $permissions + + The 'Permissions' type is used to record whether certain operations are + permissible on a file\/directory. 'getPermissions' and 'setPermissions' + get and set these permissions, respectively. Permissions apply both to + files and directories. For directories, the executable field will be + 'False', and for files the searchable field will be 'False'. Note that + directories may be searchable without being readable, if permission has + been given to use them as part of a path, but not to examine the + directory contents. + +Note that to change some, but not all permissions, a construct on the following lines must be used. + +> makeReadable f = do +> p <- getPermissions f +> setPermissions f (p {readable = True}) + +-} + +data Permissions + = Permissions { + readable, writable, + executable, searchable :: Bool + } deriving (Eq, Ord, Read, Show) + +{- |The 'getPermissions' operation returns the +permissions for the file or directory. + +The operation may fail with: + +* 'isPermissionError' if the user is not permitted to access + the permissions; or + +* 'isDoesNotExistError' if the file or directory does not exist. + +-} + +getPermissions :: FilePath -> IO Permissions +getPermissions name = do + withCString name $ \s -> do +#ifdef mingw32_HOST_OS + -- stat() does a better job of guessing the permissions on Windows + -- than access() does. e.g. for execute permission, it looks at the + -- filename extension :-) + -- + -- I tried for a while to do this properly, using the Windows security API, + -- and eventually gave up. getPermissions is a flawed API anyway. -- SimonM + allocaBytes sizeof_stat $ \ p_stat -> do + throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat + mode <- st_mode p_stat + let read = mode .&. s_IRUSR + let write = mode .&. s_IWUSR + let exec = mode .&. s_IXUSR + let is_dir = mode .&. s_IFDIR + return ( + Permissions { + readable = read /= 0, + writable = write /= 0, + executable = is_dir == 0 && exec /= 0, + searchable = is_dir /= 0 && exec /= 0 + } + ) +#else + read <- c_access s r_OK + write <- c_access s w_OK + exec <- c_access s x_OK + withFileStatus "getPermissions" name $ \st -> do + is_dir <- isDirectory st + return ( + Permissions { + readable = read == 0, + writable = write == 0, + executable = not is_dir && exec == 0, + searchable = is_dir && exec == 0 + } + ) +#endif + +{- |The 'setPermissions' operation sets the +permissions for the file or directory. + +The operation may fail with: + +* 'isPermissionError' if the user is not permitted to set + the permissions; or + +* 'isDoesNotExistError' if the file or directory does not exist. + +-} + +setPermissions :: FilePath -> Permissions -> IO () +setPermissions name (Permissions r w e s) = do + allocaBytes sizeof_stat $ \ p_stat -> do + withCString name $ \p_name -> do + throwErrnoIfMinus1_ "setPermissions" $ do + c_stat p_name p_stat + mode <- st_mode p_stat + let mode1 = modifyBit r mode s_IRUSR + let mode2 = modifyBit w mode1 s_IWUSR + let mode3 = modifyBit (e || s) mode2 s_IXUSR + c_chmod p_name mode3 + + where + modifyBit :: Bool -> CMode -> CMode -> CMode + modifyBit False m b = m .&. (complement b) + modifyBit True m b = m .|. b + + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions source dest = do + allocaBytes sizeof_stat $ \ p_stat -> do + withCString source $ \p_source -> do + withCString dest $ \p_dest -> do + throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat + mode <- st_mode p_stat + throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode + +----------------------------------------------------------------------------- +-- Implementation + +{- |@'createDirectory' dir@ creates a new directory @dir@ which is +initially empty, or as near to empty as the operating system +allows. + +The operation may fail with: + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES]@ + +* 'isAlreadyExistsError' \/ 'AlreadyExists' +The operand refers to a directory that already exists. +@ [EEXIST]@ + +* 'HardwareFault' +A physical I\/O error has occurred. +@[EIO]@ + +* 'InvalidArgument' +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ + +* 'NoSuchThing' +There is no path to the directory. +@[ENOENT, ENOTDIR]@ + +* 'ResourceExhausted' +Insufficient resources (virtual memory, process file descriptors, +physical disk space, etc.) are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ + +* 'InappropriateType' +The path refers to an existing non-directory object. +@[EEXIST]@ + +-} + +createDirectory :: FilePath -> IO () +createDirectory path = do + modifyIOError (`ioeSetFileName` path) $ + withCString path $ \s -> do + throwErrnoIfMinus1Retry_ "createDirectory" $ + mkdir s 0o777 + +#else /* !__GLASGOW_HASKELL__ */ + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions fromFPath toFPath + = getPermissions fromFPath >>= setPermissions toFPath + +#endif + +-- | @'createDirectoryIfMissing' parents dir@ creates a new directory +-- @dir@ if it doesn\'t exist. If the first argument is 'True' +-- the function will also create all parent directories if they are missing. +createDirectoryIfMissing :: Bool -- ^ Create its parents too? + -> FilePath -- ^ The path to the directory you want to make + -> IO () +createDirectoryIfMissing parents file = do + b <- doesDirectoryExist file + case (b,parents, file) of + (_, _, "") -> return () + (True, _, _) -> return () + (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file + (_, False, _) -> createDirectory file + where mkParents = scanl1 () . splitDirectories . normalise + +#if __GLASGOW_HASKELL__ +{- | @'removeDirectory' dir@ removes an existing directory /dir/. The +implementation may specify additional constraints which must be +satisfied before a directory can be removed (e.g. the directory has to +be empty, or may not be in use by other processes). It is not legal +for an implementation to partially remove a directory unless the +entire directory is removed. A conformant implementation need not +support directory removal in all situations (e.g. removal of the root +directory). + +The operation may fail with: + +* 'HardwareFault' +A physical I\/O error has occurred. +EIO + +* 'InvalidArgument' +The operand is not a valid directory name. +[ENAMETOOLONG, ELOOP] + +* 'isDoesNotExistError' \/ 'NoSuchThing' +The directory does not exist. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* 'UnsatisfiedConstraints' +Implementation-dependent constraints are not satisfied. +@[EBUSY, ENOTEMPTY, EEXIST]@ + +* 'UnsupportedOperation' +The implementation does not support removal in this situation. +@[EINVAL]@ + +* 'InappropriateType' +The operand refers to an existing non-directory object. +@[ENOTDIR]@ + +-} + +removeDirectory :: FilePath -> IO () +removeDirectory path = do + modifyIOError (`ioeSetFileName` path) $ + withCString path $ \s -> + throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) +#endif + +-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ +-- together with its content and all subdirectories. Be careful, +-- if the directory contains symlinks, the function will follow them. +removeDirectoryRecursive :: FilePath -> IO () +removeDirectoryRecursive startLoc = do + cont <- getDirectoryContents startLoc + sequence_ [rm (startLoc x) | x <- cont, x /= "." && x /= ".."] + removeDirectory startLoc + where + rm :: FilePath -> IO () + rm f = do temp <- try (removeFile f) + case temp of + Left e -> do isDir <- doesDirectoryExist f + -- If f is not a directory, re-throw the error + unless isDir $ throw e + removeDirectoryRecursive f + Right _ -> return () + +#if __GLASGOW_HASKELL__ +{- |'removeFile' /file/ removes the directory entry for an existing file +/file/, where /file/ is not itself a directory. The +implementation may specify additional constraints which must be +satisfied before a file can be removed (e.g. the file may not be in +use by other processes). + +The operation may fail with: + +* 'HardwareFault' +A physical I\/O error has occurred. +@[EIO]@ + +* 'InvalidArgument' +The operand is not a valid file name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' \/ 'NoSuchThing' +The file does not exist. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* 'UnsatisfiedConstraints' +Implementation-dependent constraints are not satisfied. +@[EBUSY]@ + +* 'InappropriateType' +The operand refers to an existing directory. +@[EPERM, EINVAL]@ + +-} + +removeFile :: FilePath -> IO () +removeFile path = do + modifyIOError (`ioeSetFileName` path) $ + withCString path $ \s -> + throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s) + +{- |@'renameDirectory' old new@ changes the name of an existing +directory from /old/ to /new/. If the /new/ directory +already exists, it is atomically replaced by the /old/ directory. +If the /new/ directory is neither the /old/ directory nor an +alias of the /old/ directory, it is removed as if by +'removeDirectory'. A conformant implementation need not support +renaming directories in all situations (e.g. renaming to an existing +directory, or across different physical devices), but the constraints +must be documented. + +On Win32 platforms, @renameDirectory@ fails if the /new/ directory already +exists. + +The operation may fail with: + +* 'HardwareFault' +A physical I\/O error has occurred. +@[EIO]@ + +* 'InvalidArgument' +Either operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' \/ 'NoSuchThing' +The original directory does not exist, or there is no path to the target. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* 'ResourceExhausted' +Insufficient resources are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ + +* 'UnsatisfiedConstraints' +Implementation-dependent constraints are not satisfied. +@[EBUSY, ENOTEMPTY, EEXIST]@ + +* 'UnsupportedOperation' +The implementation does not support renaming in this situation. +@[EINVAL, EXDEV]@ + +* 'InappropriateType' +Either path refers to an existing non-directory object. +@[ENOTDIR, EISDIR]@ + +-} + +renameDirectory :: FilePath -> FilePath -> IO () +renameDirectory opath npath = + withFileStatus "renameDirectory" opath $ \st -> do + is_dir <- isDirectory st + if (not is_dir) + then ioException (IOError Nothing InappropriateType "renameDirectory" + ("not a directory") (Just opath)) + else do + + withCString opath $ \s1 -> + withCString npath $ \s2 -> + throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2) + +{- |@'renameFile' old new@ changes the name of an existing file system +object from /old/ to /new/. If the /new/ object already +exists, it is atomically replaced by the /old/ object. Neither +path may refer to an existing directory. A conformant implementation +need not support renaming files in all situations (e.g. renaming +across different physical devices), but the constraints must be +documented. + +The operation may fail with: + +* 'HardwareFault' +A physical I\/O error has occurred. +@[EIO]@ + +* 'InvalidArgument' +Either operand is not a valid file name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' \/ 'NoSuchThing' +The original file does not exist, or there is no path to the target. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* 'ResourceExhausted' +Insufficient resources are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ + +* 'UnsatisfiedConstraints' +Implementation-dependent constraints are not satisfied. +@[EBUSY]@ + +* 'UnsupportedOperation' +The implementation does not support renaming in this situation. +@[EXDEV]@ + +* 'InappropriateType' +Either path refers to an existing directory. +@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ + +-} + +renameFile :: FilePath -> FilePath -> IO () +renameFile opath npath = + withFileOrSymlinkStatus "renameFile" opath $ \st -> do + is_dir <- isDirectory st + if is_dir + then ioException (IOError Nothing InappropriateType "renameFile" + "is a directory" (Just opath)) + else do + + withCString opath $ \s1 -> + withCString npath $ \s2 -> + throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2) + +#endif /* __GLASGOW_HASKELL__ */ + +{- |@'copyFile' old new@ copies the existing file from /old/ to /new/. +If the /new/ file already exists, it is atomically replaced by the /old/ file. +Neither path may refer to an existing directory. The permissions of /old/ are +copied to /new/, if possible. +-} + +copyFile :: FilePath -> FilePath -> IO () +#ifdef __NHC__ +copyFile fromFPath toFPath = + do readFile fromFPath >>= writeFile toFPath + try (copyPermissions fromFPath toFPath) + return () +#else +copyFile fromFPath toFPath = + copy `catch` (\e -> case e of + IOException e -> + throw $ IOException $ ioeSetLocation e "copyFile" + _ -> throw e) + where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + try (copyPermissions fromFPath tmpFPath) + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do try $ hClose hTmp + try $ removeFile tmpFPath + bufferSize = 1024 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer +#endif + +-- | Given path referring to a file or directory, returns a +-- canonicalized path, with the intent that two paths referring +-- to the same file\/directory will map to the same canonicalized +-- path. Note that it is impossible to guarantee that the +-- implication (same file\/dir \<=\> same canonicalizedPath) holds +-- in either direction: this function can make only a best-effort +-- attempt. +canonicalizePath :: FilePath -> IO FilePath +canonicalizePath fpath = + withCString fpath $ \pInPath -> + allocaBytes long_path_size $ \pOutPath -> +#if defined(mingw32_HOST_OS) + alloca $ \ppFilePart -> + do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart +#else + do c_realpath pInPath pOutPath +#endif + peekCString pOutPath + +#if defined(mingw32_HOST_OS) +foreign import stdcall unsafe "GetFullPathNameA" + c_GetFullPathName :: CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else +foreign import ccall unsafe "realpath" + c_realpath :: CString + -> CString + -> IO CString +#endif + +-- | 'makeRelative' the current directory. +makeRelativeToCurrentDirectory :: FilePath -> IO FilePath +makeRelativeToCurrentDirectory x = do + cur <- getCurrentDirectory + return $ makeRelative cur x + +-- | Given an executable file name, searches for such file +-- in the directories listed in system PATH. The returned value +-- is the path to the found executable or Nothing if there isn't +-- such executable. For example (findExecutable \"ghc\") +-- gives you the path to GHC. +findExecutable :: String -> IO (Maybe FilePath) +findExecutable binary = +#if defined(mingw32_HOST_OS) + withCString binary $ \c_binary -> + withCString ('.':exeExtension) $ \c_ext -> + allocaBytes long_path_size $ \pOutPath -> + alloca $ \ppFilePart -> do + res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart + if res > 0 && res < fromIntegral long_path_size + then do fpath <- peekCString pOutPath + return (Just fpath) + else return Nothing + +foreign import stdcall unsafe "SearchPathA" + c_SearchPath :: CString + -> CString + -> CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else + do + path <- getEnv "PATH" + search (splitSearchPath path) + where + fileName = binary <.> exeExtension + + search :: [FilePath] -> IO (Maybe FilePath) + search [] = return Nothing + search (d:ds) = do + let path = d fileName + b <- doesFileExist path + if b then return (Just path) + else search ds +#endif + + +#ifdef __GLASGOW_HASKELL__ +{- |@'getDirectoryContents' dir@ returns a list of /all/ entries +in /dir/. + +The operation may fail with: + +* 'HardwareFault' +A physical I\/O error has occurred. +@[EIO]@ + +* 'InvalidArgument' +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' \/ 'NoSuchThing' +The directory does not exist. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EACCES]@ + +* 'ResourceExhausted' +Insufficient resources are available to perform the operation. +@[EMFILE, ENFILE]@ + +* 'InappropriateType' +The path refers to an existing non-directory object. +@[ENOTDIR]@ + +-} + +getDirectoryContents :: FilePath -> IO [FilePath] +getDirectoryContents path = do + modifyIOError (`ioeSetFileName` path) $ + alloca $ \ ptr_dEnt -> + bracket + (withCString path $ \s -> + throwErrnoIfNullRetry desc (c_opendir s)) + (\p -> throwErrnoIfMinus1_ desc (c_closedir p)) + (\p -> loop ptr_dEnt p) + where + desc = "getDirectoryContents" + + loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String] + loop ptr_dEnt dir = do + resetErrno + r <- readdir dir ptr_dEnt + if (r == 0) + then do + dEnt <- peek ptr_dEnt + if (dEnt == nullPtr) + then return [] + else do + entry <- (d_name dEnt >>= peekCString) + freeDirEnt dEnt + entries <- loop ptr_dEnt dir + return (entry:entries) + else do errno <- getErrno + if (errno == eINTR) then loop ptr_dEnt dir else do + let (Errno eo) = errno + if (eo == end_of_dir) + then return [] + else throwErrno desc + + + +{- |If the operating system has a notion of current directories, +'getCurrentDirectory' returns an absolute path to the +current directory of the calling process. + +The operation may fail with: + +* 'HardwareFault' +A physical I\/O error has occurred. +@[EIO]@ + +* 'isDoesNotExistError' \/ 'NoSuchThing' +There is no path referring to the current directory. +@[EPERM, ENOENT, ESTALE...]@ + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EACCES]@ + +* 'ResourceExhausted' +Insufficient resources are available to perform the operation. + +* 'UnsupportedOperation' +The operating system has no notion of current directory. + +-} + +getCurrentDirectory :: IO FilePath +getCurrentDirectory = do + p <- mallocBytes long_path_size + go p long_path_size + where go p bytes = do + p' <- c_getcwd p (fromIntegral bytes) + if p' /= nullPtr + then do s <- peekCString p' + free p' + return s + else do errno <- getErrno + if errno == eRANGE + then do let bytes' = bytes * 2 + p' <- reallocBytes p bytes' + go p' bytes' + else throwErrno "getCurrentDirectory" + +{- |If the operating system has a notion of current directories, +@'setCurrentDirectory' dir@ changes the current +directory of the calling process to /dir/. + +The operation may fail with: + +* 'HardwareFault' +A physical I\/O error has occurred. +@[EIO]@ + +* 'InvalidArgument' +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' \/ 'NoSuchThing' +The directory does not exist. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' \/ 'PermissionDenied' +The process has insufficient privileges to perform the operation. +@[EACCES]@ + +* 'UnsupportedOperation' +The operating system has no notion of current directory, or the +current directory cannot be dynamically changed. + +* 'InappropriateType' +The path refers to an existing non-directory object. +@[ENOTDIR]@ + +-} + +setCurrentDirectory :: FilePath -> IO () +setCurrentDirectory path = do + modifyIOError (`ioeSetFileName` path) $ + withCString path $ \s -> + throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s) + -- ToDo: add path to error + +{- |The operation 'doesDirectoryExist' returns 'True' if the argument file +exists and is a directory, and 'False' otherwise. +-} + +doesDirectoryExist :: FilePath -> IO Bool +doesDirectoryExist name = + catch + (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) + (\ _ -> return False) + +{- |The operation 'doesFileExist' returns 'True' +if the argument file exists and is not a directory, and 'False' otherwise. +-} + +doesFileExist :: FilePath -> IO Bool +doesFileExist name = do + catch + (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) + (\ _ -> return False) + +{- |The 'getModificationTime' operation returns the +clock time at which the file or directory was last modified. + +The operation may fail with: + +* 'isPermissionError' if the user is not permitted to access + the modification time; or + +* 'isDoesNotExistError' if the file or directory does not exist. + +-} + +getModificationTime :: FilePath -> IO ClockTime +getModificationTime name = + withFileStatus "getModificationTime" name $ \ st -> + modificationTime st + +withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a +withFileStatus loc name f = do + modifyIOError (`ioeSetFileName` name) $ + allocaBytes sizeof_stat $ \p -> + withCString (fileNameEndClean name) $ \s -> do + throwErrnoIfMinus1Retry_ loc (c_stat s p) + f p + +withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a +withFileOrSymlinkStatus loc name f = do + modifyIOError (`ioeSetFileName` name) $ + allocaBytes sizeof_stat $ \p -> + withCString name $ \s -> do + throwErrnoIfMinus1Retry_ loc (lstat s p) + f p + +modificationTime :: Ptr CStat -> IO ClockTime +modificationTime stat = do + mtime <- st_mtime stat + let realToInteger = round . realToFrac :: Real a => a -> Integer + return (TOD (realToInteger (mtime :: CTime)) 0) + +isDirectory :: Ptr CStat -> IO Bool +isDirectory stat = do + mode <- st_mode stat + return (s_isdir mode) + +fileNameEndClean :: String -> String +fileNameEndClean name = if isDrive name then addTrailingPathSeparator name + else dropTrailingPathSeparator name + +foreign import ccall unsafe "__hscore_R_OK" r_OK :: CInt +foreign import ccall unsafe "__hscore_W_OK" w_OK :: CInt +foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt + +foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode +foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode +foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode +foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode + +foreign import ccall unsafe "__hscore_long_path_size" + long_path_size :: Int + +#else +long_path_size :: Int +long_path_size = 2048 -- // guess? + +#endif /* __GLASGOW_HASKELL__ */ + +{- | Returns the current user's home directory. + +The directory returned is expected to be writable by the current user, +but note that it isn't generally considered good practice to store +application-specific data here; use 'getAppUserDataDirectory' +instead. + +On Unix, 'getHomeDirectory' returns the value of the @HOME@ +environment variable. On Windows, the system is queried for a +suitable path; a typical path might be +@C:/Documents And Settings/user@. + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of home directory. + +* 'isDoesNotExistError' +The home directory for the current user does not exist, or +cannot be found. +-} +getHomeDirectory :: IO FilePath +getHomeDirectory = +#if defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath + if (r < 0) + then do + r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath + when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory") + else return () + peekCString pPath +#else + getEnv "HOME" +#endif + +{- | Returns the pathname of a directory in which application-specific +data for the current user can be stored. The result of +'getAppUserDataDirectory' for a given application is specific to +the current user. + +The argument should be the name of the application, which will be used +to construct the pathname (so avoid using unusual characters that +might result in an invalid pathname). + +Note: the directory may not actually exist, and may need to be created +first. It is expected that the parent directory exists and is +writable. + +On Unix, this function returns @$HOME\/.appName@. On Windows, a +typical path might be + +> C:/Documents And Settings/user/Application Data/appName + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of application-specific data directory. + +* 'isDoesNotExistError' +The home directory for the current user does not exist, or +cannot be found. +-} +getAppUserDataDirectory :: String -> IO FilePath +getAppUserDataDirectory appName = do +#if defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath + when (r<0) (raiseUnsupported "System.Directory.getAppUserDataDirectory") + s <- peekCString pPath + return (s++'\\':appName) +#else + path <- getEnv "HOME" + return (path++'/':'.':appName) +#endif + +{- | Returns the current user's document directory. + +The directory returned is expected to be writable by the current user, +but note that it isn't generally considered good practice to store +application-specific data here; use 'getAppUserDataDirectory' +instead. + +On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@ +environment variable. On Windows, the system is queried for a +suitable path; a typical path might be +@C:\/Documents and Settings\/user\/My Documents@. + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of document directory. + +* 'isDoesNotExistError' +The document directory for the current user does not exist, or +cannot be found. +-} +getUserDocumentsDirectory :: IO FilePath +getUserDocumentsDirectory = do +#if defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath + when (r<0) (raiseUnsupported "System.Directory.getUserDocumentsDirectory") + peekCString pPath +#else + getEnv "HOME" +#endif + +{- | Returns the current directory for temporary files. + +On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@ +environment variable or \"\/tmp\" if the variable isn\'t defined. +On Windows, the function checks for the existence of environment variables in +the following order and uses the first path found: + +* +TMP environment variable. + +* +TEMP environment variable. + +* +USERPROFILE environment variable. + +* +The Windows directory + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of temporary directory. + +The function doesn\'t verify whether the path exists. +-} +getTemporaryDirectory :: IO FilePath +getTemporaryDirectory = do +#if defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_GetTempPath (fromIntegral long_path_size) pPath + peekCString pPath +#else + catch (getEnv "TMPDIR") (\ex -> return "/tmp") +#endif + +#if defined(mingw32_HOST_OS) +foreign import ccall unsafe "__hscore_getFolderPath" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CString + -> IO CInt +foreign import ccall unsafe "__hscore_CSIDL_PROFILE" csidl_PROFILE :: CInt +foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt +foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt +foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt + +foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt + +raiseUnsupported loc = + ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) + +#endif + +-- ToDo: This should be determined via autoconf (AC_EXEEXT) +-- | Extension for executable files +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: String +#ifdef mingw32_HOST_OS +exeExtension = "exe" +#else +exeExtension = "" +#endif + diff --git a/cbits/directory.c b/cbits/directory.c new file mode 100644 --- /dev/null +++ b/cbits/directory.c @@ -0,0 +1,55 @@ +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +/* + * (c) The University of Glasgow 2002 + * + */ + +#define INLINE +#include "HsDirectory.h" + +/* + * Function: __hscore_getFolderPath() + * + * Late-bound version of SHGetFolderPath(), coping with OS versions + * that have shell32's lacking that particular API. + * + */ +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +typedef HRESULT (*HSCORE_GETAPPFOLDERFUNTY)(HWND,int,HANDLE,DWORD,char*); +int +__hscore_getFolderPath(HWND hwndOwner, + int nFolder, + HANDLE hToken, + DWORD dwFlags, + char* pszPath) +{ + static int loaded_dll = 0; + static HMODULE hMod = (HMODULE)NULL; + static HSCORE_GETAPPFOLDERFUNTY funcPtr = NULL; + /* The DLLs to try loading entry point from */ + char* dlls[] = { "shell32.dll", "shfolder.dll" }; + + if (loaded_dll < 0) { + return (-1); + } else if (loaded_dll == 0) { + int i; + for(i=0;i < sizeof(dlls); i++) { + hMod = LoadLibrary(dlls[i]); + if ( hMod != NULL && + (funcPtr = (HSCORE_GETAPPFOLDERFUNTY)GetProcAddress(hMod, "SHGetFolderPathA")) ) { + loaded_dll = 1; + break; + } + } + if (loaded_dll == 0) { + loaded_dll = (-1); + return (-1); + } + } + /* OK, if we got this far the function has been bound */ + return (int)funcPtr(hwndOwner,nFolder,hToken,dwFlags,pszPath); + /* ToDo: unload the DLL on shutdown? */ +} +#endif /* WIN32 */ +#endif /* !__NHC__ */ + diff --git a/directory.cabal b/directory.cabal new file mode 100644 --- /dev/null +++ b/directory.cabal @@ -0,0 +1,21 @@ +name: directory +version: 1.0.0.0 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +synopsis: library for directory handling +description: + This package provides a library for handling directories. +build-type: Configure +exposed-modules: + System.Directory +c-sources: + cbits/directory.c +include-dirs: include +includes: HsDirectory.h +install-includes: HsDirectory.h HsDirectoryConfig.h +extensions: CPP, ForeignFunctionInterface +build-depends: base, old-time, filepath +extra-tmp-files: + config.log config.status autom4te.cache + include/HsDirectoryConfig.h diff --git a/include/HsDirectory.h b/include/HsDirectory.h new file mode 100644 --- /dev/null +++ b/include/HsDirectory.h @@ -0,0 +1,108 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2001-2004 + * + * Definitions for package `directory' which are visible in Haskell land. + * + * ---------------------------------------------------------------------------*/ + +#ifndef __HSDIRECTORY_H__ +#define __HSDIRECTORY_H__ + +#include "HsDirectoryConfig.h" +// Otherwise these clash with similar definitions from other packages: +#undef PACKAGE_BUGREPORT +#undef PACKAGE_NAME +#undef PACKAGE_STRING +#undef PACKAGE_TARNAME +#undef PACKAGE_VERSION + +#if HAVE_SYS_TYPES_H +#include +#endif +#if HAVE_UNISTD_H +#include +#endif +#if HAVE_SYS_STAT_H +#include +#endif + +#include "HsFFI.h" + +#if defined(__MINGW32__) +#include +#endif + +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +extern int __hscore_getFolderPath(HWND hwndOwner, + int nFolder, + HANDLE hToken, + DWORD dwFlags, + char* pszPath); +#endif + +/* ----------------------------------------------------------------------------- + INLINE functions. + + These functions are given as inlines here for when compiling via C, + but we also generate static versions into the cbits library for + when compiling to native code. + -------------------------------------------------------------------------- */ + +#ifndef INLINE +# if defined(_MSC_VER) +# define INLINE extern __inline +# else +# define INLINE static inline +# endif +#endif + +/* A size that will contain many path names, but not necessarily all + * (PATH_MAX is not defined on systems with unlimited path length, + * e.g. the Hurd). + */ +INLINE HsInt __hscore_long_path_size() { +#ifdef PATH_MAX + return PATH_MAX; +#else + return 4096; +#endif +} + +#ifdef __GLASGOW_HASKELL__ +INLINE int __hscore_R_OK() { return R_OK; } +INLINE int __hscore_W_OK() { return W_OK; } +INLINE int __hscore_X_OK() { return X_OK; } + +INLINE mode_t __hscore_S_IRUSR() { return S_IRUSR; } +INLINE mode_t __hscore_S_IWUSR() { return S_IWUSR; } +INLINE mode_t __hscore_S_IXUSR() { return S_IXUSR; } +INLINE mode_t __hscore_S_IFDIR() { return S_IFDIR; } +#endif + +#if defined(__MINGW32__) + +/* Make sure we've got the reqd CSIDL_ constants in scope; + * w32api header files are lagging a bit in defining the full set. + */ +#if !defined(CSIDL_APPDATA) +#define CSIDL_APPDATA 0x001a +#endif +#if !defined(CSIDL_PERSONAL) +#define CSIDL_PERSONAL 0x0005 +#endif +#if !defined(CSIDL_PROFILE) +#define CSIDL_PROFILE 0x0028 +#endif +#if !defined(CSIDL_WINDOWS) +#define CSIDL_WINDOWS 0x0024 +#endif + +INLINE int __hscore_CSIDL_PROFILE() { return CSIDL_PROFILE; } +INLINE int __hscore_CSIDL_APPDATA() { return CSIDL_APPDATA; } +INLINE int __hscore_CSIDL_WINDOWS() { return CSIDL_WINDOWS; } +INLINE int __hscore_CSIDL_PERSONAL() { return CSIDL_PERSONAL; } +#endif + +#endif /* __HSDIRECTORY_H__ */ + diff --git a/include/HsDirectoryConfig.h b/include/HsDirectoryConfig.h new file mode 100644 --- /dev/null +++ b/include/HsDirectoryConfig.h @@ -0,0 +1,47 @@ +/* include/HsDirectoryConfig.h. Generated from HsDirectoryConfig.h.in by configure. */ +/* include/HsDirectoryConfig.h.in. Generated from configure.ac by autoheader. */ + +/* Define to 1 if you have the header file. */ +#define HAVE_INTTYPES_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_MEMORY_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDINT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDLIB_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STRINGS_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STRING_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_STAT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_TYPES_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_UNISTD_H 1 + +/* Define to the address where bug reports for this package should be sent. */ +#define PACKAGE_BUGREPORT "libraries@haskell.org" + +/* Define to the full name of this package. */ +#define PACKAGE_NAME "Haskell directory package" + +/* Define to the full name and version of this package. */ +#define PACKAGE_STRING "Haskell directory package 1.0" + +/* Define to the one symbol short name of this package. */ +#define PACKAGE_TARNAME "directory" + +/* Define to the version of this package. */ +#define PACKAGE_VERSION "1.0" + +/* Define to 1 if you have the ANSI C header files. */ +#define STDC_HEADERS 1