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.FilePath
  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(..) )
  35 #if defined(mingw32_HOST_OS)
  36 import GHC.IOBase ( IOErrorType(..) )
  37 #endif
  38 #else
  39 import System.IO                ( try )
  40 #endif
  41 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
  42 import Foreign
  43 import Foreign.C
  44 #endif
  45 import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
  46
  47 getAppUserDataDirectory :: String -> IO FilePath
  48 getAppUserDataDirectory appName = do
  49 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
  50   allocaBytes long_path_size $ \pPath -> do
  51      r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
  52      when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
  53      s <- peekCString pPath
  54      return (s++'\\':appName)
  55 #else
  56   path <- getEnv "HOME"
  57   return (path++'/':'.':appName)
  58 #endif
  59
  60 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
  61 foreign import ccall unsafe "directory.h __hscore_getFolderPath"
  62             c_SHGetFolderPath :: Ptr ()
  63                               -> CInt
  64                               -> Ptr ()
  65                               -> CInt
  66                               -> CString
  67                               -> IO CInt
  68
  69 -- __compat_long_path_size defined in cbits/directory.c
  70 foreign import ccall unsafe "directory.h __compat_long_path_size"
  71   long_path_size :: Int
  72
  73 foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
  74
  75 raiseUnsupported loc =
  76    ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
  77 #endif
  78
  79
  80 copyFile :: FilePath -> FilePath -> IO ()
  81 copyFile fromFPath toFPath =
  82 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
  83         do readFile fromFPath >>= writeFile toFPath
  84            try (getPermissions fromFPath >>= setPermissions toFPath)
  85            return ()
  86 #else
  87         (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
  88          bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
  89          allocaBytes bufferSize $ \buffer -> do
  90                 copyContents hFrom hTo buffer
  91                 try (getPermissions fromFPath >>= setPermissions toFPath)
  92                 return ()) `catch` (ioError . changeFunName)
  93         where
  94                 bufferSize = 1024
  95
  96                 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
  97
  98                 copyContents hFrom hTo buffer = do
  99                         count <- hGetBuf hFrom buffer bufferSize
 100                         when (count > 0) $ do
 101                                 hPutBuf hTo buffer count
 102                                 copyContents hFrom hTo buffer
 103 #endif
 104
 105 -- | Given an executable file name, searches for such file
 106 -- in the directories listed in system PATH. The returned value
 107 -- is the path to the found executable or Nothing if there isn't
 108 -- such executable. For example (findExecutable \"ghc\")
 109 -- gives you the path to GHC.
 110 findExecutable :: String -> IO (Maybe FilePath)
 111 findExecutable binary =
 112 #if defined(mingw32_HOST_OS)
 113   withCString binary $ \c_binary ->
 114   withCString ('.':exeExtension) $ \c_ext ->
 115   allocaBytes long_path_size $ \pOutPath ->
 116   alloca $ \ppFilePart -> do
 117     res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
 118     if res > 0 && res < fromIntegral long_path_size
 119       then do fpath <- peekCString pOutPath
 120               return (Just fpath)
 121       else return Nothing
 122
 123 foreign import stdcall unsafe "SearchPathA"
 124             c_SearchPath :: CString
 125                          -> CString
 126                          -> CString
 127                          -> CInt
 128                          -> CString
 129                          -> Ptr CString
 130                          -> IO CInt
 131 #else
 132  do
 133   path <- getEnv "PATH"
 134   search (splitSearchPath path)
 135   where
 136     fileName = binary <.> exeExtension
 137
 138     search :: [FilePath] -> IO (Maybe FilePath)
 139     search [] = return Nothing
 140     search (d:ds) = do
 141         let path = d </> fileName
 142         b <- doesFileExist path
 143         if b then return (Just path)
 144              else search ds
 145 #endif
 146
 147 -- ToDo: This should be determined via autoconf (AC_EXEEXT)
 148 -- | Extension for executable files
 149 -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
 150 exeExtension :: String
 151 #ifdef mingw32_HOST_OS
 152 exeExtension = "exe"
 153 #else
 154 exeExtension = ""
 155 #endif
 156
 157 -- | @'createDirectoryIfMissing' parents dir@ creates a new directory
 158 -- @dir@ if it doesn\'t exist. If the first argument is 'True'
 159 -- the function will also create all parent directories if they are missing.
 160 createDirectoryIfMissing :: Bool     -- ^ Create its parents too?
 161                          -> FilePath -- ^ The path to the directory you want to make
 162                          -> IO ()
 163 createDirectoryIfMissing parents file = do
 164   b <- doesDirectoryExist file
 165   case (b,parents, file) of
 166     (_,     _, "") -> return ()
 167     (True,  _,  _) -> return ()
 168     (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file
 169     (_, False,  _) -> createDirectory file
 170  where mkParents = scanl1 (</>) . splitDirectories . normalise