Win32 2.13.4.0 → 2.14.0.0
raw patch · 13 files changed
+740/−208 lines, 13 filesdep +os-stringdep ~filepath
Dependencies added: os-string
Dependency ranges changed: filepath
Files
- System/Win32/Console.hsc +11/−145
- System/Win32/Console/Internal.hsc +181/−0
- System/Win32/File.hsc +24/−24
- System/Win32/MinTTY.hsc +12/−5
- System/Win32/NamedPipes.hsc +277/−0
- System/Win32/Types.hsc +23/−3
- System/Win32/WindowsString/Console.hsc +91/−0
- System/Win32/WindowsString/File.hsc +24/−24
- System/Win32/WindowsString/String.hs +7/−1
- System/Win32/WindowsString/Types.hsc +50/−2
- Win32.cabal +16/−4
- changelog.md +8/−0
- include/namedpipeapi_compat.h +16/−0
System/Win32/Console.hsc view
@@ -45,6 +45,8 @@ generateConsoleCtrlEvent, -- * Command line commandLineToArgv, + getCommandLineW, + getArgs, -- * Screen buffer CONSOLE_SCREEN_BUFFER_INFO(..), CONSOLE_SCREEN_BUFFER_INFOEX(..), @@ -63,22 +65,16 @@ #include "wincon_compat.h" import System.Win32.Types +import System.Win32.Console.Internal import Graphics.Win32.Misc import Graphics.Win32.GDI.Types (COLORREF) -import Foreign.C.Types (CInt(..)) -import Foreign.C.String (withCWString, CWString) -import Foreign.Ptr (Ptr, plusPtr) +import Foreign.C.String (withCWString) import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Array (peekArray, pokeArray) +import Foreign.Marshal.Array (peekArray) 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 +103,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 +122,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
+ System/Win32/Console/Internal.hsc view
@@ -0,0 +1,181 @@+#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(..))+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++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+
System/Win32/File.hsc view
@@ -287,59 +287,59 @@ 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@@ -354,7 +354,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 +379,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@@ -435,7 +435,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 +460,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 +486,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 +500,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 +515,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/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,277 @@+#include <fcntl.h>+#include <windows.h>++#include "namedpipeapi_compat.h"++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NumericUnderscores #-}++-- | 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 5_000+ 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@@ -202,6 +203,25 @@ peekTStringLen = peekCStringLen 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
+ System/Win32/WindowsString/Console.hsc view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------+-- |+-- 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+ ) where++#include <windows.h>+#include "alignment.h"+##include "windows_cconv.h"+#include "wincon_compat.h"++import System.Win32.WindowsString.Types+import System.Win32.Console.Internal+import System.Win32.Console hiding (getArgs, commandLineToArgv)+import System.OsString.Windows++import Foreign.Storable (Storable(..))+import Foreign.Marshal.Array (peekArray)+import Foreign.Marshal.Alloc (alloca)+++-- | 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+
System/Win32/WindowsString/File.hsc view
@@ -74,59 +74,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,25 +138,25 @@ 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 @@ -171,7 +171,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 +191,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 +203,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 +214,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 +229,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.0.0 license: BSD3 license-file: LICENSE author: Alastair Reid, shelarcy, Tamar Christina@@ -11,12 +12,17 @@ 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 +flag os-string+ description: Use the new os-string package+ default: False+ manual: False+ Library default-language: Haskell2010 default-extensions: ForeignFunctionInterface, CPP@@ -32,7 +38,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 +86,7 @@ System.Win32.Event System.Win32.File System.Win32.FileMapping+ System.Win32.NamedPipes System.Win32.Info System.Win32.Path System.Win32.Mem@@ -112,6 +122,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 +138,7 @@ System.Win32.WindowsString.Utils other-modules:+ System.Win32.Console.Internal System.Win32.DebugApi.Internal System.Win32.DLL.Internal System.Win32.File.Internal@@ -143,7 +155,7 @@ 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
changelog.md view
@@ -1,5 +1,13 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) +## 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 */