Remove executable filename check on windows
[ghc.git] / compiler / main / SysTools / BaseDir.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3
4 {-
5 -----------------------------------------------------------------------------
6 --
7 -- (c) The University of Glasgow 2001-2017
8 --
9 -- Finding the compiler's base directory.
10 --
11 -----------------------------------------------------------------------------
12 -}
13
14 module SysTools.BaseDir (expandTopDir, findTopDir) where
15
16 #include "HsVersions.h"
17
18 import GhcPrelude
19
20 import Panic
21
22 import System.FilePath
23 import Data.List
24
25 -- POSIX
26 #if defined(darwin_HOST_OS) || defined(linux_HOST_OS)
27 import System.Environment (getExecutablePath)
28 #endif
29
30 -- Windows
31 #if defined(mingw32_HOST_OS)
32 #if MIN_VERSION_Win32(2,5,0)
33 import qualified System.Win32.Types as Win32
34 #else
35 import qualified System.Win32.Info as Win32
36 #endif
37 import Exception
38 import Foreign
39 import Foreign.C.String
40 import System.Directory
41 import System.Win32.Types (DWORD, LPTSTR, HANDLE)
42 import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
43 import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
44 import System.Win32.DLL (loadLibrary, getProcAddress)
45 #endif
46
47 #if defined(mingw32_HOST_OS)
48 # if defined(i386_HOST_ARCH)
49 # define WINDOWS_CCONV stdcall
50 # elif defined(x86_64_HOST_ARCH)
51 # define WINDOWS_CCONV ccall
52 # else
53 # error Unknown mingw32 arch
54 # endif
55 #endif
56
57 {-
58 Note [topdir: How GHC finds its files]
59 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60
61 GHC needs various support files (library packages, RTS etc), plus
62 various auxiliary programs (cp, gcc, etc). It starts by finding topdir,
63 the root of GHC's support files
64
65 On Unix:
66 - ghc always has a shell wrapper that passes a -B<dir> option
67
68 On Windows:
69 - ghc never has a shell wrapper.
70 - we can find the location of the ghc binary, which is
71 $topdir/<foo>/<something>.exe
72 where <something> may be "ghc", "ghc-stage2", or similar
73 - we strip off the "<foo>/<something>.exe" to leave $topdir.
74
75 from topdir we can find package.conf, ghc-asm, etc.
76
77 -}
78
79 -- | Expand occurrences of the @$topdir@ interpolation in a string.
80 expandTopDir :: FilePath -> String -> String
81 expandTopDir top_dir str
82 | Just str' <- stripPrefix "$topdir" str
83 , null str' || isPathSeparator (head str')
84 = top_dir ++ expandTopDir top_dir str'
85 expandTopDir top_dir (x:xs) = x : expandTopDir top_dir xs
86 expandTopDir _ [] = []
87
88 -- | Returns a Unix-format path pointing to TopDir.
89 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
90 -> IO String -- TopDir (in Unix format '/' separated)
91 findTopDir (Just minusb) = return (normalise minusb)
92 findTopDir Nothing
93 = do -- Get directory of executable
94 maybe_exec_dir <- getBaseDir
95 case maybe_exec_dir of
96 -- "Just" on Windows, "Nothing" on unix
97 Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
98 Just dir -> return dir
99
100 getBaseDir :: IO (Maybe String)
101 #if defined(mingw32_HOST_OS)
102 -- Assuming we are running ghc, accessed by path $(stuff)/<foo>/ghc.exe,
103 -- return the path $(stuff)/lib.
104 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
105 where
106 try_size size = allocaArray (fromIntegral size) $ \buf -> do
107 ret <- c_GetModuleFileName nullPtr buf size
108 case ret of
109 0 -> return Nothing
110 _ | ret < size -> do
111 path <- peekCWString buf
112 real <- getFinalPath path -- try to resolve symlinks paths
113 let libdir = (buildLibDir . sanitize . maybe path id) real
114 exists <- doesDirectoryExist libdir
115 if exists
116 then return $ Just libdir
117 else fail path
118 | otherwise -> try_size (size * 2)
119
120 -- getFinalPath returns paths in full raw form.
121 -- Unfortunately GHC isn't set up to handle these
122 -- So if the call succeeded, we need to drop the
123 -- \\?\ prefix.
124 sanitize s = if "\\\\?\\" `isPrefixOf` s
125 then drop 4 s
126 else s
127
128 buildLibDir :: FilePath -> FilePath
129 buildLibDir s =
130 (takeDirectory . takeDirectory . normalise $ s) </> "lib"
131
132 fail s = panic ("can't decompose ghc.exe path: " ++ show s)
133
134 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
135 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
136
137 -- Attempt to resolve symlinks in order to find the actual location GHC
138 -- is located at. See Trac #11759.
139 getFinalPath :: FilePath -> IO (Maybe FilePath)
140 getFinalPath name = do
141 dllHwnd <- failIfNull "LoadLibrary" $ loadLibrary "kernel32.dll"
142 -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista.
143 -- This means that we can't bind directly to it since it may be missing.
144 -- Instead try to find it's address at runtime and if we don't succeed consider the
145 -- function failed.
146 addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")
147 `catch` (\(_ :: SomeException) -> return Nothing)
148 case addr_m of
149 Nothing -> return Nothing
150 Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"
151 $ createFile name
152 gENERIC_READ
153 fILE_SHARE_READ
154 Nothing
155 oPEN_EXISTING
156 (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
157 Nothing
158 let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
159 -- First try to resolve the path to get the actual path
160 -- of any symlinks or other file system redirections that
161 -- may be in place. However this function can fail, and in
162 -- the event it does fail, we need to try using the
163 -- original path and see if we can decompose that.
164 -- If the call fails Win32.try will raise an exception
165 -- that needs to be caught. See #14159
166 path <- (Win32.try "GetFinalPathName"
167 (\buf len -> fnPtr handle buf len 0) 512
168 `finally` closeHandle handle)
169 `catch`
170 (\(_ :: IOException) -> return name)
171 return $ Just path
172
173 type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
174
175 foreign import WINDOWS_CCONV unsafe "dynamic"
176 makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
177 #elif defined(darwin_HOST_OS) || defined(linux_HOST_OS)
178 -- on unix, this is a bit more confusing.
179 -- The layout right now is somehting like
180 --
181 -- /bin/ghc-X.Y.Z <- wrapper script (1)
182 -- /bin/ghc <- symlink to wrapper script (2)
183 -- /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3)
184 -- /lib/ghc-X.Y.Z <- $topdir (4)
185 --
186 -- As such, we first need to find the absolute location to the
187 -- binary.
188 --
189 -- getExecutablePath will return (3). One takeDirectory will
190 -- give use /lib/ghc-X.Y.Z/bin, and another will give us (4).
191 --
192 -- This of course only works due to the current layout. If
193 -- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib}
194 -- this would need to be changed accordingly.
195 --
196 getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
197 #else
198 getBaseDir = return Nothing
199 #endif