ghc/lib/compat/Compat/Directory.hs

   1 {-# OPTIONS -cpp #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Compat.Directory
   5 -- Copyright   :  (c) The University of Glasgow 2001-2004
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  provisional
  10 -- Portability :  portable
  11 --
  12 -- Functions from System.Directory that aren't present in older versions
  13 -- of that library.
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module Compat.Directory (
  18         getAppUserDataDirectory,
  19         copyFile,
  20         findExecutable,
  21         createDirectoryIfMissing
  22   ) where
  23
  24 #include "../../includes/ghcconfig.h"
  25
  26 import System.Environment (getEnv)
  27 import System.Directory.Internals
  28 #if __GLASGOW_HASKELL__ > 600
  29 import Control.Exception        ( bracket )
  30 import Control.Monad            ( when )
  31 import Foreign.Marshal.Alloc    ( allocaBytes )
  32 import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
  33 import System.IO.Error          ( try )
  34 import GHC.IOBase ( IOException(..), IOErrorType(..) )
  35 #else
  36 import System.IO                ( try )
  37 #endif
  38 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
  39 import Foreign.Ptr
  40 import Foreign.C
  41 #endif
  42 import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
  43
  44 getAppUserDataDirectory :: String -> IO FilePath
  45 getAppUserDataDirectory appName = do
  46 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
  47   allocaBytes long_path_size $ \pPath -> do
  48      r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
  49      when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
  50      s <- peekCString pPath
  51      return (s++'\\':appName)
  52 #else
  53   path <- getEnv "HOME"
  54   return (path++'/':'.':appName)
  55 #endif
  56
  57 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
  58 foreign import ccall unsafe "directory.h __hscore_getFolderPath"
  59             c_SHGetFolderPath :: Ptr ()
  60                               -> CInt
  61                               -> Ptr ()
  62                               -> CInt
  63                               -> CString
  64                               -> IO CInt
  65
  66 -- __compat_long_path_size defined in cbits/directory.c
  67 foreign import ccall unsafe "directory.h __compat_long_path_size"
  68   long_path_size :: Int
  69
  70 foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
  71
  72 raiseUnsupported loc =
  73    ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
  74 #endif
  75
  76
  77 copyFile :: FilePath -> FilePath -> IO ()
  78 copyFile fromFPath toFPath =
  79 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
  80         do readFile fromFPath >>= writeFile toFPath
  81            try (getPermissions fromFPath >>= setPermissions toFPath)
  82            return ()
  83 #else
  84         (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
  85          bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
  86          allocaBytes bufferSize $ \buffer -> do
  87                 copyContents hFrom hTo buffer
  88                 try (getPermissions fromFPath >>= setPermissions toFPath)
  89                 return ()) `catch` (ioError . changeFunName)
  90         where
  91                 bufferSize = 1024
  92
  93                 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
  94
  95                 copyContents hFrom hTo buffer = do
  96                         count <- hGetBuf hFrom buffer bufferSize
  97                         when (count > 0) $ do
  98                                 hPutBuf hTo buffer count
  99                                 copyContents hFrom hTo buffer
 100 #endif
 101
 102
 103 findExecutable :: String -> IO (Maybe FilePath)
 104 findExecutable binary = do
 105   path <- getEnv "PATH"
 106   search (parseSearchPath path)
 107   where
 108 #ifdef mingw32_HOST_OS
 109     fileName = binary `joinFileExt` "exe"
 110 #else
 111     fileName = binary
 112 #endif
 113
 114     search :: [FilePath] -> IO (Maybe FilePath)
 115     search [] = return Nothing
 116     search (d:ds) = do
 117         let path = d `joinFileName` fileName
 118         b <- doesFileExist path
 119         if b then return (Just path)
 120              else search ds
 121
 122 createDirectoryIfMissing :: Bool     -- ^ Create its parents too?
 123                          -> FilePath -- ^ The path to the directory you want to make
 124                          -> IO ()
 125 createDirectoryIfMissing parents file = do
 126   b <- doesDirectoryExist file
 127   case (b,parents, file) of
 128     (_,     _, "") -> return ()
 129     (True,  _,  _) -> return ()
 130     (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
 131     (_, False,  _) -> createDirectory file