diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.1.3 [2021.11.07] +* Backport a fix for a `Win32` bug that would make `isMinTTY` incorrectly + return `False` on recent versions of MinTTY. + ### 0.1.2 [2018.05.07] * Only use the `Win32`-provided version of `isMinTTY` if building against `Win32-2.5.3` to be certain that one avoids Trac #13431. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/mintty.svg)](http://packdeps.haskellers.com/reverse/mintty) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] -[![Build](https://img.shields.io/travis/RyanGlScott/mintty.svg)](https://travis-ci.org/RyanGlScott/mintty) +[![Linux build](https://github.com/RyanGlScott/mintty/workflows/Haskell-CI/badge.svg)](https://github.com/RyanGlScott/mintty/actions?query=workflow%3AHaskell-CI) [![Windows build](https://ci.appveyor.com/api/projects/status/kj3knsx19ebh9wly?svg=true)](https://ci.appveyor.com/project/RyanGlScott/mintty) [Hackage: mintty]: diff --git a/mintty.cabal b/mintty.cabal --- a/mintty.cabal +++ b/mintty.cabal @@ -1,5 +1,5 @@ name: mintty -version: 0.1.2 +version: 0.1.3 synopsis: A reliable way to detect the presence of a MinTTY console on Windows description: MinTTY is a Windows-specific terminal emulator for the widely used Cygwin and MSYS projects, which provide @@ -38,14 +38,22 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.4 + , GHC == 9.0.1 source-repository head type: git location: https://github.com/RyanGlScott/mintty -flag Win32-2-5-3 - description: Use Win32-2.5.3.0 or later. +flag Win32-2-13-1 + description: Use @Win32-2.13.1.0@ or later. Older versions of @Win32@ + either do not have functionality for detecting MinTTY or + have bugs in their MinTTY detection. For these versions + of @Win32@, we backport a working version of MinTTY + detection. default: True library @@ -55,11 +63,11 @@ if os(windows) cpp-options: "-DWINDOWS" - if flag(Win32-2-5-3) - build-depends: Win32 >= 2.5.3 + if flag(Win32-2-13-1) + build-depends: Win32 >= 2.13.1 else build-depends: filepath - , Win32 < 2.5.3 + , Win32 < 2.13.1 build-tools: hsc2hs include-dirs: include includes: windows_cconv.h, winternl_compat.h diff --git a/src/System/Console/MinTTY.hs b/src/System/Console/MinTTY.hs --- a/src/System/Console/MinTTY.hs +++ b/src/System/Console/MinTTY.hs @@ -2,6 +2,8 @@ #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} #endif {-| @@ -21,7 +23,7 @@ #if defined(WINDOWS) import System.Win32.Types (HANDLE) -# if MIN_VERSION_Win32(2,5,3) +# if MIN_VERSION_Win32(2,13,1) import qualified System.Win32.MinTTY as Win32 (isMinTTY, isMinTTYHandle) # else -- NB: This is the backported definition local to this package, which we only diff --git a/src/System/Console/MinTTY/Win32.hsc b/src/System/Console/MinTTY/Win32.hsc --- a/src/System/Console/MinTTY/Win32.hsc +++ b/src/System/Console/MinTTY/Win32.hsc @@ -1,7 +1,8 @@ {- This is a (mostly) direct copy of System.Win32.MinTTY from the Win32 library. We need -this for backwards compatibility with older versions of Win32 which do not ship -with this module. +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 #-} @@ -38,11 +39,9 @@ #if MIN_VERSION_base(4,6,0) import Control.Exception (catch) #endif -import Control.Monad (void) -import Data.List (isPrefixOf, isInfixOf, isSuffixOf) -import Foreign hiding (void) +import Data.List (isInfixOf) +import Foreign import Foreign.C.Types -import System.FilePath (takeFileName) #if __GLASGOW_HASKELL__ < 711 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) @@ -99,11 +98,8 @@ return False cygwinMSYSCheck :: String -> Bool -cygwinMSYSCheck fn = ("cygwin-" `isPrefixOf` fn' || "msys-" `isPrefixOf` fn') && - "-pty" `isInfixOf` fn' && - "-master" `isSuffixOf` fn' - where - fn' = takeFileName fn +cygwinMSYSCheck fn = ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) && + "-pty" `isInfixOf` fn -- Note that GetFileInformationByHandleEx might return a filepath like: -- -- \msys-dd50a72ab4668b33-pty1-to-master @@ -113,8 +109,16 @@ -- \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`. +-- 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 @@ -142,24 +146,14 @@ bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR allocaBytes bufSize $ \buf -> alloca $ \p_len -> do - {- - See Note [Don't link against ntdll] + 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 - -} - ntQueryObject h objectNameInformation buf (fromIntegral bufSize) p_len oni <- peek buf return $ usBuffer $ oniName oni --- See Note [Don't link against ntdll] -ntQueryObject :: HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION - -> ULONG -> Ptr ULONG -> IO () -ntQueryObject h cls buf bufSize p_len = do - lib <- getModuleHandle (Just "ntdll.dll") - ptr <- getProcAddress lib "NtQueryObject" - let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr ptr) - void $ failIfNeg "NtQueryObject" $ c_NtQueryObject h cls buf bufSize p_len - fileNameInfo :: CInt fileNameInfo = #const FileNameInfo @@ -169,6 +163,12 @@ 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 @@ -200,28 +200,8 @@ , fniFileName = vfniFileName } -{- -In an ideal world, we'd use this instead of the hack below. -See Note [Don't link against ntdll] - -foreign import WINDOWS_CCONV "winternl.h NtQueryObject" - c_NtQueryObject :: HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION - -> ULONG -> Ptr ULONG -> IO NTSTATUS --} - -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 NTSTATUS = #type NTSTATUS -type ULONG = #type ULONG -failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a -failIfNeg = failIf (< 0) - newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION { oniName :: UNICODE_STRING } deriving Show @@ -265,15 +245,10 @@ sizeOfTCHAR :: Int sizeOfTCHAR = sizeOf (undefined :: TCHAR) -{- -Note [Don't link against ntdll] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Compatibility with old versions of Win32 +#if !(MIN_VERSION_Win32(2,5,0)) +type ULONG = #type ULONG -We deliberately avoid using any direct foreign imports from ntdll, and instead -dynamically load any functions we need from ntdll by hand. Why? As it turns -out, if you're using some versions of the 32-bit mingw-w64-crt library (which -is shipped with GHC on Windows), statically linking against both ntdll and -msvcrt can lead to nasty linker redefinition errors. See GHC Trac #13431. -(Curiously, this bug is only present on 32-bit Windows, which is why it went -unnoticed for a while.) --} +failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a +failIfNeg = failIf (< 0) +#endif