{-# OPTIONS_GHC -optc-DWINVER=0x0600 #-}

{-# OPTIONS_GHC -optc-D_WIN32_WINNT=0x0600 #-}

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

{-# LANGUAGE ScopedTypeVariables #-}





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

{-# LANGUAGE Safe #-}



{-# LINE 8 "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 MinTTY.

-- 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 32 "System\\Win32\\MinTTY.hsc" #-}

import Control.Exception (catch)



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

import Data.List (isPrefixOf, isInfixOf, isSuffixOf)

import Foreign

import Foreign.C.Types

import System.FilePath (takeFileName)





{-# LINE 42 "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 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-" `isPrefixOf` fn' || "msys-" `isPrefixOf` fn') &&

            "-pty" `isInfixOf` fn' &&

            "-master" `isSuffixOf` fn'

  where

    fn' = takeFileName 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. Therefore, we must take care to first call takeFileName

-- before checking for "cygwin" or "msys" at the start using `isPrefixOf`.



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 147 "System\\Win32\\MinTTY.hsc" #-}



mAX_PATH :: Num a => a

mAX_PATH = 260

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



objectNameInformation :: CInt

objectNameInformation = 1

{-# LINE 153 "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 174 "System\\Win32\\MinTTY.hsc" #-}

    alignment _ = 4

{-# LINE 175 "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 178 "System\\Win32\\MinTTY.hsc" #-}

            end   = advancePtr start len'

        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf len'

{-# LINE 180 "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 184 "System\\Win32\\MinTTY.hsc" #-}

        let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR

        vfniFileName <- peekTStringLen (plusPtr buf ((4)), len)

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

        return $ FILE_NAME_INFO

          { fniFileNameLength = vfniFileNameLength

          , fniFileName       = vfniFileName

          }



type NTSTATUS = Int32

{-# LINE 192 "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 199 "System\\Win32\\MinTTY.hsc" #-}

    alignment _ = 8

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

    poke buf oni = ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (oniName oni)

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

    peek buf = fmap OBJECT_NAME_INFORMATION $ ((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf

{-# LINE 202 "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 211 "System\\Win32\\MinTTY.hsc" #-}

    alignment _ = 8

{-# LINE 212 "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 215 "System\\Win32\\MinTTY.hsc" #-}

            end   = advancePtr start len'

        ((\hsc_ptr -> pokeByteOff hsc_ptr 0))        buf len'

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

        ((\hsc_ptr -> pokeByteOff hsc_ptr 2)) buf (len' + sizeOfTCHAR)

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

        ((\hsc_ptr -> pokeByteOff hsc_ptr 8))        buf start

{-# LINE 219 "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 223 "System\\Win32\\MinTTY.hsc" #-}

        vusMaximumLength <- ((\hsc_ptr -> peekByteOff hsc_ptr 2)) buf

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

        vusBufferPtr     <- ((\hsc_ptr -> peekByteOff hsc_ptr 8))        buf

{-# LINE 225 "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)