1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
{-# OPTIONS -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : Compat.Directory
-- Copyright : (c) The University of Glasgow 2001-2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- Functions from System.Directory that aren't present in older versions
-- of that library.
--
-----------------------------------------------------------------------------
module Compat.Directory (
getAppUserDataDirectory,
copyFile,
findExecutable,
createDirectoryIfMissing
) where
#include "../../includes/ghcconfig.h"
import System.Environment (getEnv)
import System.FilePath
#if __GLASGOW_HASKELL__ > 600
import Control.Exception ( bracket )
import Control.Monad ( when )
import Foreign.Marshal.Alloc ( allocaBytes )
import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
import System.IO.Error ( try )
import GHC.IOBase ( IOException(..), IOErrorType(..) )
#else
import System.IO ( try )
#endif
#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
import Foreign.Ptr
import Foreign.C
#endif
import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
getAppUserDataDirectory :: String -> IO FilePath
getAppUserDataDirectory appName = do
#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
allocaBytes long_path_size $ \pPath -> do
r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
s <- peekCString pPath
return (s++'\\':appName)
#else
path <- getEnv "HOME"
return (path++'/':'.':appName)
#endif
#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
foreign import ccall unsafe "directory.h __hscore_getFolderPath"
c_SHGetFolderPath :: Ptr ()
-> CInt
-> Ptr ()
-> CInt
-> CString
-> IO CInt
-- __compat_long_path_size defined in cbits/directory.c
foreign import ccall unsafe "directory.h __compat_long_path_size"
long_path_size :: Int
foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
raiseUnsupported loc =
ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
#endif
copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
do readFile fromFPath >>= writeFile toFPath
try (getPermissions fromFPath >>= setPermissions toFPath)
return ()
#else
(bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
allocaBytes bufferSize $ \buffer -> do
copyContents hFrom hTo buffer
try (getPermissions fromFPath >>= setPermissions toFPath)
return ()) `catch` (ioError . changeFunName)
where
bufferSize = 1024
changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
copyContents hFrom hTo buffer = do
count <- hGetBuf hFrom buffer bufferSize
when (count > 0) $ do
hPutBuf hTo buffer count
copyContents hFrom hTo buffer
#endif
-- | 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
-- 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
-- | @'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
|
