Implement improved "get executable path" query

System.Environment.getExecutablePath has some problems:

- Some system-specific implementations throw an exception in some
  scenarios, e.g. when the executable file has been deleted

- The Linux implementation succeeds but returns an invalid FilePath
  when the file has been deleted.

- The fallback implementation returns argv[0] which is not
  necessarily an absolute path, and is subject to manipulation.

- The documentation does not explain any of this.

Breaking the getExecutablePath API or changing its behaviour is not
an appealing direction.  So we will provide a new API.

There are two facets to the problem of querying the executable path:

1. Does the platform provide a reliable way to do it?  This is
   statically known.

2. If so, is there a valid answer, and what is it?  This may vary,
   even over the runtime of a single process.

Accordingly, the type of the new mechanism is:

  Maybe (IO (Maybe FilePath))

This commit implements this mechanism, defining the query action for
FreeBSD, Linux, macOS and Windows.

Fixes: #10957
Fixes: #12377

3 files changed, 68 insertions, 2 deletions

diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs
index 5604ca2b03..44382acf45 100644
--- a/libraries/base/System/Environment.hs
+++ b/libraries/base/System/Environment.hs
@@ -19,6 +19,7 @@ module System.Environment
     (
       getArgs,
       getProgName,
+      executablePath,
       getExecutablePath,
       getEnv,
       lookupEnv,
diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc
index 59a3d624e8..6d8eac9b83 100644
--- a/libraries/base/System/Environment/ExecutablePath.hsc
+++ b/libraries/base/System/Environment/ExecutablePath.hsc
@@ -16,28 +16,36 @@
 -- @since 4.6.0.0
 -----------------------------------------------------------------------------
 
-module System.Environment.ExecutablePath ( getExecutablePath ) where
+module System.Environment.ExecutablePath
+  ( getExecutablePath
+  , executablePath
+  ) where
 
 -- 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)
+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>
@@ -61,7 +69,9 @@ import System.Posix.Internals
 -- 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.
+-- | 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.)
@@ -70,9 +80,31 @@ import System.Posix.Internals
 -- 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 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.)
+--
+-- @since 4.17.0.0
+executablePath :: Maybe (IO (Maybe FilePath))
+
+
 --------------------------------------------------------------------------------
 -- Mac OS X
 
@@ -118,6 +150,12 @@ realpath path =
 
 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
 
@@ -140,6 +178,14 @@ readSymbolicLink file =
 
 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
 
@@ -178,6 +224,16 @@ getExecutablePath = do
       , -1   -- current process
       ]
 
+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
@@ -207,6 +263,10 @@ getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32
                     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.
@@ -294,6 +354,8 @@ getExecutablePath =
   where msg = "no OS specific implementation and program name couldn't be " ++
               "found in argv"
 
+executablePath = Nothing
+
 --------------------------------------------------------------------------------
 
 #endif
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index ece5f77a75..5515227821 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -4,6 +4,9 @@
 
   * Add explicitly bidirectional `pattern TypeRep` to `Type.Reflection`.
 
+  * Introduce `GHC.ExecutablePath.executablePath`, which is more robust than
+    `getExecutablePath` in cases when the executable has been deleted.
+
 ## 4.16.0.0 *TBA*
 
   * Make it possible to promote `Natural`s and remove the separate `Nat` kind.