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
|
{-# 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.Directory.Internals
#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
findExecutable :: String -> IO (Maybe FilePath)
findExecutable binary = do
path <- getEnv "PATH"
search (parseSearchPath path)
where
#ifdef mingw32_HOST_OS
fileName = binary `joinFileExt` "exe"
#else
fileName = binary
#endif
search :: [FilePath] -> IO (Maybe FilePath)
search [] = return Nothing
search (d:ds) = do
let path = d `joinFileName` fileName
b <- doesFileExist path
if b then return (Just path)
else search ds
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) (tail (pathParents file))
(_, False, _) -> createDirectory file
|
