{-# OPTIONS_GHC -optc-DWINVER=0x0600 #-}
{-# OPTIONS_GHC -optc-D_WIN32_WINNT=0x0600 #-}
{-# LINE 1 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
{-# LANGUAGE ScopedTypeVariables #-}


{-# LINE 4 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
{-# LANGUAGE Safe #-}

{-# LINE 8 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
-----------------------------------------------------------------------------

-- |

-- 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 an old version of MinTTY

-- that emulates a TTY. Note, however, that this does not check for more recent

-- versions of MinTTY that use the native Windows console PTY directly. The old

-- approach (where MinTTY emulates a TTY) sometimes requires different

-- approaches to handling keyboard inputs.

--

-- Much of this code was originally authored by Phil Ruffwind and the

-- git-for-windows project.

--

-----------------------------------------------------------------------------


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

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


{-# LINE 37 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
import Control.Exception (catch)

{-# LINE 39 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
import Data.List (isInfixOf)
import Foreign
import Foreign.C.Types


{-# LINE 46 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}

-- 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.





#include "windows_cconv.h"



-- | Returns 'True' if the current process's standard error is attached to an

-- emulated MinTTY console (e.g., Cygwin or MSYS that use an old version of

-- MinTTY). 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 an emulated MinTTY

-- console (e.g., Cygwin or MSYS that use an old version of MinTTY). 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 = 2
{-# LINE 158 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}

mAX_PATH :: Num a => a
mAX_PATH = 260
{-# LINE 161 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}

objectNameInformation :: CInt
objectNameInformation = 1
{-# LINE 164 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}

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    _ = (8)
{-# LINE 185 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    alignment _ = 4
{-# LINE 186 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do
        let len'  = (min mAX_PATH len) * sizeOfTCHAR
            start = advancePtr (castPtr buf) ((4))
{-# LINE 189 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
            end   = advancePtr start len'
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf len'
{-# LINE 191 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        copyArray start (castPtr str :: Ptr Word8) len'
        poke (castPtr end) (0 :: TCHAR)
    peek buf = do
        vfniFileNameLength <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf
{-# LINE 195 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR
        vfniFileName <- peekTStringLen (plusPtr buf ((4)), len)
{-# LINE 197 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        return $ FILE_NAME_INFO
          { fniFileNameLength = vfniFileNameLength
          , fniFileName       = vfniFileName
          }

type NTSTATUS = Int32
{-# LINE 203 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}

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

instance Storable OBJECT_NAME_INFORMATION where
    sizeOf    _ = (16)
{-# LINE 210 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    alignment _ = 8
{-# LINE 211 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    poke buf oni = ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (oniName oni)
{-# LINE 212 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    peek buf = fmap OBJECT_NAME_INFORMATION $ ((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf
{-# LINE 213 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}

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

instance Storable UNICODE_STRING where
    sizeOf    _ = (16)
{-# LINE 222 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    alignment _ = 8
{-# LINE 223 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do
        let len'  = (min mAX_PATH len) * sizeOfTCHAR
            start = advancePtr (castPtr buf) ((16))
{-# LINE 226 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
            end   = advancePtr start len'
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0))        buf len'
{-# LINE 228 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 2)) buf (len' + sizeOfTCHAR)
{-# LINE 229 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 8))        buf start
{-# LINE 230 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        copyArray start (castPtr str :: Ptr Word8) len'
        poke (castPtr end) (0 :: TCHAR)
    peek buf = do
        vusLength        <- ((\hsc_ptr -> peekByteOff hsc_ptr 0))        buf
{-# LINE 234 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        vusMaximumLength <- ((\hsc_ptr -> peekByteOff hsc_ptr 2)) buf
{-# LINE 235 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        vusBufferPtr     <- ((\hsc_ptr -> peekByteOff hsc_ptr 8))        buf
{-# LINE 236 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        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)