1{- 2This is a (mostly) direct copy of System.Win32.MinTTY from the Win32 library. We need 3this for backwards compatibility with older versions of Win32 which do not ship 4with this module. 5-} 6 7{-# LANGUAGE CPP #-} 8{-# LANGUAGE ScopedTypeVariables #-} 9 10#if __GLASGOW_HASKELL__ >= 709 11{-# LANGUAGE Safe #-} 12#elif __GLASGOW_HASKELL__ >= 701 13{-# LANGUAGE Trustworthy #-} 14#endif 15----------------------------------------------------------------------------- 16-- | 17-- Module : System.Win32.MinTTY 18-- Copyright : (c) University of Glasgow 2006 19-- License : BSD-style (see the file LICENSE) 20-- 21-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info> 22-- Stability : provisional 23-- Portability : portable 24-- 25-- A function to check if the current terminal uses MinTTY. 26-- Much of this code was originally authored by Phil Ruffwind and the 27-- git-for-windows project. 28-- 29----------------------------------------------------------------------------- 30 31module System.Console.MinTTY.Win32 (isMinTTY, isMinTTYHandle) where 32 33import Graphics.Win32.Misc 34import System.Win32.DLL 35import System.Win32.File 36import System.Win32.Types 37 38#if MIN_VERSION_base(4,6,0) 39import Control.Exception (catch) 40#endif 41import Control.Monad (void) 42import Data.List (isPrefixOf, isInfixOf, isSuffixOf) 43import Foreign hiding (void) 44import Foreign.C.Types 45import System.FilePath (takeFileName) 46 47#if __GLASGOW_HASKELL__ < 711 48#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) 49#endif 50 51-- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP. 52-- Since we need some structs that are only available with Vista or later, 53-- we must manually set WINVER/_WIN32_WINNT accordingly. 54#undef WINVER 55#define WINVER 0x0600 56#undef _WIN32_WINNT 57#define _WIN32_WINNT 0x0600 58##include "windows_cconv.h" 59#include <windows.h> 60#include "winternl_compat.h" 61 62-- | Returns 'True' if the current process's standard error is attached to a 63-- MinTTY console (e.g., Cygwin or MSYS). Returns 'False' otherwise. 64isMinTTY :: IO Bool 65isMinTTY = do 66 h <- getStdHandle sTD_ERROR_HANDLE 67 `catch` \(_ :: IOError) -> 68 return nullHANDLE 69 if h == nullHANDLE 70 then return False 71 else isMinTTYHandle h 72 73-- | Returns 'True' is the given handle is attached to a MinTTY console 74-- (e.g., Cygwin or MSYS). Returns 'False' otherwise. 75isMinTTYHandle :: HANDLE -> IO Bool 76isMinTTYHandle h = do 77 fileType <- getFileType h 78 if fileType /= fILE_TYPE_PIPE 79 then return False 80 else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h 81 -- GetFileNameByHandleEx is only available on Vista and later (hence 82 -- the name isMinTTYVista). If we're on an older version of Windows, 83 -- getProcAddress will throw an IOException when it fails to find 84 -- GetFileNameByHandleEx, and thus we will default to using 85 -- NtQueryObject (isMinTTYCompat). 86 87isMinTTYVista :: HANDLE -> IO Bool 88isMinTTYVista h = do 89 fn <- getFileNameByHandle h 90 return $ cygwinMSYSCheck fn 91 `catch` \(_ :: IOError) -> 92 return False 93 94isMinTTYCompat :: HANDLE -> IO Bool 95isMinTTYCompat h = do 96 fn <- ntQueryObjectNameInformation h 97 return $ cygwinMSYSCheck fn 98 `catch` \(_ :: IOError) -> 99 return False 100 101cygwinMSYSCheck :: String -> Bool 102cygwinMSYSCheck fn = ("cygwin-" `isPrefixOf` fn' || "msys-" `isPrefixOf` fn') && 103 "-pty" `isInfixOf` fn' && 104 "-master" `isSuffixOf` fn' 105 where 106 fn' = takeFileName fn 107-- Note that GetFileInformationByHandleEx might return a filepath like: 108-- 109-- \msys-dd50a72ab4668b33-pty1-to-master 110-- 111-- But NtQueryObject might return something like: 112-- 113-- \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master 114-- 115-- This means we can't rely on "\cygwin-" or "\msys-" being at the very start 116-- of the filepath. Therefore, we must take care to first call takeFileName 117-- before checking for "cygwin" or "msys" at the start using `isPrefixOf`. 118 119getFileNameByHandle :: HANDLE -> IO String 120getFileNameByHandle h = do 121 let sizeOfDWORD = sizeOf (undefined :: DWORD) 122 -- note: implicitly assuming that DWORD has stronger alignment than wchar_t 123 bufSize = sizeOfDWORD + mAX_PATH * sizeOfTCHAR 124 allocaBytes bufSize $ \buf -> do 125 getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) 126 fni <- peek buf 127 return $ fniFileName fni 128 129getFileInformationByHandleEx 130 :: HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO () 131getFileInformationByHandleEx h cls buf bufSize = do 132 lib <- getModuleHandle (Just "kernel32.dll") 133 ptr <- getProcAddress lib "GetFileInformationByHandleEx" 134 let c_GetFileInformationByHandleEx = 135 mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) 136 failIfFalse_ "getFileInformationByHandleEx" 137 (c_GetFileInformationByHandleEx h cls buf bufSize) 138 139ntQueryObjectNameInformation :: HANDLE -> IO String 140ntQueryObjectNameInformation h = do 141 let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION) 142 bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR 143 allocaBytes bufSize $ \buf -> 144 alloca $ \p_len -> do 145 {- 146 See Note [Don't link against ntdll] 147 _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject 148 h objectNameInformation buf (fromIntegral bufSize) p_len 149 -} 150 ntQueryObject h objectNameInformation buf (fromIntegral bufSize) p_len 151 oni <- peek buf 152 return $ usBuffer $ oniName oni 153 154-- See Note [Don't link against ntdll] 155ntQueryObject :: HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION 156 -> ULONG -> Ptr ULONG -> IO () 157ntQueryObject h cls buf bufSize p_len = do 158 lib <- getModuleHandle (Just "ntdll.dll") 159 ptr <- getProcAddress lib "NtQueryObject" 160 let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr ptr) 161 void $ failIfNeg "NtQueryObject" $ c_NtQueryObject h cls buf bufSize p_len 162 163fileNameInfo :: CInt 164fileNameInfo = #const FileNameInfo 165 166mAX_PATH :: Num a => a 167mAX_PATH = #const MAX_PATH 168 169objectNameInformation :: CInt 170objectNameInformation = #const ObjectNameInformation 171 172type F_GetFileInformationByHandleEx = 173 HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL 174 175foreign import WINDOWS_CCONV "dynamic" 176 mk_GetFileInformationByHandleEx 177 :: FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx 178 179data FILE_NAME_INFO = FILE_NAME_INFO 180 { fniFileNameLength :: DWORD 181 , fniFileName :: String 182 } deriving Show 183 184instance Storable FILE_NAME_INFO where 185 sizeOf _ = #size FILE_NAME_INFO 186 alignment _ = #alignment FILE_NAME_INFO 187 poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do 188 let len' = (min mAX_PATH len) * sizeOfTCHAR 189 start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName) 190 end = advancePtr start len' 191 (#poke FILE_NAME_INFO, FileNameLength) buf len' 192 copyArray start (castPtr str :: Ptr Word8) len' 193 poke (castPtr end) (0 :: TCHAR) 194 peek buf = do 195 vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf 196 let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR 197 vfniFileName <- peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len) 198 return $ FILE_NAME_INFO 199 { fniFileNameLength = vfniFileNameLength 200 , fniFileName = vfniFileName 201 } 202 203{- 204In an ideal world, we'd use this instead of the hack below. 205See Note [Don't link against ntdll] 206 207foreign import WINDOWS_CCONV "winternl.h NtQueryObject" 208 c_NtQueryObject :: HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION 209 -> ULONG -> Ptr ULONG -> IO NTSTATUS 210-} 211 212type F_NtQueryObject 213 = HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION 214 -> ULONG -> Ptr ULONG -> IO NTSTATUS 215 216foreign import WINDOWS_CCONV "dynamic" 217 mk_NtQueryObject :: FunPtr F_NtQueryObject -> F_NtQueryObject 218 219type NTSTATUS = #type NTSTATUS 220type ULONG = #type ULONG 221 222failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a 223failIfNeg = failIf (< 0) 224 225newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION 226 { oniName :: UNICODE_STRING 227 } deriving Show 228 229instance Storable OBJECT_NAME_INFORMATION where 230 sizeOf _ = #size OBJECT_NAME_INFORMATION 231 alignment _ = #alignment OBJECT_NAME_INFORMATION 232 poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni) 233 peek buf = fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf 234 235data UNICODE_STRING = UNICODE_STRING 236 { usLength :: USHORT 237 , usMaximumLength :: USHORT 238 , usBuffer :: String 239 } deriving Show 240 241instance Storable UNICODE_STRING where 242 sizeOf _ = #size UNICODE_STRING 243 alignment _ = #alignment UNICODE_STRING 244 poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do 245 let len' = (min mAX_PATH len) * sizeOfTCHAR 246 start = advancePtr (castPtr buf) (#size UNICODE_STRING) 247 end = advancePtr start len' 248 (#poke UNICODE_STRING, Length) buf len' 249 (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR) 250 (#poke UNICODE_STRING, Buffer) buf start 251 copyArray start (castPtr str :: Ptr Word8) len' 252 poke (castPtr end) (0 :: TCHAR) 253 peek buf = do 254 vusLength <- (#peek UNICODE_STRING, Length) buf 255 vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf 256 vusBufferPtr <- (#peek UNICODE_STRING, Buffer) buf 257 let len = fromIntegral vusLength `div` sizeOfTCHAR 258 vusBuffer <- peekTStringLen (vusBufferPtr, len) 259 return $ UNICODE_STRING 260 { usLength = vusLength 261 , usMaximumLength = vusMaximumLength 262 , usBuffer = vusBuffer 263 } 264 265sizeOfTCHAR :: Int 266sizeOfTCHAR = sizeOf (undefined :: TCHAR) 267 268{- 269Note [Don't link against ntdll] 270~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 271 272We deliberately avoid using any direct foreign imports from ntdll, and instead 273dynamically load any functions we need from ntdll by hand. Why? As it turns 274out, if you're using some versions of the 32-bit mingw-w64-crt library (which 275is shipped with GHC on Windows), statically linking against both ntdll and 276msvcrt can lead to nasty linker redefinition errors. See GHC Trac #13431. 277(Curiously, this bug is only present on 32-bit Windows, which is why it went 278unnoticed for a while.) 279-} 280