summaryrefslogtreecommitdiff
path: root/libraries/base/System/Environment/ExecutablePath.hsc
blob: cb9fad7a7e7d6a6e8761a2c29268eccef95a6262 (plain)
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
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Environment.ExecutablePath
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Function to retrieve the absolute filepath of the current executable.
--
-- @since 4.6.0.0
-----------------------------------------------------------------------------

module System.Environment.ExecutablePath
  ( getExecutablePath
##if !defined(javascript_HOST_ARCH)
  , executablePath
##endif
  ) where

##if defined(javascript_HOST_ARCH)

getExecutablePath :: IO FilePath
getExecutablePath = return "a.jsexe"

##else

-- The imports are purposely kept completely disjoint to prevent edits
-- to one OS implementation from breaking another.

#if defined(darwin_HOST_OS)
import Control.Exception (catch, throw)
import Data.Word
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.IO.Error (isDoesNotExistError)
import System.Posix.Internals
#elif defined(linux_HOST_OS)
import Data.List (isSuffixOf)
import Foreign.C
import Foreign.Marshal.Array
import System.Posix.Internals
#elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS)
import Control.Exception (catch, throw)
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import System.IO.Error (isDoesNotExistError)
import System.Posix.Internals
#include <sys/types.h>
#include <sys/sysctl.h>
#elif defined(mingw32_HOST_OS)
import Control.Exception
import Data.List (isPrefixOf)
import Data.Word
import Foreign.C
import Foreign.Marshal.Array
import Foreign.Ptr
import GHC.Windows
#include <windows.h>
#include <stdint.h>
#else
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.Posix.Internals
#endif

-- The exported function is defined outside any if-guard to make sure
-- every OS implements it with the same type.

-- | Returns the absolute pathname of the current executable,
-- or @argv[0]@ if the operating system does not provide a reliable
-- way query the current executable.
--
-- Note that for scripts and interactive sessions, this is the path to
-- the interpreter (e.g. ghci.)
--
-- Since base 4.11.0.0, 'getExecutablePath' resolves symlinks on Windows.
-- If an executable is launched through a symlink, 'getExecutablePath'
-- returns the absolute path of the original executable.
--
-- If the executable has been deleted, behaviour is ill-defined and
-- varies by operating system.  See 'executablePath' for a more
-- reliable way to query the current executable.
--
-- @since 4.6.0.0
getExecutablePath :: IO FilePath

-- | Get an action to query the absolute pathname of the current executable.
--
-- If the operating system provides a reliable way to determine the current
-- executable, return the query action, otherwise return @Nothing@.  The action
-- is defined on FreeBSD, Linux, MacOS, NetBSD, and Windows.
--
-- Even where the query action is defined, there may be situations where no
-- result is available, e.g. if the executable file was deleted while the
-- program is running.  Therefore the result of the query action is a @Maybe
-- FilePath@.
--
-- Note that for scripts and interactive sessions, the result is the path to
-- the interpreter (e.g. ghci.)
--
-- Note also that while most operating systems return @Nothing@ if the
-- executable file was deleted/unlinked, some (including NetBSD) return the
-- original path.
--
-- @since 4.17.0.0
executablePath :: Maybe (IO (Maybe FilePath))


--------------------------------------------------------------------------------
-- Mac OS X

#if defined(darwin_HOST_OS)

type UInt32 = Word32

foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"
    c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt

-- | Returns the path of the main executable. The path may be a
-- symbolic link and not the real file.
--
-- See dyld(3)
_NSGetExecutablePath :: IO FilePath
_NSGetExecutablePath =
    allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X
    alloca $ \ bufsize -> do
        poke bufsize 1024
        status <- c__NSGetExecutablePath buf bufsize
        if status == 0
            then peekFilePath buf
            else do reqBufsize <- fromIntegral `fmap` peek bufsize
                    allocaBytes reqBufsize $ \ newBuf -> do
                        status2 <- c__NSGetExecutablePath newBuf bufsize
                        if status2 == 0
                             then peekFilePath newBuf
                             else errorWithoutStackTrace "_NSGetExecutablePath: buffer too small"

foreign import ccall unsafe "stdlib.h realpath"
    c_realpath :: CString -> CString -> IO CString

-- | Resolves all symbolic links, extra \/ characters, and references
-- to \/.\/ and \/..\/. Returns an absolute pathname.
--
-- See realpath(3)
realpath :: FilePath -> IO FilePath
realpath path =
    withFilePath path $ \ fileName ->
    allocaBytes 1024 $ \ resolvedName -> do
        _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName
        peekFilePath resolvedName

getExecutablePath = _NSGetExecutablePath >>= realpath

-- realpath(3) fails with ENOENT file does not exist (e.g. was deleted)
executablePath = Just (fmap Just getExecutablePath `catch` f)
  where
  f e | isDoesNotExistError e = pure Nothing
      | otherwise             = throw e

--------------------------------------------------------------------------------
-- Linux

#elif defined(linux_HOST_OS)

foreign import ccall unsafe "readlink"
    c_readlink :: CString -> CString -> CSize -> IO CInt

-- | Reads the @FilePath@ pointed to by the symbolic link and returns
-- it.
--
-- See readlink(2)
readSymbolicLink :: FilePath -> IO FilePath
readSymbolicLink file =
    allocaArray0 4096 $ \buf ->
        withFilePath file $ \s -> do
            len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $
                   c_readlink s buf 4096
            peekFilePathLen (buf,fromIntegral len)

getExecutablePath = readSymbolicLink $ "/proc/self/exe"

executablePath = Just (check <$> getExecutablePath) where
  -- procfs(5): If the pathname has been unlinked, the symbolic link will
  -- contain the string '(deleted)' appended to the original pathname.
  --
  -- See also https://gitlab.haskell.org/ghc/ghc/-/issues/10957
  check s | "(deleted)" `isSuffixOf` s = Nothing
          | otherwise = Just s

--------------------------------------------------------------------------------
-- FreeBSD / NetBSD

#elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS)

foreign import ccall unsafe "sysctl"
  c_sysctl
    :: Ptr CInt   -- MIB
    -> CUInt      -- MIB size
    -> Ptr CChar  -- old / current value buffer
    -> Ptr CSize  -- old / current value buffer size
    -> Ptr CChar  -- new value
    -> CSize      -- new value size
    -> IO CInt    -- result

getExecutablePath = do
  withArrayLen mib $ \n mibPtr -> do
    let mibLen = fromIntegral n
    alloca $ \bufSizePtr -> do
      status <- c_sysctl mibPtr mibLen nullPtr bufSizePtr nullPtr 0
      case status of
        0 -> do
          reqBufSize <- fromIntegral <$> peek bufSizePtr
          allocaBytes reqBufSize $ \buf -> do
            newStatus <- c_sysctl mibPtr mibLen buf bufSizePtr nullPtr 0
            case newStatus of
              0 -> peekFilePath buf
              _ -> barf
        _ -> barf
  where
    barf = throwErrno "getExecutablePath"
    mib =
#  if defined(freebsd_HOST_OS)
      [ (#const CTL_KERN)
      , (#const KERN_PROC)
      , (#const KERN_PROC_PATHNAME)
      , -1   -- current process
      ]
#  elif defined(netbsd_HOST_OS)
      [ (#const CTL_KERN)
      , (#const KERN_PROC_ARGS)
      , -1   -- current process
      , (#const KERN_PROC_PATHNAME)
      ]
#  endif

executablePath = Just (fmap Just getExecutablePath `catch` f)
  where
  -- The sysctl fails with errno ENOENT when executable has been deleted;
  -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346.
  f e | isDoesNotExistError e = pure Nothing

  -- As far as I know, ENOENT is the only kind of failure that should be
  -- expected and handled.  Re-throw other errors.
      | otherwise             = throw e


--------------------------------------------------------------------------------
-- Windows

#elif defined(mingw32_HOST_OS)

# if defined(i386_HOST_ARCH)
##  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
##  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif

getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32
  where
    go size = allocaArray (fromIntegral size) $ \ buf -> do
        ret <- c_GetModuleFileName nullPtr buf size
        case ret of
            0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error"
            _ | ret < size -> do
                  path <- peekCWString buf
                  real <- getFinalPath path
                  exists <- withCWString real c_pathFileExists
                  if exists
                    then return real
                    else fail path
              | otherwise  -> go (size * 2)

-- Windows prevents deletion of executable file while program is running.
-- Therefore return @Just@ of the result.
executablePath = Just (Just <$> getExecutablePath)

-- | Returns the final path of the given path. If the given
--   path is a symbolic link, the returned value is the
--   path the (possibly chain of) symbolic link(s) points to.
--   Otherwise, the original path is returned, even when the filepath
--   is incorrect.
--
-- Adapted from:
-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa364962.aspx
getFinalPath :: FilePath -> IO FilePath
getFinalPath path = withCWString path $ \s ->
  bracket (createFile s) c_closeHandle $ \h -> do
    let invalid = h == iNVALID_HANDLE_VALUE
    if invalid then pure path else go h bufSize

  where go h sz = allocaArray (fromIntegral sz) $ \outPath -> do
          ret <- c_getFinalPathHandle h outPath sz (#const FILE_NAME_OPENED)
          if ret < sz
            then sanitize . rejectUNCPath <$> peekCWString outPath
            else go h (2 * sz)

        sanitize s
          | "\\\\?\\" `isPrefixOf` s = drop 4 s
          | otherwise                = s

        -- see https://gitlab.haskell.org/ghc/ghc/issues/14460
        rejectUNCPath s
          | "\\\\?\\UNC\\" `isPrefixOf` s = path
          | otherwise                     = s

        -- the initial size of the buffer in which we store the
        -- final path; if this is not enough, we try with a buffer of
        -- size 2^k * bufSize, for k = 1, 2, 3, ... until the buffer
        -- is large enough.
        bufSize = 1024

foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
    c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32

foreign import WINDOWS_CCONV unsafe "windows.h PathFileExistsW"
    c_pathFileExists :: CWString -> IO Bool

foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW"
    c_createFile :: CWString
                 -> Word32
                 -> Word32
                 -> Ptr ()
                 -> Word32
                 -> Word32
                 -> Ptr ()
                 -> IO (Ptr ())

createFile :: CWString -> IO (Ptr ())
createFile file =
  c_createFile file (#const GENERIC_READ)
                    (#const FILE_SHARE_READ)
                    nullPtr
                    (#const OPEN_EXISTING)
                    (#const FILE_ATTRIBUTE_NORMAL)
                    nullPtr

foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"
  c_closeHandle  :: Ptr () -> IO Bool

foreign import WINDOWS_CCONV unsafe "windows.h GetFinalPathNameByHandleW"
  c_getFinalPathHandle :: Ptr () -> CWString -> Word32 -> Word32 -> IO Word32

--------------------------------------------------------------------------------
-- Fallback to argv[0]

#else

foreign import ccall unsafe "getFullProgArgv"
    c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()

getExecutablePath =
    alloca $ \ p_argc ->
    alloca $ \ p_argv -> do
        c_getFullProgArgv p_argc p_argv
        argc <- peek p_argc
        if argc > 0
            -- If argc > 0 then argv[0] is guaranteed by the standard
            -- to be a pointer to a null-terminated string.
            then peek p_argv >>= peek >>= peekFilePath
            else errorWithoutStackTrace $ "getExecutablePath: " ++ msg
  where msg = "no OS specific implementation and program name couldn't be " ++
              "found in argv"

executablePath = Nothing

--------------------------------------------------------------------------------

#endif

##endif