Cabal use proper ShellExecute

jasagredo · Dec 18, 2023 · 7a30389 · 7a30389
1 parent c4c79cc
commit 7a30389
Show file tree

Hide file tree

Showing 3 changed files with 77 additions and 20 deletions.
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
@@ -245,6 +245,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
@@ -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
@@ -28,7 +28,7 @@ module Distribution.Client.Utils
   , existsAndIsMoreRecentThan
   , tryFindAddSourcePackageDesc
   , tryFindPackageDesc
-  , findOpenProgramLocation
+  , callOpenAction
   , relaxEncodingErrors
   , ProgressPhase (..)
   , progressMessage
@@ -68,14 +68,19 @@ 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
 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,65 @@ 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 unsafe "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 "open")
-      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.