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