diff --git a/Graphics/Win32/Window.hsc b/Graphics/Win32/Window.hsc --- a/Graphics/Win32/Window.hsc +++ b/Graphics/Win32/Window.hsc @@ -238,7 +238,7 @@ -} #if defined(i386_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h SetWindowLongW" -#elif defined(x86_64_HOST_ARCH) +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h SetWindowLongPtrW" #else # error Unknown mingw32 arch @@ -247,7 +247,7 @@ #if defined(i386_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongW" -#elif defined(x86_64_HOST_ARCH) +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongPtrW" #else # error Unknown mingw32 arch diff --git a/System/Win32/Console.hsc b/System/Win32/Console.hsc --- a/System/Win32/Console.hsc +++ b/System/Win32/Console.hsc @@ -1,5 +1,5 @@ #if __GLASGOW_HASKELL__ >= 709 -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Trustworthy #-} #endif @@ -45,6 +45,8 @@ generateConsoleCtrlEvent, -- * Command line commandLineToArgv, + getCommandLineW, + getArgs, -- * Screen buffer CONSOLE_SCREEN_BUFFER_INFO(..), CONSOLE_SCREEN_BUFFER_INFOEX(..), @@ -54,7 +56,19 @@ getConsoleScreenBufferInfo, getCurrentConsoleScreenBufferInfo, getConsoleScreenBufferInfoEx, - getCurrentConsoleScreenBufferInfoEx + getCurrentConsoleScreenBufferInfoEx, + + -- * Env + getEnv, + getEnvironment, + -- * Console I/O + KEY_EVENT_RECORD(..), + MOUSE_EVENT_RECORD(..), + WINDOW_BUFFER_SIZE_RECORD(..), + MENU_EVENT_RECORD(..), + FOCUS_EVENT_RECORD(..), + INPUT_RECORD(..), + readConsoleInput ) where #include @@ -62,23 +76,23 @@ ##include "windows_cconv.h" #include "wincon_compat.h" +import Data.Char (chr) import System.Win32.Types +import System.Win32.String +import System.Win32.Console.Internal import Graphics.Win32.Misc import Graphics.Win32.GDI.Types (COLORREF) -import Foreign.C.Types (CInt(..)) +import GHC.IO (bracket) +import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) +import Foreign.Ptr (plusPtr, Ptr) +import Foreign.C.Types (CWchar) import Foreign.C.String (withCWString, CWString) -import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Array (peekArray, pokeArray) +import Foreign.Marshal.Array (peekArray, peekArray0) import Foreign.Marshal.Alloc (alloca) -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" - c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" - c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL - getConsoleMode :: HANDLE -> IO DWORD getConsoleMode h = alloca $ \ptr -> do failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr @@ -107,36 +121,12 @@ dISABLE_NEWLINE_AUTO_RETURN = 8 eNABLE_LVB_GRID_WORLDWIDE = 16 -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP" - getConsoleCP :: IO UINT - -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCP" - setConsoleCP :: UINT -> IO () - -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleOutputCP" - getConsoleOutputCP :: IO UINT - -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleOutputCP" - setConsoleOutputCP :: UINT -> IO () - -type CtrlEvent = DWORD -#{enum CtrlEvent, - , cTRL_C_EVENT = 0 - , cTRL_BREAK_EVENT = 1 - } - generateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO () generateConsoleCtrlEvent e p = failIfFalse_ "generateConsoleCtrlEvent" $ c_GenerateConsoleCtrlEvent e p -foreign import WINDOWS_CCONV safe "windows.h GenerateConsoleCtrlEvent" - c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL - -foreign import WINDOWS_CCONV unsafe "Shellapi.h CommandLineToArgvW" - c_CommandLineToArgvW :: CWString -> Ptr CInt -> IO (Ptr CWString) - -- | This function can be used to parse command line arguments and return -- the split up arguments as elements in a list. commandLineToArgv :: String -> IO [String] @@ -150,118 +140,12 @@ _ <- localFree res mapM peekTString args -data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO - { dwSize :: COORD - , dwCursorPosition :: COORD - , wAttributes :: WORD - , srWindow :: SMALL_RECT - , dwMaximumWindowSize :: COORD - } deriving (Show, Eq) - -instance Storable CONSOLE_SCREEN_BUFFER_INFO where - sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFO} - alignment _ = #alignment CONSOLE_SCREEN_BUFFER_INFO - peek buf = do - dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf - dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf - wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf - srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf - dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf - return $ CONSOLE_SCREEN_BUFFER_INFO dwSize' dwCursorPosition' wAttributes' srWindow' dwMaximumWindowSize' - poke buf info = do - (#poke CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf (dwSize info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf (dwCursorPosition info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf (wAttributes info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf (srWindow info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf (dwMaximumWindowSize info) - -data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX - { dwSizeEx :: COORD - , dwCursorPositionEx :: COORD - , wAttributesEx :: WORD - , srWindowEx :: SMALL_RECT - , dwMaximumWindowSizeEx :: COORD - , wPopupAttributes :: WORD - , bFullscreenSupported :: BOOL - , colorTable :: [COLORREF] - -- ^ Only the first 16 'COLORREF' values passed to the Windows Console - -- API. If fewer than 16 values, the remainder are padded with @0@ when - -- passed to the API. - } deriving (Show, Eq) - -instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where - sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFOEX} - alignment = const #{alignment CONSOLE_SCREEN_BUFFER_INFOEX} - peek buf = do - dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf - dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf - wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf - srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf - dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf - wPopupAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf - bFullscreenSupported' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf - colorTable' <- peekArray 16 ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) - return $ CONSOLE_SCREEN_BUFFER_INFOEX dwSize' dwCursorPosition' - wAttributes' srWindow' dwMaximumWindowSize' wPopupAttributes' - bFullscreenSupported' colorTable' - poke buf info = do - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, cbSize) buf cbSize - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf (dwSizeEx info) - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf (dwCursorPositionEx info) - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf (wAttributesEx info) - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf (srWindowEx info) - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf (dwMaximumWindowSizeEx info) - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf (wPopupAttributes info) - (#poke CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf (bFullscreenSupported info) - pokeArray ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) colorTable' - where - cbSize :: ULONG - cbSize = #{size CONSOLE_SCREEN_BUFFER_INFOEX} - colorTable' = take 16 $ colorTable info ++ repeat 0 - -data COORD = COORD - { xPos :: SHORT - , yPos :: SHORT - } deriving (Show, Eq) - -instance Storable COORD where - sizeOf = const #{size COORD} - alignment _ = #alignment COORD - peek buf = do - x' <- (#peek COORD, X) buf - y' <- (#peek COORD, Y) buf - return $ COORD x' y' - poke buf coord = do - (#poke COORD, X) buf (xPos coord) - (#poke COORD, Y) buf (yPos coord) - -data SMALL_RECT = SMALL_RECT - { leftPos :: SHORT - , topPos :: SHORT - , rightPos :: SHORT - , bottomPos :: SHORT - } deriving (Show, Eq) - -instance Storable SMALL_RECT where - sizeOf _ = #{size SMALL_RECT} - alignment _ = #alignment SMALL_RECT - peek buf = do - left' <- (#peek SMALL_RECT, Left) buf - top' <- (#peek SMALL_RECT, Top) buf - right' <- (#peek SMALL_RECT, Right) buf - bottom' <- (#peek SMALL_RECT, Bottom) buf - return $ SMALL_RECT left' top' right' bottom' - poke buf small_rect = do - (#poke SMALL_RECT, Left) buf (leftPos small_rect) - (#poke SMALL_RECT, Top) buf (topPos small_rect) - (#poke SMALL_RECT, Right) buf (rightPos small_rect) - (#poke SMALL_RECT, Bottom) buf (bottomPos small_rect) - -foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo" - c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL - -foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfoEx" - c_GetConsoleScreenBufferInfoEx :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFOEX -> IO BOOL +-- | Based on 'GetCommandLineW'. This behaves slightly different +-- than 'System.Environment.getArgs'. See the online documentation: +-- +getArgs :: IO [String] +getArgs = do + getCommandLineW >>= peekTString >>= commandLineToArgv getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO getConsoleScreenBufferInfo h = alloca $ \ptr -> do @@ -288,3 +172,81 @@ getCurrentConsoleScreenBufferInfoEx = do h <- failIf (== nullHANDLE) "getStdHandle" $ getStdHandle sTD_OUTPUT_HANDLE getConsoleScreenBufferInfoEx h + + +-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD +getEnv :: String -> IO (Maybe String) +getEnv name = + withCWString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- c_GetEnvironmentVariableW c_name buf c_len + case c_len' of + 0 -> do + err_code <- getLastError + if err_code == eERROR_ENVVAR_NOT_FOUND + then return Nothing + else errorWin "GetEnvironmentVariableW" + _ | c_len' > fromIntegral maxLength -> + -- shouldn't happen, because we provide maxLength + ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) + | otherwise -> do + let len' = fromIntegral c_len' + Just <$> peekTStringLen (buf, len') + where + -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew + -- max characters (wide chars): 32767 + -- => bytes = 32767 * 2 = 65534 + -- +1 byte for NUL (although not needed I think) + maxLength :: Int + maxLength = 65535 + + +getEnvironment :: IO [(String, String)] +getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do + strs <- builder lpwstr + return (divvy <$> strs) + where + divvy :: String -> (String, String) + divvy str = + case break (=='=') str of + (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment) + (name,_:value) -> (name,value) + + builder :: LPWSTR -> IO [String] + builder ptr = go 0 + where + go :: Int -> IO [String] + go off = do + (str, l) <- peekCWStringOff ptr off + if l == 0 + then pure [] + else (str:) <$> go (((l + 1) * 2) + off) + + +peekCWStringOff :: CWString -> Int -> IO (String, Int) +peekCWStringOff cp off = do + cs <- peekArray0 wNUL (cp `plusPtr` off) + return (cWcharsToChars cs, length cs) + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> [Char] +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = [] + +-- | Reads all available input records up to the amount specified by the +-- len parameter. +readConsoleInput :: HANDLE -> Int -> Ptr INPUT_RECORD -> IO Int +readConsoleInput handle len inputRecordPtr = + alloca $ \numEventsReadPtr -> do + poke numEventsReadPtr 0 + failIfFalse_ "ReadConsoleInput" $ + c_ReadConsoleInput handle inputRecordPtr (fromIntegral len) numEventsReadPtr + numEvents <- peek numEventsReadPtr + return $ fromIntegral numEvents diff --git a/System/Win32/Console/Internal.hsc b/System/Win32/Console/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Console/Internal.hsc @@ -0,0 +1,336 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Console.Internal +-- Copyright : (c) University of Glasgow 2023 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Internals for Console modules. +-- +----------------------------------------------------------------------------- + +module System.Win32.Console.Internal where + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "wincon_compat.h" + +import System.Win32.Types +import Graphics.Win32.GDI.Types (COLORREF) + +import Foreign.C.Types (CInt(..), CWchar) +import Foreign.C.String (CWString) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, pokeArray) + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" + c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" + c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP" + getConsoleCP :: IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCP" + setConsoleCP :: UINT -> IO () + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleOutputCP" + getConsoleOutputCP :: IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleOutputCP" + setConsoleOutputCP :: UINT -> IO () + +type CtrlEvent = DWORD +#{enum CtrlEvent, + , cTRL_C_EVENT = 0 + , cTRL_BREAK_EVENT = 1 + } + +foreign import WINDOWS_CCONV safe "windows.h GenerateConsoleCtrlEvent" + c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "Shellapi.h CommandLineToArgvW" + c_CommandLineToArgvW :: CWString -> Ptr CInt -> IO (Ptr CWString) + +foreign import WINDOWS_CCONV unsafe "processenv.h GetCommandLineW" + getCommandLineW :: IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentVariableW" + c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentStringsW" + c_GetEnvironmentStringsW :: IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "processenv.h FreeEnvironmentStringsW" + c_FreeEnvironmentStrings :: LPWSTR -> IO Bool + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO + { dwSize :: COORD + , dwCursorPosition :: COORD + , wAttributes :: WORD + , srWindow :: SMALL_RECT + , dwMaximumWindowSize :: COORD + } deriving (Show, Eq) + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFO} + alignment _ = #alignment CONSOLE_SCREEN_BUFFER_INFO + peek buf = do + dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf + dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf + wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf + srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf + dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf + return $ CONSOLE_SCREEN_BUFFER_INFO dwSize' dwCursorPosition' wAttributes' srWindow' dwMaximumWindowSize' + poke buf info = do + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf (dwSize info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf (dwCursorPosition info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf (wAttributes info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf (srWindow info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf (dwMaximumWindowSize info) + +data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX + { dwSizeEx :: COORD + , dwCursorPositionEx :: COORD + , wAttributesEx :: WORD + , srWindowEx :: SMALL_RECT + , dwMaximumWindowSizeEx :: COORD + , wPopupAttributes :: WORD + , bFullscreenSupported :: BOOL + , colorTable :: [COLORREF] + -- ^ Only the first 16 'COLORREF' values passed to the Windows Console + -- API. If fewer than 16 values, the remainder are padded with @0@ when + -- passed to the API. + } deriving (Show, Eq) + +instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where + sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFOEX} + alignment = const #{alignment CONSOLE_SCREEN_BUFFER_INFOEX} + peek buf = do + dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf + dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf + wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf + srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf + dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf + wPopupAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf + bFullscreenSupported' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf + colorTable' <- peekArray 16 ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) + return $ CONSOLE_SCREEN_BUFFER_INFOEX dwSize' dwCursorPosition' + wAttributes' srWindow' dwMaximumWindowSize' wPopupAttributes' + bFullscreenSupported' colorTable' + poke buf info = do + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, cbSize) buf cbSize + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf (dwSizeEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf (dwCursorPositionEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf (wAttributesEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf (srWindowEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf (dwMaximumWindowSizeEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf (wPopupAttributes info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf (bFullscreenSupported info) + pokeArray ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) colorTable' + where + cbSize :: ULONG + cbSize = #{size CONSOLE_SCREEN_BUFFER_INFOEX} + colorTable' = take 16 $ colorTable info ++ repeat 0 + +data COORD = COORD + { xPos :: SHORT + , yPos :: SHORT + } deriving (Show, Eq) + +instance Storable COORD where + sizeOf = const #{size COORD} + alignment _ = #alignment COORD + peek buf = do + x' <- (#peek COORD, X) buf + y' <- (#peek COORD, Y) buf + return $ COORD x' y' + poke buf coord = do + (#poke COORD, X) buf (xPos coord) + (#poke COORD, Y) buf (yPos coord) + +data SMALL_RECT = SMALL_RECT + { leftPos :: SHORT + , topPos :: SHORT + , rightPos :: SHORT + , bottomPos :: SHORT + } deriving (Show, Eq) + +instance Storable SMALL_RECT where + sizeOf _ = #{size SMALL_RECT} + alignment _ = #alignment SMALL_RECT + peek buf = do + left' <- (#peek SMALL_RECT, Left) buf + top' <- (#peek SMALL_RECT, Top) buf + right' <- (#peek SMALL_RECT, Right) buf + bottom' <- (#peek SMALL_RECT, Bottom) buf + return $ SMALL_RECT left' top' right' bottom' + poke buf small_rect = do + (#poke SMALL_RECT, Left) buf (leftPos small_rect) + (#poke SMALL_RECT, Top) buf (topPos small_rect) + (#poke SMALL_RECT, Right) buf (rightPos small_rect) + (#poke SMALL_RECT, Bottom) buf (bottomPos small_rect) + +foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo" + c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfoEx" + c_GetConsoleScreenBufferInfoEx :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFOEX -> IO BOOL + +-- | This type represents a keyboard input event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/key-event-record-str +data KEY_EVENT_RECORD = KEY_EVENT_RECORD + { keyDown :: BOOL + , repeatCount :: WORD + , virtualKeyCode :: WORD + , virtualScanCode :: WORD + , uChar :: CWchar + , controlKeyStateK :: DWORD + } deriving (Eq, Show) + +-- | This type represents a mouse event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/mouse-event-record-str +data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD + { mousePosition :: COORD + , buttonState :: DWORD + , controlKeyStateM :: DWORD + , eventFlags :: DWORD + } deriving (Eq, Show) + +-- | This type represents a window size change event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/window-buffer-size-record-str +newtype WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD + { windowSize :: COORD + } deriving (Eq, Show) + +-- | This type represents a window menu event. (Current ignored by VTY). The structure +-- is documented here: https://learn.microsoft.com/en-us/windows/console/menu-event-record-str +newtype MENU_EVENT_RECORD = MENU_EVENT_RECORD + { commandId :: UINT + } deriving (Eq, Show) + +-- | This type represents a window focus change event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/focus-event-record-str +newtype FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD + { setFocus :: BOOL + } deriving (Eq, Show) + +-- | Description of a Windows console input event. Documented here: +-- https://learn.microsoft.com/en-us/windows/console/input-record-str +data INPUT_RECORD = + KeyEvent KEY_EVENT_RECORD + | MouseEvent MOUSE_EVENT_RECORD + | WindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD + | MenuEvent MENU_EVENT_RECORD + | FocusEvent FOCUS_EVENT_RECORD + deriving (Eq, Show) + +instance Storable KEY_EVENT_RECORD where + sizeOf = const #{size KEY_EVENT_RECORD} + alignment _ = #alignment KEY_EVENT_RECORD + poke buf input = do + (#poke KEY_EVENT_RECORD, bKeyDown) buf (keyDown input) + (#poke KEY_EVENT_RECORD, wRepeatCount) buf (repeatCount input) + (#poke KEY_EVENT_RECORD, wVirtualKeyCode) buf (virtualKeyCode input) + (#poke KEY_EVENT_RECORD, wVirtualScanCode) buf (virtualScanCode input) + (#poke KEY_EVENT_RECORD, uChar) buf (uChar input) + (#poke KEY_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateK input) + peek buf = do + keyDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) buf + repeatCount' <- (#peek KEY_EVENT_RECORD, wRepeatCount) buf + virtualKeyCode' <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) buf + virtualScanCode' <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) buf + uChar' <- (#peek KEY_EVENT_RECORD, uChar) buf + controlKeyStateK' <- (#peek KEY_EVENT_RECORD, dwControlKeyState) buf + return $ KEY_EVENT_RECORD keyDown' repeatCount' virtualKeyCode' virtualScanCode' uChar' controlKeyStateK' + +instance Storable MOUSE_EVENT_RECORD where + sizeOf = const #{size MOUSE_EVENT_RECORD} + alignment _ = #alignment MOUSE_EVENT_RECORD + poke buf input = do + (#poke MOUSE_EVENT_RECORD, dwMousePosition) buf (mousePosition input) + (#poke MOUSE_EVENT_RECORD, dwButtonState) buf (buttonState input) + (#poke MOUSE_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateM input) + (#poke MOUSE_EVENT_RECORD, dwEventFlags) buf (eventFlags input) + peek buf = do + mousePosition' <- (#peek MOUSE_EVENT_RECORD, dwMousePosition) buf + buttonState' <- (#peek MOUSE_EVENT_RECORD, dwButtonState) buf + controlKeyStateM' <- (#peek MOUSE_EVENT_RECORD, dwControlKeyState) buf + eventFlags' <- (#peek MOUSE_EVENT_RECORD, dwEventFlags) buf + return $ MOUSE_EVENT_RECORD mousePosition' buttonState' controlKeyStateM' eventFlags' + +instance Storable WINDOW_BUFFER_SIZE_RECORD where + sizeOf = const #{size WINDOW_BUFFER_SIZE_RECORD} + alignment _ = #alignment WINDOW_BUFFER_SIZE_RECORD + poke buf input = do + (#poke WINDOW_BUFFER_SIZE_RECORD, dwSize) buf (windowSize input) + peek buf = do + size' <- (#peek WINDOW_BUFFER_SIZE_RECORD, dwSize) buf + return $ WINDOW_BUFFER_SIZE_RECORD size' + +instance Storable MENU_EVENT_RECORD where + sizeOf = const #{size MENU_EVENT_RECORD} + alignment _ = #alignment MENU_EVENT_RECORD + poke buf input = do + (#poke MENU_EVENT_RECORD, dwCommandId) buf (commandId input) + peek buf = do + commandId' <- (#peek MENU_EVENT_RECORD, dwCommandId) buf + return $ MENU_EVENT_RECORD commandId' + +instance Storable FOCUS_EVENT_RECORD where + sizeOf = const #{size FOCUS_EVENT_RECORD} + alignment _ = #alignment FOCUS_EVENT_RECORD + poke buf input = do + (#poke FOCUS_EVENT_RECORD, bSetFocus) buf (setFocus input) + peek buf = do + setFocus' <- (#peek FOCUS_EVENT_RECORD, bSetFocus) buf + return $ FOCUS_EVENT_RECORD setFocus' + +instance Storable INPUT_RECORD where + sizeOf = const #{size INPUT_RECORD} + alignment _ = #alignment INPUT_RECORD + + poke buf (KeyEvent key) = do + (#poke INPUT_RECORD, EventType) buf (#{const KEY_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf key + poke buf (MouseEvent mouse) = do + (#poke INPUT_RECORD, EventType) buf (#{const MOUSE_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf mouse + poke buf (WindowBufferSizeEvent window) = do + (#poke INPUT_RECORD, EventType) buf (#{const WINDOW_BUFFER_SIZE_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf window + poke buf (MenuEvent menu) = do + (#poke INPUT_RECORD, EventType) buf (#{const MENU_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf menu + poke buf (FocusEvent focus) = do + (#poke INPUT_RECORD, EventType) buf (#{const FOCUS_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf focus + + peek buf = do + event <- (#peek INPUT_RECORD, EventType) buf :: IO WORD + case event of + #{const KEY_EVENT} -> + KeyEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const MOUSE_EVENT} -> + MouseEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const WINDOW_BUFFER_SIZE_EVENT} -> + WindowBufferSizeEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const MENU_EVENT} -> + MenuEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const FOCUS_EVENT} -> + FocusEvent `fmap` (#peek INPUT_RECORD, Event) buf + _ -> error $ "Unknown input event type " ++ show event + +foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" + c_ReadConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL diff --git a/System/Win32/DebugApi.hsc b/System/Win32/DebugApi.hsc --- a/System/Win32/DebugApi.hsc +++ b/System/Win32/DebugApi.hsc @@ -54,14 +54,22 @@ , useAllRegs , withThreadContext -#if __i386__ +#if defined(i386_HOST_ARCH) , eax, ebx, ecx, edx, esi, edi, ebp, eip, esp -#elif __x86_64__ +#elif defined(x86_64_HOST_ARCH) , rax, rbx, rcx, rdx, rsi, rdi, rbp, rip, rsp #endif +#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) , segCs, segDs, segEs, segFs, segGs , eFlags , dr +#endif +#if defined(aarch64_HOST_ARCH) + , x0, x1, x2, x3, x4, x5, x6, x7, x8 + , x9, x10, x11, x12, x13, x14, x15, x16, x17 + , x18, x19, x20, x21, x22, x23, x24, x25, x26 + , x27, x28, fp, lr, sp, pc +#endif , setReg, getReg, modReg , makeModThreadContext , modifyThreadContext @@ -331,7 +339,7 @@ (act buf) -#if __i386__ +#if defined(i386_HOST_ARCH) eax, ebx, ecx, edx :: Int esi, edi :: Int ebp, eip, esp :: Int @@ -344,7 +352,7 @@ ebp = (#offset CONTEXT, Ebp) eip = (#offset CONTEXT, Eip) esp = (#offset CONTEXT, Esp) -#elif __x86_64__ +#elif defined(x86_64_HOST_ARCH) rax, rbx, rcx, rdx :: Int rsi, rdi :: Int rbp, rip, rsp :: Int @@ -357,10 +365,49 @@ rbp = (#offset CONTEXT, Rbp) rip = (#offset CONTEXT, Rip) rsp = (#offset CONTEXT, Rsp) +#elif defined(aarch64_HOST_ARCH) +x0, x1, x2, x3, x4, x5, x6, x7, x8 :: Int +x9, x10, x11, x12, x13, x14, x15, x16, x17 :: Int +x18, x19, x20, x21, x22, x23, x24, x25, x26 :: Int +x27, x28, fp, lr, sp, pc :: Int +x0 = (#offset CONTEXT, X0 ) +x1 = (#offset CONTEXT, X1 ) +x2 = (#offset CONTEXT, X2 ) +x3 = (#offset CONTEXT, X3 ) +x4 = (#offset CONTEXT, X4 ) +x5 = (#offset CONTEXT, X5 ) +x6 = (#offset CONTEXT, X6 ) +x7 = (#offset CONTEXT, X7 ) +x8 = (#offset CONTEXT, X8 ) +x9 = (#offset CONTEXT, X9 ) +x10 = (#offset CONTEXT, X10) +x11 = (#offset CONTEXT, X11) +x12 = (#offset CONTEXT, X12) +x13 = (#offset CONTEXT, X13) +x14 = (#offset CONTEXT, X14) +x15 = (#offset CONTEXT, X15) +x16 = (#offset CONTEXT, X16) +x17 = (#offset CONTEXT, X17) +x18 = (#offset CONTEXT, X18) +x19 = (#offset CONTEXT, X19) +x20 = (#offset CONTEXT, X20) +x21 = (#offset CONTEXT, X21) +x22 = (#offset CONTEXT, X22) +x23 = (#offset CONTEXT, X23) +x24 = (#offset CONTEXT, X24) +x25 = (#offset CONTEXT, X25) +x26 = (#offset CONTEXT, X26) +x27 = (#offset CONTEXT, X27) +x28 = (#offset CONTEXT, X28) +fp = (#offset CONTEXT, Fp) +lr = (#offset CONTEXT, Lr) +sp = (#offset CONTEXT, Sp) +pc = (#offset CONTEXT, Pc) #else -#error Unsupported architecture +#error Unknown mingw32 arch #endif +#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) segCs, segDs, segEs, segFs, segGs :: Int segCs = (#offset CONTEXT, SegCs) segDs = (#offset CONTEXT, SegDs) @@ -380,6 +427,7 @@ 6 -> (#offset CONTEXT, Dr6) 7 -> (#offset CONTEXT, Dr7) _ -> undefined +#endif setReg :: Ptr a -> Int -> DWORD -> IO () setReg = pokeByteOff diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -189,6 +189,8 @@ , createDirectoryEx , removeDirectory , getBinaryType + , getTempFileName + , replaceFile -- * HANDLE operations , createFile @@ -245,6 +247,7 @@ import Foreign hiding (void) import Control.Monad import Control.Concurrent +import Data.Maybe (fromMaybe) ##include "windows_cconv.h" @@ -287,64 +290,80 @@ deleteFile :: String -> IO () deleteFile name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $ c_DeleteFile c_name copyFile :: String -> String -> Bool -> IO () copyFile src dest over = - withTString src $ \ c_src -> - withTString dest $ \ c_dest -> + withFilePath src $ \ c_src -> + withFilePath dest $ \ c_dest -> failIfFalseWithRetry_ (unwords ["CopyFile",show src,show dest]) $ c_CopyFile c_src c_dest over moveFile :: String -> String -> IO () moveFile src dest = - withTString src $ \ c_src -> - withTString dest $ \ c_dest -> + withFilePath src $ \ c_src -> + withFilePath dest $ \ c_dest -> failIfFalseWithRetry_ (unwords ["MoveFile",show src,show dest]) $ c_MoveFile c_src c_dest moveFileEx :: String -> Maybe String -> MoveFileFlag -> IO () moveFileEx src dest flags = - withTString src $ \ c_src -> - maybeWith withTString dest $ \ c_dest -> + withFilePath src $ \ c_src -> + maybeWith withFilePath dest $ \ c_dest -> failIfFalseWithRetry_ (unwords ["MoveFileEx",show src,show dest]) $ c_MoveFileEx c_src c_dest flags setCurrentDirectory :: String -> IO () setCurrentDirectory name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $ c_SetCurrentDirectory c_name createDirectory :: String -> Maybe LPSECURITY_ATTRIBUTES -> IO () createDirectory name mb_attr = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["CreateDirectory",show name]) $ c_CreateDirectory c_name (maybePtr mb_attr) createDirectoryEx :: String -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO () createDirectoryEx template name mb_attr = - withTString template $ \ c_template -> - withTString name $ \ c_name -> + withFilePath template $ \ c_template -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["CreateDirectoryEx",show template,show name]) $ c_CreateDirectoryEx c_template c_name (maybePtr mb_attr) removeDirectory :: String -> IO () removeDirectory name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $ c_RemoveDirectory c_name getBinaryType :: String -> IO BinaryType getBinaryType name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> alloca $ \ p_btype -> do failIfFalse_ (unwords ["GetBinaryType",show name]) $ c_GetBinaryType c_name p_btype peek p_btype +-- | Get a unique temporary filename. +-- +-- Calls 'GetTempFileNameW'. +getTempFileName :: String -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long) + -> String -- ^ prefix for the temporary file name + -> Maybe UINT -- ^ if 'Nothing', a unique name is generated + -- otherwise a non-zero value is used as the unique part + -> IO (String, UINT) +getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do + uid <- withFilePath dir $ \c_dir -> + withFilePath prefix $ \ c_prefix -> do + failIfZero "getTempFileName" $ + c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf + fname <- peekTString c_buf + return (fname, uid) + ---------------------------------------------------------------- -- HANDLE operations ---------------------------------------------------------------- @@ -354,7 +373,7 @@ createFile' :: ((HANDLE -> Bool) -> String -> IO HANDLE -> IO HANDLE) -> String -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE createFile' f name access share mb_attr mode flag mb_h = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> f (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) @@ -379,19 +398,19 @@ setFileAttributes :: String -> FileAttributeOrFlag -> IO () setFileAttributes name attr = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["SetFileAttributes",show name]) $ c_SetFileAttributes c_name attr getFileAttributes :: String -> IO FileAttributeOrFlag getFileAttributes name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfWithRetry (== 0xFFFFFFFF) (unwords ["GetFileAttributes",show name]) $ c_GetFileAttributes c_name getFileAttributesExStandard :: String -> IO WIN32_FILE_ATTRIBUTE_DATA getFileAttributesExStandard name = alloca $ \res -> do - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ "getFileAttributesExStandard" $ c_GetFileAttributesEx c_name getFileExInfoStandard res peek res @@ -401,6 +420,10 @@ failIfFalseWithRetry_ "GetFileInformationByHandle" $ c_GetFileInformationByHandle h res peek res +replaceFile :: LPCWSTR -> LPCWSTR -> LPCWSTR -> DWORD -> IO () +replaceFile replacedFile replacementFile backupFile replaceFlags = + failIfFalse_ "ReplaceFile" $ c_ReplaceFile replacedFile replacementFile backupFile replaceFlags nullPtr nullPtr + ---------------------------------------------------------------- -- Read/write files ---------------------------------------------------------------- @@ -435,7 +458,7 @@ findFirstChangeNotification :: String -> Bool -> FileNotificationFlag -> IO HANDLE findFirstChangeNotification path watch flag = - withTString path $ \ c_path -> + withFilePath path $ \ c_path -> failIfNull (unwords ["FindFirstChangeNotification",show path]) $ c_FindFirstChangeNotification c_path watch flag @@ -460,7 +483,7 @@ findFirstFile str = do fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) ) withForeignPtr fp_finddata $ \p_finddata -> do - handle <- withTString str $ \tstr -> do + handle <- withFilePath str $ \tstr -> do failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $ c_FindFirstFile tstr p_finddata return (handle, FindData fp_finddata) @@ -486,8 +509,8 @@ defineDosDevice :: DefineDosDeviceFlags -> String -> Maybe String -> IO () defineDosDevice flags name path = - maybeWith withTString path $ \ c_path -> - withTString name $ \ c_name -> + maybeWith withFilePath path $ \ c_path -> + withFilePath name $ \ c_name -> failIfFalse_ "DefineDosDevice" $ c_DefineDosDevice flags c_name c_path ---------------------------------------------------------------- @@ -500,7 +523,7 @@ getDiskFreeSpace :: Maybe String -> IO (DWORD,DWORD,DWORD,DWORD) getDiskFreeSpace path = - maybeWith withTString path $ \ c_path -> + maybeWith withFilePath path $ \ c_path -> alloca $ \ p_sectors -> alloca $ \ p_bytes -> alloca $ \ p_nfree -> @@ -515,8 +538,8 @@ setVolumeLabel :: Maybe String -> Maybe String -> IO () setVolumeLabel path name = - maybeWith withTString path $ \ c_path -> - maybeWith withTString name $ \ c_name -> + maybeWith withFilePath path $ \ c_path -> + maybeWith withFilePath name $ \ c_name -> failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name ---------------------------------------------------------------- diff --git a/System/Win32/File/Internal.hsc b/System/Win32/File/Internal.hsc --- a/System/Win32/File/Internal.hsc +++ b/System/Win32/File/Internal.hsc @@ -26,6 +26,9 @@ ##include "windows_cconv.h" +-- For REPLACEFILE_IGNORE_ACL_ERRORS +#define _WIN32_WINNT 0x0600 + #include #include "alignment.h" @@ -193,6 +196,16 @@ ---------------------------------------------------------------- +type ReplaceType = DWORD + +#{enum ReplaceType, + , rEPLACEFILE_WRITE_THROUGH = REPLACEFILE_WRITE_THROUGH + , rEPLACEFILE_IGNORE_MERGE_ERRORS = REPLACEFILE_IGNORE_MERGE_ERRORS + , rEPLACEFILE_IGNORE_ACL_ERRORS = REPLACEFILE_IGNORE_ACL_ERRORS + } + +---------------------------------------------------------------- + type FileNotificationFlag = DWORD #{enum FileNotificationFlag, @@ -367,6 +380,9 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetBinaryTypeW" c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool +foreign import WINDOWS_CCONV unsafe "windows.h ReplaceFileW" + c_ReplaceFile :: LPCWSTR -> LPCWSTR -> LPCWSTR -> DWORD -> LPVOID -> LPVOID -> IO Bool + ---------------------------------------------------------------- -- HANDLE operations ---------------------------------------------------------------- @@ -398,6 +414,9 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetFileInformationByHandle" c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetTempFileNameW" + c_GetTempFileNameW :: LPCWSTR -> LPCWSTR -> UINT -> LPWSTR -> IO UINT ---------------------------------------------------------------- -- Read/write files diff --git a/System/Win32/MinTTY.hsc b/System/Win32/MinTTY.hsc --- a/System/Win32/MinTTY.hsc +++ b/System/Win32/MinTTY.hsc @@ -15,7 +15,12 @@ -- Stability : provisional -- Portability : portable -- --- A function to check if the current terminal uses MinTTY. +-- 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. -- @@ -50,8 +55,9 @@ #include #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. +-- | 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 @@ -61,8 +67,9 @@ 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. +-- | 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 diff --git a/System/Win32/NamedPipes.hsc b/System/Win32/NamedPipes.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/NamedPipes.hsc @@ -0,0 +1,276 @@ +#include +#include + +#include "namedpipeapi_compat.h" + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} + +-- | For full details on the Windows named pipes API see +-- +-- +module System.Win32.NamedPipes ( + + -- * Named pipe server APIs + createNamedPipe, + pIPE_UNLIMITED_INSTANCES, + + -- ** Parameter types + LPSECURITY_ATTRIBUTES, + OpenMode, + pIPE_ACCESS_DUPLEX, + pIPE_ACCESS_INBOUND, + pIPE_ACCESS_OUTBOUND, + fILE_FLAG_OVERLAPPED, + PipeMode, + pIPE_TYPE_BYTE, + pIPE_TYPE_MESSAGE, + pIPE_READMODE_BYTE, + pIPE_READMODE_MESSAGE, + pIPE_WAIT, + pIPE_NOWAIT, + pIPE_ACCEPT_REMOTE_CLIENTS, + pIPE_REJECT_REMOTE_CLIENTS, + + -- * Named pipe client APIs + -- ** connect to a named pipe + connect, + + -- ** waiting for named pipe instances + waitNamedPipe, + + TimeOut, + nMPWAIT_USE_DEFAULT_WAIT, + nMPWAIT_WAIT_FOREVER, + ) where + + +import Control.Exception +import Control.Monad (when) +import Foreign.C.String (withCString) + +import System.Win32.Types hiding (try) +import System.Win32.File + +-- | The named pipe open mode. +-- +-- This must specify one of: +-- +-- * 'pIPE_ACCESS_DUPLEX' +-- * 'pIPE_ACCESS_INBOUND' +-- * 'pIPE_ACCESS_OUTBOUND' +-- +-- It may also specify: +-- +-- * 'fILE_FLAG_WRITE_THROUGH' +-- * 'fILE_FLAG_OVERLAPPED' +-- +-- It may also specify any combination of: +-- +-- * 'wRITE_DAC' +-- * 'wRITE_OWNER' +-- * 'aCCESS_SYSTEM_SECURITY' +-- +type OpenMode = UINT + +#{enum OpenMode, + , pIPE_ACCESS_DUPLEX = PIPE_ACCESS_DUPLEX + , pIPE_ACCESS_INBOUND = PIPE_ACCESS_INBOUND + , pIPE_ACCESS_OUTBOUND = PIPE_ACCESS_OUTBOUND + } + +-- | The pipe mode. +-- +-- One of the following type modes can be specified. The same type mode must be +-- specified for each instance of the pipe. +-- +-- * 'pIPE_TYPE_BYTE' +-- * 'pIPE_TYPE_MESSAGE' +-- +-- One of the following read modes can be specified. Different instances of the +-- same pipe can specify different read modes. +-- +-- * 'pIPE_READMODE_BYTE' +-- * 'pIPE_READMODE_MESSAGE' +-- +-- One of the following wait modes can be specified. Different instances of the +-- same pipe can specify different wait modes. +-- +-- * 'pIPE_WAIT' +-- * 'pIPE_NOWAIT' +-- +-- One of the following remote-client modes can be specified. Different +-- instances of the same pipe can specify different remote-client modes. +-- +-- * 'pIPE_ACCEPT_REMOTE_CLIENT' +-- * 'pIPE_REJECT_REMOTE_CLIENT' +-- +type PipeMode = UINT + +#{enum PipeMode, + , pIPE_TYPE_BYTE = PIPE_TYPE_BYTE + , pIPE_TYPE_MESSAGE = PIPE_TYPE_MESSAGE + , pIPE_READMODE_BYTE = PIPE_READMODE_BYTE + , pIPE_READMODE_MESSAGE = PIPE_READMODE_MESSAGE + , pIPE_WAIT = PIPE_WAIT + , pIPE_NOWAIT = PIPE_NOWAIT + , pIPE_ACCEPT_REMOTE_CLIENTS = PIPE_ACCEPT_REMOTE_CLIENTS + , pIPE_REJECT_REMOTE_CLIENTS = PIPE_REJECT_REMOTE_CLIENTS + } + +-- | If the 'createNamedPipe' @nMaxInstances@ parameter is +-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created +-- is limited only by the availability of system resources. +pIPE_UNLIMITED_INSTANCES :: DWORD +pIPE_UNLIMITED_INSTANCES = #const PIPE_UNLIMITED_INSTANCES + +-- | Creates an instance of a named pipe and returns a handle for subsequent +-- pipe operations. A named pipe server process uses this function either to +-- create the first instance of a specific named pipe and establish its basic +-- attributes or to create a new instance of an existing named pipe. +-- +-- For full details see +-- +-- +-- To create a named pipe which can be associate with IO completion port on +-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument, +-- e.g. +-- +-- > Win32.createNamedPipe pipeName +-- > (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED) +-- > (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE) +-- > pIPE_UNLIMITED_INSTANCES +-- > 512 +-- > 512 +-- > 0 +-- > NothinROR +-- +-- +createNamedPipe :: String -- ^ A unique pipe name of the form @\\\\.\\pipe\\{pipename}@ + -- The `pipename` part of the name can include any + -- character other than a backslash, including + -- numbers and special characters. The entire pipe + -- name string can be up to 256 characters long. + -- Pipe names are not case sensitive. + -> OpenMode + -> PipeMode + -> DWORD -- ^ nMaxInstances + -> DWORD -- ^ nOutBufferSize + -> DWORD -- ^ nInBufferSize + -> DWORD -- ^ nDefaultTimeOut + -> Maybe LPSECURITY_ATTRIBUTES + -> IO HANDLE +createNamedPipe name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut mb_attr = + withTString name $ \ c_name -> + failIf (==iNVALID_HANDLE_VALUE) ("CreateNamedPipe ('" ++ name ++ "')") $ + c_CreateNamedPipe c_name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut (maybePtr mb_attr) + +foreign import ccall unsafe "windows.h CreateNamedPipeW" + c_CreateNamedPipe :: LPCTSTR + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> LPSECURITY_ATTRIBUTES + -> IO HANDLE + + +-- | Timeout in milliseconds. +-- +-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to +-- 'createNamedPipe' should be used. +-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named +-- pipe instance is available. +-- +type TimeOut = DWORD +#{enum TimeOut, + , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT + , nMPWAIT_WAIT_FOREVER = NMPWAIT_WAIT_FOREVER + } + + +-- | Wait until a named pipe instance is available. If there is no instance at +-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e. +-- @invalid argument (The semaphore timeout period has expired)@ +-- +-- It returns 'True' if there is an available instance, subsequent 'createFile' +-- might still fail, if another thread will take turn and connect before, or if +-- the other end shuts down the name pipe. +-- +-- It returns 'False' if timeout fired. +-- +waitNamedPipe :: String -- ^ pipe name + -> TimeOut -- ^ nTimeOut + -> IO Bool +waitNamedPipe name timeout = + withCString name $ \ c_name -> do + r <- c_WaitNamedPipe c_name timeout + e <- getLastError + if | r -> pure r + | e == eRROR_SEM_TIMEOUT -> pure False + | otherwise -> failWith "waitNamedPipe" e + + +-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import. +foreign import ccall safe "windows.h WaitNamedPipeA" + c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName + -> DWORD -- nTimeOut + -> IO BOOL + +-- | A reliable connect call, as designed in +-- +-- +-- The arguments are passed directly to 'createFile'. +-- +-- Note we pick the more familiar posix naming convention, do not confuse this +-- function with 'connectNamedPipe' (which corresponds to posix 'accept') +-- +connect :: String -- ^ file name + -> AccessMode -- ^ dwDesiredAccess + -> ShareMode -- ^ dwSharedMode + -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes + -> CreateMode -- ^ dwCreationDisposition + -> FileAttributeOrFlag -- ^ dwFlagsAndAttributes + -> Maybe HANDLE -- ^ hTemplateFile + -> IO HANDLE +connect fileName dwDesiredAccess dwSharedMode lpSecurityAttributes dwCreationDisposition dwFlagsAndAttributes hTemplateFile = connectLoop + where + connectLoop = do + -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is + -- caused by `ERROR_SHARING_VIOLATION`. + mh <- try $ + createFile fileName + dwDesiredAccess + dwSharedMode + lpSecurityAttributes + dwCreationDisposition + dwFlagsAndAttributes + hTemplateFile + case mh :: Either IOException HANDLE of + Left e -> do + errorCode <- getLastError + when (errorCode /= eRROR_PIPE_BUSY) + $ throwIO e + -- all pipe instance were busy, wait 20s and retry; we ignore the + -- result + _ <- waitNamedPipe fileName 5000 + connectLoop + + Right h -> pure h + + +-- | [ERROR_PIPE_BUSY](https://docs.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-#ERROR_PIPE_BUSY): +-- all pipe instances are busy. +-- +eRROR_PIPE_BUSY :: ErrCode +eRROR_PIPE_BUSY = #const ERROR_PIPE_BUSY + +eRROR_SEM_TIMEOUT :: ErrCode +eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT diff --git a/System/Win32/Types.hsc b/System/Win32/Types.hsc --- a/System/Win32/Types.hsc +++ b/System/Win32/Types.hsc @@ -28,13 +28,14 @@ import Data.Typeable (cast) import Data.Word (Word8, Word16, Word32, Word64) import Foreign.C.Error (Errno(..), errnoToIOError) -import Foreign.C.String (newCWString, withCWStringLen) +import Foreign.C.String (newCWString, withCWStringLen, CWString) import Foreign.C.String (peekCWString, peekCWStringLen, withCWString) import Foreign.C.Types (CChar, CUChar, CWchar, CInt(..), CIntPtr(..), CUIntPtr) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_) import Foreign.Ptr (FunPtr, Ptr, nullPtr, ptrToIntPtr) import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import Foreign (allocaArray) +import GHC.IO.Exception import GHC.IO.FD (FD(..)) import GHC.IO.Handle.FD (fdToHandle) import GHC.IO.Handle.Types (Handle(..), Handle__(..)) @@ -62,8 +63,6 @@ import Foreign.Marshal.Utils (fromBool, with) import Foreign (peek) import Foreign.Ptr (ptrToWordPtr) -import GHC.IO.Exception (ioException, IOException(..), - IOErrorType(InappropriateType, ResourceBusy)) import GHC.IO.SubSystem (()) import GHC.IO.Handle.Windows import GHC.IO.IOMode @@ -181,6 +180,7 @@ ---------------------------------------------------------------- withTString :: String -> (LPTSTR -> IO a) -> IO a +withFilePath :: FilePath -> (LPTSTR -> IO a) -> IO a withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a peekTString :: LPCTSTR -> IO String peekTStringLen :: (LPCTSTR, Int) -> IO String @@ -189,6 +189,7 @@ -- UTF-16 version: type TCHAR = CWchar withTString = withCWString +withFilePath path = useAsCWStringSafe path withTStringLen = withCWStringLen peekTString = peekCWString peekTStringLen = peekCWStringLen @@ -203,6 +204,25 @@ newTString = newCString -} +-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are +-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660 +useAsCWStringSafe :: FilePath -> (CWString -> IO a) -> IO a +useAsCWStringSafe path f = + if '\NUL' `elem` path + then ioError err + else withCWString path f + where + err = + IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "useAsCWStringSafe" + , ioe_description = "Windows filepaths must not contain internal NUL codepoints." + , ioe_errno = Nothing + , ioe_filename = Just path + } + + ---------------------------------------------------------------- -- Handles ---------------------------------------------------------------- @@ -436,6 +456,8 @@ eRROR_PROC_NOT_FOUND :: ErrCode eRROR_PROC_NOT_FOUND = #const ERROR_PROC_NOT_FOUND +eERROR_ENVVAR_NOT_FOUND :: ErrCode +eERROR_ENVVAR_NOT_FOUND = #const ERROR_ENVVAR_NOT_FOUND errorWin :: String -> IO a errorWin fn_name = do diff --git a/System/Win32/WindowsString/Console.hsc b/System/Win32/WindowsString/Console.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Console.hsc @@ -0,0 +1,180 @@ +{-# LANGUAGE PackageImports #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.Console +-- Copyright : (c) University of Glasgow 2023 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Console API (WindowsString variant) +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Console ( + -- * Console mode + getConsoleMode, + setConsoleMode, + eNABLE_ECHO_INPUT, + eNABLE_EXTENDED_FLAGS, + eNABLE_INSERT_MODE, + eNABLE_LINE_INPUT, + eNABLE_MOUSE_INPUT, + eNABLE_PROCESSED_INPUT, + eNABLE_QUICK_EDIT_MODE, + eNABLE_WINDOW_INPUT, + eNABLE_VIRTUAL_TERMINAL_INPUT, + eNABLE_PROCESSED_OUTPUT, + eNABLE_WRAP_AT_EOL_OUTPUT, + eNABLE_VIRTUAL_TERMINAL_PROCESSING, + dISABLE_NEWLINE_AUTO_RETURN, + eNABLE_LVB_GRID_WORLDWIDE, + -- * Console code pages + getConsoleCP, + setConsoleCP, + getConsoleOutputCP, + setConsoleOutputCP, + -- * Ctrl events + CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT, + generateConsoleCtrlEvent, + -- * Command line + commandLineToArgv, + getCommandLineW, + getArgs, + -- * Screen buffer + CONSOLE_SCREEN_BUFFER_INFO(..), + CONSOLE_SCREEN_BUFFER_INFOEX(..), + COORD(..), + SMALL_RECT(..), + COLORREF, + getConsoleScreenBufferInfo, + getCurrentConsoleScreenBufferInfo, + getConsoleScreenBufferInfoEx, + getCurrentConsoleScreenBufferInfoEx, + + -- * Env + getEnv, + getEnvironment + ) where + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "wincon_compat.h" + +import System.Win32.WindowsString.Types +import System.Win32.WindowsString.String (withTStringBufferLen) +import System.Win32.Console.Internal +import System.Win32.Console hiding (getArgs, commandLineToArgv, getEnv, getEnvironment) +import System.OsString.Windows +import System.OsString.Internal.Types + +import Foreign.C.Types (CWchar) +import Foreign.C.String (CWString) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, peekArray0) +import Foreign.Marshal.Alloc (alloca) +import GHC.IO (bracket) +import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) + +import Prelude hiding (break, length, tail) +import qualified Prelude as P + +#if !MIN_VERSION_filepath(1,5,0) +import Data.Coerce +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC + +tail :: WindowsString -> WindowsString +tail = coerce BC.tail + +break :: (WindowsChar -> Bool) -> WindowsString -> (WindowsString, WindowsString) +break = coerce BC.break +#endif + + +-- | This function can be used to parse command line arguments and return +-- the split up arguments as elements in a list. +commandLineToArgv :: WindowsString -> IO [WindowsString] +commandLineToArgv arg + | arg == mempty = return [] + | otherwise = withTString arg $ \c_arg -> do + alloca $ \c_size -> do + res <- c_CommandLineToArgvW c_arg c_size + size <- peek c_size + args <- peekArray (fromIntegral size) res + _ <- localFree res + mapM peekTString args + +-- | Based on 'GetCommandLineW'. This behaves slightly different +-- than 'System.Environment.getArgs'. See the online documentation: +-- +getArgs :: IO [WindowsString] +getArgs = do + getCommandLineW >>= peekTString >>= commandLineToArgv + + +-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD +getEnv :: WindowsString -> IO (Maybe WindowsString) +getEnv name = + withTString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- c_GetEnvironmentVariableW c_name buf c_len + case c_len' of + 0 -> do + err_code <- getLastError + if err_code == eERROR_ENVVAR_NOT_FOUND + then return Nothing + else errorWin "GetEnvironmentVariableW" + _ | c_len' > fromIntegral maxLength -> + -- shouldn't happen, because we provide maxLength + ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) + | otherwise -> do + let len' = fromIntegral c_len' + Just <$> peekTStringLen (buf, len') + where + -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew + -- max characters (wide chars): 32767 + -- => bytes = 32767 * 2 = 65534 + -- +1 byte for NUL (although not needed I think) + maxLength :: Int + maxLength = 65535 + + +getEnvironment :: IO [(WindowsString, WindowsString)] +getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do + strs <- builder lpwstr + return (divvy <$> strs) + where + divvy :: WindowsString -> (WindowsString, WindowsString) + divvy str = + case break (== unsafeFromChar '=') str of + (xs,ys) + | ys == mempty -> (xs,ys) -- don't barf (like Posix.getEnvironment) + (name, ys) -> let value = tail ys in (name,value) + + builder :: LPWSTR -> IO [WindowsString] + builder ptr = go 0 + where + go :: Int -> IO [WindowsString] + go off = do + (str, l) <- peekCWStringOff ptr off + if l == 0 + then pure [] + else (str:) <$> go (((l + 1) * 2) + off) + + +peekCWStringOff :: CWString -> Int -> IO (WindowsString, Int) +peekCWStringOff cp off = do + cs <- peekArray0 wNUL (cp `plusPtr` off) + return (cWcharsToChars cs, P.length cs) + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> WindowsString +cWcharsToChars = pack . fmap (WindowsChar . fromIntegral) + diff --git a/System/Win32/WindowsString/File.hsc b/System/Win32/WindowsString/File.hsc --- a/System/Win32/WindowsString/File.hsc +++ b/System/Win32/WindowsString/File.hsc @@ -26,6 +26,7 @@ , setFileAttributes , getFileAttributes , getFileAttributesExStandard + , getTempFileName , findFirstChangeNotification , getFindDataFileName , findFirstFile @@ -34,6 +35,7 @@ , setVolumeLabel , getFileExInfoStandard , getFileExMaxInfoLevel + , replaceFile , module System.Win32.File ) where @@ -52,6 +54,7 @@ , setFileAttributes , getFileAttributes , getFileAttributesExStandard + , getTempFileName , findFirstChangeNotification , getFindDataFileName , findFirstFile @@ -60,10 +63,12 @@ , setVolumeLabel , getFileExInfoStandard , getFileExMaxInfoLevel + , replaceFile ) import System.Win32.WindowsString.Types import System.OsString.Windows import Unsafe.Coerce (unsafeCoerce) +import Data.Maybe (fromMaybe) import Foreign hiding (void) @@ -74,59 +79,59 @@ deleteFile :: WindowsString -> IO () deleteFile name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $ c_DeleteFile c_name copyFile :: WindowsString -> WindowsString -> Bool -> IO () copyFile src dest over = - withTString src $ \ c_src -> - withTString dest $ \ c_dest -> + withFilePath src $ \ c_src -> + withFilePath dest $ \ c_dest -> failIfFalseWithRetry_ (unwords ["CopyFile",show src,show dest]) $ c_CopyFile c_src c_dest over moveFile :: WindowsString -> WindowsString -> IO () moveFile src dest = - withTString src $ \ c_src -> - withTString dest $ \ c_dest -> + withFilePath src $ \ c_src -> + withFilePath dest $ \ c_dest -> failIfFalseWithRetry_ (unwords ["MoveFile",show src,show dest]) $ c_MoveFile c_src c_dest moveFileEx :: WindowsString -> Maybe WindowsString -> MoveFileFlag -> IO () moveFileEx src dest flags = - withTString src $ \ c_src -> - maybeWith withTString dest $ \ c_dest -> + withFilePath src $ \ c_src -> + maybeWith withFilePath dest $ \ c_dest -> failIfFalseWithRetry_ (unwords ["MoveFileEx",show src,show dest]) $ c_MoveFileEx c_src c_dest flags setCurrentDirectory :: WindowsString -> IO () setCurrentDirectory name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $ c_SetCurrentDirectory c_name createDirectory :: WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO () createDirectory name mb_attr = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["CreateDirectory",show name]) $ c_CreateDirectory c_name (maybePtr mb_attr) createDirectoryEx :: WindowsString -> WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO () createDirectoryEx template name mb_attr = - withTString template $ \ c_template -> - withTString name $ \ c_name -> + withFilePath template $ \ c_template -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["CreateDirectoryEx",show template,show name]) $ c_CreateDirectoryEx c_template c_name (maybePtr mb_attr) removeDirectory :: WindowsString -> IO () removeDirectory name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $ c_RemoveDirectory c_name getBinaryType :: WindowsString -> IO BinaryType getBinaryType name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> alloca $ \ p_btype -> do failIfFalse_ (unwords ["GetBinaryType",show name]) $ c_GetBinaryType c_name p_btype @@ -138,30 +143,56 @@ createFile :: WindowsString -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE createFile name access share mb_attr mode flag mb_h = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) setFileAttributes :: WindowsString -> FileAttributeOrFlag -> IO () setFileAttributes name attr = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["SetFileAttributes",show name]) $ c_SetFileAttributes c_name attr getFileAttributes :: WindowsString -> IO FileAttributeOrFlag getFileAttributes name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfWithRetry (== 0xFFFFFFFF) (unwords ["GetFileAttributes",show name]) $ c_GetFileAttributes c_name getFileAttributesExStandard :: WindowsString -> IO WIN32_FILE_ATTRIBUTE_DATA getFileAttributesExStandard name = alloca $ \res -> do - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ "getFileAttributesExStandard" $ c_GetFileAttributesEx c_name (unsafeCoerce getFileExInfoStandard) res peek res +-- | Get a unique temporary filename. +-- +-- Calls 'GetTempFileNameW'. +getTempFileName :: WindowsString -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long) + -> WindowsString -- ^ prefix for the temporary file name + -> Maybe UINT -- ^ if 'Nothing', a unique name is generated + -- otherwise a non-zero value is used as the unique part + -> IO (WindowsString, UINT) +getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do + uid <- withFilePath dir $ \c_dir -> + withFilePath prefix $ \ c_prefix -> do + failIfZero "getTempFileName" $ + c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf + fname <- peekTString c_buf + pure (fname, uid) +replaceFile :: WindowsString -> WindowsString -> Maybe WindowsString -> DWORD -> IO () +replaceFile replacedFile replacementFile mBackupFile replaceFlags = + withFilePath replacedFile $ \ c_replacedFile -> + withFilePath replacementFile $ \ c_replacementFile -> + let getResult f = + case mBackupFile of + Nothing -> f nullPtr + Just backupFile -> withFilePath backupFile f + in getResult $ \ c_backupFile -> + failIfFalse_ "ReplaceFile" $ c_ReplaceFile c_replacedFile c_replacementFile c_backupFile replaceFlags nullPtr nullPtr + ---------------------------------------------------------------- -- File Notifications -- @@ -171,7 +202,7 @@ findFirstChangeNotification :: WindowsString -> Bool -> FileNotificationFlag -> IO HANDLE findFirstChangeNotification path watch flag = - withTString path $ \ c_path -> + withFilePath path $ \ c_path -> failIfNull (unwords ["FindFirstChangeNotification",show path]) $ c_FindFirstChangeNotification c_path watch flag @@ -191,7 +222,7 @@ findFirstFile str = do fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) ) withForeignPtr fp_finddata $ \p_finddata -> do - handle <- withTString str $ \tstr -> do + handle <- withFilePath str $ \tstr -> do failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $ c_FindFirstFile tstr p_finddata return (handle, unsafeCoerce (FindData fp_finddata)) @@ -203,8 +234,8 @@ defineDosDevice :: DefineDosDeviceFlags -> WindowsString -> Maybe WindowsString -> IO () defineDosDevice flags name path = - maybeWith withTString path $ \ c_path -> - withTString name $ \ c_name -> + maybeWith withFilePath path $ \ c_path -> + withFilePath name $ \ c_name -> failIfFalse_ "DefineDosDevice" $ c_DefineDosDevice flags c_name c_path ---------------------------------------------------------------- @@ -214,7 +245,7 @@ getDiskFreeSpace :: Maybe WindowsString -> IO (DWORD,DWORD,DWORD,DWORD) getDiskFreeSpace path = - maybeWith withTString path $ \ c_path -> + maybeWith withFilePath path $ \ c_path -> alloca $ \ p_sectors -> alloca $ \ p_bytes -> alloca $ \ p_nfree -> @@ -229,8 +260,8 @@ setVolumeLabel :: Maybe WindowsString -> Maybe WindowsString -> IO () setVolumeLabel path name = - maybeWith withTString path $ \ c_path -> - maybeWith withTString name $ \ c_name -> + maybeWith withFilePath path $ \ c_path -> + maybeWith withFilePath name $ \ c_name -> failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name ---------------------------------------------------------------- diff --git a/System/Win32/WindowsString/String.hs b/System/Win32/WindowsString/String.hs --- a/System/Win32/WindowsString/String.hs +++ b/System/Win32/WindowsString/String.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + {- | Module : System.Win32.String Copyright : 2013 shelarcy @@ -28,7 +30,11 @@ ) import System.Win32.WindowsString.Types import System.OsString.Internal.Types -import qualified System.OsPath.Data.ByteString.Short as SBS +#if MIN_VERSION_filepath(1,5,0) +import qualified "os-string" System.OsString.Data.ByteString.Short as SBS +#else +import qualified "filepath" System.OsPath.Data.ByteString.Short as SBS +#endif import Data.Word (Word8) -- | Marshal a dummy Haskell string into a NUL terminated C wide string diff --git a/System/Win32/WindowsString/Types.hsc b/System/Win32/WindowsString/Types.hsc --- a/System/Win32/WindowsString/Types.hsc +++ b/System/Win32/WindowsString/Types.hsc @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : System.Win32.Types @@ -36,11 +39,25 @@ , errorWin , failWith , try + , withFilePath + , useAsCWStringSafe ) -import System.OsString.Windows +import Foreign.C.Types (CUIntPtr(..)) +import Foreign.C.String (CWString) +import qualified System.OsPath.Windows as WS +import System.OsPath.Windows (WindowsPath) +import System.OsString.Windows (decodeWith, encodeWith) import System.OsString.Internal.Types -import System.OsPath.Data.ByteString.Short.Word16 ( +#if MIN_VERSION_filepath(1,5,0) +import "os-string" System.OsString.Encoding.Internal (decodeWithBaseWindows) +import qualified "os-string" System.OsString.Data.ByteString.Short.Word16 as SBS +import "os-string" System.OsString.Data.ByteString.Short.Word16 ( +#else +import "filepath" System.OsPath.Encoding.Internal (decodeWithBaseWindows) +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as SBS +import "filepath" System.OsPath.Data.ByteString.Short.Word16 ( +#endif packCWString, packCWStringLen, useAsCWString, @@ -56,7 +73,9 @@ import Foreign.Ptr ( Ptr ) import Foreign.C.Error ( errnoToIOError ) import Control.Exception ( throwIO ) +import qualified Control.Exception as EX import GHC.Ptr (castPtr) +import GHC.IO.Exception #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) @@ -67,6 +86,7 @@ #include #include +#include ##include "windows_cconv.h" @@ -75,6 +95,7 @@ ---------------------------------------------------------------- withTString :: WindowsString -> (LPTSTR -> IO a) -> IO a +withFilePath :: WindowsPath -> (LPTSTR -> IO a) -> IO a withTStringLen :: WindowsString -> ((LPTSTR, Int) -> IO a) -> IO a peekTString :: LPCTSTR -> IO WindowsString peekTStringLen :: (LPCTSTR, Int) -> IO WindowsString @@ -83,10 +104,37 @@ -- UTF-16 version: -- the casts are from 'Ptr Word16' to 'Ptr CWchar', which is safe withTString (WindowsString str) f = useAsCWString str (\ptr -> f (castPtr ptr)) +withFilePath path = useAsCWStringSafe path withTStringLen (WindowsString str) f = useAsCWStringLen str (\(ptr, len) -> f (castPtr ptr, len)) peekTString = fmap WindowsString . packCWString . castPtr peekTStringLen = fmap WindowsString . packCWStringLen . first castPtr newTString (WindowsString str) = fmap castPtr $ newCWString str + +foreign import ccall unsafe "wchar.h wcslen" c_wcslen + :: CWString -> IO SIZE_T + +-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are +-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660 +useAsCWStringSafe :: WindowsPath -> (CWString -> IO a) -> IO a +useAsCWStringSafe wp@(WS path) f = useAsCWString path $ \(castPtr -> ptr) -> do + let len = SBS.numWord16 path + clen <- c_wcslen ptr + if clen == fromIntegral len + then f ptr + else do + path' <- either (const (_toStr wp)) id <$> (EX.try @IOException) (decodeWithBaseWindows path) + ioError (err path') + where + _toStr = fmap WS.toChar . WS.unpack + err path' = + IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "useAsCWStringSafe" + , ioe_description = "Windows filepaths must not contain internal NUL codepoints." + , ioe_errno = Nothing + , ioe_filename = Just path' + } ---------------------------------------------------------------- -- Errors diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: Win32 -version: 2.13.4.0 +version: 2.14.2.2 license: BSD3 license-file: LICENSE author: Alastair Reid, shelarcy, Tamar Christina @@ -11,12 +12,24 @@ synopsis: A binding to Windows Win32 API. description: This library contains direct bindings to the Windows Win32 APIs for Haskell. build-type: Simple -cabal-version: 2.0 extra-source-files: include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h include/Win32Aux.h include/win32debug.h include/alignment.h +extra-doc-files: changelog.md +tested-with: + GHC == 9.2.7, + GHC == 9.4.5, + GHC == 9.6.7, + GHC == 9.8.4, + GHC == 9.10.1, + GHC == 9.12.1 +flag os-string + description: Use the new os-string package + default: False + manual: False + Library default-language: Haskell2010 default-extensions: ForeignFunctionInterface, CPP @@ -32,7 +45,10 @@ -- AFPP support if impl(ghc >= 8.0) - build-depends: filepath >= 1.4.100.0 + if flag(os-string) + build-depends: filepath >= 1.5.0.0, os-string >= 2.0.0 + else + build-depends: filepath >= 1.4.100.0 && < 1.5.0.0 -- Black list hsc2hs 0.68.6 which is horribly broken. build-tool-depends: hsc2hs:hsc2hs > 0 && < 0.68.6 || > 0.68.6 @@ -77,6 +93,7 @@ System.Win32.Event System.Win32.File System.Win32.FileMapping + System.Win32.NamedPipes System.Win32.Info System.Win32.Path System.Win32.Mem @@ -112,6 +129,7 @@ -- AFPP support if impl(ghc >= 8.0) exposed-modules: + System.Win32.WindowsString.Console System.Win32.WindowsString.Types System.Win32.WindowsString.DebugApi System.Win32.WindowsString.DLL @@ -127,6 +145,7 @@ System.Win32.WindowsString.Utils other-modules: + System.Win32.Console.Internal System.Win32.DebugApi.Internal System.Win32.DLL.Internal System.Win32.File.Internal @@ -142,8 +161,7 @@ "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32" ghc-options: -Wall include-dirs: include - includes: "alphablend.h", "diatemp.h", "dumpBMP.h", "ellipse.h", "errors.h", "HsGDI.h", "HsWin32.h", "Win32Aux.h", "win32debug.h", "windows_cconv.h", "WndProc.h", "alignment.h" - install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "wincon_compat.h", "winternl_compat.h", "winuser_compat.h", "winreg_compat.h", "tlhelp32_compat.h", "winnls_compat.h", "winnt_compat.h" + install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "wincon_compat.h", "winternl_compat.h", "winuser_compat.h", "winreg_compat.h", "tlhelp32_compat.h", "winnls_compat.h", "winnt_compat.h", "namedpipeapi_compat.h" c-sources: cbits/HsGDI.c cbits/HsWin32.c @@ -157,4 +175,4 @@ source-repository head type: git - location: git://github.com/haskell/win32 + location: https://github.com/haskell/win32 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,33 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) +## 2.14.2.2 May 2026 + +* Fix version bounds for older GHC and drop numeric underscore + +## 2.14.2.1 June 2025 + +* Fix compilation of `ReplaceFileW` on some GHC versions [#245](https://github.com/haskell/win32/issues/245) + +## 2.14.2.0 May 2025 + +* Add ReplaceFileW +* Add support for Windows on Arm +* Add ReadConsoleInput + +## 2.14.1.0 November 2024 + +* Add getTempFileName +* Add WindowsString variant for getEnv etc +* Implement getEnv and getEnvironment + +## 2.14.0.0 January 2023 + +* Add support for named pipes [#220](https://github.com/haskell/win32/pull/220) +* Ensure that FilePaths don't contain interior NULs wrt [#218](https://github.com/haskell/win32/pull/218) +* Add support for GetCommandLineW [#218](https://github.com/haskell/win32/pull/221) +* Support filepath >= 1.5.0.0 and os-string [#226](https://github.com/haskell/win32/pull/226) +* Remove unused imports [#225](https://github.com/haskell/win32/pull/225) + ## 2.13.4.0 October 2022 * Add support for semaphores with `System.Win32.Semaphore` (See #214). diff --git a/include/namedpipeapi_compat.h b/include/namedpipeapi_compat.h new file mode 100644 --- /dev/null +++ b/include/namedpipeapi_compat.h @@ -0,0 +1,16 @@ +/* The version of wincon.h provided by the version of MSYS2 included with x86 + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef NAMEDPIPEAPI_COMPAT_H +#define NAMEDPIPEAPI_COMPAT_H + +#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 +# +#else + +#define PIPE_ACCEPT_REMOTE_CLIENTS 0x0 +#define PIPE_REJECT_REMOTE_CLIENTS 0x8 +#endif /* GHC version check */ +#endif /* NAMEDPIPEAPI_COMPAT_H */ diff --git a/include/tlhelp32_compat.h b/include/tlhelp32_compat.h --- a/include/tlhelp32_compat.h +++ b/include/tlhelp32_compat.h @@ -4,7 +4,7 @@ * tlhelp32.h is not included in MinGW, which was shipped with the 32-bit * Windows version of GHC prior to the 7.10.3 release. */ -#if __GLASGOW_HASKELL__ > 708 +#if __GLASGOW_HASKELL__ >= 710 #else // Declarations from tlhelp32.h that Win32 requires #include diff --git a/include/windows_cconv.h b/include/windows_cconv.h --- a/include/windows_cconv.h +++ b/include/windows_cconv.h @@ -3,7 +3,7 @@ #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch