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