Directory.hs.prettyprinter.golden

{-# LANGUAGE ForeignFunctionInterface, NondecreasingIndentation #-}
module System.Directory
       (createDirectory, createDirectoryIfMissing, removeDirectory,
        removeDirectoryRecursive, renameDirectory, getDirectoryContents,
        getCurrentDirectory, setCurrentDirectory, getHomeDirectory,
        getAppUserDataDirectory, getUserDocumentsDirectory,
        getTemporaryDirectory, removeFile, renameFile, copyFile,
        canonicalizePath, makeRelativeToCurrentDirectory, findExecutable,
        doesFileExist, doesDirectoryExist,
        Permissions(Permissions, readable, writable, executable,
                    searchable),
        getPermissions, setPermissions, copyPermissions,
        getModificationTime)
       where
import Prelude hiding (catch)
import qualified Prelude
import Control.Monad (guard)
import System.Environment (getEnv)
import System.FilePath
import System.IO
import System.IO.Error hiding (catch, try)
import Control.Monad (when, unless)
import Control.Exception.Base
import Foreign
import Foreign.C
import System.Time (ClockTime(..))
import GHC.IO.Exception
       (IOException(..), IOErrorType(..), ioException)
import System.Posix.Types
import System.Posix.Internals
import qualified System.Win32 as Win32
 
data Permissions = Permissions{readable, writable, executable,
                               searchable :: Bool}
                 deriving (Eq, Ord, Read, Show)
 
getPermissions :: FilePath -> IO Permissions
getPermissions name
  = do withFilePath name $
         \ s ->
           do allocaBytes sizeof_stat $
                \ p_stat ->
                  do throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat
                     mode <- st_mode p_stat
                     let usr_read = mode .&. s_IRUSR
                     let usr_write = mode .&. s_IWUSR
                     let usr_exec = mode .&. s_IXUSR
                     let is_dir = mode .&. s_IFDIR
                     return
                       (Permissions{readable = usr_read /= 0, writable = usr_write /= 0,
                                    executable = is_dir == 0 && usr_exec /= 0,
                                    searchable = is_dir /= 0 && usr_exec /= 0})
 
setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s)
  = do allocaBytes sizeof_stat $
         \ p_stat ->
           do withFilePath 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_wchmod p_name mode3
  where  
        modifyBit :: Bool -> CMode -> CMode -> CMode
        modifyBit False m b = m .&. (complement b)
        modifyBit True m b = m .|. b
 
foreign import ccall unsafe "_wchmod" c_wchmod ::
               CWString -> CMode -> IO CInt
 
copyPermissions :: FilePath -> FilePath -> IO ()
copyPermissions source dest
  = do allocaBytes sizeof_stat $
         \ p_stat ->
           do withFilePath source $
                \ p_source ->
                  do withFilePath dest $
                       \ p_dest ->
                         do throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat
                            mode <- st_mode p_stat
                            throwErrnoIfMinus1_ "copyPermissions" $ c_wchmod p_dest mode
 
createDirectory :: FilePath -> IO ()
createDirectory path = do Win32.createDirectory path Nothing
 
createDirectoryIfMissing :: Bool -> FilePath -> IO ()
createDirectoryIfMissing create_parents path0
  | create_parents = createDirs (parents path0)
  | otherwise = createDirs (take 1 (parents path0))
  where parents
          = reverse . scanl1 (</>) . splitDirectories . normalise
        createDirs [] = return ()
        createDirs (dir : []) = createDir dir throw
        createDirs (dir : dirs)
          = createDir dir $
              \ _ ->
                do createDirs dirs
                   createDir dir throw
         
        createDir :: FilePath -> (IOException -> IO ()) -> IO ()
        createDir dir notExistHandler
          = do r <- try $ createDirectory dir
               case (r :: Either IOException ()) of
                   Right () -> return ()
                   Left e | isDoesNotExistError e -> notExistHandler e
                          | isAlreadyExistsError e ->
                            (do withFileStatus "createDirectoryIfMissing" dir $
                                  \ st ->
                                    do isDir <- isDirectory st
                                       if isDir then return () else throw e)
                              `catch` ((\ _ -> return ()) :: IOException -> IO ())
                          | otherwise -> throw e
 
removeDirectory :: FilePath -> IO ()
removeDirectory path = Win32.removeDirectory path
 
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
                                unless isDir $ throw (e :: SomeException)
                                removeDirectoryRecursive f
                   Right _ -> return ()
 
removeFile :: FilePath -> IO ()
removeFile path = Win32.deleteFile path
 
renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory opath npath
  = do withFileStatus "renameDirectory" opath $
         \ st ->
           do is_dir <- isDirectory st
              if (not is_dir) then
                ioException
                  (ioeSetErrorString
                     (mkIOError InappropriateType "renameDirectory" Nothing
                        (Just opath))
                     "not a directory")
                else
                do Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
 
renameFile :: FilePath -> FilePath -> IO ()
renameFile opath npath
  = do withFileOrSymlinkStatus "renameFile" opath $
         \ st ->
           do is_dir <- isDirectory st
              if is_dir then
                ioException
                  (ioeSetErrorString
                     (mkIOError InappropriateType "renameFile" Nothing (Just opath))
                     "is a directory")
                else
                do Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
 
copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath
  = copy `Prelude.catch`
      (\ exc -> throw $ ioeSetLocation exc "copyFile")
  where copy
          = bracket (openBinaryFile fromFPath ReadMode) hClose $
              \ hFrom ->
                bracketOnError openTmp cleanTmp $
                  \ (tmpFPath, hTmp) ->
                    do allocaBytes bufferSize $ copyContents hFrom hTmp
                       hClose hTmp
                       ignoreIOExceptions $ copyPermissions fromFPath tmpFPath
                       renameFile tmpFPath toFPath
        openTmp
          = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
        cleanTmp (tmpFPath, hTmp)
          = do ignoreIOExceptions $ hClose hTmp
               ignoreIOExceptions $ 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
        ignoreIOExceptions io = io `catch` ioExceptionIgnorer
         
        ioExceptionIgnorer :: IOException -> IO ()
        ioExceptionIgnorer _ = return ()
 
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath fpath
  = do path <- Win32.getFullPathName fpath
       return (normalise path)
 
makeRelativeToCurrentDirectory :: FilePath -> IO FilePath
makeRelativeToCurrentDirectory x
  = do cur <- getCurrentDirectory
       return $ makeRelative cur x
 
findExecutable :: String -> IO (Maybe FilePath)
findExecutable binary
  = Win32.searchPath Nothing binary ('.' : exeExtension)
 
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path
  = modifyIOError
      ((`ioeSetFileName` path) .
         (`ioeSetLocation` "getDirectoryContents"))
      $
      do bracket (Win32.findFirstFile (path </> "*"))
           (\ (h, _) -> Win32.findClose h)
           (\ (h, fdat) -> loop h fdat [])
  where  
        loop ::
             Win32.HANDLE -> Win32.FindData -> [FilePath] -> IO [FilePath]
        loop h fdat acc
          = do filename <- Win32.getFindDataFileName fdat
               more <- Win32.findNextFile h fdat
               if more then loop h fdat (filename : acc) else
                 return (filename : acc)
 
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do Win32.getCurrentDirectory
 
setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path = Win32.setCurrentDirectory path
 
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name
  = (withFileStatus "doesDirectoryExist" name $
       \ st -> isDirectory st)
      `catch` ((\ _ -> return False) :: IOException -> IO Bool)
 
doesFileExist :: FilePath -> IO Bool
doesFileExist name
  = (withFileStatus "doesFileExist" name $
       \ st ->
         do b <- isDirectory st
            return (not b))
      `catch` ((\ _ -> return False) :: IOException -> IO Bool)
 
getModificationTime :: FilePath -> IO ClockTime
getModificationTime name
  = do withFileStatus "getModificationTime" name $
         \ st -> do modificationTime st
 
withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
withFileStatus loc name f
  = do modifyIOError (`ioeSetFileName` name) $
         allocaBytes sizeof_stat $
           \ p ->
             withFilePath (fileNameEndClean name) $
               \ s -> do throwErrnoIfMinus1Retry_ loc (c_stat s p)
 
withFileOrSymlinkStatus ::
                        String -> FilePath -> (Ptr CStat -> IO a) -> IO a
withFileOrSymlinkStatus loc name f
  = do modifyIOError (`ioeSetFileName` name) $
         allocaBytes sizeof_stat $
           \ p ->
             withFilePath name $
               \ s -> do throwErrnoIfMinus1Retry_ loc (lstat s 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 "HsDirectory.h __hscore_S_IRUSR"
               s_IRUSR :: CMode
 
foreign import ccall unsafe "HsDirectory.h __hscore_S_IWUSR"
               s_IWUSR :: CMode
 
foreign import ccall unsafe "HsDirectory.h __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
 
getHomeDirectory :: IO FilePath
getHomeDirectory
  = modifyIOError ((`ioeSetLocation` "getHomeDirectory")) $
      do r <- try $
                Win32.sHGetFolderPath nullPtr Win32.cSIDL_PROFILE nullPtr 0
         case (r :: Either IOException String) of
             Right s -> return s
             Left _ -> do r1 <- try $
                                  Win32.sHGetFolderPath nullPtr Win32.cSIDL_WINDOWS nullPtr 0
                          case r1 of
                              Right s -> return s
                              Left e -> ioError (e :: IOException)
 
getAppUserDataDirectory :: String -> IO FilePath
getAppUserDataDirectory appName
  = do modifyIOError ((`ioeSetLocation` "getAppUserDataDirectory")) $
         do s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0
            return (s ++ '\\' : appName)
 
getUserDocumentsDirectory :: IO FilePath
getUserDocumentsDirectory
  = do modifyIOError ((`ioeSetLocation` "getUserDocumentsDirectory"))
         $ do Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0
 
getTemporaryDirectory :: IO FilePath
getTemporaryDirectory = do Win32.getTemporaryDirectory
 
exeExtension :: String
exeExtension = "exe"