diff --git a/System/Win32/Console.hsc b/System/Win32/Console.hsc --- a/System/Win32/Console.hsc +++ b/System/Win32/Console.hsc @@ -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: +-- +getArgs :: IO [String] +getArgs = do + getCommandLineW >>= peekTString >>= commandLineToArgv getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO getConsoleScreenBufferInfo h = alloca $ \ptr -> do diff --git a/System/Win32/Console/Internal.hsc b/System/Win32/Console/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Console/Internal.hsc @@ -0,0 +1,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 +-- Stability : provisional +-- Portability : portable +-- +-- Internals for Console modules. +-- +----------------------------------------------------------------------------- + +module System.Win32.Console.Internal where + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "wincon_compat.h" + +import System.Win32.Types +import Graphics.Win32.GDI.Types (COLORREF) + +import Foreign.C.Types (CInt(..)) +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 + diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -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 ---------------------------------------------------------------- diff --git a/System/Win32/MinTTY.hsc b/System/Win32/MinTTY.hsc --- a/System/Win32/MinTTY.hsc +++ b/System/Win32/MinTTY.hsc @@ -15,7 +15,12 @@ -- Stability : provisional -- Portability : portable -- --- A function to check if the current terminal uses MinTTY. +-- A function to check if the current terminal uses an old version of MinTTY +-- that emulates a TTY. Note, however, that this does not check for more recent +-- versions of MinTTY that use the native Windows console PTY directly. The old +-- approach (where MinTTY emulates a TTY) sometimes requires different +-- approaches to handling keyboard inputs. +-- -- Much of this code was originally authored by Phil Ruffwind and the -- git-for-windows project. -- @@ -50,8 +55,9 @@ #include #include "winternl_compat.h" --- | Returns 'True' if the current process's standard error is attached to a --- MinTTY console (e.g., Cygwin or MSYS). Returns 'False' otherwise. +-- | Returns 'True' if the current process's standard error is attached to an +-- emulated MinTTY console (e.g., Cygwin or MSYS that use an old version of +-- MinTTY). Returns 'False' otherwise. isMinTTY :: IO Bool isMinTTY = do h <- getStdHandle sTD_ERROR_HANDLE @@ -61,8 +67,9 @@ then return False else isMinTTYHandle h --- | Returns 'True' is the given handle is attached to a MinTTY console --- (e.g., Cygwin or MSYS). Returns 'False' otherwise. +-- | Returns 'True' is the given handle is attached to an emulated MinTTY +-- console (e.g., Cygwin or MSYS that use an old version of MinTTY). Returns +-- 'False' otherwise. isMinTTYHandle :: HANDLE -> IO Bool isMinTTYHandle h = do fileType <- getFileType h diff --git a/System/Win32/NamedPipes.hsc b/System/Win32/NamedPipes.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/NamedPipes.hsc @@ -0,0 +1,277 @@ +#include +#include + +#include "namedpipeapi_compat.h" + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | For full details on the Windows named pipes API see +-- +-- +module System.Win32.NamedPipes ( + + -- * Named pipe server APIs + createNamedPipe, + pIPE_UNLIMITED_INSTANCES, + + -- ** Parameter types + LPSECURITY_ATTRIBUTES, + OpenMode, + pIPE_ACCESS_DUPLEX, + pIPE_ACCESS_INBOUND, + pIPE_ACCESS_OUTBOUND, + fILE_FLAG_OVERLAPPED, + PipeMode, + pIPE_TYPE_BYTE, + pIPE_TYPE_MESSAGE, + pIPE_READMODE_BYTE, + pIPE_READMODE_MESSAGE, + pIPE_WAIT, + pIPE_NOWAIT, + pIPE_ACCEPT_REMOTE_CLIENTS, + pIPE_REJECT_REMOTE_CLIENTS, + + -- * Named pipe client APIs + -- ** connect to a named pipe + connect, + + -- ** waiting for named pipe instances + waitNamedPipe, + + TimeOut, + nMPWAIT_USE_DEFAULT_WAIT, + nMPWAIT_WAIT_FOREVER, + ) where + + +import Control.Exception +import Control.Monad (when) +import Foreign.C.String (withCString) + +import System.Win32.Types hiding (try) +import System.Win32.File + +-- | The named pipe open mode. +-- +-- This must specify one of: +-- +-- * 'pIPE_ACCESS_DUPLEX' +-- * 'pIPE_ACCESS_INBOUND' +-- * 'pIPE_ACCESS_OUTBOUND' +-- +-- It may also specify: +-- +-- * 'fILE_FLAG_WRITE_THROUGH' +-- * 'fILE_FLAG_OVERLAPPED' +-- +-- It may also specify any combination of: +-- +-- * 'wRITE_DAC' +-- * 'wRITE_OWNER' +-- * 'aCCESS_SYSTEM_SECURITY' +-- +type OpenMode = UINT + +#{enum OpenMode, + , pIPE_ACCESS_DUPLEX = PIPE_ACCESS_DUPLEX + , pIPE_ACCESS_INBOUND = PIPE_ACCESS_INBOUND + , pIPE_ACCESS_OUTBOUND = PIPE_ACCESS_OUTBOUND + } + +-- | The pipe mode. +-- +-- One of the following type modes can be specified. The same type mode must be +-- specified for each instance of the pipe. +-- +-- * 'pIPE_TYPE_BYTE' +-- * 'pIPE_TYPE_MESSAGE' +-- +-- One of the following read modes can be specified. Different instances of the +-- same pipe can specify different read modes. +-- +-- * 'pIPE_READMODE_BYTE' +-- * 'pIPE_READMODE_MESSAGE' +-- +-- One of the following wait modes can be specified. Different instances of the +-- same pipe can specify different wait modes. +-- +-- * 'pIPE_WAIT' +-- * 'pIPE_NOWAIT' +-- +-- One of the following remote-client modes can be specified. Different +-- instances of the same pipe can specify different remote-client modes. +-- +-- * 'pIPE_ACCEPT_REMOTE_CLIENT' +-- * 'pIPE_REJECT_REMOTE_CLIENT' +-- +type PipeMode = UINT + +#{enum PipeMode, + , pIPE_TYPE_BYTE = PIPE_TYPE_BYTE + , pIPE_TYPE_MESSAGE = PIPE_TYPE_MESSAGE + , pIPE_READMODE_BYTE = PIPE_READMODE_BYTE + , pIPE_READMODE_MESSAGE = PIPE_READMODE_MESSAGE + , pIPE_WAIT = PIPE_WAIT + , pIPE_NOWAIT = PIPE_NOWAIT + , pIPE_ACCEPT_REMOTE_CLIENTS = PIPE_ACCEPT_REMOTE_CLIENTS + , pIPE_REJECT_REMOTE_CLIENTS = PIPE_REJECT_REMOTE_CLIENTS + } + +-- | If the 'createNamedPipe' @nMaxInstances@ parameter is +-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created +-- is limited only by the availability of system resources. +pIPE_UNLIMITED_INSTANCES :: DWORD +pIPE_UNLIMITED_INSTANCES = #const PIPE_UNLIMITED_INSTANCES + +-- | Creates an instance of a named pipe and returns a handle for subsequent +-- pipe operations. A named pipe server process uses this function either to +-- create the first instance of a specific named pipe and establish its basic +-- attributes or to create a new instance of an existing named pipe. +-- +-- For full details see +-- +-- +-- To create a named pipe which can be associate with IO completion port on +-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument, +-- e.g. +-- +-- > Win32.createNamedPipe pipeName +-- > (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED) +-- > (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE) +-- > pIPE_UNLIMITED_INSTANCES +-- > 512 +-- > 512 +-- > 0 +-- > NothinROR +-- +-- +createNamedPipe :: String -- ^ A unique pipe name of the form @\\.\pipe\{pipename}@ + -- The `pipename` part of the name can include any + -- character other than a backslash, including + -- numbers and special characters. The entire pipe + -- name string can be up to 256 characters long. + -- Pipe names are not case sensitive. + -> OpenMode + -> PipeMode + -> DWORD -- ^ nMaxInstances + -> DWORD -- ^ nOutBufferSize + -> DWORD -- ^ nInBufferSize + -> DWORD -- ^ nDefaultTimeOut + -> Maybe LPSECURITY_ATTRIBUTES + -> IO HANDLE +createNamedPipe name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut mb_attr = + withTString name $ \ c_name -> + failIf (==iNVALID_HANDLE_VALUE) ("CreateNamedPipe ('" ++ name ++ "')") $ + c_CreateNamedPipe c_name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut (maybePtr mb_attr) + +foreign import ccall unsafe "windows.h CreateNamedPipeW" + c_CreateNamedPipe :: LPCTSTR + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> LPSECURITY_ATTRIBUTES + -> IO HANDLE + + +-- | Timeout in milliseconds. +-- +-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to +-- 'createNamedPipe' should be used. +-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named +-- pipe instance is available. +-- +type TimeOut = DWORD +#{enum TimeOut, + , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT + , nMPWAIT_WAIT_FOREVER = NMPWAIT_WAIT_FOREVER + } + + +-- | Wait until a named pipe instance is available. If there is no instance at +-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e. +-- @invalid argument (The semaphore timeout period has expired)@ +-- +-- It returns 'True' if there is an available instance, subsequent 'createFile' +-- might still fail, if another thread will take turn and connect before, or if +-- the other end shuts down the name pipe. +-- +-- It returns 'False' if timeout fired. +-- +waitNamedPipe :: String -- ^ pipe name + -> TimeOut -- ^ nTimeOut + -> IO Bool +waitNamedPipe name timeout = + withCString name $ \ c_name -> do + r <- c_WaitNamedPipe c_name timeout + e <- getLastError + if | r -> pure r + | e == eRROR_SEM_TIMEOUT -> pure False + | otherwise -> failWith "waitNamedPipe" e + + +-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import. +foreign import ccall safe "windows.h WaitNamedPipeA" + c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName + -> DWORD -- nTimeOut + -> IO BOOL + +-- | A reliable connect call, as designed in +-- +-- +-- The arguments are passed directly to 'createFile'. +-- +-- Note we pick the more familiar posix naming convention, do not confuse this +-- function with 'connectNamedPipe' (which corresponds to posix 'accept') +-- +connect :: String -- ^ file name + -> AccessMode -- ^ dwDesiredAccess + -> ShareMode -- ^ dwSharedMode + -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes + -> CreateMode -- ^ dwCreationDisposition + -> FileAttributeOrFlag -- ^ dwFlagsAndAttributes + -> Maybe HANDLE -- ^ hTemplateFile + -> IO HANDLE +connect fileName dwDesiredAccess dwSharedMode lpSecurityAttributes dwCreationDisposition dwFlagsAndAttributes hTemplateFile = connectLoop + where + connectLoop = do + -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is + -- caused by `ERROR_SHARING_VIOLATION`. + mh <- try $ + createFile fileName + dwDesiredAccess + dwSharedMode + lpSecurityAttributes + dwCreationDisposition + dwFlagsAndAttributes + hTemplateFile + case mh :: Either IOException HANDLE of + Left e -> do + errorCode <- getLastError + when (errorCode /= eRROR_PIPE_BUSY) + $ throwIO e + -- all pipe instance were busy, wait 20s and retry; we ignore the + -- result + _ <- waitNamedPipe fileName 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 diff --git a/System/Win32/Types.hsc b/System/Win32/Types.hsc --- a/System/Win32/Types.hsc +++ b/System/Win32/Types.hsc @@ -28,13 +28,14 @@ import Data.Typeable (cast) import Data.Word (Word8, Word16, Word32, Word64) import Foreign.C.Error (Errno(..), errnoToIOError) -import Foreign.C.String (newCWString, withCWStringLen) +import Foreign.C.String (newCWString, withCWStringLen, CWString) import Foreign.C.String (peekCWString, peekCWStringLen, withCWString) import Foreign.C.Types (CChar, CUChar, CWchar, CInt(..), CIntPtr(..), CUIntPtr) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_) import Foreign.Ptr (FunPtr, Ptr, nullPtr, ptrToIntPtr) import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import Foreign (allocaArray) +import GHC.IO.Exception import GHC.IO.FD (FD(..)) import GHC.IO.Handle.FD (fdToHandle) import GHC.IO.Handle.Types (Handle(..), Handle__(..)) @@ -62,8 +63,6 @@ import Foreign.Marshal.Utils (fromBool, with) import Foreign (peek) import Foreign.Ptr (ptrToWordPtr) -import GHC.IO.Exception (ioException, IOException(..), - IOErrorType(InappropriateType, ResourceBusy)) import GHC.IO.SubSystem (()) import GHC.IO.Handle.Windows import GHC.IO.IOMode @@ -181,6 +180,7 @@ ---------------------------------------------------------------- withTString :: String -> (LPTSTR -> IO a) -> IO a +withFilePath :: FilePath -> (LPTSTR -> IO a) -> IO a withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a peekTString :: LPCTSTR -> IO String peekTStringLen :: (LPCTSTR, Int) -> IO String @@ -189,6 +189,7 @@ -- UTF-16 version: type TCHAR = CWchar withTString = withCWString +withFilePath path = useAsCWStringSafe path withTStringLen = withCWStringLen peekTString = peekCWString peekTStringLen = peekCWStringLen @@ -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 diff --git a/System/Win32/WindowsString/Console.hsc b/System/Win32/WindowsString/Console.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Console.hsc @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.Console +-- Copyright : (c) University of Glasgow 2023 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Console API (WindowsString variant) +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Console ( + -- * Console mode + getConsoleMode, + setConsoleMode, + eNABLE_ECHO_INPUT, + eNABLE_EXTENDED_FLAGS, + eNABLE_INSERT_MODE, + eNABLE_LINE_INPUT, + eNABLE_MOUSE_INPUT, + eNABLE_PROCESSED_INPUT, + eNABLE_QUICK_EDIT_MODE, + eNABLE_WINDOW_INPUT, + eNABLE_VIRTUAL_TERMINAL_INPUT, + eNABLE_PROCESSED_OUTPUT, + eNABLE_WRAP_AT_EOL_OUTPUT, + eNABLE_VIRTUAL_TERMINAL_PROCESSING, + dISABLE_NEWLINE_AUTO_RETURN, + eNABLE_LVB_GRID_WORLDWIDE, + -- * Console code pages + getConsoleCP, + setConsoleCP, + getConsoleOutputCP, + setConsoleOutputCP, + -- * Ctrl events + CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT, + generateConsoleCtrlEvent, + -- * Command line + commandLineToArgv, + getCommandLineW, + getArgs, + -- * Screen buffer + CONSOLE_SCREEN_BUFFER_INFO(..), + CONSOLE_SCREEN_BUFFER_INFOEX(..), + COORD(..), + SMALL_RECT(..), + COLORREF, + getConsoleScreenBufferInfo, + getCurrentConsoleScreenBufferInfo, + getConsoleScreenBufferInfoEx, + getCurrentConsoleScreenBufferInfoEx + ) where + +#include +#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: +-- +getArgs :: IO [WindowsString] +getArgs = do + getCommandLineW >>= peekTString >>= commandLineToArgv + diff --git a/System/Win32/WindowsString/File.hsc b/System/Win32/WindowsString/File.hsc --- a/System/Win32/WindowsString/File.hsc +++ b/System/Win32/WindowsString/File.hsc @@ -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 ---------------------------------------------------------------- diff --git a/System/Win32/WindowsString/String.hs b/System/Win32/WindowsString/String.hs --- a/System/Win32/WindowsString/String.hs +++ b/System/Win32/WindowsString/String.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + {- | Module : System.Win32.String Copyright : 2013 shelarcy @@ -28,7 +30,11 @@ ) import System.Win32.WindowsString.Types import System.OsString.Internal.Types -import qualified System.OsPath.Data.ByteString.Short as SBS +#if MIN_VERSION_filepath(1, 5, 0) +import qualified "os-string" System.OsString.Data.ByteString.Short as SBS +#else +import qualified "filepath" System.OsPath.Data.ByteString.Short as SBS +#endif import Data.Word (Word8) -- | Marshal a dummy Haskell string into a NUL terminated C wide string diff --git a/System/Win32/WindowsString/Types.hsc b/System/Win32/WindowsString/Types.hsc --- a/System/Win32/WindowsString/Types.hsc +++ b/System/Win32/WindowsString/Types.hsc @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : System.Win32.Types @@ -36,11 +39,25 @@ , errorWin , failWith , try + , withFilePath + , useAsCWStringSafe ) -import System.OsString.Windows +import Foreign.C.Types (CUIntPtr(..)) +import Foreign.C.String (CWString) +import qualified System.OsPath.Windows as WS +import System.OsPath.Windows (WindowsPath) +import System.OsString.Windows (decodeWith, encodeWith) import System.OsString.Internal.Types -import System.OsPath.Data.ByteString.Short.Word16 ( +#if MIN_VERSION_filepath(1, 5, 0) +import "os-string" System.OsString.Encoding.Internal (decodeWithBaseWindows) +import qualified "os-string" System.OsString.Data.ByteString.Short.Word16 as SBS +import "os-string" System.OsString.Data.ByteString.Short.Word16 ( +#else +import "filepath" System.OsPath.Encoding.Internal (decodeWithBaseWindows) +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as SBS +import "filepath" System.OsPath.Data.ByteString.Short.Word16 ( +#endif packCWString, packCWStringLen, useAsCWString, @@ -56,7 +73,9 @@ import Foreign.Ptr ( Ptr ) import Foreign.C.Error ( errnoToIOError ) import Control.Exception ( throwIO ) +import qualified Control.Exception as EX import GHC.Ptr (castPtr) +import GHC.IO.Exception #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) @@ -67,6 +86,7 @@ #include #include +#include ##include "windows_cconv.h" @@ -75,6 +95,7 @@ ---------------------------------------------------------------- withTString :: WindowsString -> (LPTSTR -> IO a) -> IO a +withFilePath :: WindowsPath -> (LPTSTR -> IO a) -> IO a withTStringLen :: WindowsString -> ((LPTSTR, Int) -> IO a) -> IO a peekTString :: LPCTSTR -> IO WindowsString peekTStringLen :: (LPCTSTR, Int) -> IO WindowsString @@ -83,10 +104,37 @@ -- UTF-16 version: -- the casts are from 'Ptr Word16' to 'Ptr CWchar', which is safe withTString (WindowsString str) f = useAsCWString str (\ptr -> f (castPtr ptr)) +withFilePath path = useAsCWStringSafe path withTStringLen (WindowsString str) f = useAsCWStringLen str (\(ptr, len) -> f (castPtr ptr, len)) peekTString = fmap WindowsString . packCWString . castPtr peekTStringLen = fmap WindowsString . packCWStringLen . first castPtr newTString (WindowsString str) = fmap castPtr $ newCWString str + +foreign import ccall unsafe "wchar.h wcslen" c_wcslen + :: CWString -> IO SIZE_T + +-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are +-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660 +useAsCWStringSafe :: WindowsPath -> (CWString -> IO a) -> IO a +useAsCWStringSafe wp@(WS path) f = useAsCWString path $ \(castPtr -> ptr) -> do + let len = SBS.numWord16 path + clen <- c_wcslen ptr + if clen == fromIntegral len + then f ptr + else do + path' <- either (const (_toStr wp)) id <$> (EX.try @IOException) (decodeWithBaseWindows path) + ioError (err path') + where + _toStr = fmap WS.toChar . WS.unpack + err path' = + IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "useAsCWStringSafe" + , ioe_description = "Windows filepaths must not contain internal NUL codepoints." + , ioe_errno = Nothing + , ioe_filename = Just path' + } ---------------------------------------------------------------- -- Errors diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: Win32 -version: 2.13.4.0 +version: 2.14.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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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). diff --git a/include/namedpipeapi_compat.h b/include/namedpipeapi_compat.h new file mode 100644 --- /dev/null +++ b/include/namedpipeapi_compat.h @@ -0,0 +1,16 @@ +/* The version of wincon.h provided by the version of MSYS2 included with x86 + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef NAMEDPIPEAPI_COMPAT_H +#define NAMEDPIPEAPI_COMPAT_H + +#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 +# +#else + +#define PIPE_ACCEPT_REMOTE_CLIENTS 0x0 +#define PIPE_REJECT_REMOTE_CLIENTS 0x8 +#endif /* GHC version check */ +#endif /* NAMEDPIPEAPI_COMPAT_H */