{-# 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 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 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
import Control.Exception (catch)

{-# LINE 34 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
import Data.List (isPrefixOf, isInfixOf, isSuffixOf)
import Foreign
import Foreign.C.Types
import System.FilePath (takeFileName)


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

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

objectNameInformation :: CInt
objectNameInformation = 1
{-# LINE 153 "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 174 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    alignment _ = 4
{-# LINE 175 "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 178 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
            end   = advancePtr start len'
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf len'
{-# LINE 180 "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 184 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR
        vfniFileName <- peekTStringLen (plusPtr buf ((4)), len)
{-# LINE 186 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        return $ FILE_NAME_INFO
          { fniFileNameLength = vfniFileNameLength
          , fniFileName       = vfniFileName
          }

type NTSTATUS = Int32
{-# LINE 192 "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 199 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    alignment _ = 8
{-# LINE 200 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    poke buf oni = ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (oniName oni)
{-# LINE 201 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    peek buf = fmap OBJECT_NAME_INFORMATION $ ((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf
{-# LINE 202 "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 211 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
    alignment _ = 8
{-# LINE 212 "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 215 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
            end   = advancePtr start len'
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0))        buf len'
{-# LINE 217 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 2)) buf (len' + sizeOfTCHAR)
{-# LINE 218 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 8))        buf start
{-# LINE 219 "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 223 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        vusMaximumLength <- ((\hsc_ptr -> peekByteOff hsc_ptr 2)) buf
{-# LINE 224 "libraries\\Win32\\System\\Win32\\MinTTY.hsc" #-}
        vusBufferPtr     <- ((\hsc_ptr -> peekByteOff hsc_ptr 8))        buf
{-# LINE 225 "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)