Update Trac ticket URLs to point to GitLab
[ghc.git] / libraries / base / System / Environment / ExecutablePath.hsc
1 {-# LANGUAGE Safe #-}
2 {-# LANGUAGE CPP #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module      :  System.Environment.ExecutablePath
7 -- Copyright   :  (c) The University of Glasgow 2001
8 -- License     :  BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- Maintainer  :  libraries@haskell.org
11 -- Stability   :  provisional
12 -- Portability :  portable
13 --
14 -- Function to retrieve the absolute filepath of the current executable.
15 --
16 -- @since 4.6.0.0
17 -----------------------------------------------------------------------------
18
19 module System.Environment.ExecutablePath ( getExecutablePath ) where
20
21 -- The imports are purposely kept completely disjoint to prevent edits
22 -- to one OS implementation from breaking another.
23
24 #if defined(darwin_HOST_OS)
25 import Data.Word
26 import Foreign.C
27 import Foreign.Marshal.Alloc
28 import Foreign.Ptr
29 import Foreign.Storable
30 import System.Posix.Internals
31 #elif defined(linux_HOST_OS)
32 import Foreign.C
33 import Foreign.Marshal.Array
34 import System.Posix.Internals
35 #elif defined(mingw32_HOST_OS)
36 import Control.Exception
37 import Data.List
38 import Data.Word
39 import Foreign.C
40 import Foreign.Marshal.Array
41 import Foreign.Ptr
42 #include <windows.h>
43 #include <stdint.h>
44 #else
45 import Foreign.C
46 import Foreign.Marshal.Alloc
47 import Foreign.Ptr
48 import Foreign.Storable
49 import System.Posix.Internals
50 #endif
51
52 -- The exported function is defined outside any if-guard to make sure
53 -- every OS implements it with the same type.
54
55 -- | Returns the absolute pathname of the current executable.
56 --
57 -- Note that for scripts and interactive sessions, this is the path to
58 -- the interpreter (e.g. ghci.)
59 --
60 -- Since base 4.11.0.0, 'getExecutablePath' resolves symlinks on Windows.
61 -- If an executable is launched through a symlink, 'getExecutablePath'
62 -- returns the absolute path of the original executable.
63 --
64 -- @since 4.6.0.0
65 getExecutablePath :: IO FilePath
66
67 --------------------------------------------------------------------------------
68 -- Mac OS X
69
70 #if defined(darwin_HOST_OS)
71
72 type UInt32 = Word32
73
74 foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"
75     c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt
76
77 -- | Returns the path of the main executable. The path may be a
78 -- symbolic link and not the real file.
79 --
80 -- See dyld(3)
81 _NSGetExecutablePath :: IO FilePath
82 _NSGetExecutablePath =
83     allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X
84     alloca $ \ bufsize -> do
85         poke bufsize 1024
86         status <- c__NSGetExecutablePath buf bufsize
87         if status == 0
88             then peekFilePath buf
89             else do reqBufsize <- fromIntegral `fmap` peek bufsize
90                     allocaBytes reqBufsize $ \ newBuf -> do
91                         status2 <- c__NSGetExecutablePath newBuf bufsize
92                         if status2 == 0
93                              then peekFilePath newBuf
94                              else errorWithoutStackTrace "_NSGetExecutablePath: buffer too small"
95
96 foreign import ccall unsafe "stdlib.h realpath"
97     c_realpath :: CString -> CString -> IO CString
98
99 -- | Resolves all symbolic links, extra \/ characters, and references
100 -- to \/.\/ and \/..\/. Returns an absolute pathname.
101 --
102 -- See realpath(3)
103 realpath :: FilePath -> IO FilePath
104 realpath path =
105     withFilePath path $ \ fileName ->
106     allocaBytes 1024 $ \ resolvedName -> do
107         _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName
108         peekFilePath resolvedName
109
110 getExecutablePath = _NSGetExecutablePath >>= realpath
111
112 --------------------------------------------------------------------------------
113 -- Linux
114
115 #elif defined(linux_HOST_OS)
116
117 foreign import ccall unsafe "readlink"
118     c_readlink :: CString -> CString -> CSize -> IO CInt
119
120 -- | Reads the @FilePath@ pointed to by the symbolic link and returns
121 -- it.
122 --
123 -- See readlink(2)
124 readSymbolicLink :: FilePath -> IO FilePath
125 readSymbolicLink file =
126     allocaArray0 4096 $ \buf -> do
127         withFilePath file $ \s -> do
128             len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $
129                    c_readlink s buf 4096
130             peekFilePathLen (buf,fromIntegral len)
131
132 getExecutablePath = readSymbolicLink $ "/proc/self/exe"
133
134 --------------------------------------------------------------------------------
135 -- Windows
136
137 #elif defined(mingw32_HOST_OS)
138
139 # if defined(i386_HOST_ARCH)
140 ##  define WINDOWS_CCONV stdcall
141 # elif defined(x86_64_HOST_ARCH)
142 ##  define WINDOWS_CCONV ccall
143 # else
144 #  error Unknown mingw32 arch
145 # endif
146
147 getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32
148   where
149     go size = allocaArray (fromIntegral size) $ \ buf -> do
150         ret <- c_GetModuleFileName nullPtr buf size
151         case ret of
152             0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error"
153             _ | ret < size -> do
154                   path <- peekCWString buf
155                   real <- getFinalPath path
156                   exists <- withCWString real c_pathFileExists
157                   if exists
158                     then return real
159                     else fail path
160               | otherwise  -> go (size * 2)
161
162 -- | Returns the final path of the given path. If the given
163 --   path is a symbolic link, the returned value is the
164 --   path the (possibly chain of) symbolic link(s) points to.
165 --   Otherwise, the original path is returned, even when the filepath
166 --   is incorrect.
167 --
168 -- Adapted from:
169 -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa364962.aspx
170 getFinalPath :: FilePath -> IO FilePath
171 getFinalPath path = withCWString path $ \s ->
172   bracket (createFile s) c_closeHandle $ \h -> do
173     let invalid = h == wordPtrToPtr (#const (intptr_t)INVALID_HANDLE_VALUE)
174     if invalid then pure path else go h bufSize
175
176   where go h sz = allocaArray (fromIntegral sz) $ \outPath -> do
177           ret <- c_getFinalPathHandle h outPath sz (#const FILE_NAME_OPENED)
178           if ret < sz
179             then sanitize . rejectUNCPath <$> peekCWString outPath
180             else go h (2 * sz)
181
182         sanitize s
183           | "\\\\?\\" `isPrefixOf` s = drop 4 s
184           | otherwise                = s
185
186         -- see https://gitlab.haskell.org/ghc/ghc/issues/14460
187         rejectUNCPath s
188           | "\\\\?\\UNC\\" `isPrefixOf` s = path
189           | otherwise                     = s
190
191         -- the initial size of the buffer in which we store the
192         -- final path; if this is not enough, we try with a buffer of
193         -- size 2^k * bufSize, for k = 1, 2, 3, ... until the buffer
194         -- is large enough.
195         bufSize = 1024
196
197 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
198     c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
199
200 foreign import WINDOWS_CCONV unsafe "windows.h PathFileExistsW"
201     c_pathFileExists :: CWString -> IO Bool
202
203 foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW"
204     c_createFile :: CWString
205                  -> Word32
206                  -> Word32
207                  -> Ptr ()
208                  -> Word32
209                  -> Word32
210                  -> Ptr ()
211                  -> IO (Ptr ())
212
213 createFile :: CWString -> IO (Ptr ())
214 createFile file =
215   c_createFile file (#const GENERIC_READ)
216                     (#const FILE_SHARE_READ)
217                     nullPtr
218                     (#const OPEN_EXISTING)
219                     (#const FILE_ATTRIBUTE_NORMAL)
220                     nullPtr
221
222 foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"
223   c_closeHandle  :: Ptr () -> IO Bool
224
225 foreign import WINDOWS_CCONV unsafe "windows.h GetFinalPathNameByHandleW"
226   c_getFinalPathHandle :: Ptr () -> CWString -> Word32 -> Word32 -> IO Word32
227
228 --------------------------------------------------------------------------------
229 -- Fallback to argv[0]
230
231 #else
232
233 foreign import ccall unsafe "getFullProgArgv"
234     c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
235
236 getExecutablePath =
237     alloca $ \ p_argc ->
238     alloca $ \ p_argv -> do
239         c_getFullProgArgv p_argc p_argv
240         argc <- peek p_argc
241         if argc > 0
242             -- If argc > 0 then argv[0] is guaranteed by the standard
243             -- to be a pointer to a null-terminated string.
244             then peek p_argv >>= peek >>= peekFilePath
245             else errorWithoutStackTrace $ "getExecutablePath: " ++ msg
246   where msg = "no OS specific implementation and program name couldn't be " ++
247               "found in argv"
248
249 --------------------------------------------------------------------------------
250
251 #endif