{-# 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 #include #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 #include #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