From 189d9d52f2614d42dfe92820926bfe7ad3856f8a Mon Sep 17 00:00:00 2001
From: Javier Sagredo <javier.sagredo@iohk.io>
Date: Mon, 18 Dec 2023 17:45:35 +0100
Subject: [PATCH] Cabal use proper ShellExecute

---
 cabal-install/cabal-install.cabal             |  4 +
 .../Distribution/Client/ProjectBuilding.hs    |  7 +-
 .../src/Distribution/Client/Utils.hs          | 93 ++++++++++++++++---
 3 files changed, 84 insertions(+), 20 deletions(-)

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 3cb68deb661..ac54a7a9dc8 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -247,6 +247,10 @@ library
     if os(windows)
       -- newer directory for symlinks
       build-depends: Win32 >= 2.8 && < 3, directory >=1.3.1.0
+      if arch(i386)
+        cpp-options:        "-DWINDOWS_CCONV=stdcall"
+      else
+        cpp-options:        "-DWINDOWS_CCONV=ccall"
     else
       build-depends: unix >= 2.5 && < 2.9
 
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index e0c97aca924..eaf6fac4b32 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -82,7 +82,7 @@ import Distribution.Client.Types hiding
   )
 import Distribution.Client.Utils
   ( ProgressPhase (..)
-  , findOpenProgramLocation
+  , callOpenAction
   , numberOfProcessors
   , progressMessage
   , removeExistingFile
@@ -1650,10 +1650,7 @@ buildInplaceUnpackedPackage
               docDir = case distHaddockOutputDir of
                 Nothing -> distBuildDirectory distDirLayout dparams </> "doc" </> "html" </> name
                 Just dir -> dir
-          exe <- findOpenProgramLocation platform
-          case exe of
-            Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest])
-            Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err
+          callOpenAction verbosity dest platform
 
     return
       BuildResult
diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs
index 59158ffd2a5..1a99c37719f 100644
--- a/cabal-install/src/Distribution/Client/Utils.hs
+++ b/cabal-install/src/Distribution/Client/Utils.hs
@@ -28,7 +28,7 @@ module Distribution.Client.Utils
   , existsAndIsMoreRecentThan
   , tryFindAddSourcePackageDesc
   , tryFindPackageDesc
-  , findOpenProgramLocation
+  , callOpenAction
   , relaxEncodingErrors
   , ProgressPhase (..)
   , progressMessage
@@ -68,6 +68,12 @@ import Data.List
 import Distribution.Compat.Environment
 import Distribution.Compat.Time (getModTime)
 import Distribution.Simple.Setup (Flag (..))
+#if !defined(mingw32_HOST_OS)
+import Distribution.Simple.Program.Run
+  ( runProgramInvocation
+  , simpleProgramInvocation
+  )
+#endif
 import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap)
 import Distribution.System (OS (..), Platform (..))
 import Distribution.Version
@@ -75,7 +81,6 @@ import System.Directory
   ( canonicalizePath
   , doesDirectoryExist
   , doesFileExist
-  , findExecutable
   , getCurrentDirectory
   , getDirectoryContents
   , removeFile
@@ -108,6 +113,17 @@ import GHC.IO.Encoding.Failure
 import qualified System.Directory as Dir
 import qualified System.IO.Error as IOError
 #endif
+#if defined(mingw32_HOST_OS)
+import System.Win32.Types
+  ( INT
+  , HANDLE
+  , HINSTANCE
+  , LPCTSTR
+  , handleToWord
+  , nullPtr
+  , withTString
+  )
+#endif
 import qualified Data.Set as Set
 import Distribution.Client.Errors
 
@@ -397,25 +413,72 @@ tryFindPackageDesc verbosity depPath err = do
     Right file -> return file
     Left _ -> dieWithException verbosity $ TryFindPackageDescErr err
 
-findOpenProgramLocation :: Platform -> IO (Either String FilePath)
-findOpenProgramLocation (Platform _ os) =
-  let
+#if defined(mingw32_HOST_OS)
+
+-- | This code was derived from the [@open-browser@
+-- package](https://hackage.haskell.org/package/open-browser)
+--
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/bb762153(v=vs.85).aspx
+foreign import WINDOWS_CCONV "windows.h ShellExecuteW"
+  c_ShellExecute
+    :: HANDLE -- _In_opt_
+    -> LPCTSTR -- _In_opt_
+    -> LPCTSTR -- _In_
+    -> LPCTSTR -- _In_opt_
+    -> LPCTSTR -- _In_opt_
+    -> INT -- _In_
+    -> IO HINSTANCE
+
+-- | This function was derived from the [@open-browser@
+-- package](https://hackage.haskell.org/package/open-browser)
+callOpenAction :: Verbosity -> String -> Platform -> IO ()
+callOpenAction verbosity dest (Platform _ Windows) =
+  withTString "open" $ \openStr ->
+    withTString dest $ \urlStr ->
+      exitCodeToBool
+        =<< c_ShellExecute
+          nullPtr
+          openStr
+          urlStr
+          nullPtr
+          nullPtr
+          1
+  where
+    exitCodeToBool h
+      | handleToWord h > 32 = pure ()
+      | otherwise =
+          dieWithException verbosity $
+            FindOpenProgramLocationErr $
+              "Couldn't run shellExecute, error code: " <> show (handleToWord h)
+callOpenAction verbosity _ (Platform _ os) =
+  dieWithException verbosity $
+    FindOpenProgramLocationErr $
+      "Couldn't determine file-opener program for " <> show os
+
+#else
+
+callOpenAction :: Verbosity -> String -> Platform -> IO ()
+callOpenAction verbosity dest (Platform _ os) = do
+  open <- case os of
+    OSX -> locate "open"
+    Linux -> xdg
+    FreeBSD -> xdg
+    OpenBSD -> xdg
+    NetBSD -> xdg
+    DragonFly -> xdg
+    _ -> pure $ Left ("Couldn't determine file-opener program for " <> show os)
+  case open of
+    Right open' -> runProgramInvocation verbosity (simpleProgramInvocation open' [dest])
+    Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err
+  where
     locate name = do
       exe <- findExecutable name
       case exe of
         Just s -> pure (Right s)
         Nothing -> pure (Left ("Couldn't find file-opener program `" <> name <> "`"))
     xdg = locate "xdg-open"
-   in
-    case os of
-      Windows -> pure (Right "start")
-      OSX -> locate "open"
-      Linux -> xdg
-      FreeBSD -> xdg
-      OpenBSD -> xdg
-      NetBSD -> xdg
-      DragonFly -> xdg
-      _ -> pure (Left ("Couldn't determine file-opener program for " <> show os))
+
+#endif
 
 -- | Phase of building a dependency. Represents current status of package
 -- dependency processing. See #4040 for details.