Win32.hsc

{-
This is a (mostly) direct copy of System.Win32.MinTTY from the Win32 library. We need
this both for backwards compatibility with older versions of Win32, which do not ship
with this module, as well as to backport fixes for bugs in old versions of Win32 that
do ship with this module.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  System.Win32.MinTTY
-- Copyright   :  (c) University of Glasgow 2006
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
-- Stability   :  provisional
-- Portability :  portable
--
-- A function to check if the current terminal uses MinTTY.
-- Much of this code was originally authored by Phil Ruffwind and the
-- git-for-windows project.
--
-----------------------------------------------------------------------------

module System.Console.MinTTY.Win32 (isMinTTY, isMinTTYHandle) where

import Graphics.Win32.Misc
import System.Win32.DLL
import System.Win32.File
import System.Win32.Types

#if MIN_VERSION_base(4,6,0)
import Control.Exception (catch)
#endif
import Data.List (isInfixOf)
import Foreign
import Foreign.C.Types

#if __GLASGOW_HASKELL__ < 711
#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
#endif

-- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP.
-- Since we need some structs that are only available with Vista or later,
-- we must manually set WINVER/_WIN32_WINNT accordingly.
#undef WINVER
#define WINVER 0x0600
#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0600
##include "windows_cconv.h"
#include <windows.h>
#include "winternl_compat.h"

-- | Returns 'True' if the current process's standard error is attached to a
-- MinTTY console (e.g., Cygwin or MSYS). Returns 'False' otherwise.
isMinTTY :: IO Bool
isMinTTY = do
    h <- getStdHandle sTD_ERROR_HANDLE
           `catch` \(_ :: IOError) ->
             return nullHANDLE
    if h == nullHANDLE
       then return False
       else isMinTTYHandle h

-- | Returns 'True' is the given handle is attached to a MinTTY console
-- (e.g., Cygwin or MSYS). Returns 'False' otherwise.
isMinTTYHandle :: HANDLE -> IO Bool
isMinTTYHandle h = do
    fileType <- getFileType h
    if fileType /= fILE_TYPE_PIPE
      then return False
      else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h
      -- GetFileNameByHandleEx is only available on Vista and later (hence
      -- the name isMinTTYVista). If we're on an older version of Windows,
      -- getProcAddress will throw an IOException when it fails to find
      -- GetFileNameByHandleEx, and thus we will default to using
      -- NtQueryObject (isMinTTYCompat).

isMinTTYVista :: HANDLE -> IO Bool
isMinTTYVista h = do
    fn <- getFileNameByHandle h
    return $ cygwinMSYSCheck fn
  `catch` \(_ :: IOError) ->
    return False

isMinTTYCompat :: HANDLE -> IO Bool
isMinTTYCompat h = do
    fn <- ntQueryObjectNameInformation h
    return $ cygwinMSYSCheck fn
  `catch` \(_ :: IOError) ->
    return False

cygwinMSYSCheck :: String -> Bool
cygwinMSYSCheck fn = ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) &&
            "-pty" `isInfixOf` fn
-- Note that GetFileInformationByHandleEx might return a filepath like:
--
--    \msys-dd50a72ab4668b33-pty1-to-master
--
-- But NtQueryObject might return something like:
--
--    \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master
--
-- This means we can't rely on "\cygwin-" or "\msys-" being at the very start
-- of the filepath. As a result, we use `isPrefixOf` to check for "cygwin" and
-- "msys".
--
-- It's unclear if "-master" will always appear in the filepath name. Recent
-- versions of MinTTY have been known to give filepaths like this (#186):
--
--    \msys-dd50a72ab4668b33-pty0-to-master-nat
--
-- Just in case MinTTY ever changes this convention, we don't bother checking
-- for the presence of "-master" in the filepath name at all.

getFileNameByHandle :: HANDLE -> IO String
getFileNameByHandle h = do
  let sizeOfDWORD = sizeOf (undefined :: DWORD)
      -- note: implicitly assuming that DWORD has stronger alignment than wchar_t
      bufSize     = sizeOfDWORD + mAX_PATH * sizeOfTCHAR
  allocaBytes bufSize $ \buf -> do
    getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize)
    fni <- peek buf
    return $ fniFileName fni

getFileInformationByHandleEx
  :: HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO ()
getFileInformationByHandleEx h cls buf bufSize = do
  lib <- getModuleHandle (Just "kernel32.dll")
  ptr <- getProcAddress lib "GetFileInformationByHandleEx"
  let c_GetFileInformationByHandleEx =
        mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr)
  failIfFalse_ "getFileInformationByHandleEx"
    (c_GetFileInformationByHandleEx h cls buf bufSize)

ntQueryObjectNameInformation :: HANDLE -> IO String
ntQueryObjectNameInformation h = do
  let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION)
      bufSize   = sizeOfONI + mAX_PATH * sizeOfTCHAR
  allocaBytes bufSize $ \buf ->
    alloca $ \p_len -> do
      hwnd <- getModuleHandle (Just "ntdll.exe")
      addr <- getProcAddress hwnd "NtQueryObject"
      let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr addr)
      _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject
             h objectNameInformation buf (fromIntegral bufSize) p_len
      oni <- peek buf
      return $ usBuffer $ oniName oni

fileNameInfo :: CInt
fileNameInfo = #const FileNameInfo

mAX_PATH :: Num a => a
mAX_PATH = #const MAX_PATH

objectNameInformation :: CInt
objectNameInformation = #const ObjectNameInformation

type F_NtQueryObject = HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION
                     -> ULONG -> Ptr ULONG -> IO NTSTATUS

foreign import WINDOWS_CCONV "dynamic"
  mk_NtQueryObject :: FunPtr F_NtQueryObject -> F_NtQueryObject

type F_GetFileInformationByHandleEx =
  HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL

foreign import WINDOWS_CCONV "dynamic"
  mk_GetFileInformationByHandleEx
    :: FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx

data FILE_NAME_INFO = FILE_NAME_INFO
  { fniFileNameLength :: DWORD
  , fniFileName       :: String
  } deriving Show

instance Storable FILE_NAME_INFO where
    sizeOf    _ = #size      FILE_NAME_INFO
    alignment _ = #alignment FILE_NAME_INFO
    poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do
        let len'  = (min mAX_PATH len) * sizeOfTCHAR
            start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName)
            end   = advancePtr start len'
        (#poke FILE_NAME_INFO, FileNameLength) buf len'
        copyArray start (castPtr str :: Ptr Word8) len'
        poke (castPtr end) (0 :: TCHAR)
    peek buf = do
        vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf
        let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR
        vfniFileName <- peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len)
        return $ FILE_NAME_INFO
          { fniFileNameLength = vfniFileNameLength
          , fniFileName       = vfniFileName
          }

type NTSTATUS = #type NTSTATUS

newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION
  { oniName :: UNICODE_STRING
  } deriving Show

instance Storable OBJECT_NAME_INFORMATION where
    sizeOf    _ = #size      OBJECT_NAME_INFORMATION
    alignment _ = #alignment OBJECT_NAME_INFORMATION
    poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni)
    peek buf = fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf

data UNICODE_STRING = UNICODE_STRING
  { usLength        :: USHORT
  , usMaximumLength :: USHORT
  , usBuffer        :: String
  } deriving Show

instance Storable UNICODE_STRING where
    sizeOf    _ = #size      UNICODE_STRING
    alignment _ = #alignment UNICODE_STRING
    poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do
        let len'  = (min mAX_PATH len) * sizeOfTCHAR
            start = advancePtr (castPtr buf) (#size UNICODE_STRING)
            end   = advancePtr start len'
        (#poke UNICODE_STRING, Length)        buf len'
        (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR)
        (#poke UNICODE_STRING, Buffer)        buf start
        copyArray start (castPtr str :: Ptr Word8) len'
        poke (castPtr end) (0 :: TCHAR)
    peek buf = do
        vusLength        <- (#peek UNICODE_STRING, Length)        buf
        vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf
        vusBufferPtr     <- (#peek UNICODE_STRING, Buffer)        buf
        let len          =  fromIntegral vusLength `div` sizeOfTCHAR
        vusBuffer        <- peekTStringLen (vusBufferPtr, len)
        return $ UNICODE_STRING
          { usLength        = vusLength
          , usMaximumLength = vusMaximumLength
          , usBuffer        = vusBuffer
          }

sizeOfTCHAR :: Int
sizeOfTCHAR = sizeOf (undefined :: TCHAR)

-- Compatibility with old versions of Win32
#if !(MIN_VERSION_Win32(2,5,0))
type ULONG    = #type ULONG

failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a
failIfNeg = failIf (< 0)
#endif