Win32 2.13.4.0 → 2.14.2.2
raw patch · 18 files changed
Files
- Graphics/Win32/Window.hsc +2/−2
- System/Win32/Console.hsc +108/−146
- System/Win32/Console/Internal.hsc +336/−0
- System/Win32/DebugApi.hsc +53/−5
- System/Win32/File.hsc +47/−24
- System/Win32/File/Internal.hsc +19/−0
- System/Win32/MinTTY.hsc +12/−5
- System/Win32/NamedPipes.hsc +276/−0
- System/Win32/Types.hsc +25/−3
- System/Win32/WindowsString/Console.hsc +180/−0
- System/Win32/WindowsString/File.hsc +55/−24
- System/Win32/WindowsString/String.hs +7/−1
- System/Win32/WindowsString/Types.hsc +50/−2
- Win32.cabal +24/−6
- changelog.md +28/−0
- include/namedpipeapi_compat.h +16/−0
- include/tlhelp32_compat.h +1/−1
- include/windows_cconv.h +1/−1
Graphics/Win32/Window.hsc view
@@ -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
System/Win32/Console.hsc view
@@ -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 <windows.h> @@ -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: +-- <https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getcommandlinew> +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
+ System/Win32/Console/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- Internals for Console modules.+--+-----------------------------------------------------------------------------++module System.Win32.Console.Internal where++#include <windows.h>+#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
System/Win32/DebugApi.hsc view
@@ -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
System/Win32/File.hsc view
@@ -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 ----------------------------------------------------------------
System/Win32/File/Internal.hsc view
@@ -26,6 +26,9 @@ ##include "windows_cconv.h" +-- For REPLACEFILE_IGNORE_ACL_ERRORS+#define _WIN32_WINNT 0x0600+ #include <windows.h> #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
System/Win32/MinTTY.hsc view
@@ -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 <windows.h> #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
+ System/Win32/NamedPipes.hsc view
@@ -0,0 +1,276 @@+#include <fcntl.h>+#include <windows.h>++#include "namedpipeapi_compat.h"++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}++-- | For full details on the Windows named pipes API see+-- <https://docs.microsoft.com/en-us/windows/desktop/ipc/named-pipes>+--+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+-- <https://docs.microsoft.com/en-us/windows/desktop/api/winbase/nf-winbase-createnamedpipea>+--+-- 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+-- <https://docs.microsoft.com/en-us/windows/win32/ipc/named-pipe-client>+--+-- 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
System/Win32/Types.hsc view
@@ -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
+ System/Win32/WindowsString/Console.hsc view
@@ -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 <ei@vuokko.info>+-- 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 <windows.h>+#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:+-- <https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getcommandlinew>+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)+
System/Win32/WindowsString/File.hsc view
@@ -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 ----------------------------------------------------------------
System/Win32/WindowsString/String.hs view
@@ -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
System/Win32/WindowsString/Types.hsc view
@@ -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 <fcntl.h> #include <windows.h> +#include <wchar.h> ##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
Win32.cabal view
@@ -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
changelog.md view
@@ -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).
+ include/namedpipeapi_compat.h view
@@ -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 */
include/tlhelp32_compat.h view
@@ -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 <windows.h>
include/windows_cconv.h view
@@ -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