diff --git a/Graphics/Win32/GDI.hs b/Graphics/Win32/GDI.hs --- a/Graphics/Win32/GDI.hs +++ b/Graphics/Win32/GDI.hs @@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- {-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. +-- The above warning suppression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings diff --git a/Graphics/Win32/GDI/Graphics2D.hs b/Graphics/Win32/GDI/Graphics2D.hs --- a/Graphics/Win32/GDI/Graphics2D.hs +++ b/Graphics/Win32/GDI/Graphics2D.hs @@ -102,7 +102,7 @@ -- Filled Shapes ---------------------------------------------------------------- --- ToDo: We ought to be able to specify a colour instead of the +-- TODO: We ought to be able to specify a colour instead of the -- Brush by adding 1 to colour number. fillRect :: HDC -> RECT -> HBRUSH -> IO () diff --git a/Graphics/Win32/Icon.hs b/Graphics/Win32/Icon.hs --- a/Graphics/Win32/Icon.hs +++ b/Graphics/Win32/Icon.hs @@ -19,6 +19,7 @@ module Graphics.Win32.Icon where +import Foreign (Ptr) import Graphics.Win32.GDI.Types import System.Win32.Types @@ -27,6 +28,12 @@ ---------------------------------------------------------------- -- Icons ---------------------------------------------------------------- + +createIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON +createIcon instance_ width height planes bitsPixel andBits xorBits = + failIfNull "CreateIcon" $ c_CreateIcon instance_ width height planes bitsPixel andBits xorBits +foreign import WINDOWS_CCONV unsafe "windows.h CreateIcon" + c_CreateIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON copyIcon :: HICON -> IO HICON copyIcon icon = diff --git a/Graphics/Win32/LayeredWindow.hsc b/Graphics/Win32/LayeredWindow.hsc --- a/Graphics/Win32/LayeredWindow.hsc +++ b/Graphics/Win32/LayeredWindow.hsc @@ -10,17 +10,14 @@ Provides LayeredWindow functionality. -} -module Graphics.Win32.LayeredWindow where +module Graphics.Win32.LayeredWindow (module Graphics.Win32.LayeredWindow, Graphics.Win32.Window.c_GetWindowLongPtr ) where import Control.Monad ( void ) import Data.Bits ( (.|.) ) import Foreign.Ptr ( Ptr ) -import Foreign.C.Types ( CIntPtr(..) ) -import Foreign.Marshal.Utils ( with ) import Graphics.Win32.GDI.AlphaBlend ( BLENDFUNCTION ) import Graphics.Win32.GDI.Types ( COLORREF, HDC, SIZE, SIZE, POINT ) -import Graphics.Win32.Window ( WindowStyleEx, c_SetWindowLongPtr, ) -import System.Win32.Types ( DWORD, HANDLE, BYTE, BOOL, - LONG_PTR, INT ) +import Graphics.Win32.Window ( WindowStyleEx, c_GetWindowLongPtr, c_SetWindowLongPtr ) +import System.Win32.Types ( DWORD, HANDLE, BYTE, BOOL, INT ) #include ##include "windows_cconv.h" @@ -29,7 +26,7 @@ toLayeredWindow :: HANDLE -> IO () toLayeredWindow w = do flg <- c_GetWindowLongPtr w gWL_EXSTYLE - void $ with (fromIntegral $ flg .|. (fromIntegral wS_EX_LAYERED)) $ c_SetWindowLongPtr w gWL_EXSTYLE + void $ c_SetWindowLongPtr w gWL_EXSTYLE (flg .|. (fromIntegral wS_EX_LAYERED)) -- test w = c_SetLayeredWindowAttributes w 0 128 lWA_ALPHA @@ -52,16 +49,9 @@ foreign import WINDOWS_CCONV unsafe "windows.h UpdateLayeredWindow" c_UpdateLayeredWindow :: HANDLE -> HDC -> Ptr POINT -> Ptr SIZE -> HDC -> Ptr POINT -> COLORREF -> Ptr BLENDFUNCTION -> DWORD -> IO BOOL -#if defined(x86_64_HOST_ARCH) -foreign import WINDOWS_CCONV "windows.h GetWindowLongPtrW" - c_GetWindowLongPtr :: HANDLE -> INT -> IO LONG_PTR -#else -foreign import WINDOWS_CCONV "windows.h GetWindowLongW" - c_GetWindowLongPtr :: HANDLE -> INT -> IO LONG_PTR -#endif - #{enum DWORD, , uLW_ALPHA = ULW_ALPHA , uLW_COLORKEY = ULW_COLORKEY , uLW_OPAQUE = ULW_OPAQUE } + diff --git a/Graphics/Win32/Message.hsc b/Graphics/Win32/Message.hsc --- a/Graphics/Win32/Message.hsc +++ b/Graphics/Win32/Message.hsc @@ -158,6 +158,7 @@ , wM_QUEUESYNC = WM_QUEUESYNC , wM_USER = WM_USER , wM_APP = WM_APP + , wM_SETICON = WM_SETICON } registerWindowMessage :: String -> IO WindowMessage @@ -173,6 +174,8 @@ , sIZE_MAXIMIZED = SIZE_MAXIMIZED , sIZE_MAXSHOW = SIZE_MAXSHOW , sIZE_MAXHIDE = SIZE_MAXHIDE + , iCON_SMALL = ICON_SMALL + , iCON_BIG = ICON_BIG } ---------------------------------------------------------------- diff --git a/Graphics/Win32/Misc.hsc b/Graphics/Win32/Misc.hsc --- a/Graphics/Win32/Misc.hsc +++ b/Graphics/Win32/Misc.hsc @@ -268,7 +268,7 @@ type TIMERPROC = FunPtr (HWND -> UINT -> TimerId -> DWORD -> IO ()) --- ToDo: support the other two forms of timer initialisation +-- TODO: support the other two forms of timer initialisation -- Cause WM_TIMER events to be sent to window callback diff --git a/Graphics/Win32/Window.hsc b/Graphics/Win32/Window.hsc --- a/Graphics/Win32/Window.hsc +++ b/Graphics/Win32/Window.hsc @@ -16,14 +16,15 @@ module Graphics.Win32.Window where -import Control.Monad (liftM) +import Control.Monad (liftM, when, unless) import Data.Maybe (fromMaybe) import Data.Int (Int32) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Utils (maybeWith) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, castPtr, nullPtr) +import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, nullPtr) +import Foreign.Ptr (intPtrToPtr, castPtrToFunPtr, freeHaskellFunPtr,ptrToIntPtr) import Foreign.Storable (pokeByteOff) import Foreign.C.Types (CIntPtr(..)) import Graphics.Win32.GDI.Types (HBITMAP, HCURSOR, HDC, HDWP, HRGN, HWND, PRGN) @@ -31,11 +32,12 @@ import Graphics.Win32.GDI.Types (LPRECT, RECT, allocaRECT, peekRECT, withRECT) import Graphics.Win32.GDI.Types (POINT, allocaPOINT, peekPOINT, withPOINT) import Graphics.Win32.GDI.Types (prim_ChildWindowFromPointEx) -import Graphics.Win32.Message (WindowMessage) +import Graphics.Win32.Message (WindowMessage, wM_NCDESTROY) import System.IO.Unsafe (unsafePerformIO) import System.Win32.Types (ATOM, maybePtr, newTString, ptrToMaybe, numToMaybe) import System.Win32.Types (Addr, BOOL, DWORD, INT, LONG, LRESULT, UINT, WPARAM) -import System.Win32.Types (HINSTANCE, LPARAM, LPCTSTR, LPTSTR, LPVOID, withTString, peekTString) +import System.Win32.Types (HANDLE, HINSTANCE, LONG_PTR, LPARAM, LPCTSTR) +import System.Win32.Types (LPTSTR, LPVOID, withTString, peekTString) import System.Win32.Types (failIf, failIf_, failIfFalse_, failIfNull, maybeNum, failUnlessSuccess, getLastError, errorWin) ##include "windows_cconv.h" @@ -202,12 +204,27 @@ foreign import WINDOWS_CCONV "wrapper" mkWindowClosure :: WindowClosure -> IO (FunPtr WindowClosure) -setWindowClosure :: HWND -> WindowClosure -> IO () +mkCIntPtr :: FunPtr a -> CIntPtr +mkCIntPtr = fromIntegral . ptrToIntPtr . castFunPtrToPtr + +-- | The standard C wndproc for every window class registered by +-- 'registerClass' is a C function pointer provided with this library. It in +-- turn delegates to a Haskell function pointer stored in 'gWLP_USERDATA'. +-- This action creates that function pointer. All Haskell function pointers +-- must be freed in order to allow the objects they close over to be garbage +-- collected. Consequently, if you are replacing a window closure previously +-- set via this method or indirectly with 'createWindow' or 'createWindowEx' +-- you must free it. This action returns a function pointer to the old window +-- closure for you to free. The current window closure is freed automatically +-- by 'defWindowProc' when it receives 'wM_NCDESTROY'. +setWindowClosure :: HWND -> WindowClosure -> IO (Maybe (FunPtr WindowClosure)) setWindowClosure wnd closure = do fp <- mkWindowClosure closure - _ <- c_SetWindowLongPtr wnd (#{const GWLP_USERDATA}) - (castPtr (castFunPtrToPtr fp)) - return () + fpOld <- c_SetWindowLongPtr wnd (#{const GWLP_USERDATA}) + (mkCIntPtr fp) + if fpOld == 0 + then return Nothing + else return $ Just $ castPtrToFunPtr $ intPtrToPtr $ fromIntegral fpOld {- Note [SetWindowLongPtrW] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -221,13 +238,27 @@ -} #if defined(i386_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h SetWindowLongW" -#elif defined(x86_64_HOST_ARCH) +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h SetWindowLongPtrW" #else # error Unknown mingw32 arch #endif - c_SetWindowLongPtr :: HWND -> INT -> Ptr LONG -> IO (Ptr LONG) + c_SetWindowLongPtr :: HWND -> INT -> LONG_PTR -> IO (LONG_PTR) +#if defined(i386_HOST_ARCH) +foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongW" +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) +foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongPtrW" +#else +# error Unknown mingw32 arch +#endif + c_GetWindowLongPtr :: HANDLE -> INT -> IO LONG_PTR + + +-- | Creates a window with a default extended window style. If you create many +-- windows over the life of your program, WindowClosure may leak memory. Be +-- sure to delegate to 'defWindowProc' for 'wM_NCDESTROY' and see +-- 'defWindowProc' and 'setWindowClosure' for details. createWindow :: ClassName -> String -> WindowStyle -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos -> @@ -236,6 +267,10 @@ createWindow = createWindowEx 0 -- apparently CreateWindowA/W are just macros for CreateWindowExA/W +-- | Creates a window and allows your to specify the extended window style. If +-- you create many windows over the life of your program, WindowClosure may +-- leak memory. Be sure to delegate to 'defWindowProc' for 'wM_NCDESTROY' and see +-- 'defWindowProc' and 'setWindowClosure' for details. createWindowEx :: WindowStyle -> ClassName -> String -> WindowStyle -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos @@ -250,7 +285,7 @@ c_CreateWindowEx estyle cname c_wname wstyle (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h) (maybePtr mb_parent) (maybePtr mb_menu) inst nullPtr - setWindowClosure wnd closure + _ <- setWindowClosure wnd closure return wnd foreign import WINDOWS_CCONV "windows.h CreateWindowExW" c_CreateWindowEx @@ -261,12 +296,43 @@ ---------------------------------------------------------------- +-- | Delegates to the Win32 default window procedure. If you are using a +-- window created by 'createWindow', 'createWindowEx' or on which you have +-- called 'setWindowClosure', please note that the window will leak memory once +-- it is destroyed unless you call 'freeWindowProc' when it receives +-- 'wM_NCDESTROY'. If you wish to do this, instead of using this function +-- directly, you can delegate to 'defWindowProcSafe' which will handle it for +-- you. As an alternative, you can manually retrieve the window closure +-- function pointer and free it after the window has been destroyed. Check the +-- implementation of 'freeWindowProc' for a guide. defWindowProc :: Maybe HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT defWindowProc mb_wnd msg w l = c_DefWindowProc (maybePtr mb_wnd) msg w l + +-- | Delegates to the standard default window procedure, but if it receives the +-- 'wM_NCDESTROY' message it first frees the window closure to allow the +-- closure and any objects it closes over to be garbage collected. 'wM_NCDESTROY' is +-- the last message a window receives prior to being deleted. +defWindowProcSafe :: Maybe HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT +defWindowProcSafe mb_wnd msg w l = do + when (msg == wM_NCDESTROY) (maybe (return ()) freeWindowProc mb_wnd) + defWindowProc mb_wnd msg w l + foreign import WINDOWS_CCONV "windows.h DefWindowProcW" c_DefWindowProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT +-- | Frees a function pointer to the window closure which has been set +-- directly by 'setWindowClosure' or indirectly by 'createWindowEx'. You +-- should call this function in your window closure's 'wM_NCDESTROY' case +-- unless you delegate that case to 'defWindowProc' (e.g. as part of the +-- default). +freeWindowProc :: HWND -> IO () +freeWindowProc hwnd = do + fp <- c_GetWindowLongPtr hwnd (#{const GWLP_USERDATA}) + unless (fp == 0) $ + freeHaskellFunPtr $ castPtrToFunPtr . intPtrToPtr . fromIntegral $ fp + + ---------------------------------------------------------------- getClientRect :: HWND -> IO RECT @@ -356,7 +422,7 @@ return size' foreign import WINDOWS_CCONV "windows.h GetWindowTextLengthW" c_GetWindowTextLength :: HWND -> IO Int - + ---------------------------------------------------------------- -- Paint struct ---------------------------------------------------------------- @@ -408,6 +474,9 @@ foreign import WINDOWS_CCONV "windows.h ShowWindow" showWindow :: HWND -> ShowWindowControl -> IO Bool +foreign import WINDOWS_CCONV "windows.h IsWindowVisible" + isWindowVisible :: HWND -> IO Bool + ---------------------------------------------------------------- -- Misc ---------------------------------------------------------------- @@ -544,7 +613,7 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetForegroundWindow" getForegroundWindow :: IO HWND - + getParent :: HWND -> IO HWND getParent wnd = failIfNull "GetParent" $ c_GetParent wnd @@ -686,7 +755,7 @@ -- UpdateWindow (I think) -- RedrawWindow (I think) -- --- The following dont have to be reentrant (according to documentation) +-- The following don't have to be reentrant (according to documentation) -- -- GetMessage -- PeekMessage @@ -717,7 +786,7 @@ getMessage :: LPMSG -> Maybe HWND -> IO Bool getMessage msg mb_wnd = do - res <- failIf (== maxBound) "GetMessage" $ + res <- failIf (== -1) "GetMessage" $ c_GetMessage msg (maybePtr mb_wnd) 0 0 return (res /= 0) foreign import WINDOWS_CCONV "windows.h GetMessageW" @@ -729,7 +798,7 @@ peekMessage :: LPMSG -> Maybe HWND -> UINT -> UINT -> UINT -> IO () peekMessage msg mb_wnd filterMin filterMax remove = do - failIf_ (== maxBound) "PeekMessage" $ + failIf_ (== -1) "PeekMessage" $ c_PeekMessage msg (maybePtr mb_wnd) filterMin filterMax remove foreign import WINDOWS_CCONV "windows.h PeekMessageW" c_PeekMessage :: LPMSG -> HWND -> UINT -> UINT -> UINT -> IO LONG diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMainWithHooks autoconfUserHooks diff --git a/System/Win32.hs b/System/Win32.hs --- a/System/Win32.hs +++ b/System/Win32.hs @@ -19,6 +19,7 @@ module System.Win32 ( module System.Win32.DLL + , module System.Win32.Event , module System.Win32.File , module System.Win32.FileMapping , module System.Win32.Info @@ -40,6 +41,7 @@ ) where import System.Win32.DLL +import System.Win32.Event import System.Win32.File import System.Win32.FileMapping import System.Win32.Info diff --git a/System/Win32/Automation/Input.hsc b/System/Win32/Automation/Input.hsc --- a/System/Win32/Automation/Input.hsc +++ b/System/Win32/Automation/Input.hsc @@ -11,7 +11,16 @@ Provide sendInput function and INPUT types. -} module System.Win32.Automation.Input - ( module System.Win32.Automation.Input + ( sendInput + , sendInputPtr + , makeKeyboardInput + , PINPUT + , LPINPUT + , INPUT(..) + , PHARDWAREINPUT + , HARDWAREINPUT(..) + , getMessageExtraInfo + , setMessageExtraInfo , module System.Win32.Automation.Input.Key , module System.Win32.Automation.Input.Mouse ) where diff --git a/System/Win32/Console.hsc b/System/Win32/Console.hsc --- a/System/Win32/Console.hsc +++ b/System/Win32/Console.hsc @@ -1,5 +1,5 @@ #if __GLASGOW_HASKELL__ >= 709 -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Trustworthy #-} #endif @@ -45,34 +45,54 @@ generateConsoleCtrlEvent, -- * Command line commandLineToArgv, + getCommandLineW, + getArgs, -- * Screen buffer CONSOLE_SCREEN_BUFFER_INFO(..), + CONSOLE_SCREEN_BUFFER_INFOEX(..), COORD(..), SMALL_RECT(..), + COLORREF, getConsoleScreenBufferInfo, - getCurrentConsoleScreenBufferInfo + getCurrentConsoleScreenBufferInfo, + getConsoleScreenBufferInfoEx, + getCurrentConsoleScreenBufferInfoEx, + + -- * Env + getEnv, + getEnvironment, + -- * Console I/O + KEY_EVENT_RECORD(..), + MOUSE_EVENT_RECORD(..), + WINDOW_BUFFER_SIZE_RECORD(..), + MENU_EVENT_RECORD(..), + FOCUS_EVENT_RECORD(..), + INPUT_RECORD(..), + readConsoleInput ) where #include #include "alignment.h" ##include "windows_cconv.h" +#include "wincon_compat.h" +import Data.Char (chr) import System.Win32.Types +import System.Win32.String +import System.Win32.Console.Internal import Graphics.Win32.Misc +import Graphics.Win32.GDI.Types (COLORREF) -import Foreign.C.Types (CInt(..)) +import GHC.IO (bracket) +import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) +import Foreign.Ptr (plusPtr, Ptr) +import Foreign.C.Types (CWchar) import Foreign.C.String (withCWString, CWString) -import Foreign.Ptr (Ptr) import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Array (peekArray, peekArray0) import Foreign.Marshal.Alloc (alloca) -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" - c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" - c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL - getConsoleMode :: HANDLE -> IO DWORD getConsoleMode h = alloca $ \ptr -> do failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr @@ -101,37 +121,13 @@ 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 commandline arguments and return +-- | 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] commandLineToArgv [] = return [] @@ -144,71 +140,12 @@ _ <- localFree res mapM peekTString args -data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO - { dwSize :: COORD - , dwCursorPosition :: COORD - , wAttributes :: WORD - , srWindow :: SMALL_RECT - , dwMaximumWindowSize :: COORD - } deriving (Show, Eq) - -instance Storable CONSOLE_SCREEN_BUFFER_INFO where - sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFO} - alignment _ = #alignment CONSOLE_SCREEN_BUFFER_INFO - peek buf = do - dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf - dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf - wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf - srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf - dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf - return $ CONSOLE_SCREEN_BUFFER_INFO dwSize' dwCursorPosition' wAttributes' srWindow' dwMaximumWindowSize' - poke buf info = do - (#poke CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf (dwSize info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf (dwCursorPosition info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf (wAttributes info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf (srWindow info) - (#poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf (dwMaximumWindowSize info) - -data COORD = COORD - { x :: SHORT - , y :: 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 (x coord) - (#poke COORD, Y) buf (y coord) - -data SMALL_RECT = SMALL_RECT - { left :: SHORT - , top :: SHORT - , right :: SHORT - , bottom :: 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 (left small_rect) - (#poke SMALL_RECT, Top) buf (top small_rect) - (#poke SMALL_RECT, Right) buf (right small_rect) - (#poke SMALL_RECT, Bottom) buf (bottom small_rect) - -foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo" - c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> 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 @@ -219,3 +156,97 @@ getCurrentConsoleScreenBufferInfo = do h <- failIf (== nullHANDLE) "getStdHandle" $ getStdHandle sTD_OUTPUT_HANDLE getConsoleScreenBufferInfo h + +getConsoleScreenBufferInfoEx :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFOEX +getConsoleScreenBufferInfoEx h = alloca $ \ptr -> do + -- The cbSize member must be set or GetConsoleScreenBufferInfoEx fails with + -- ERROR_INVALID_PARAMETER (87). + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, cbSize) ptr cbSize + failIfFalse_ "GetConsoleScreenBufferInfoEx" $ c_GetConsoleScreenBufferInfoEx h ptr + peek ptr + where + cbSize :: ULONG + cbSize = #{size CONSOLE_SCREEN_BUFFER_INFOEX} + +getCurrentConsoleScreenBufferInfoEx :: IO CONSOLE_SCREEN_BUFFER_INFOEX +getCurrentConsoleScreenBufferInfoEx = do + h <- failIf (== nullHANDLE) "getStdHandle" $ getStdHandle sTD_OUTPUT_HANDLE + getConsoleScreenBufferInfoEx h + + +-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD +getEnv :: String -> IO (Maybe String) +getEnv name = + withCWString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- c_GetEnvironmentVariableW c_name buf c_len + case c_len' of + 0 -> do + err_code <- getLastError + if err_code == eERROR_ENVVAR_NOT_FOUND + then return Nothing + else errorWin "GetEnvironmentVariableW" + _ | c_len' > fromIntegral maxLength -> + -- shouldn't happen, because we provide maxLength + ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) + | otherwise -> do + let len' = fromIntegral c_len' + Just <$> peekTStringLen (buf, len') + where + -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew + -- max characters (wide chars): 32767 + -- => bytes = 32767 * 2 = 65534 + -- +1 byte for NUL (although not needed I think) + maxLength :: Int + maxLength = 65535 + + +getEnvironment :: IO [(String, String)] +getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do + strs <- builder lpwstr + return (divvy <$> strs) + where + divvy :: String -> (String, String) + divvy str = + case break (=='=') str of + (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment) + (name,_:value) -> (name,value) + + builder :: LPWSTR -> IO [String] + builder ptr = go 0 + where + go :: Int -> IO [String] + go off = do + (str, l) <- peekCWStringOff ptr off + if l == 0 + then pure [] + else (str:) <$> go (((l + 1) * 2) + off) + + +peekCWStringOff :: CWString -> Int -> IO (String, Int) +peekCWStringOff cp off = do + cs <- peekArray0 wNUL (cp `plusPtr` off) + return (cWcharsToChars cs, length cs) + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> [Char] +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = [] + +-- | Reads all available input records up to the amount specified by the +-- len parameter. +readConsoleInput :: HANDLE -> Int -> Ptr INPUT_RECORD -> IO Int +readConsoleInput handle len inputRecordPtr = + alloca $ \numEventsReadPtr -> do + poke numEventsReadPtr 0 + failIfFalse_ "ReadConsoleInput" $ + c_ReadConsoleInput handle inputRecordPtr (fromIntegral len) numEventsReadPtr + numEvents <- peek numEventsReadPtr + return $ fromIntegral numEvents diff --git a/System/Win32/Console/HWND.hs b/System/Win32/Console/HWND.hs --- a/System/Win32/Console/HWND.hs +++ b/System/Win32/Console/HWND.hs @@ -9,7 +9,7 @@ Get the handle of the current console window. -} -module System.Win32.Console.HWND where +module System.Win32.Console.HWND (getConsoleHWND) where import Control.Concurrent ( threadDelay ) import Control.Exception ( bracket ) import Foreign.Ptr ( nullPtr ) diff --git a/System/Win32/Console/Internal.hsc b/System/Win32/Console/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Console/Internal.hsc @@ -0,0 +1,336 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Console.Internal +-- Copyright : (c) University of Glasgow 2023 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Internals for Console modules. +-- +----------------------------------------------------------------------------- + +module System.Win32.Console.Internal where + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "wincon_compat.h" + +import System.Win32.Types +import Graphics.Win32.GDI.Types (COLORREF) + +import Foreign.C.Types (CInt(..), CWchar) +import Foreign.C.String (CWString) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, pokeArray) + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" + c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" + c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP" + getConsoleCP :: IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCP" + setConsoleCP :: UINT -> IO () + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleOutputCP" + getConsoleOutputCP :: IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleOutputCP" + setConsoleOutputCP :: UINT -> IO () + +type CtrlEvent = DWORD +#{enum CtrlEvent, + , cTRL_C_EVENT = 0 + , cTRL_BREAK_EVENT = 1 + } + +foreign import WINDOWS_CCONV safe "windows.h GenerateConsoleCtrlEvent" + c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "Shellapi.h CommandLineToArgvW" + c_CommandLineToArgvW :: CWString -> Ptr CInt -> IO (Ptr CWString) + +foreign import WINDOWS_CCONV unsafe "processenv.h GetCommandLineW" + getCommandLineW :: IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentVariableW" + c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentStringsW" + c_GetEnvironmentStringsW :: IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "processenv.h FreeEnvironmentStringsW" + c_FreeEnvironmentStrings :: LPWSTR -> IO Bool + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO + { dwSize :: COORD + , dwCursorPosition :: COORD + , wAttributes :: WORD + , srWindow :: SMALL_RECT + , dwMaximumWindowSize :: COORD + } deriving (Show, Eq) + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFO} + alignment _ = #alignment CONSOLE_SCREEN_BUFFER_INFO + peek buf = do + dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf + dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf + wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf + srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf + dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf + return $ CONSOLE_SCREEN_BUFFER_INFO dwSize' dwCursorPosition' wAttributes' srWindow' dwMaximumWindowSize' + poke buf info = do + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf (dwSize info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf (dwCursorPosition info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf (wAttributes info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf (srWindow info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf (dwMaximumWindowSize info) + +data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX + { dwSizeEx :: COORD + , dwCursorPositionEx :: COORD + , wAttributesEx :: WORD + , srWindowEx :: SMALL_RECT + , dwMaximumWindowSizeEx :: COORD + , wPopupAttributes :: WORD + , bFullscreenSupported :: BOOL + , colorTable :: [COLORREF] + -- ^ Only the first 16 'COLORREF' values passed to the Windows Console + -- API. If fewer than 16 values, the remainder are padded with @0@ when + -- passed to the API. + } deriving (Show, Eq) + +instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where + sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFOEX} + alignment = const #{alignment CONSOLE_SCREEN_BUFFER_INFOEX} + peek buf = do + dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf + dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf + wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf + srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf + dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf + wPopupAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf + bFullscreenSupported' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf + colorTable' <- peekArray 16 ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) + return $ CONSOLE_SCREEN_BUFFER_INFOEX dwSize' dwCursorPosition' + wAttributes' srWindow' dwMaximumWindowSize' wPopupAttributes' + bFullscreenSupported' colorTable' + poke buf info = do + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, cbSize) buf cbSize + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf (dwSizeEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf (dwCursorPositionEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf (wAttributesEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf (srWindowEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf (dwMaximumWindowSizeEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf (wPopupAttributes info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf (bFullscreenSupported info) + pokeArray ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) colorTable' + where + cbSize :: ULONG + cbSize = #{size CONSOLE_SCREEN_BUFFER_INFOEX} + colorTable' = take 16 $ colorTable info ++ repeat 0 + +data COORD = COORD + { xPos :: SHORT + , yPos :: SHORT + } deriving (Show, Eq) + +instance Storable COORD where + sizeOf = const #{size COORD} + alignment _ = #alignment COORD + peek buf = do + x' <- (#peek COORD, X) buf + y' <- (#peek COORD, Y) buf + return $ COORD x' y' + poke buf coord = do + (#poke COORD, X) buf (xPos coord) + (#poke COORD, Y) buf (yPos coord) + +data SMALL_RECT = SMALL_RECT + { leftPos :: SHORT + , topPos :: SHORT + , rightPos :: SHORT + , bottomPos :: SHORT + } deriving (Show, Eq) + +instance Storable SMALL_RECT where + sizeOf _ = #{size SMALL_RECT} + alignment _ = #alignment SMALL_RECT + peek buf = do + left' <- (#peek SMALL_RECT, Left) buf + top' <- (#peek SMALL_RECT, Top) buf + right' <- (#peek SMALL_RECT, Right) buf + bottom' <- (#peek SMALL_RECT, Bottom) buf + return $ SMALL_RECT left' top' right' bottom' + poke buf small_rect = do + (#poke SMALL_RECT, Left) buf (leftPos small_rect) + (#poke SMALL_RECT, Top) buf (topPos small_rect) + (#poke SMALL_RECT, Right) buf (rightPos small_rect) + (#poke SMALL_RECT, Bottom) buf (bottomPos small_rect) + +foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo" + c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfoEx" + c_GetConsoleScreenBufferInfoEx :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFOEX -> IO BOOL + +-- | This type represents a keyboard input event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/key-event-record-str +data KEY_EVENT_RECORD = KEY_EVENT_RECORD + { keyDown :: BOOL + , repeatCount :: WORD + , virtualKeyCode :: WORD + , virtualScanCode :: WORD + , uChar :: CWchar + , controlKeyStateK :: DWORD + } deriving (Eq, Show) + +-- | This type represents a mouse event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/mouse-event-record-str +data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD + { mousePosition :: COORD + , buttonState :: DWORD + , controlKeyStateM :: DWORD + , eventFlags :: DWORD + } deriving (Eq, Show) + +-- | This type represents a window size change event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/window-buffer-size-record-str +newtype WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD + { windowSize :: COORD + } deriving (Eq, Show) + +-- | This type represents a window menu event. (Current ignored by VTY). The structure +-- is documented here: https://learn.microsoft.com/en-us/windows/console/menu-event-record-str +newtype MENU_EVENT_RECORD = MENU_EVENT_RECORD + { commandId :: UINT + } deriving (Eq, Show) + +-- | This type represents a window focus change event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/focus-event-record-str +newtype FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD + { setFocus :: BOOL + } deriving (Eq, Show) + +-- | Description of a Windows console input event. Documented here: +-- https://learn.microsoft.com/en-us/windows/console/input-record-str +data INPUT_RECORD = + KeyEvent KEY_EVENT_RECORD + | MouseEvent MOUSE_EVENT_RECORD + | WindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD + | MenuEvent MENU_EVENT_RECORD + | FocusEvent FOCUS_EVENT_RECORD + deriving (Eq, Show) + +instance Storable KEY_EVENT_RECORD where + sizeOf = const #{size KEY_EVENT_RECORD} + alignment _ = #alignment KEY_EVENT_RECORD + poke buf input = do + (#poke KEY_EVENT_RECORD, bKeyDown) buf (keyDown input) + (#poke KEY_EVENT_RECORD, wRepeatCount) buf (repeatCount input) + (#poke KEY_EVENT_RECORD, wVirtualKeyCode) buf (virtualKeyCode input) + (#poke KEY_EVENT_RECORD, wVirtualScanCode) buf (virtualScanCode input) + (#poke KEY_EVENT_RECORD, uChar) buf (uChar input) + (#poke KEY_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateK input) + peek buf = do + keyDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) buf + repeatCount' <- (#peek KEY_EVENT_RECORD, wRepeatCount) buf + virtualKeyCode' <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) buf + virtualScanCode' <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) buf + uChar' <- (#peek KEY_EVENT_RECORD, uChar) buf + controlKeyStateK' <- (#peek KEY_EVENT_RECORD, dwControlKeyState) buf + return $ KEY_EVENT_RECORD keyDown' repeatCount' virtualKeyCode' virtualScanCode' uChar' controlKeyStateK' + +instance Storable MOUSE_EVENT_RECORD where + sizeOf = const #{size MOUSE_EVENT_RECORD} + alignment _ = #alignment MOUSE_EVENT_RECORD + poke buf input = do + (#poke MOUSE_EVENT_RECORD, dwMousePosition) buf (mousePosition input) + (#poke MOUSE_EVENT_RECORD, dwButtonState) buf (buttonState input) + (#poke MOUSE_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateM input) + (#poke MOUSE_EVENT_RECORD, dwEventFlags) buf (eventFlags input) + peek buf = do + mousePosition' <- (#peek MOUSE_EVENT_RECORD, dwMousePosition) buf + buttonState' <- (#peek MOUSE_EVENT_RECORD, dwButtonState) buf + controlKeyStateM' <- (#peek MOUSE_EVENT_RECORD, dwControlKeyState) buf + eventFlags' <- (#peek MOUSE_EVENT_RECORD, dwEventFlags) buf + return $ MOUSE_EVENT_RECORD mousePosition' buttonState' controlKeyStateM' eventFlags' + +instance Storable WINDOW_BUFFER_SIZE_RECORD where + sizeOf = const #{size WINDOW_BUFFER_SIZE_RECORD} + alignment _ = #alignment WINDOW_BUFFER_SIZE_RECORD + poke buf input = do + (#poke WINDOW_BUFFER_SIZE_RECORD, dwSize) buf (windowSize input) + peek buf = do + size' <- (#peek WINDOW_BUFFER_SIZE_RECORD, dwSize) buf + return $ WINDOW_BUFFER_SIZE_RECORD size' + +instance Storable MENU_EVENT_RECORD where + sizeOf = const #{size MENU_EVENT_RECORD} + alignment _ = #alignment MENU_EVENT_RECORD + poke buf input = do + (#poke MENU_EVENT_RECORD, dwCommandId) buf (commandId input) + peek buf = do + commandId' <- (#peek MENU_EVENT_RECORD, dwCommandId) buf + return $ MENU_EVENT_RECORD commandId' + +instance Storable FOCUS_EVENT_RECORD where + sizeOf = const #{size FOCUS_EVENT_RECORD} + alignment _ = #alignment FOCUS_EVENT_RECORD + poke buf input = do + (#poke FOCUS_EVENT_RECORD, bSetFocus) buf (setFocus input) + peek buf = do + setFocus' <- (#peek FOCUS_EVENT_RECORD, bSetFocus) buf + return $ FOCUS_EVENT_RECORD setFocus' + +instance Storable INPUT_RECORD where + sizeOf = const #{size INPUT_RECORD} + alignment _ = #alignment INPUT_RECORD + + poke buf (KeyEvent key) = do + (#poke INPUT_RECORD, EventType) buf (#{const KEY_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf key + poke buf (MouseEvent mouse) = do + (#poke INPUT_RECORD, EventType) buf (#{const MOUSE_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf mouse + poke buf (WindowBufferSizeEvent window) = do + (#poke INPUT_RECORD, EventType) buf (#{const WINDOW_BUFFER_SIZE_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf window + poke buf (MenuEvent menu) = do + (#poke INPUT_RECORD, EventType) buf (#{const MENU_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf menu + poke buf (FocusEvent focus) = do + (#poke INPUT_RECORD, EventType) buf (#{const FOCUS_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf focus + + peek buf = do + event <- (#peek INPUT_RECORD, EventType) buf :: IO WORD + case event of + #{const KEY_EVENT} -> + KeyEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const MOUSE_EVENT} -> + MouseEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const WINDOW_BUFFER_SIZE_EVENT} -> + WindowBufferSizeEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const MENU_EVENT} -> + MenuEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const FOCUS_EVENT} -> + FocusEvent `fmap` (#peek INPUT_RECORD, Event) buf + _ -> error $ "Unknown input event type " ++ show event + +foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" + c_ReadConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL diff --git a/System/Win32/Console/Title.hsc b/System/Win32/Console/Title.hsc --- a/System/Win32/Console/Title.hsc +++ b/System/Win32/Console/Title.hsc @@ -10,7 +10,10 @@ Get/Set the title for the current console window. -} -module System.Win32.Console.Title where +module System.Win32.Console.Title + ( getConsoleTitle + , setConsoleTitle + ) where import System.Win32.String ( LPTSTR, LPCTSTR , withTStringBufferLen, withTString, peekTStringLen ) diff --git a/System/Win32/DLL.hsc b/System/Win32/DLL.hsc --- a/System/Win32/DLL.hsc +++ b/System/Win32/DLL.hsc @@ -17,81 +17,63 @@ -- ----------------------------------------------------------------------------- -module System.Win32.DLL where +module System.Win32.DLL + ( disableThreadLibraryCalls + , freeLibrary + , getModuleFileName + , getModuleHandle + , getProcAddress + , loadLibrary + , loadLibraryEx + , setDllDirectory + , LoadLibraryFlags + , lOAD_LIBRARY_AS_DATAFILE + , lOAD_WITH_ALTERED_SEARCH_PATH + ) where +import System.Win32.DLL.Internal import System.Win32.Types import Foreign import Foreign.C import Data.Maybe (fromMaybe) -##include "windows_cconv.h" - -#include - disableThreadLibraryCalls :: HMODULE -> IO () disableThreadLibraryCalls hmod = failIfFalse_ "DisableThreadLibraryCalls" $ c_DisableThreadLibraryCalls hmod -foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls" - c_DisableThreadLibraryCalls :: HMODULE -> IO Bool freeLibrary :: HMODULE -> IO () freeLibrary hmod = failIfFalse_ "FreeLibrary" $ c_FreeLibrary hmod -foreign import WINDOWS_CCONV unsafe "windows.h FreeLibrary" - c_FreeLibrary :: HMODULE -> IO Bool -{-# CFILES cbits/HsWin32.c #-} -foreign import ccall "HsWin32.h &FreeLibraryFinaliser" - c_FreeLibraryFinaliser :: FunPtr (HMODULE -> IO ()) - getModuleFileName :: HMODULE -> IO String getModuleFileName hmod = allocaArray 512 $ \ c_str -> do failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512 peekTString c_str -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool getModuleHandle :: Maybe String -> IO HMODULE getModuleHandle mb_name = maybeWith withTString mb_name $ \ c_name -> failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleHandleW" - c_GetModuleHandle :: LPCTSTR -> IO HMODULE getProcAddress :: HMODULE -> String -> IO Addr getProcAddress hmod procname = withCAString procname $ \ c_procname -> failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname -foreign import WINDOWS_CCONV unsafe "windows.h GetProcAddress" - c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr -loadLibrary :: String -> IO HINSTANCE +loadLibrary :: String -> IO HMODULE loadLibrary name = withTString name $ \ c_name -> failIfNull "LoadLibrary" $ c_LoadLibrary c_name -foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryW" - c_LoadLibrary :: LPCTSTR -> IO HINSTANCE -type LoadLibraryFlags = DWORD - -#{enum LoadLibraryFlags, - , lOAD_LIBRARY_AS_DATAFILE = LOAD_LIBRARY_AS_DATAFILE - , lOAD_WITH_ALTERED_SEARCH_PATH = LOAD_WITH_ALTERED_SEARCH_PATH - } - -loadLibraryEx :: String -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE +loadLibraryEx :: String -> HANDLE -> LoadLibraryFlags -> IO HMODULE loadLibraryEx name h flags = withTString name $ \ c_name -> failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags -foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryExW" - c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE setDllDirectory :: Maybe String -> IO () setDllDirectory name = maybeWith withTString name $ \ c_name -> failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" name]) $ c_SetDllDirectory c_name -foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW" - c_SetDllDirectory :: LPTSTR -> IO BOOL diff --git a/System/Win32/DLL/Internal.hsc b/System/Win32/DLL/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DLL/Internal.hsc @@ -0,0 +1,57 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.DLL.Internal +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.DLL.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +#include + +foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls" + c_DisableThreadLibraryCalls :: HMODULE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h FreeLibrary" + c_FreeLibrary :: HMODULE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleHandleW" + c_GetModuleHandle :: LPCTSTR -> IO HMODULE + +foreign import WINDOWS_CCONV unsafe "windows.h GetProcAddress" + c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr + +foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryW" + c_LoadLibrary :: LPCTSTR -> IO HMODULE + +type LoadLibraryFlags = DWORD + +#{enum LoadLibraryFlags, + , lOAD_LIBRARY_AS_DATAFILE = LOAD_LIBRARY_AS_DATAFILE + , lOAD_WITH_ALTERED_SEARCH_PATH = LOAD_WITH_ALTERED_SEARCH_PATH + } + +foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryExW" + c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HMODULE + +foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW" + c_SetDllDirectory :: LPTSTR -> IO BOOL diff --git a/System/Win32/DebugApi.hsc b/System/Win32/DebugApi.hsc --- a/System/Win32/DebugApi.hsc +++ b/System/Win32/DebugApi.hsc @@ -16,33 +16,82 @@ -- A collection of FFI declarations for using Windows DebugApi. -- ----------------------------------------------------------------------------- -module System.Win32.DebugApi where +module System.Win32.DebugApi + ( PID, TID, DebugEventId, ForeignAddress + , PHANDLE, THANDLE + , ThreadInfo + , ImageInfo + , ExceptionInfo + , Exception(..) + , DebugEventInfo(..) + , DebugEvent + , debugBreak + , isDebuggerPresent + + -- * Debug events + , waitForDebugEvent + , getDebugEvents + , continueDebugEvent + + -- * Debugging another process + , debugActiveProcess + , peekProcessMemory + , readProcessMemory + , pokeProcessMemory + , withProcessMemory + , peekP + , pokeP + + -- * Thread control + , suspendThread + , resumeThread + , withSuspendedThread + + -- * Thread register control + , getThreadContext + , setThreadContext + , useAllRegs + , withThreadContext + +#if defined(i386_HOST_ARCH) + , eax, ebx, ecx, edx, esi, edi, ebp, eip, esp +#elif defined(x86_64_HOST_ARCH) + , rax, rbx, rcx, rdx, rsi, rdi, rbp, rip, rsp +#endif +#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) + , segCs, segDs, segEs, segFs, segGs + , eFlags + , dr +#endif +#if defined(aarch64_HOST_ARCH) + , x0, x1, x2, x3, x4, x5, x6, x7, x8 + , x9, x10, x11, x12, x13, x14, x15, x16, x17 + , x18, x19, x20, x21, x22, x23, x24, x25, x26 + , x27, x28, fp, lr, sp, pc +#endif + , setReg, getReg, modReg + , makeModThreadContext + , modifyThreadContext + + -- * Sending debug output to another process + , outputDebugString + ) where + +import System.Win32.DebugApi.Internal import Control.Exception( bracket_ ) -import Data.Word ( Word8, Word32 ) import Foreign ( Ptr, nullPtr, ForeignPtr, mallocForeignPtrBytes , peekByteOff, plusPtr, allocaBytes, castPtr, poke , withForeignPtr, Storable, sizeOf, peek, pokeByteOff ) import System.IO ( fixIO ) -import System.Win32.Types ( HANDLE, BOOL, WORD, DWORD, failIf_, failWith - , getLastError, failIf, LPTSTR, withTString ) +import System.Win32.Types ( WORD, DWORD, failIf_, failWith + , getLastError, failIf, withTString ) ##include "windows_cconv.h" #include "windows.h" -type PID = DWORD -type TID = DWORD -type DebugEventId = (PID, TID) -type ForeignAddress = Word32 -type PHANDLE = Ptr () -type THANDLE = Ptr () -type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress) -- handle to thread, thread local, thread start -type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress) -type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address - - data Exception = UnknownException | AccessViolation Bool ForeignAddress @@ -290,7 +339,7 @@ (act buf) -#if __i386__ +#if defined(i386_HOST_ARCH) eax, ebx, ecx, edx :: Int esi, edi :: Int ebp, eip, esp :: Int @@ -303,7 +352,7 @@ ebp = (#offset CONTEXT, Ebp) eip = (#offset CONTEXT, Eip) esp = (#offset CONTEXT, Esp) -#elif __x86_64__ +#elif defined(x86_64_HOST_ARCH) rax, rbx, rcx, rdx :: Int rsi, rdi :: Int rbp, rip, rsp :: Int @@ -316,10 +365,49 @@ rbp = (#offset CONTEXT, Rbp) rip = (#offset CONTEXT, Rip) rsp = (#offset CONTEXT, Rsp) +#elif defined(aarch64_HOST_ARCH) +x0, x1, x2, x3, x4, x5, x6, x7, x8 :: Int +x9, x10, x11, x12, x13, x14, x15, x16, x17 :: Int +x18, x19, x20, x21, x22, x23, x24, x25, x26 :: Int +x27, x28, fp, lr, sp, pc :: Int +x0 = (#offset CONTEXT, X0 ) +x1 = (#offset CONTEXT, X1 ) +x2 = (#offset CONTEXT, X2 ) +x3 = (#offset CONTEXT, X3 ) +x4 = (#offset CONTEXT, X4 ) +x5 = (#offset CONTEXT, X5 ) +x6 = (#offset CONTEXT, X6 ) +x7 = (#offset CONTEXT, X7 ) +x8 = (#offset CONTEXT, X8 ) +x9 = (#offset CONTEXT, X9 ) +x10 = (#offset CONTEXT, X10) +x11 = (#offset CONTEXT, X11) +x12 = (#offset CONTEXT, X12) +x13 = (#offset CONTEXT, X13) +x14 = (#offset CONTEXT, X14) +x15 = (#offset CONTEXT, X15) +x16 = (#offset CONTEXT, X16) +x17 = (#offset CONTEXT, X17) +x18 = (#offset CONTEXT, X18) +x19 = (#offset CONTEXT, X19) +x20 = (#offset CONTEXT, X20) +x21 = (#offset CONTEXT, X21) +x22 = (#offset CONTEXT, X22) +x23 = (#offset CONTEXT, X23) +x24 = (#offset CONTEXT, X24) +x25 = (#offset CONTEXT, X25) +x26 = (#offset CONTEXT, X26) +x27 = (#offset CONTEXT, X27) +x28 = (#offset CONTEXT, X28) +fp = (#offset CONTEXT, Fp) +lr = (#offset CONTEXT, Lr) +sp = (#offset CONTEXT, Sp) +pc = (#offset CONTEXT, Pc) #else -#error Unsupported architecture +#error Unknown mingw32 arch #endif +#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) segCs, segDs, segEs, segFs, segGs :: Int segCs = (#offset CONTEXT, SegCs) segDs = (#offset CONTEXT, SegDs) @@ -339,6 +427,7 @@ 6 -> (#offset CONTEXT, Dr6) 7 -> (#offset CONTEXT, Dr7) _ -> undefined +#endif setReg :: Ptr a -> Int -> DWORD -> IO () setReg = pokeByteOff @@ -364,48 +453,3 @@ outputDebugString :: String -> IO () outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s --------------------------------------------------------------------------- --- Raw imports - -foreign import WINDOWS_CCONV "windows.h SuspendThread" - c_SuspendThread :: THANDLE -> IO DWORD - -foreign import WINDOWS_CCONV "windows.h ResumeThread" - c_ResumeThread :: THANDLE -> IO DWORD - -foreign import WINDOWS_CCONV "windows.h WaitForDebugEvent" - c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h ContinueDebugEvent" - c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h DebugActiveProcess" - c_DebugActiveProcess :: DWORD -> IO Bool - --- Windows XP --- foreign import WINDOWS_CCONV "windows.h DebugActiveProcessStop" --- c_DebugActiveProcessStop :: DWORD -> IO Bool - -foreign import WINDOWS_CCONV "windows.h ReadProcessMemory" c_ReadProcessMemory :: - PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h WriteProcessMemory" c_WriteProcessMemory :: - PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h GetThreadContext" - c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h SetThreadContext" - c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL - ---foreign import WINDOWS_CCONV "windows.h GetThreadId" --- c_GetThreadId :: THANDLE -> IO TID - -foreign import WINDOWS_CCONV "windows.h OutputDebugStringW" - c_OutputDebugString :: LPTSTR -> IO () - -foreign import WINDOWS_CCONV "windows.h IsDebuggerPresent" - isDebuggerPresent :: IO BOOL - -foreign import WINDOWS_CCONV "windows.h DebugBreak" - debugBreak :: IO () diff --git a/System/Win32/DebugApi/Internal.hsc b/System/Win32/DebugApi/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DebugApi/Internal.hsc @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.DebugApi.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for using Windows DebugApi. +-- +----------------------------------------------------------------------------- + +module System.Win32.DebugApi.Internal where + +import Data.Word ( Word8, Word32 ) +import Foreign ( Ptr ) +import System.Win32.Types ( BOOL, DWORD, HANDLE, LPTSTR ) + +##include "windows_cconv.h" +#include "windows.h" + +type PID = DWORD +type TID = DWORD +type DebugEventId = (PID, TID) +type ForeignAddress = Word32 + +type PHANDLE = Ptr () +type THANDLE = Ptr () + +type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress) -- handle to thread, thread local, thread start +type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress) +type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address + +-------------------------------------------------------------------------- +-- Raw imports + +foreign import WINDOWS_CCONV "windows.h SuspendThread" + c_SuspendThread :: THANDLE -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h ResumeThread" + c_ResumeThread :: THANDLE -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForDebugEvent" + c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h ContinueDebugEvent" + c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h DebugActiveProcess" + c_DebugActiveProcess :: DWORD -> IO Bool + +-- Windows XP +-- foreign import WINDOWS_CCONV "windows.h DebugActiveProcessStop" +-- c_DebugActiveProcessStop :: DWORD -> IO Bool + +foreign import WINDOWS_CCONV "windows.h ReadProcessMemory" c_ReadProcessMemory :: + PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h WriteProcessMemory" c_WriteProcessMemory :: + PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetThreadContext" + c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetThreadContext" + c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL + +--foreign import WINDOWS_CCONV "windows.h GetThreadId" +-- c_GetThreadId :: THANDLE -> IO TID + +foreign import WINDOWS_CCONV "windows.h OutputDebugStringW" + c_OutputDebugString :: LPTSTR -> IO () + +foreign import WINDOWS_CCONV "windows.h IsDebuggerPresent" + isDebuggerPresent :: IO BOOL + +foreign import WINDOWS_CCONV "windows.h DebugBreak" + debugBreak :: IO () diff --git a/System/Win32/Encoding.hs b/System/Win32/Encoding.hs --- a/System/Win32/Encoding.hs +++ b/System/Win32/Encoding.hs @@ -8,7 +8,7 @@ Stability : Provisional Portability : Non-portable (Win32 API) - Enocode/Decode mutibyte charactor using Win32 API. + Enocode/Decode mutibyte character using Win32 API. -} module System.Win32.Encoding @@ -40,7 +40,7 @@ then return conCP else getACP --- | The "System.IO" output functions (e.g. `putStr`) don't +-- | The "System.IO" output functions (e.g., `putStr`) don't -- automatically convert to multibyte string on Windows, so this -- function is provided to make the conversion from a Unicode string -- in the given code page to a proper multibyte string. To get the diff --git a/System/Win32/Event.hsc b/System/Win32/Event.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Event.hsc @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Event +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 event system between +-- processes. +-- +----------------------------------------------------------------------------- +module System.Win32.Event + ( -- * Duplicate options + DuplicateOption + , dUPLICATE_CLOSE_SOURCE + , dUPLICATE_SAME_ACCESS + -- * Access modes + , AccessMode + , eVENT_ALL_ACCESS + , eVENT_MODIFY_STATE + -- * Wait results + , WaitResult + , wAIT_ABANDONED + , wAIT_IO_COMPLETION + , wAIT_OBJECT_0 + , wAIT_TIMEOUT + , wAIT_FAILED + -- * Managing events + , openEvent + , createEvent + , duplicateHandle + , setEvent + , resetEvent + , pulseEvent + -- * Signalling objects + , signalObjectAndWait + -- * Waiting on objects + , waitForSingleObject + , waitForSingleObjectEx + , waitForMultipleObjects + , waitForMultipleObjectsEx + ) where + +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( withArrayLen ) +import Foreign.Marshal.Utils ( maybeWith, with ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.Storable ( Storable(..) ) +import Graphics.Win32.Misc ( MilliSeconds ) +import System.Win32.File ( AccessMode, LPSECURITY_ATTRIBUTES, SECURITY_ATTRIBUTES ) +import System.Win32.Types ( LPCTSTR, HANDLE, BOOL, withTString, failIf, failIfFalse_ ) +import System.Win32.Word ( DWORD ) + +##include "windows_cconv.h" + +#include "windows.h" +#include "winuser_compat.h" +#include "alignment.h" + +--------------------------------------------------------------------------- +-- Enums +--------------------------------------------------------------------------- +type DuplicateOption = DWORD +#{enum DuplicateOption, + , dUPLICATE_CLOSE_SOURCE = DUPLICATE_CLOSE_SOURCE + , dUPLICATE_SAME_ACCESS = DUPLICATE_SAME_ACCESS + } + +#{enum AccessMode, + , eVENT_ALL_ACCESS = EVENT_ALL_ACCESS + , eVENT_MODIFY_STATE = EVENT_MODIFY_STATE + } + +type WaitResult = DWORD +#{enum WaitResult, + , wAIT_ABANDONED = WAIT_ABANDONED + , wAIT_IO_COMPLETION = WAIT_IO_COMPLETION + , wAIT_OBJECT_0 = WAIT_OBJECT_0 + , wAIT_TIMEOUT = WAIT_TIMEOUT + , wAIT_FAILED = WAIT_FAILED + } + +--------------------------------------------------------------------------- +-- API in Haskell +--------------------------------------------------------------------------- +openEvent :: AccessMode -> Bool -> String -> IO HANDLE +openEvent amode inherit name = withTString name $ \c_name -> + failIf (==nullPtr) "openEvent: OpenEvent" $ c_OpenEvent (fromIntegral amode) inherit c_name + +createEvent :: Maybe SECURITY_ATTRIBUTES -> Bool -> Bool -> String -> IO HANDLE +createEvent msecurity manual initial name = withTString name $ \c_name -> + maybeWith with msecurity $ \c_sec -> + failIf (==nullPtr) "createEvent: CreateEvent" $ c_CreateEvent c_sec manual initial c_name + +duplicateHandle :: HANDLE -> HANDLE -> HANDLE -> AccessMode -> Bool -> DuplicateOption -> IO HANDLE +duplicateHandle srcProccess srcHandler targetProcess access inherit opts = alloca $ \res -> do + failIfFalse_ "duplicateHandle: DuplicateHandle" $ c_DuplicateHandle srcProccess srcHandler targetProcess res (fromIntegral access) inherit opts + peek res + +setEvent :: HANDLE -> IO () +setEvent event = failIfFalse_ "setEvent: SetEvent" $ c_SetEvent event + +resetEvent :: HANDLE -> IO () +resetEvent event = failIfFalse_ "resetEvent: ResetEvent" $ c_ResetEvent event + +pulseEvent :: HANDLE -> IO () +pulseEvent event = failIfFalse_ "pulseEvent: PulseEvent" $ c_PulseEvent event + +signalObjectAndWait :: HANDLE -> HANDLE -> MilliSeconds -> Bool -> IO WaitResult +signalObjectAndWait toSignal toWaitOn millis alterable = c_SignalObjectAndWait toSignal toWaitOn millis alterable + +waitForSingleObject :: HANDLE -> MilliSeconds -> IO WaitResult +waitForSingleObject toWaitOn millis = c_WaitForSingleObject toWaitOn millis + +waitForSingleObjectEx :: HANDLE -> MilliSeconds -> Bool -> IO WaitResult +waitForSingleObjectEx toWaitOn millis alterable = c_WaitForSingleObjectEx toWaitOn millis alterable + +waitForMultipleObjects :: [HANDLE] -> Bool -> MilliSeconds -> IO WaitResult +waitForMultipleObjects hs waitAll millis = withArrayLen hs $ \n hsp -> + c_WaitForMultipleObjects (fromIntegral n) hsp waitAll millis + +waitForMultipleObjectsEx :: [HANDLE] -> Bool -> MilliSeconds -> Bool -> IO WaitResult +waitForMultipleObjectsEx hs waitAll millis alterable = withArrayLen hs $ \n hsp -> + c_WaitForMultipleObjectsEx (fromIntegral n) hsp waitAll millis alterable + +--------------------------------------------------------------------------- +-- Imports +--------------------------------------------------------------------------- +foreign import WINDOWS_CCONV "windows.h OpenEventW" + c_OpenEvent :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h CreateEventW" + c_CreateEvent :: LPSECURITY_ATTRIBUTES -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h DuplicateHandle" + c_DuplicateHandle :: HANDLE -> HANDLE -> HANDLE -> Ptr HANDLE -> DWORD -> BOOL -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetEvent" + c_SetEvent :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV "windows.h ResetEvent" + c_ResetEvent :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV "windows.h PulseEvent" + c_PulseEvent :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV "windows.h SignalObjectAndWait" + c_SignalObjectAndWait :: HANDLE -> HANDLE -> DWORD -> BOOL -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" + c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForSingleObjectEx" + c_WaitForSingleObjectEx :: HANDLE -> DWORD -> BOOL -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForMultipleObjects" + c_WaitForMultipleObjects :: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForMultipleObjectsEx" + c_WaitForMultipleObjectsEx :: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> BOOL -> IO DWORD diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -17,314 +17,250 @@ -- ----------------------------------------------------------------------------- -module System.Win32.File where - -import System.Win32.Types -import System.Win32.Time - -import Foreign hiding (void) -import Control.Monad -import Control.Concurrent - -##include "windows_cconv.h" - -#include -#include "alignment.h" - ----------------------------------------------------------------- --- Enumeration types ----------------------------------------------------------------- - -type AccessMode = UINT - -gENERIC_NONE :: AccessMode -gENERIC_NONE = 0 - -#{enum AccessMode, - , gENERIC_READ = GENERIC_READ - , gENERIC_WRITE = GENERIC_WRITE - , gENERIC_EXECUTE = GENERIC_EXECUTE - , gENERIC_ALL = GENERIC_ALL - , dELETE = DELETE - , rEAD_CONTROL = READ_CONTROL - , wRITE_DAC = WRITE_DAC - , wRITE_OWNER = WRITE_OWNER - , sYNCHRONIZE = SYNCHRONIZE - , sTANDARD_RIGHTS_REQUIRED = STANDARD_RIGHTS_REQUIRED - , sTANDARD_RIGHTS_READ = STANDARD_RIGHTS_READ - , sTANDARD_RIGHTS_WRITE = STANDARD_RIGHTS_WRITE - , sTANDARD_RIGHTS_EXECUTE = STANDARD_RIGHTS_EXECUTE - , sTANDARD_RIGHTS_ALL = STANDARD_RIGHTS_ALL - , sPECIFIC_RIGHTS_ALL = SPECIFIC_RIGHTS_ALL - , aCCESS_SYSTEM_SECURITY = ACCESS_SYSTEM_SECURITY - , mAXIMUM_ALLOWED = MAXIMUM_ALLOWED - , fILE_ADD_FILE = FILE_ADD_FILE - , fILE_ADD_SUBDIRECTORY = FILE_ADD_SUBDIRECTORY - , fILE_ALL_ACCESS = FILE_ALL_ACCESS - , fILE_APPEND_DATA = FILE_APPEND_DATA - , fILE_CREATE_PIPE_INSTANCE = FILE_CREATE_PIPE_INSTANCE - , fILE_DELETE_CHILD = FILE_DELETE_CHILD - , fILE_EXECUTE = FILE_EXECUTE - , fILE_LIST_DIRECTORY = FILE_LIST_DIRECTORY - , fILE_READ_ATTRIBUTES = FILE_READ_ATTRIBUTES - , fILE_READ_DATA = FILE_READ_DATA - , fILE_READ_EA = FILE_READ_EA - , fILE_TRAVERSE = FILE_TRAVERSE - , fILE_WRITE_ATTRIBUTES = FILE_WRITE_ATTRIBUTES - , fILE_WRITE_DATA = FILE_WRITE_DATA - , fILE_WRITE_EA = FILE_WRITE_EA - } - ----------------------------------------------------------------- - -type ShareMode = UINT - -fILE_SHARE_NONE :: ShareMode -fILE_SHARE_NONE = 0 - -#{enum ShareMode, - , fILE_SHARE_READ = FILE_SHARE_READ - , fILE_SHARE_WRITE = FILE_SHARE_WRITE - , fILE_SHARE_DELETE = FILE_SHARE_DELETE - } - ----------------------------------------------------------------- - -type CreateMode = UINT - -#{enum CreateMode, - , cREATE_NEW = CREATE_NEW - , cREATE_ALWAYS = CREATE_ALWAYS - , oPEN_EXISTING = OPEN_EXISTING - , oPEN_ALWAYS = OPEN_ALWAYS - , tRUNCATE_EXISTING = TRUNCATE_EXISTING - } +module System.Win32.File + ( -- * Access modes + AccessMode + , gENERIC_NONE + , gENERIC_READ + , gENERIC_WRITE + , gENERIC_EXECUTE + , gENERIC_ALL + , dELETE + , rEAD_CONTROL + , wRITE_DAC + , wRITE_OWNER + , sYNCHRONIZE + , sTANDARD_RIGHTS_REQUIRED + , sTANDARD_RIGHTS_READ + , sTANDARD_RIGHTS_WRITE + , sTANDARD_RIGHTS_EXECUTE + , sTANDARD_RIGHTS_ALL + , sPECIFIC_RIGHTS_ALL + , aCCESS_SYSTEM_SECURITY + , mAXIMUM_ALLOWED + , fILE_ADD_FILE + , fILE_ADD_SUBDIRECTORY + , fILE_ALL_ACCESS + , fILE_APPEND_DATA + , fILE_CREATE_PIPE_INSTANCE + , fILE_DELETE_CHILD + , fILE_EXECUTE + , fILE_LIST_DIRECTORY + , fILE_READ_ATTRIBUTES + , fILE_READ_DATA + , fILE_READ_EA + , fILE_TRAVERSE + , fILE_WRITE_ATTRIBUTES + , fILE_WRITE_DATA + , fILE_WRITE_EA ----------------------------------------------------------------- + -- * Sharing modes + , ShareMode + , fILE_SHARE_NONE + , fILE_SHARE_READ + , fILE_SHARE_WRITE + , fILE_SHARE_DELETE -type FileAttributeOrFlag = UINT + -- * Creation modes + , CreateMode + , cREATE_NEW + , cREATE_ALWAYS + , oPEN_EXISTING + , oPEN_ALWAYS + , tRUNCATE_EXISTING -#{enum FileAttributeOrFlag, - , fILE_ATTRIBUTE_READONLY = FILE_ATTRIBUTE_READONLY - , fILE_ATTRIBUTE_HIDDEN = FILE_ATTRIBUTE_HIDDEN - , fILE_ATTRIBUTE_SYSTEM = FILE_ATTRIBUTE_SYSTEM - , fILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY - , fILE_ATTRIBUTE_ARCHIVE = FILE_ATTRIBUTE_ARCHIVE - , fILE_ATTRIBUTE_NORMAL = FILE_ATTRIBUTE_NORMAL - , fILE_ATTRIBUTE_TEMPORARY = FILE_ATTRIBUTE_TEMPORARY - , fILE_ATTRIBUTE_COMPRESSED = FILE_ATTRIBUTE_COMPRESSED - , fILE_ATTRIBUTE_REPARSE_POINT = FILE_ATTRIBUTE_REPARSE_POINT - , fILE_FLAG_WRITE_THROUGH = FILE_FLAG_WRITE_THROUGH - , fILE_FLAG_OVERLAPPED = FILE_FLAG_OVERLAPPED - , fILE_FLAG_NO_BUFFERING = FILE_FLAG_NO_BUFFERING - , fILE_FLAG_RANDOM_ACCESS = FILE_FLAG_RANDOM_ACCESS - , fILE_FLAG_SEQUENTIAL_SCAN = FILE_FLAG_SEQUENTIAL_SCAN - , fILE_FLAG_DELETE_ON_CLOSE = FILE_FLAG_DELETE_ON_CLOSE - , fILE_FLAG_BACKUP_SEMANTICS = FILE_FLAG_BACKUP_SEMANTICS - , fILE_FLAG_POSIX_SEMANTICS = FILE_FLAG_POSIX_SEMANTICS - } + -- * File attributes and flags + , FileAttributeOrFlag + , fILE_ATTRIBUTE_READONLY + , fILE_ATTRIBUTE_HIDDEN + , fILE_ATTRIBUTE_SYSTEM + , fILE_ATTRIBUTE_DIRECTORY + , fILE_ATTRIBUTE_ARCHIVE + , fILE_ATTRIBUTE_NORMAL + , fILE_ATTRIBUTE_TEMPORARY + , fILE_ATTRIBUTE_COMPRESSED + , fILE_ATTRIBUTE_REPARSE_POINT + , fILE_FLAG_WRITE_THROUGH + , fILE_FLAG_OVERLAPPED + , fILE_FLAG_NO_BUFFERING + , fILE_FLAG_RANDOM_ACCESS + , fILE_FLAG_SEQUENTIAL_SCAN + , fILE_FLAG_DELETE_ON_CLOSE + , fILE_FLAG_BACKUP_SEMANTICS + , fILE_FLAG_POSIX_SEMANTICS #ifndef __WINE_WINDOWS_H -#{enum FileAttributeOrFlag, - , sECURITY_ANONYMOUS = SECURITY_ANONYMOUS - , sECURITY_IDENTIFICATION = SECURITY_IDENTIFICATION - , sECURITY_IMPERSONATION = SECURITY_IMPERSONATION - , sECURITY_DELEGATION = SECURITY_DELEGATION - , sECURITY_CONTEXT_TRACKING = SECURITY_CONTEXT_TRACKING - , sECURITY_EFFECTIVE_ONLY = SECURITY_EFFECTIVE_ONLY - , sECURITY_SQOS_PRESENT = SECURITY_SQOS_PRESENT - , sECURITY_VALID_SQOS_FLAGS = SECURITY_VALID_SQOS_FLAGS - } + , sECURITY_ANONYMOUS + , sECURITY_IDENTIFICATION + , sECURITY_IMPERSONATION + , sECURITY_DELEGATION + , sECURITY_CONTEXT_TRACKING + , sECURITY_EFFECTIVE_ONLY + , sECURITY_SQOS_PRESENT + , sECURITY_VALID_SQOS_FLAGS #endif ----------------------------------------------------------------- - -type MoveFileFlag = DWORD - -#{enum MoveFileFlag, - , mOVEFILE_REPLACE_EXISTING = MOVEFILE_REPLACE_EXISTING - , mOVEFILE_COPY_ALLOWED = MOVEFILE_COPY_ALLOWED - , mOVEFILE_DELAY_UNTIL_REBOOT = MOVEFILE_DELAY_UNTIL_REBOOT - } - ----------------------------------------------------------------- - -type FilePtrDirection = DWORD - -#{enum FilePtrDirection, - , fILE_BEGIN = FILE_BEGIN - , fILE_CURRENT = FILE_CURRENT - , fILE_END = FILE_END - } - ----------------------------------------------------------------- - -type DriveType = UINT - -#{enum DriveType, - , dRIVE_UNKNOWN = DRIVE_UNKNOWN - , dRIVE_NO_ROOT_DIR = DRIVE_NO_ROOT_DIR - , dRIVE_REMOVABLE = DRIVE_REMOVABLE - , dRIVE_FIXED = DRIVE_FIXED - , dRIVE_REMOTE = DRIVE_REMOTE - , dRIVE_CDROM = DRIVE_CDROM - , dRIVE_RAMDISK = DRIVE_RAMDISK - } - ----------------------------------------------------------------- - -type DefineDosDeviceFlags = DWORD - -#{enum DefineDosDeviceFlags, - , dDD_RAW_TARGET_PATH = DDD_RAW_TARGET_PATH - , dDD_REMOVE_DEFINITION = DDD_REMOVE_DEFINITION - , dDD_EXACT_MATCH_ON_REMOVE = DDD_EXACT_MATCH_ON_REMOVE - } - ----------------------------------------------------------------- - -type BinaryType = DWORD - -#{enum BinaryType, - , sCS_32BIT_BINARY = SCS_32BIT_BINARY - , sCS_DOS_BINARY = SCS_DOS_BINARY - , sCS_WOW_BINARY = SCS_WOW_BINARY - , sCS_PIF_BINARY = SCS_PIF_BINARY - , sCS_POSIX_BINARY = SCS_POSIX_BINARY - , sCS_OS216_BINARY = SCS_OS216_BINARY - } + -- * Move file flags + , MoveFileFlag + , mOVEFILE_REPLACE_EXISTING + , mOVEFILE_COPY_ALLOWED + , mOVEFILE_DELAY_UNTIL_REBOOT ----------------------------------------------------------------- + -- * File pointer directions + , FilePtrDirection + , fILE_BEGIN + , fILE_CURRENT + , fILE_END -type FileNotificationFlag = DWORD + -- * Drive types + , DriveType + , dRIVE_UNKNOWN + , dRIVE_NO_ROOT_DIR + , dRIVE_REMOVABLE + , dRIVE_FIXED + , dRIVE_REMOTE + , dRIVE_CDROM + , dRIVE_RAMDISK -#{enum FileNotificationFlag, - , fILE_NOTIFY_CHANGE_FILE_NAME = FILE_NOTIFY_CHANGE_FILE_NAME - , fILE_NOTIFY_CHANGE_DIR_NAME = FILE_NOTIFY_CHANGE_DIR_NAME - , fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES - , fILE_NOTIFY_CHANGE_SIZE = FILE_NOTIFY_CHANGE_SIZE - , fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE - , fILE_NOTIFY_CHANGE_SECURITY = FILE_NOTIFY_CHANGE_SECURITY - } + -- * Define DOS device flags + , DefineDosDeviceFlags + , dDD_RAW_TARGET_PATH + , dDD_REMOVE_DEFINITION + , dDD_EXACT_MATCH_ON_REMOVE ----------------------------------------------------------------- + -- * Binary types + , BinaryType + , sCS_32BIT_BINARY + , sCS_DOS_BINARY + , sCS_WOW_BINARY + , sCS_PIF_BINARY + , sCS_POSIX_BINARY + , sCS_OS216_BINARY -type FileType = DWORD + -- * File notification flags + , FileNotificationFlag + , fILE_NOTIFY_CHANGE_FILE_NAME + , fILE_NOTIFY_CHANGE_DIR_NAME + , fILE_NOTIFY_CHANGE_ATTRIBUTES + , fILE_NOTIFY_CHANGE_SIZE + , fILE_NOTIFY_CHANGE_LAST_WRITE + , fILE_NOTIFY_CHANGE_SECURITY -#{enum FileType, - , fILE_TYPE_UNKNOWN = FILE_TYPE_UNKNOWN - , fILE_TYPE_DISK = FILE_TYPE_DISK - , fILE_TYPE_CHAR = FILE_TYPE_CHAR - , fILE_TYPE_PIPE = FILE_TYPE_PIPE - , fILE_TYPE_REMOTE = FILE_TYPE_REMOTE - } + -- * File types + , FileType + , fILE_TYPE_UNKNOWN + , fILE_TYPE_DISK + , fILE_TYPE_CHAR + , fILE_TYPE_PIPE + , fILE_TYPE_REMOTE ----------------------------------------------------------------- + -- * Lock modes + , LockMode + , lOCKFILE_EXCLUSIVE_LOCK + , lOCKFILE_FAIL_IMMEDIATELY -type LockMode = DWORD + -- * GetFileEx information levels + , GET_FILEEX_INFO_LEVELS + , getFileExInfoStandard + , getFileExMaxInfoLevel -#{enum LockMode, - , lOCKFILE_EXCLUSIVE_LOCK = LOCKFILE_EXCLUSIVE_LOCK - , lOCKFILE_FAIL_IMMEDIATELY = LOCKFILE_FAIL_IMMEDIATELY - } + -- * Security attributes + , SECURITY_ATTRIBUTES(..) + , PSECURITY_ATTRIBUTES + , LPSECURITY_ATTRIBUTES + , MbLPSECURITY_ATTRIBUTES ----------------------------------------------------------------- + -- * BY_HANDLE file information + , BY_HANDLE_FILE_INFORMATION(..) -newtype GET_FILEEX_INFO_LEVELS = GET_FILEEX_INFO_LEVELS (#type GET_FILEEX_INFO_LEVELS) - deriving (Eq, Ord) + -- * Win32 file attribute data + , WIN32_FILE_ATTRIBUTE_DATA(..) -#{enum GET_FILEEX_INFO_LEVELS, GET_FILEEX_INFO_LEVELS - , getFileExInfoStandard = GetFileExInfoStandard - , getFileExMaxInfoLevel = GetFileExMaxInfoLevel - } + -- * Helpers + , failIfWithRetry + , failIfWithRetry_ + , failIfFalseWithRetry_ + -- * File operations + , deleteFile + , copyFile + , moveFile + , moveFileEx + , setCurrentDirectory + , createDirectory + , createDirectoryEx + , removeDirectory + , getBinaryType + , getTempFileName + , replaceFile ----------------------------------------------------------------- + -- * HANDLE operations + , createFile + , createFile_NoRetry + , closeHandle + , getFileType + , flushFileBuffers + , setEndOfFile + , setFileAttributes + , getFileAttributes + , getFileAttributesExStandard + , getFileInformationByHandle -type LPSECURITY_ATTRIBUTES = Ptr () -type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES + -- ** Reading/writing + -- | Some operations below bear the @win32_@ prefix to avoid shadowing + -- operations from "Prelude". + , OVERLAPPED(..) + , LPOVERLAPPED + , MbLPOVERLAPPED + , win32_ReadFile + , win32_WriteFile + , setFilePointerEx ----------------------------------------------------------------- --- Other types ----------------------------------------------------------------- + -- * File notifications + , findFirstChangeNotification + , findNextChangeNotification + , findCloseChangeNotification -data BY_HANDLE_FILE_INFORMATION = BY_HANDLE_FILE_INFORMATION - { bhfiFileAttributes :: FileAttributeOrFlag - , bhfiCreationTime, bhfiLastAccessTime, bhfiLastWriteTime :: FILETIME - , bhfiVolumeSerialNumber :: DWORD - , bhfiSize :: DDWORD - , bhfiNumberOfLinks :: DWORD - , bhfiFileIndex :: DDWORD - } deriving (Show) + -- * Directories + , FindData + , getFindDataFileName + , findFirstFile + , findNextFile + , findClose -instance Storable BY_HANDLE_FILE_INFORMATION where - sizeOf = const (#size BY_HANDLE_FILE_INFORMATION) - alignment _ = #alignment BY_HANDLE_FILE_INFORMATION - poke buf bhi = do - (#poke BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf (bhfiFileAttributes bhi) - (#poke BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf (bhfiCreationTime bhi) - (#poke BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf (bhfiLastAccessTime bhi) - (#poke BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf (bhfiLastWriteTime bhi) - (#poke BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf (bhfiVolumeSerialNumber bhi) - (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf sizeHi - (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf sizeLow - (#poke BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf (bhfiNumberOfLinks bhi) - (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf idxHi - (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf idxLow - where - (sizeHi,sizeLow) = ddwordToDwords $ bhfiSize bhi - (idxHi,idxLow) = ddwordToDwords $ bhfiFileIndex bhi + -- * DOS device flags + , defineDosDevice + , areFileApisANSI + , setFileApisToOEM + , setFileApisToANSI + , setHandleCount + , getLogicalDrives + , getDiskFreeSpace + , setVolumeLabel - peek buf = do - attr <- (#peek BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf - ctim <- (#peek BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf - lati <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf - lwti <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf - vser <- (#peek BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf - fshi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf - fslo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf - link <- (#peek BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf - idhi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf - idlo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf - return $ BY_HANDLE_FILE_INFORMATION attr ctim lati lwti vser - (dwordsToDdword (fshi,fslo)) link (dwordsToDdword (idhi,idlo)) + -- * File locks + , lockFile + , unlockFile + ) where ----------------------------------------------------------------- +import System.Win32.File.Internal +import System.Win32.Types -data WIN32_FILE_ATTRIBUTE_DATA = WIN32_FILE_ATTRIBUTE_DATA - { fadFileAttributes :: DWORD - , fadCreationTime , fadLastAccessTime , fadLastWriteTime :: FILETIME - , fadFileSize :: DDWORD - } deriving (Show) +import Foreign hiding (void) +import Control.Monad +import Control.Concurrent +import Data.Maybe (fromMaybe) -instance Storable WIN32_FILE_ATTRIBUTE_DATA where - sizeOf = const (#size WIN32_FILE_ATTRIBUTE_DATA) - alignment _ = #alignment WIN32_FILE_ATTRIBUTE_DATA - poke buf ad = do - (#poke WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf (fadFileAttributes ad) - (#poke WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime) buf (fadCreationTime ad) - (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf (fadLastAccessTime ad) - (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime) buf (fadLastWriteTime ad) - (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh) buf sizeHi - (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow) buf sizeLo - where - (sizeHi,sizeLo) = ddwordToDwords $ fadFileSize ad +##include "windows_cconv.h" - peek buf = do - attr <- (#peek WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf - ctim <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime) buf - lati <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf - lwti <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime) buf - fshi <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh) buf - fslo <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow) buf - return $ WIN32_FILE_ATTRIBUTE_DATA attr ctim lati lwti - (dwordsToDdword (fshi,fslo)) +#include +#include "alignment.h" ---------------------------------------------------------------- -- File operations ---------------------------------------------------------------- --- | like failIfFalse_, but retried on sharing violations. +-- | like failIf, but retried on sharing violations. -- This is necessary for many file operations; see --- http://support.microsoft.com/kb/316609 +-- https://www.betaarchive.com/wiki/index.php/Microsoft_KB_Archive/316609 -- failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a failIfWithRetry cond msg action = retryOrFail retries @@ -354,187 +290,144 @@ deleteFile :: String -> IO () deleteFile name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $ c_DeleteFile c_name -foreign import WINDOWS_CCONV unsafe "windows.h DeleteFileW" - c_DeleteFile :: LPCTSTR -> IO Bool 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 -foreign import WINDOWS_CCONV unsafe "windows.h CopyFileW" - c_CopyFile :: LPCTSTR -> LPCTSTR -> Bool -> IO Bool 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 -foreign import WINDOWS_CCONV unsafe "windows.h MoveFileW" - c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool 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 -foreign import WINDOWS_CCONV unsafe "windows.h MoveFileExW" - c_MoveFileEx :: LPCTSTR -> LPCTSTR -> MoveFileFlag -> IO Bool setCurrentDirectory :: String -> IO () setCurrentDirectory name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $ c_SetCurrentDirectory c_name -foreign import WINDOWS_CCONV unsafe "windows.h SetCurrentDirectoryW" - c_SetCurrentDirectory :: LPCTSTR -> IO Bool 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) -foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryW" - c_CreateDirectory :: LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool 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) -foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryExW" - c_CreateDirectoryEx :: LPCTSTR -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool removeDirectory :: String -> IO () removeDirectory name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $ c_RemoveDirectory c_name -foreign import WINDOWS_CCONV unsafe "windows.h RemoveDirectoryW" - c_RemoveDirectory :: LPCTSTR -> IO Bool getBinaryType :: String -> IO BinaryType getBinaryType name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> alloca $ \ p_btype -> do failIfFalse_ (unwords ["GetBinaryType",show name]) $ c_GetBinaryType c_name p_btype peek p_btype -foreign import WINDOWS_CCONV unsafe "windows.h GetBinaryTypeW" - c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool +-- | Get a unique temporary filename. +-- +-- Calls 'GetTempFileNameW'. +getTempFileName :: String -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long) + -> String -- ^ prefix for the temporary file name + -> Maybe UINT -- ^ if 'Nothing', a unique name is generated + -- otherwise a non-zero value is used as the unique part + -> IO (String, UINT) +getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do + uid <- withFilePath dir $ \c_dir -> + withFilePath prefix $ \ c_prefix -> do + failIfZero "getTempFileName" $ + c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf + fname <- peekTString c_buf + return (fname, uid) + ---------------------------------------------------------------- -- HANDLE operations ---------------------------------------------------------------- createFile :: String -> 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 -> - failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ +createFile = createFile' failIfWithRetry + +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 = + 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) -foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" - c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE +-- | Like createFile, but does not use failIfWithRetry. If another +-- process has the same file open, this will fail. +createFile_NoRetry :: String -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE +createFile_NoRetry = createFile' failIf + closeHandle :: HANDLE -> IO () closeHandle h = failIfFalse_ "CloseHandle" $ c_CloseHandle h -foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle" - c_CloseHandle :: HANDLE -> IO Bool -{-# CFILES cbits/HsWin32.c #-} -foreign import ccall "HsWin32.h &CloseHandleFinaliser" - c_CloseHandleFinaliser :: FunPtr (Ptr a -> IO ()) - -foreign import WINDOWS_CCONV unsafe "windows.h GetFileType" - getFileType :: HANDLE -> IO FileType --Apparently no error code flushFileBuffers :: HANDLE -> IO () flushFileBuffers h = failIfFalse_ "FlushFileBuffers" $ c_FlushFileBuffers h -foreign import WINDOWS_CCONV unsafe "windows.h FlushFileBuffers" - c_FlushFileBuffers :: HANDLE -> IO Bool setEndOfFile :: HANDLE -> IO () setEndOfFile h = failIfFalse_ "SetEndOfFile" $ c_SetEndOfFile h -foreign import WINDOWS_CCONV unsafe "windows.h SetEndOfFile" - c_SetEndOfFile :: HANDLE -> IO Bool 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 -foreign import WINDOWS_CCONV unsafe "windows.h SetFileAttributesW" - c_SetFileAttributes :: LPCTSTR -> FileAttributeOrFlag -> IO Bool getFileAttributes :: String -> IO FileAttributeOrFlag getFileAttributes name = - withTString name $ \ c_name -> + withFilePath name $ \ c_name -> failIfWithRetry (== 0xFFFFFFFF) (unwords ["GetFileAttributes",show name]) $ c_GetFileAttributes c_name -foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesW" - c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag 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 -foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesExW" - c_GetFileAttributesEx :: LPCTSTR -> GET_FILEEX_INFO_LEVELS -> Ptr a -> IO BOOL getFileInformationByHandle :: HANDLE -> IO BY_HANDLE_FILE_INFORMATION getFileInformationByHandle h = alloca $ \res -> do failIfFalseWithRetry_ "GetFileInformationByHandle" $ c_GetFileInformationByHandle h res peek res -foreign import WINDOWS_CCONV unsafe "windows.h GetFileInformationByHandle" - c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL +replaceFile :: LPCWSTR -> LPCWSTR -> LPCWSTR -> DWORD -> IO () +replaceFile replacedFile replacementFile backupFile replaceFlags = + failIfFalse_ "ReplaceFile" $ c_ReplaceFile replacedFile replacementFile backupFile replaceFlags nullPtr nullPtr + ---------------------------------------------------------------- -- Read/write files ---------------------------------------------------------------- --- No support for this yet -data OVERLAPPED - = OVERLAPPED { ovl_internal :: ULONG_PTR - , ovl_internalHigh :: ULONG_PTR - , ovl_offset :: DWORD - , ovl_offsetHigh :: DWORD - , ovl_hEvent :: HANDLE - } deriving (Show) - -instance Storable OVERLAPPED where - sizeOf = const (#size OVERLAPPED) - alignment _ = #alignment OVERLAPPED - poke buf ad = do - (#poke OVERLAPPED, Internal ) buf (ovl_internal ad) - (#poke OVERLAPPED, InternalHigh) buf (ovl_internalHigh ad) - (#poke OVERLAPPED, Offset ) buf (ovl_offset ad) - (#poke OVERLAPPED, OffsetHigh ) buf (ovl_offsetHigh ad) - (#poke OVERLAPPED, hEvent ) buf (ovl_hEvent ad) - - peek buf = do - intnl <- (#peek OVERLAPPED, Internal ) buf - intnl_high <- (#peek OVERLAPPED, InternalHigh) buf - off <- (#peek OVERLAPPED, Offset ) buf - off_high <- (#peek OVERLAPPED, OffsetHigh ) buf - hevnt <- (#peek OVERLAPPED, hEvent ) buf - return $ OVERLAPPED intnl intnl_high off off_high hevnt - -type LPOVERLAPPED = Ptr OVERLAPPED - -type MbLPOVERLAPPED = Maybe LPOVERLAPPED - --Sigh - I give up & prefix win32_ to the next two to avoid -- senseless Prelude name clashes. --sof. @@ -543,24 +436,18 @@ alloca $ \ p_n -> do failIfFalse_ "ReadFile" $ c_ReadFile h buf n p_n (maybePtr mb_over) peek p_n -foreign import WINDOWS_CCONV unsafe "windows.h ReadFile" - c_ReadFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool win32_WriteFile :: HANDLE -> Ptr a -> DWORD -> Maybe LPOVERLAPPED -> IO DWORD win32_WriteFile h buf n mb_over = alloca $ \ p_n -> do failIfFalse_ "WriteFile" $ c_WriteFile h buf n p_n (maybePtr mb_over) peek p_n -foreign import WINDOWS_CCONV unsafe "windows.h WriteFile" - c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool setFilePointerEx :: HANDLE -> LARGE_INTEGER -> FilePtrDirection -> IO LARGE_INTEGER setFilePointerEx h dist dir = alloca $ \p_pos -> do failIfFalse_ "SetFilePointerEx" $ c_SetFilePointerEx h dist p_pos dir peek p_pos -foreign import WINDOWS_CCONV unsafe "windows.h SetFilePointerEx" - c_SetFilePointerEx :: HANDLE -> LARGE_INTEGER -> Ptr LARGE_INTEGER -> FilePtrDirection -> IO Bool ---------------------------------------------------------------- -- File Notifications @@ -571,32 +458,22 @@ 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 -foreign import WINDOWS_CCONV unsafe "windows.h FindFirstChangeNotificationW" - c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE findNextChangeNotification :: HANDLE -> IO () findNextChangeNotification h = failIfFalse_ "FindNextChangeNotification" $ c_FindNextChangeNotification h -foreign import WINDOWS_CCONV unsafe "windows.h FindNextChangeNotification" - c_FindNextChangeNotification :: HANDLE -> IO Bool findCloseChangeNotification :: HANDLE -> IO () findCloseChangeNotification h = failIfFalse_ "FindCloseChangeNotification" $ c_FindCloseChangeNotification h -foreign import WINDOWS_CCONV unsafe "windows.h FindCloseChangeNotification" - c_FindCloseChangeNotification :: HANDLE -> IO Bool ---------------------------------------------------------------- -- Directories ---------------------------------------------------------------- -type WIN32_FIND_DATA = () - -newtype FindData = FindData (ForeignPtr WIN32_FIND_DATA) - getFindDataFileName :: FindData -> IO FilePath getFindDataFileName (FindData fp) = withForeignPtr fp $ \p -> @@ -606,12 +483,10 @@ 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) -foreign import WINDOWS_CCONV unsafe "windows.h FindFirstFileW" - c_FindFirstFile :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE findNextFile :: HANDLE -> FindData -> IO Bool -- False -> no more files findNextFile h (FindData finddata) = do @@ -624,13 +499,9 @@ if err_code == (# const ERROR_NO_MORE_FILES ) then return False else failWith "findNextFile" err_code -foreign import WINDOWS_CCONV unsafe "windows.h FindNextFileW" - c_FindNextFile :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL findClose :: HANDLE -> IO () findClose h = failIfFalse_ "findClose" $ c_FindClose h -foreign import WINDOWS_CCONV unsafe "windows.h FindClose" - c_FindClose :: HANDLE -> IO BOOL ---------------------------------------------------------------- -- DOS Device flags @@ -638,42 +509,21 @@ 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 -foreign import WINDOWS_CCONV unsafe "windows.h DefineDosDeviceW" - c_DefineDosDevice :: DefineDosDeviceFlags -> LPCTSTR -> LPCTSTR -> IO Bool ---------------------------------------------------------------- --- These functions are very unusual in the Win32 API: --- They dont return error codes - -foreign import WINDOWS_CCONV unsafe "windows.h AreFileApisANSI" - areFileApisANSI :: IO Bool - -foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToOEM" - setFileApisToOEM :: IO () - -foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToANSI" - setFileApisToANSI :: IO () - -foreign import WINDOWS_CCONV unsafe "windows.h SetHandleCount" - setHandleCount :: UINT -> IO UINT - ----------------------------------------------------------------- - getLogicalDrives :: IO DWORD getLogicalDrives = failIfZero "GetLogicalDrives" $ c_GetLogicalDrives -foreign import WINDOWS_CCONV unsafe "windows.h GetLogicalDrives" - c_GetLogicalDrives :: IO DWORD -- %fun GetDriveType :: Maybe String -> IO DriveType 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 -> @@ -685,16 +535,12 @@ nfree <- peek p_nfree nclusters <- peek p_nclusters return (sectors, bytes, nfree, nclusters) -foreign import WINDOWS_CCONV unsafe "windows.h GetDiskFreeSpaceW" - c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool 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 -foreign import WINDOWS_CCONV unsafe "windows.h SetVolumeLabelW" - c_SetVolumeLabel :: LPCTSTR -> LPCTSTR -> IO Bool ---------------------------------------------------------------- -- File locks @@ -716,10 +562,6 @@ ovlp = OVERLAPPED 0 0 o_low o_hi nullPtr with ovlp $ \ptr -> c_LockFileEx hwnd mode 0 s_low s_hi ptr -foreign import WINDOWS_CCONV unsafe "LockFileEx" - c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED - -> IO BOOL - -- | Unlocks a given range in a file handle, To unlock an entire file -- use 0xFFFFFFFFFFFFFFFF for size and 0 for offset. unlockFile :: HANDLE -- ^ CreateFile handle @@ -734,9 +576,6 @@ o_hi = fromIntegral (f_offset `shiftR` 32) ovlp = OVERLAPPED 0 0 o_low o_hi nullPtr with ovlp $ \ptr -> c_UnlockFileEx hwnd 0 s_low s_hi ptr - -foreign import WINDOWS_CCONV unsafe "UnlockFileEx" - c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL ---------------------------------------------------------------- -- End diff --git a/System/Win32/File/Internal.hsc b/System/Win32/File/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/File/Internal.hsc @@ -0,0 +1,548 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.File.Internal +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.File.Internal where + +import System.Win32.Types +import System.Win32.Time + +import Foreign hiding (void) + +##include "windows_cconv.h" + +-- For REPLACEFILE_IGNORE_ACL_ERRORS +#define _WIN32_WINNT 0x0600 + +#include +#include "alignment.h" + +---------------------------------------------------------------- +-- Enumeration types +---------------------------------------------------------------- + +type AccessMode = UINT + +gENERIC_NONE :: AccessMode +gENERIC_NONE = 0 + +#{enum AccessMode, + , gENERIC_READ = GENERIC_READ + , gENERIC_WRITE = GENERIC_WRITE + , gENERIC_EXECUTE = GENERIC_EXECUTE + , gENERIC_ALL = GENERIC_ALL + , dELETE = DELETE + , rEAD_CONTROL = READ_CONTROL + , wRITE_DAC = WRITE_DAC + , wRITE_OWNER = WRITE_OWNER + , sYNCHRONIZE = SYNCHRONIZE + , sTANDARD_RIGHTS_REQUIRED = STANDARD_RIGHTS_REQUIRED + , sTANDARD_RIGHTS_READ = STANDARD_RIGHTS_READ + , sTANDARD_RIGHTS_WRITE = STANDARD_RIGHTS_WRITE + , sTANDARD_RIGHTS_EXECUTE = STANDARD_RIGHTS_EXECUTE + , sTANDARD_RIGHTS_ALL = STANDARD_RIGHTS_ALL + , sPECIFIC_RIGHTS_ALL = SPECIFIC_RIGHTS_ALL + , aCCESS_SYSTEM_SECURITY = ACCESS_SYSTEM_SECURITY + , mAXIMUM_ALLOWED = MAXIMUM_ALLOWED + , fILE_ADD_FILE = FILE_ADD_FILE + , fILE_ADD_SUBDIRECTORY = FILE_ADD_SUBDIRECTORY + , fILE_ALL_ACCESS = FILE_ALL_ACCESS + , fILE_APPEND_DATA = FILE_APPEND_DATA + , fILE_CREATE_PIPE_INSTANCE = FILE_CREATE_PIPE_INSTANCE + , fILE_DELETE_CHILD = FILE_DELETE_CHILD + , fILE_EXECUTE = FILE_EXECUTE + , fILE_LIST_DIRECTORY = FILE_LIST_DIRECTORY + , fILE_READ_ATTRIBUTES = FILE_READ_ATTRIBUTES + , fILE_READ_DATA = FILE_READ_DATA + , fILE_READ_EA = FILE_READ_EA + , fILE_TRAVERSE = FILE_TRAVERSE + , fILE_WRITE_ATTRIBUTES = FILE_WRITE_ATTRIBUTES + , fILE_WRITE_DATA = FILE_WRITE_DATA + , fILE_WRITE_EA = FILE_WRITE_EA + } + +---------------------------------------------------------------- + +type ShareMode = UINT + +fILE_SHARE_NONE :: ShareMode +fILE_SHARE_NONE = 0 + +#{enum ShareMode, + , fILE_SHARE_READ = FILE_SHARE_READ + , fILE_SHARE_WRITE = FILE_SHARE_WRITE + , fILE_SHARE_DELETE = FILE_SHARE_DELETE + } + +---------------------------------------------------------------- + +type CreateMode = UINT + +#{enum CreateMode, + , cREATE_NEW = CREATE_NEW + , cREATE_ALWAYS = CREATE_ALWAYS + , oPEN_EXISTING = OPEN_EXISTING + , oPEN_ALWAYS = OPEN_ALWAYS + , tRUNCATE_EXISTING = TRUNCATE_EXISTING + } + +---------------------------------------------------------------- + +type FileAttributeOrFlag = UINT + +#{enum FileAttributeOrFlag, + , fILE_ATTRIBUTE_READONLY = FILE_ATTRIBUTE_READONLY + , fILE_ATTRIBUTE_HIDDEN = FILE_ATTRIBUTE_HIDDEN + , fILE_ATTRIBUTE_SYSTEM = FILE_ATTRIBUTE_SYSTEM + , fILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY + , fILE_ATTRIBUTE_ARCHIVE = FILE_ATTRIBUTE_ARCHIVE + , fILE_ATTRIBUTE_NORMAL = FILE_ATTRIBUTE_NORMAL + , fILE_ATTRIBUTE_TEMPORARY = FILE_ATTRIBUTE_TEMPORARY + , fILE_ATTRIBUTE_COMPRESSED = FILE_ATTRIBUTE_COMPRESSED + , fILE_ATTRIBUTE_REPARSE_POINT = FILE_ATTRIBUTE_REPARSE_POINT + , fILE_FLAG_WRITE_THROUGH = FILE_FLAG_WRITE_THROUGH + , fILE_FLAG_OVERLAPPED = FILE_FLAG_OVERLAPPED + , fILE_FLAG_NO_BUFFERING = FILE_FLAG_NO_BUFFERING + , fILE_FLAG_RANDOM_ACCESS = FILE_FLAG_RANDOM_ACCESS + , fILE_FLAG_SEQUENTIAL_SCAN = FILE_FLAG_SEQUENTIAL_SCAN + , fILE_FLAG_DELETE_ON_CLOSE = FILE_FLAG_DELETE_ON_CLOSE + , fILE_FLAG_BACKUP_SEMANTICS = FILE_FLAG_BACKUP_SEMANTICS + , fILE_FLAG_POSIX_SEMANTICS = FILE_FLAG_POSIX_SEMANTICS + } +#ifndef __WINE_WINDOWS_H +#{enum FileAttributeOrFlag, + , sECURITY_ANONYMOUS = SECURITY_ANONYMOUS + , sECURITY_IDENTIFICATION = SECURITY_IDENTIFICATION + , sECURITY_IMPERSONATION = SECURITY_IMPERSONATION + , sECURITY_DELEGATION = SECURITY_DELEGATION + , sECURITY_CONTEXT_TRACKING = SECURITY_CONTEXT_TRACKING + , sECURITY_EFFECTIVE_ONLY = SECURITY_EFFECTIVE_ONLY + , sECURITY_SQOS_PRESENT = SECURITY_SQOS_PRESENT + , sECURITY_VALID_SQOS_FLAGS = SECURITY_VALID_SQOS_FLAGS + } +#endif + +---------------------------------------------------------------- + +type MoveFileFlag = DWORD + +#{enum MoveFileFlag, + , mOVEFILE_REPLACE_EXISTING = MOVEFILE_REPLACE_EXISTING + , mOVEFILE_COPY_ALLOWED = MOVEFILE_COPY_ALLOWED + , mOVEFILE_DELAY_UNTIL_REBOOT = MOVEFILE_DELAY_UNTIL_REBOOT + } + +---------------------------------------------------------------- + +type FilePtrDirection = DWORD + +#{enum FilePtrDirection, + , fILE_BEGIN = FILE_BEGIN + , fILE_CURRENT = FILE_CURRENT + , fILE_END = FILE_END + } + +---------------------------------------------------------------- + +type DriveType = UINT + +#{enum DriveType, + , dRIVE_UNKNOWN = DRIVE_UNKNOWN + , dRIVE_NO_ROOT_DIR = DRIVE_NO_ROOT_DIR + , dRIVE_REMOVABLE = DRIVE_REMOVABLE + , dRIVE_FIXED = DRIVE_FIXED + , dRIVE_REMOTE = DRIVE_REMOTE + , dRIVE_CDROM = DRIVE_CDROM + , dRIVE_RAMDISK = DRIVE_RAMDISK + } + +---------------------------------------------------------------- + +type DefineDosDeviceFlags = DWORD + +#{enum DefineDosDeviceFlags, + , dDD_RAW_TARGET_PATH = DDD_RAW_TARGET_PATH + , dDD_REMOVE_DEFINITION = DDD_REMOVE_DEFINITION + , dDD_EXACT_MATCH_ON_REMOVE = DDD_EXACT_MATCH_ON_REMOVE + } + +---------------------------------------------------------------- + +type BinaryType = DWORD + +#{enum BinaryType, + , sCS_32BIT_BINARY = SCS_32BIT_BINARY + , sCS_DOS_BINARY = SCS_DOS_BINARY + , sCS_WOW_BINARY = SCS_WOW_BINARY + , sCS_PIF_BINARY = SCS_PIF_BINARY + , sCS_POSIX_BINARY = SCS_POSIX_BINARY + , sCS_OS216_BINARY = SCS_OS216_BINARY + } + +---------------------------------------------------------------- + +type ReplaceType = DWORD + +#{enum ReplaceType, + , rEPLACEFILE_WRITE_THROUGH = REPLACEFILE_WRITE_THROUGH + , rEPLACEFILE_IGNORE_MERGE_ERRORS = REPLACEFILE_IGNORE_MERGE_ERRORS + , rEPLACEFILE_IGNORE_ACL_ERRORS = REPLACEFILE_IGNORE_ACL_ERRORS + } + +---------------------------------------------------------------- + +type FileNotificationFlag = DWORD + +#{enum FileNotificationFlag, + , fILE_NOTIFY_CHANGE_FILE_NAME = FILE_NOTIFY_CHANGE_FILE_NAME + , fILE_NOTIFY_CHANGE_DIR_NAME = FILE_NOTIFY_CHANGE_DIR_NAME + , fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES + , fILE_NOTIFY_CHANGE_SIZE = FILE_NOTIFY_CHANGE_SIZE + , fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE + , fILE_NOTIFY_CHANGE_SECURITY = FILE_NOTIFY_CHANGE_SECURITY + } + +---------------------------------------------------------------- + +type FileType = DWORD + +#{enum FileType, + , fILE_TYPE_UNKNOWN = FILE_TYPE_UNKNOWN + , fILE_TYPE_DISK = FILE_TYPE_DISK + , fILE_TYPE_CHAR = FILE_TYPE_CHAR + , fILE_TYPE_PIPE = FILE_TYPE_PIPE + , fILE_TYPE_REMOTE = FILE_TYPE_REMOTE + } + +---------------------------------------------------------------- + +type LockMode = DWORD + +#{enum LockMode, + , lOCKFILE_EXCLUSIVE_LOCK = LOCKFILE_EXCLUSIVE_LOCK + , lOCKFILE_FAIL_IMMEDIATELY = LOCKFILE_FAIL_IMMEDIATELY + } + +---------------------------------------------------------------- + +newtype GET_FILEEX_INFO_LEVELS = GET_FILEEX_INFO_LEVELS (#type GET_FILEEX_INFO_LEVELS) + deriving (Eq, Ord) + +#{enum GET_FILEEX_INFO_LEVELS, GET_FILEEX_INFO_LEVELS + , getFileExInfoStandard = GetFileExInfoStandard + , getFileExMaxInfoLevel = GetFileExMaxInfoLevel + } + +---------------------------------------------------------------- + +data SECURITY_ATTRIBUTES = SECURITY_ATTRIBUTES + { nLength :: !DWORD + , lpSecurityDescriptor :: !LPVOID + , bInheritHandle :: !BOOL + } deriving Show + +type PSECURITY_ATTRIBUTES = Ptr SECURITY_ATTRIBUTES +type LPSECURITY_ATTRIBUTES = Ptr SECURITY_ATTRIBUTES +type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES + +instance Storable SECURITY_ATTRIBUTES where + sizeOf = const #{size SECURITY_ATTRIBUTES} + alignment _ = #alignment SECURITY_ATTRIBUTES + poke buf input = do + (#poke SECURITY_ATTRIBUTES, nLength) buf (nLength input) + (#poke SECURITY_ATTRIBUTES, lpSecurityDescriptor) buf (lpSecurityDescriptor input) + (#poke SECURITY_ATTRIBUTES, bInheritHandle) buf (bInheritHandle input) + peek buf = do + nLength' <- (#peek SECURITY_ATTRIBUTES, nLength) buf + lpSecurityDescriptor' <- (#peek SECURITY_ATTRIBUTES, lpSecurityDescriptor) buf + bInheritHandle' <- (#peek SECURITY_ATTRIBUTES, bInheritHandle) buf + return $ SECURITY_ATTRIBUTES nLength' lpSecurityDescriptor' bInheritHandle' + +---------------------------------------------------------------- +-- Other types +---------------------------------------------------------------- + +data BY_HANDLE_FILE_INFORMATION = BY_HANDLE_FILE_INFORMATION + { bhfiFileAttributes :: FileAttributeOrFlag + , bhfiCreationTime, bhfiLastAccessTime, bhfiLastWriteTime :: FILETIME + , bhfiVolumeSerialNumber :: DWORD + , bhfiSize :: DDWORD + , bhfiNumberOfLinks :: DWORD + , bhfiFileIndex :: DDWORD + } deriving (Show) + +instance Storable BY_HANDLE_FILE_INFORMATION where + sizeOf = const (#size BY_HANDLE_FILE_INFORMATION) + alignment _ = #alignment BY_HANDLE_FILE_INFORMATION + poke buf bhi = do + (#poke BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf (bhfiFileAttributes bhi) + (#poke BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf (bhfiCreationTime bhi) + (#poke BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf (bhfiLastAccessTime bhi) + (#poke BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf (bhfiLastWriteTime bhi) + (#poke BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf (bhfiVolumeSerialNumber bhi) + (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf sizeHi + (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf sizeLow + (#poke BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf (bhfiNumberOfLinks bhi) + (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf idxHi + (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf idxLow + where + (sizeHi,sizeLow) = ddwordToDwords $ bhfiSize bhi + (idxHi,idxLow) = ddwordToDwords $ bhfiFileIndex bhi + + peek buf = do + attr <- (#peek BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf + ctim <- (#peek BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf + lati <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf + lwti <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf + vser <- (#peek BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf + fshi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf + fslo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf + link <- (#peek BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf + idhi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf + idlo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf + return $ BY_HANDLE_FILE_INFORMATION attr ctim lati lwti vser + (dwordsToDdword (fshi,fslo)) link (dwordsToDdword (idhi,idlo)) + +---------------------------------------------------------------- + +data WIN32_FILE_ATTRIBUTE_DATA = WIN32_FILE_ATTRIBUTE_DATA + { fadFileAttributes :: DWORD + , fadCreationTime , fadLastAccessTime , fadLastWriteTime :: FILETIME + , fadFileSize :: DDWORD + } deriving (Show) + +instance Storable WIN32_FILE_ATTRIBUTE_DATA where + sizeOf = const (#size WIN32_FILE_ATTRIBUTE_DATA) + alignment _ = #alignment WIN32_FILE_ATTRIBUTE_DATA + poke buf ad = do + (#poke WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf (fadFileAttributes ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime) buf (fadCreationTime ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf (fadLastAccessTime ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime) buf (fadLastWriteTime ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh) buf sizeHi + (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow) buf sizeLo + where + (sizeHi,sizeLo) = ddwordToDwords $ fadFileSize ad + + peek buf = do + attr <- (#peek WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf + ctim <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime) buf + lati <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf + lwti <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime) buf + fshi <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh) buf + fslo <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow) buf + return $ WIN32_FILE_ATTRIBUTE_DATA attr ctim lati lwti + (dwordsToDdword (fshi,fslo)) + +---------------------------------------------------------------- +-- File operations +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h DeleteFileW" + c_DeleteFile :: LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CopyFileW" + c_CopyFile :: LPCTSTR -> LPCTSTR -> Bool -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h MoveFileW" + c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h MoveFileExW" + c_MoveFileEx :: LPCTSTR -> LPCTSTR -> MoveFileFlag -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetCurrentDirectoryW" + c_SetCurrentDirectory :: LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryW" + c_CreateDirectory :: LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryExW" + c_CreateDirectoryEx :: LPCTSTR -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h RemoveDirectoryW" + c_RemoveDirectory :: LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetBinaryTypeW" + c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h ReplaceFileW" + c_ReplaceFile :: LPCWSTR -> LPCWSTR -> LPCWSTR -> DWORD -> LPVOID -> LPVOID -> IO Bool + +---------------------------------------------------------------- +-- HANDLE operations +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" + c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE + +foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle" + c_CloseHandle :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileType" + getFileType :: HANDLE -> IO FileType +--Apparently no error code + +foreign import WINDOWS_CCONV unsafe "windows.h FlushFileBuffers" + c_FlushFileBuffers :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetEndOfFile" + c_SetEndOfFile :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetFileAttributesW" + c_SetFileAttributes :: LPCTSTR -> FileAttributeOrFlag -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesW" + c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesExW" + c_GetFileAttributesEx :: LPCTSTR -> GET_FILEEX_INFO_LEVELS -> Ptr a -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileInformationByHandle" + c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetTempFileNameW" + c_GetTempFileNameW :: LPCWSTR -> LPCWSTR -> UINT -> LPWSTR -> IO UINT + +---------------------------------------------------------------- +-- Read/write files +---------------------------------------------------------------- + +-- No support for this yet +data OVERLAPPED + = OVERLAPPED { ovl_internal :: ULONG_PTR + , ovl_internalHigh :: ULONG_PTR + , ovl_offset :: DWORD + , ovl_offsetHigh :: DWORD + , ovl_hEvent :: HANDLE + } deriving (Show) + +instance Storable OVERLAPPED where + sizeOf = const (#size OVERLAPPED) + alignment _ = #alignment OVERLAPPED + poke buf ad = do + (#poke OVERLAPPED, Internal ) buf (ovl_internal ad) + (#poke OVERLAPPED, InternalHigh) buf (ovl_internalHigh ad) + (#poke OVERLAPPED, Offset ) buf (ovl_offset ad) + (#poke OVERLAPPED, OffsetHigh ) buf (ovl_offsetHigh ad) + (#poke OVERLAPPED, hEvent ) buf (ovl_hEvent ad) + + peek buf = do + intnl <- (#peek OVERLAPPED, Internal ) buf + intnl_high <- (#peek OVERLAPPED, InternalHigh) buf + off <- (#peek OVERLAPPED, Offset ) buf + off_high <- (#peek OVERLAPPED, OffsetHigh ) buf + hevnt <- (#peek OVERLAPPED, hEvent ) buf + return $ OVERLAPPED intnl intnl_high off off_high hevnt + +type LPOVERLAPPED = Ptr OVERLAPPED + +type MbLPOVERLAPPED = Maybe LPOVERLAPPED + +foreign import WINDOWS_CCONV unsafe "windows.h ReadFile" + c_ReadFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h WriteFile" + c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetFilePointerEx" + c_SetFilePointerEx :: HANDLE -> LARGE_INTEGER -> Ptr LARGE_INTEGER -> FilePtrDirection -> IO Bool + +---------------------------------------------------------------- +-- File Notifications +-- +-- Use these to initialise, "increment" and close a HANDLE you can wait +-- on. +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h FindFirstChangeNotificationW" + c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE + +foreign import WINDOWS_CCONV unsafe "windows.h FindNextChangeNotification" + c_FindNextChangeNotification :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h FindCloseChangeNotification" + c_FindCloseChangeNotification :: HANDLE -> IO Bool + +---------------------------------------------------------------- +-- Directories +---------------------------------------------------------------- + +type WIN32_FIND_DATA = () + +newtype FindData = FindData (ForeignPtr WIN32_FIND_DATA) + +foreign import WINDOWS_CCONV unsafe "windows.h FindFirstFileW" + c_FindFirstFile :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE + +foreign import WINDOWS_CCONV unsafe "windows.h FindNextFileW" + c_FindNextFile :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h FindClose" + c_FindClose :: HANDLE -> IO BOOL + +---------------------------------------------------------------- +-- DOS Device flags +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h DefineDosDeviceW" + c_DefineDosDevice :: DefineDosDeviceFlags -> LPCTSTR -> LPCTSTR -> IO Bool + +---------------------------------------------------------------- + +-- These functions are very unusual in the Win32 API: +-- They don't return error codes + +foreign import WINDOWS_CCONV unsafe "windows.h AreFileApisANSI" + areFileApisANSI :: IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToOEM" + setFileApisToOEM :: IO () + +foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToANSI" + setFileApisToANSI :: IO () + +foreign import WINDOWS_CCONV unsafe "windows.h SetHandleCount" + setHandleCount :: UINT -> IO UINT + +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h GetLogicalDrives" + c_GetLogicalDrives :: IO DWORD + +-- %fun GetDriveType :: Maybe String -> IO DriveType + +foreign import WINDOWS_CCONV unsafe "windows.h GetDiskFreeSpaceW" + c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetVolumeLabelW" + c_SetVolumeLabel :: LPCTSTR -> LPCTSTR -> IO Bool + +---------------------------------------------------------------- +-- File locks +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "LockFileEx" + c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED + -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "UnlockFileEx" + c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/FileMapping.hsc b/System/Win32/FileMapping.hsc --- a/System/Win32/FileMapping.hsc +++ b/System/Win32/FileMapping.hsc @@ -1,4 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else {-# LANGUAGE Trustworthy #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : System.Win32.FileMapping @@ -12,9 +16,37 @@ -- A collection of FFI declarations for interfacing with Win32 mapped files. -- ----------------------------------------------------------------------------- -module System.Win32.FileMapping where +module System.Win32.FileMapping + ( mapFile + , MappedObject(..) + , withMappedFile + , withMappedArea + -- * Enums + -- ** Section protection flags + , ProtectSectionFlags + , sEC_COMMIT + , sEC_IMAGE + , sEC_NOCACHE + , sEC_RESERVE + -- ** Access falgs + , FileMapAccess + , fILE_MAP_ALL_ACCESS + , fILE_MAP_COPY + , fILE_MAP_READ + , fILE_MAP_WRITE + , fILE_SHARE_WRITE -import System.Win32.Types ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR, withTString + -- * Mapping files + , createFileMapping + , openFileMapping + , mapViewOfFileEx + , mapViewOfFile + , unmapViewOfFile + ) where + + +import System.Win32.FileMapping.Internal +import System.Win32.Types ( HANDLE, BOOL, SIZE_T, withTString , failIf, failIfNull, DDWORD, ddwordToDwords , iNVALID_HANDLE_VALUE ) import System.Win32.Mem @@ -22,11 +54,8 @@ import System.Win32.Info import Control.Exception ( mask_, bracket ) -import Data.ByteString ( ByteString ) -import Data.ByteString.Internal ( fromForeignPtr ) -import Foreign ( Ptr, nullPtr, plusPtr, maybeWith, FunPtr +import Foreign ( Ptr, nullPtr, plusPtr, maybeWith , ForeignPtr, newForeignPtr ) -import Foreign.C.Types (CUIntPtr(..)) ##include "windows_cconv.h" @@ -53,14 +82,6 @@ newForeignPtr c_UnmapViewOfFileFinaliser ptr return (fp, fromIntegral $ bhfiSize fi) --- | As mapFile, but returns ByteString -mapFileBs :: FilePath -> IO ByteString -mapFileBs p = do - (fp,i) <- mapFile p - return $ fromForeignPtr fp 0 i - -data MappedObject = MappedObject HANDLE HANDLE FileMapAccess - -- | Opens an existing file and creates mapping object to it. withMappedFile :: FilePath -- ^ Path @@ -106,24 +127,6 @@ (act . flip plusPtr (fromIntegral offset)) --------------------------------------------------------------------------- --- Enums ---------------------------------------------------------------------------- -type ProtectSectionFlags = DWORD -#{enum ProtectSectionFlags, - , sEC_COMMIT = SEC_COMMIT - , sEC_IMAGE = SEC_IMAGE - , sEC_NOCACHE = SEC_NOCACHE - , sEC_RESERVE = SEC_RESERVE - } -type FileMapAccess = DWORD -#{enum FileMapAccess, - , fILE_MAP_ALL_ACCESS = FILE_MAP_ALL_ACCESS - , fILE_MAP_COPY = FILE_MAP_COPY - , fILE_MAP_READ = FILE_MAP_READ - , fILE_MAP_WRITE = FILE_MAP_WRITE - } - ---------------------------------------------------------------------------- -- API in Haskell --------------------------------------------------------------------------- createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> IO HANDLE @@ -153,21 +156,3 @@ unmapViewOfFile :: Ptr a -> IO () unmapViewOfFile v = c_UnmapViewOfFile v >> return () ---------------------------------------------------------------------------- --- Imports ---------------------------------------------------------------------------- -foreign import WINDOWS_CCONV "windows.h OpenFileMappingW" - c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE - -foreign import WINDOWS_CCONV "windows.h CreateFileMappingW" - c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE - -foreign import WINDOWS_CCONV "windows.h MapViewOfFileEx" - c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b) - -foreign import WINDOWS_CCONV "windows.h UnmapViewOfFile" - c_UnmapViewOfFile :: Ptr a -> IO BOOL - -{-# CFILES cbits/HsWin32.c #-} -foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser" - c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ()) diff --git a/System/Win32/FileMapping/Internal.hsc b/System/Win32/FileMapping/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/FileMapping/Internal.hsc @@ -0,0 +1,72 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.FileMapping.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 mapped files. +-- +----------------------------------------------------------------------------- +module System.Win32.FileMapping.Internal where + +import System.Win32.Types ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR ) + +import Foreign ( Ptr, FunPtr ) +import Foreign.C.Types (CUIntPtr(..)) + +##include "windows_cconv.h" + +#include "windows.h" + +--------------------------------------------------------------------------- +-- Derived functions +--------------------------------------------------------------------------- + +data MappedObject = MappedObject HANDLE HANDLE FileMapAccess + + +--------------------------------------------------------------------------- +-- Enums +--------------------------------------------------------------------------- +type ProtectSectionFlags = DWORD +#{enum ProtectSectionFlags, + , sEC_COMMIT = SEC_COMMIT + , sEC_IMAGE = SEC_IMAGE + , sEC_NOCACHE = SEC_NOCACHE + , sEC_RESERVE = SEC_RESERVE + } +type FileMapAccess = DWORD +#{enum FileMapAccess, + , fILE_MAP_ALL_ACCESS = FILE_MAP_ALL_ACCESS + , fILE_MAP_COPY = FILE_MAP_COPY + , fILE_MAP_READ = FILE_MAP_READ + , fILE_MAP_WRITE = FILE_MAP_WRITE + } + +--------------------------------------------------------------------------- +-- Imports +--------------------------------------------------------------------------- +foreign import WINDOWS_CCONV "windows.h OpenFileMappingW" + c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h CreateFileMappingW" + c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h MapViewOfFileEx" + c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b) + +foreign import WINDOWS_CCONV "windows.h UnmapViewOfFile" + c_UnmapViewOfFile :: Ptr a -> IO BOOL + +{-# CFILES cbits/HsWin32.c #-} +foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser" + c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ()) diff --git a/System/Win32/HardLink.hs b/System/Win32/HardLink.hs --- a/System/Win32/HardLink.hs +++ b/System/Win32/HardLink.hs @@ -12,17 +12,20 @@ Note: You should worry about file system type when use this module's function in your application: - * NTFS only supprts this functionality. + * NTFS only supports this functionality. * ReFS doesn't support hard link currently. -} module System.Win32.HardLink - ( module System.Win32.HardLink + ( createHardLink + , createHardLink' ) where -import System.Win32.File ( LPSECURITY_ATTRIBUTES, failIfFalseWithRetry_ ) -import System.Win32.String ( LPCTSTR, withTString ) -import System.Win32.Types ( BOOL, nullPtr ) +import System.Win32.HardLink.Internal +import System.Win32.File ( failIfFalseWithRetry_ ) +import System.Win32.String ( withTString ) +import System.Win32.Types ( nullPtr ) + #include "windows_cconv.h" -- | NOTE: createHardLink is /flipped arguments/ to provide compatibility for Unix. @@ -42,11 +45,6 @@ failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $ c_CreateHardLink c_link c_target nullPtr -foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW" - c_CreateHardLink :: LPCTSTR -- ^ Hard link name - -> LPCTSTR -- ^ Target file path - -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/. - -> IO BOOL {- -- We plan to check file system type internally. diff --git a/System/Win32/HardLink/Internal.hs b/System/Win32/HardLink/Internal.hs new file mode 100644 --- /dev/null +++ b/System/Win32/HardLink/Internal.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.HardLink.Internal + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling hard link using Win32 API. [NTFS only] + + Note: You should worry about file system type when use this module's function in your application: + + * NTFS only supprts this functionality. + + * ReFS doesn't support hard link currently. +-} +module System.Win32.HardLink.Internal where + +import System.Win32.File ( LPSECURITY_ATTRIBUTES ) +import System.Win32.String ( LPCTSTR ) +import System.Win32.Types ( BOOL ) + +#include "windows_cconv.h" + +foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW" + c_CreateHardLink :: LPCTSTR -- ^ Hard link name + -> LPCTSTR -- ^ Target file path + -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/. + -> IO BOOL diff --git a/System/Win32/Info.hsc b/System/Win32/Info.hsc --- a/System/Win32/Info.hsc +++ b/System/Win32/Info.hsc @@ -17,16 +17,126 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Info where +module System.Win32.Info + ( SystemColor + , cOLOR_SCROLLBAR + , cOLOR_BACKGROUND + , cOLOR_ACTIVECAPTION + , cOLOR_INACTIVECAPTION + , cOLOR_MENU + , cOLOR_WINDOW + , cOLOR_WINDOWFRAME + , cOLOR_MENUTEXT + , cOLOR_WINDOWTEXT + , cOLOR_CAPTIONTEXT + , cOLOR_ACTIVEBORDER + , cOLOR_INACTIVEBORDER + , cOLOR_APPWORKSPACE + , cOLOR_HIGHLIGHT + , cOLOR_HIGHLIGHTTEXT + , cOLOR_BTNFACE + , cOLOR_BTNSHADOW + , cOLOR_GRAYTEXT + , cOLOR_BTNTEXT + , cOLOR_INACTIVECAPTIONTEXT + , cOLOR_BTNHIGHLIGHT + -- * Standard directories + , getSystemDirectory + , getWindowsDirectory + , getCurrentDirectory + , getTemporaryDirectory + , getFullPathName + , getLongPathName + , getShortPathName + , searchPath + + -- * System information + , ProcessorArchitecture(..) + , SYSTEM_INFO(..) + , getSystemInfo + + -- * System metrics + , SMSetting + , sM_ARRANGE + , sM_CLEANBOOT + , sM_CMETRICS + , sM_CMOUSEBUTTONS + , sM_CXBORDER + , sM_CYBORDER + , sM_CXCURSOR + , sM_CYCURSOR + , sM_CXDLGFRAME + , sM_CYDLGFRAME + , sM_CXDOUBLECLK + , sM_CYDOUBLECLK + , sM_CXDRAG + , sM_CYDRAG + , sM_CXEDGE + , sM_CYEDGE + , sM_CXFRAME + , sM_CYFRAME + , sM_CXFULLSCREEN + , sM_CYFULLSCREEN + , sM_CXHSCROLL + , sM_CYVSCROLL + , sM_CXICON + , sM_CYICON + , sM_CXICONSPACING + , sM_CYICONSPACING + , sM_CXMAXIMIZED + , sM_CYMAXIMIZED + , sM_CXMENUCHECK + , sM_CYMENUCHECK + , sM_CXMENUSIZE + , sM_CYMENUSIZE + , sM_CXMIN + , sM_CYMIN + , sM_CXMINIMIZED + , sM_CYMINIMIZED + , sM_CXMINTRACK + , sM_CYMINTRACK + , sM_CXSCREEN + , sM_CYSCREEN + , sM_CXSIZE + , sM_CYSIZE + , sM_CXSIZEFRAME + , sM_CYSIZEFRAME + , sM_CXSMICON + , sM_CYSMICON + , sM_CXSMSIZE + , sM_CYSMSIZE + , sM_CXVSCROLL + , sM_CYHSCROLL + , sM_CYVTHUMB + , sM_CYCAPTION + , sM_CYKANJIWINDOW + , sM_CYMENU + , sM_CYSMCAPTION + , sM_DBCSENABLED + , sM_DEBUG + , sM_MENUDROPALIGNMENT + , sM_MIDEASTENABLED + , sM_MOUSEPRESENT + , sM_NETWORK + , sM_PENWINDOWS + , sM_SECURE + , sM_SHOWSOUNDS + , sM_SLOWMACHINE + , sM_SWAPBUTTON + + -- * User name + , getUserName + ) where + +import System.Win32.Info.Internal import Control.Exception (catch) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with, maybeWith) import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Ptr (nullPtr) import Foreign.Storable (Storable(..)) import System.IO.Error (isDoesNotExistError) -import System.Win32.Types (DWORD, LPDWORD, LPCTSTR, LPTSTR, LPVOID, UINT, WORD) import System.Win32.Types (failIfFalse_, peekTStringLen, withTString, try) #if !MIN_VERSION_base(4,6,0) @@ -65,41 +175,6 @@ -- %fun GetKeyboardType :: KeyboardTypeKind -> IO KeyboardType ---------------------------------------------------------------- --- System Color ----------------------------------------------------------------- - -type SystemColor = UINT - --- ToDo: This list is out of date. - -#{enum SystemColor, - , cOLOR_SCROLLBAR = COLOR_SCROLLBAR - , cOLOR_BACKGROUND = COLOR_BACKGROUND - , cOLOR_ACTIVECAPTION = COLOR_ACTIVECAPTION - , cOLOR_INACTIVECAPTION = COLOR_INACTIVECAPTION - , cOLOR_MENU = COLOR_MENU - , cOLOR_WINDOW = COLOR_WINDOW - , cOLOR_WINDOWFRAME = COLOR_WINDOWFRAME - , cOLOR_MENUTEXT = COLOR_MENUTEXT - , cOLOR_WINDOWTEXT = COLOR_WINDOWTEXT - , cOLOR_CAPTIONTEXT = COLOR_CAPTIONTEXT - , cOLOR_ACTIVEBORDER = COLOR_ACTIVEBORDER - , cOLOR_INACTIVEBORDER = COLOR_INACTIVEBORDER - , cOLOR_APPWORKSPACE = COLOR_APPWORKSPACE - , cOLOR_HIGHLIGHT = COLOR_HIGHLIGHT - , cOLOR_HIGHLIGHTTEXT = COLOR_HIGHLIGHTTEXT - , cOLOR_BTNFACE = COLOR_BTNFACE - , cOLOR_BTNSHADOW = COLOR_BTNSHADOW - , cOLOR_GRAYTEXT = COLOR_GRAYTEXT - , cOLOR_BTNTEXT = COLOR_BTNTEXT - , cOLOR_INACTIVECAPTIONTEXT = COLOR_INACTIVECAPTIONTEXT - , cOLOR_BTNHIGHLIGHT = COLOR_BTNHIGHLIGHT - } - --- %fun GetSysColor :: SystemColor -> IO COLORREF --- %fun SetSysColors :: [(SystemColor,COLORREF)] -> IO () - ----------------------------------------------------------------- -- Standard Directories ---------------------------------------------------------------- @@ -111,6 +186,7 @@ getCurrentDirectory :: IO String getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512 + getTemporaryDirectory :: IO String getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 @@ -145,204 +221,15 @@ then return Nothing else ioError e -foreign import WINDOWS_CCONV unsafe "GetWindowsDirectoryW" - c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetSystemDirectoryW" - c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetCurrentDirectoryW" - c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetTempPathW" - c_getTempPath :: DWORD -> LPTSTR -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetFullPathNameW" - c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "GetLongPathNameW" - c_GetLongPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "GetShortPathNameW" - c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "SearchPathW" - c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR - -> IO DWORD - ---------------------------------------------------------------- -- System Info (Info about processor and memory subsystem) ---------------------------------------------------------------- -data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64 - deriving (Show,Eq) - -instance Storable ProcessorArchitecture where - sizeOf _ = sizeOf (undefined::WORD) - alignment _ = alignment (undefined::WORD) - poke buf pa = pokeByteOff buf 0 $ case pa of - PaUnknown w -> w - PaIntel -> #const PROCESSOR_ARCHITECTURE_INTEL - PaMips -> #const PROCESSOR_ARCHITECTURE_MIPS - PaAlpha -> #const PROCESSOR_ARCHITECTURE_ALPHA - PaPpc -> #const PROCESSOR_ARCHITECTURE_PPC - PaIa64 -> #const PROCESSOR_ARCHITECTURE_IA64 -#ifndef __WINE_WINDOWS_H - PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 -#endif - PaAmd64 -> #const PROCESSOR_ARCHITECTURE_AMD64 - peek buf = do - v <- (peekByteOff buf 0:: IO WORD) - return $ case v of - (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel - (#const PROCESSOR_ARCHITECTURE_MIPS) -> PaMips - (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha - (#const PROCESSOR_ARCHITECTURE_PPC) -> PaPpc - (#const PROCESSOR_ARCHITECTURE_IA64) -> PaIa64 -#ifndef __WINE_WINDOWS_H - (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64 -#endif - (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64 - w -> PaUnknown w - -data SYSTEM_INFO = SYSTEM_INFO - { siProcessorArchitecture :: ProcessorArchitecture - , siPageSize :: DWORD - , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID - , siActiveProcessorMask :: DWORD - , siNumberOfProcessors :: DWORD - , siProcessorType :: DWORD - , siAllocationGranularity :: DWORD - , siProcessorLevel :: WORD - , siProcessorRevision :: WORD - } deriving (Show) - -instance Storable SYSTEM_INFO where - sizeOf = const #size SYSTEM_INFO - alignment _ = #alignment SYSTEM_INFO - poke buf si = do - (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si) - (#poke SYSTEM_INFO, dwPageSize) buf (siPageSize si) - (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si) - (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si) - (#poke SYSTEM_INFO, dwActiveProcessorMask) buf (siActiveProcessorMask si) - (#poke SYSTEM_INFO, dwNumberOfProcessors) buf (siNumberOfProcessors si) - (#poke SYSTEM_INFO, dwProcessorType) buf (siProcessorType si) - (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si) - (#poke SYSTEM_INFO, wProcessorLevel) buf (siProcessorLevel si) - (#poke SYSTEM_INFO, wProcessorRevision) buf (siProcessorRevision si) - - peek buf = do - processorArchitecture <- - (#peek SYSTEM_INFO, wProcessorArchitecture) buf - pageSize <- (#peek SYSTEM_INFO, dwPageSize) buf - minimumApplicationAddress <- - (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf - maximumApplicationAddress <- - (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf - activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf - numberOfProcessors <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf - processorType <- (#peek SYSTEM_INFO, dwProcessorType) buf - allocationGranularity <- - (#peek SYSTEM_INFO, dwAllocationGranularity) buf - processorLevel <- (#peek SYSTEM_INFO, wProcessorLevel) buf - processorRevision <- (#peek SYSTEM_INFO, wProcessorRevision) buf - return $ SYSTEM_INFO { - siProcessorArchitecture = processorArchitecture, - siPageSize = pageSize, - siMinimumApplicationAddress = minimumApplicationAddress, - siMaximumApplicationAddress = maximumApplicationAddress, - siActiveProcessorMask = activeProcessorMask, - siNumberOfProcessors = numberOfProcessors, - siProcessorType = processorType, - siAllocationGranularity = allocationGranularity, - siProcessorLevel = processorLevel, - siProcessorRevision = processorRevision - } - -foreign import WINDOWS_CCONV unsafe "windows.h GetSystemInfo" - c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO () - getSystemInfo :: IO SYSTEM_INFO getSystemInfo = alloca $ \ret -> do c_GetSystemInfo ret peek ret ----------------------------------------------------------------- --- System metrics ----------------------------------------------------------------- - -type SMSetting = UINT - -#{enum SMSetting, - , sM_ARRANGE = SM_ARRANGE - , sM_CLEANBOOT = SM_CLEANBOOT - , sM_CMETRICS = SM_CMETRICS - , sM_CMOUSEBUTTONS = SM_CMOUSEBUTTONS - , sM_CXBORDER = SM_CXBORDER - , sM_CYBORDER = SM_CYBORDER - , sM_CXCURSOR = SM_CXCURSOR - , sM_CYCURSOR = SM_CYCURSOR - , sM_CXDLGFRAME = SM_CXDLGFRAME - , sM_CYDLGFRAME = SM_CYDLGFRAME - , sM_CXDOUBLECLK = SM_CXDOUBLECLK - , sM_CYDOUBLECLK = SM_CYDOUBLECLK - , sM_CXDRAG = SM_CXDRAG - , sM_CYDRAG = SM_CYDRAG - , sM_CXEDGE = SM_CXEDGE - , sM_CYEDGE = SM_CYEDGE - , sM_CXFRAME = SM_CXFRAME - , sM_CYFRAME = SM_CYFRAME - , sM_CXFULLSCREEN = SM_CXFULLSCREEN - , sM_CYFULLSCREEN = SM_CYFULLSCREEN - , sM_CXHSCROLL = SM_CXHSCROLL - , sM_CYVSCROLL = SM_CYVSCROLL - , sM_CXICON = SM_CXICON - , sM_CYICON = SM_CYICON - , sM_CXICONSPACING = SM_CXICONSPACING - , sM_CYICONSPACING = SM_CYICONSPACING - , sM_CXMAXIMIZED = SM_CXMAXIMIZED - , sM_CYMAXIMIZED = SM_CYMAXIMIZED - , sM_CXMENUCHECK = SM_CXMENUCHECK - , sM_CYMENUCHECK = SM_CYMENUCHECK - , sM_CXMENUSIZE = SM_CXMENUSIZE - , sM_CYMENUSIZE = SM_CYMENUSIZE - , sM_CXMIN = SM_CXMIN - , sM_CYMIN = SM_CYMIN - , sM_CXMINIMIZED = SM_CXMINIMIZED - , sM_CYMINIMIZED = SM_CYMINIMIZED - , sM_CXMINTRACK = SM_CXMINTRACK - , sM_CYMINTRACK = SM_CYMINTRACK - , sM_CXSCREEN = SM_CXSCREEN - , sM_CYSCREEN = SM_CYSCREEN - , sM_CXSIZE = SM_CXSIZE - , sM_CYSIZE = SM_CYSIZE - , sM_CXSIZEFRAME = SM_CXSIZEFRAME - , sM_CYSIZEFRAME = SM_CYSIZEFRAME - , sM_CXSMICON = SM_CXSMICON - , sM_CYSMICON = SM_CYSMICON - , sM_CXSMSIZE = SM_CXSMSIZE - , sM_CYSMSIZE = SM_CYSMSIZE - , sM_CXVSCROLL = SM_CXVSCROLL - , sM_CYHSCROLL = SM_CYHSCROLL - , sM_CYVTHUMB = SM_CYVTHUMB - , sM_CYCAPTION = SM_CYCAPTION - , sM_CYKANJIWINDOW = SM_CYKANJIWINDOW - , sM_CYMENU = SM_CYMENU - , sM_CYSMCAPTION = SM_CYSMCAPTION - , sM_DBCSENABLED = SM_DBCSENABLED - , sM_DEBUG = SM_DEBUG - , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT - , sM_MIDEASTENABLED = SM_MIDEASTENABLED - , sM_MOUSEPRESENT = SM_MOUSEPRESENT - , sM_NETWORK = SM_NETWORK - , sM_PENWINDOWS = SM_PENWINDOWS - , sM_SECURE = SM_SECURE - , sM_SHOWSOUNDS = SM_SHOWSOUNDS - , sM_SLOWMACHINE = SM_SLOWMACHINE - , sM_SWAPBUTTON = SM_SWAPBUTTON - } - -- %fun GetSystemMetrics :: SMSetting -> IO Int ---------------------------------------------------------------- @@ -357,9 +244,6 @@ ---------------------------------------------------------------- -- %fun GetUserName :: IO String - -foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW" - c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool getUserName :: IO String getUserName = diff --git a/System/Win32/Info/Computer.hsc b/System/Win32/Info/Computer.hsc --- a/System/Win32/Info/Computer.hsc +++ b/System/Win32/Info/Computer.hsc @@ -94,7 +94,7 @@ len' <- peek len peekTStringLen (buf, (fromIntegral len')) where - maxLength = #const MAX_COMPUTERNAME_LENGTH + maxLength = #const MAX_PATH foreign import WINDOWS_CCONV unsafe "GetComputerNameW" c_GetComputerName :: LPTSTR -> LPDWORD -> IO Bool @@ -126,7 +126,7 @@ -- Hardware Profiles ---------------------------------------------------------------- {- --- TODO: Deside HW_PROFILE_INFO type design +-- TODO: Decide HW_PROFILE_INFO type design type LPHW_PROFILE_INFO = Ptr HW_PROFILE_INFO @@ -195,7 +195,7 @@ with (fromIntegral maxLength) $ \len -> do failIfFalse_ "GetComputerName" $ c_GetUserName buf len - -- GetUserNameW includes NUL charactor. + -- GetUserNameW includes NUL character. peekTString buf where -- This requires Lmcons.h diff --git a/System/Win32/Info/Internal.hsc b/System/Win32/Info/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Info/Internal.hsc @@ -0,0 +1,313 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Info.Internal +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.Info.Internal where + +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import System.Win32.Types (DWORD, LPDWORD, LPCTSTR, LPTSTR, LPVOID, UINT, WORD) + +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif + +##include "windows_cconv.h" + +#include +#include "alignment.h" + +---------------------------------------------------------------- +-- Environment Strings +---------------------------------------------------------------- + +-- %fun ExpandEnvironmentStrings :: String -> IO String + +---------------------------------------------------------------- +-- Computer Name +---------------------------------------------------------------- + +-- %fun GetComputerName :: IO String +-- %fun SetComputerName :: String -> IO () +-- %end free(arg1) + +---------------------------------------------------------------- +-- Hardware Profiles +---------------------------------------------------------------- + +-- %fun GetCurrentHwProfile :: IO HW_PROFILE_INFO + +---------------------------------------------------------------- +-- Keyboard Type +---------------------------------------------------------------- + +-- %fun GetKeyboardType :: KeyboardTypeKind -> IO KeyboardType + +---------------------------------------------------------------- +-- System Color +---------------------------------------------------------------- + +type SystemColor = UINT + +-- ToDo: This list is out of date. + +#{enum SystemColor, + , cOLOR_SCROLLBAR = COLOR_SCROLLBAR + , cOLOR_BACKGROUND = COLOR_BACKGROUND + , cOLOR_ACTIVECAPTION = COLOR_ACTIVECAPTION + , cOLOR_INACTIVECAPTION = COLOR_INACTIVECAPTION + , cOLOR_MENU = COLOR_MENU + , cOLOR_WINDOW = COLOR_WINDOW + , cOLOR_WINDOWFRAME = COLOR_WINDOWFRAME + , cOLOR_MENUTEXT = COLOR_MENUTEXT + , cOLOR_WINDOWTEXT = COLOR_WINDOWTEXT + , cOLOR_CAPTIONTEXT = COLOR_CAPTIONTEXT + , cOLOR_ACTIVEBORDER = COLOR_ACTIVEBORDER + , cOLOR_INACTIVEBORDER = COLOR_INACTIVEBORDER + , cOLOR_APPWORKSPACE = COLOR_APPWORKSPACE + , cOLOR_HIGHLIGHT = COLOR_HIGHLIGHT + , cOLOR_HIGHLIGHTTEXT = COLOR_HIGHLIGHTTEXT + , cOLOR_BTNFACE = COLOR_BTNFACE + , cOLOR_BTNSHADOW = COLOR_BTNSHADOW + , cOLOR_GRAYTEXT = COLOR_GRAYTEXT + , cOLOR_BTNTEXT = COLOR_BTNTEXT + , cOLOR_INACTIVECAPTIONTEXT = COLOR_INACTIVECAPTIONTEXT + , cOLOR_BTNHIGHLIGHT = COLOR_BTNHIGHLIGHT + } + +-- %fun GetSysColor :: SystemColor -> IO COLORREF +-- %fun SetSysColors :: [(SystemColor,COLORREF)] -> IO () + +---------------------------------------------------------------- +-- Standard Directories +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "GetWindowsDirectoryW" + c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetSystemDirectoryW" + c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetCurrentDirectoryW" + c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetTempPathW" + c_getTempPath :: DWORD -> LPTSTR -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetFullPathNameW" + c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "GetLongPathNameW" + c_GetLongPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "GetShortPathNameW" + c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "SearchPathW" + c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR + -> IO DWORD + +---------------------------------------------------------------- +-- System Info (Info about processor and memory subsystem) +---------------------------------------------------------------- + +data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64 + deriving (Show,Eq) + +instance Storable ProcessorArchitecture where + sizeOf _ = sizeOf (undefined::WORD) + alignment _ = alignment (undefined::WORD) + poke buf pa = pokeByteOff buf 0 $ case pa of + PaUnknown w -> w + PaIntel -> #const PROCESSOR_ARCHITECTURE_INTEL + PaMips -> #const PROCESSOR_ARCHITECTURE_MIPS + PaAlpha -> #const PROCESSOR_ARCHITECTURE_ALPHA + PaPpc -> #const PROCESSOR_ARCHITECTURE_PPC + PaIa64 -> #const PROCESSOR_ARCHITECTURE_IA64 +#ifndef __WINE_WINDOWS_H + PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 +#endif + PaAmd64 -> #const PROCESSOR_ARCHITECTURE_AMD64 + peek buf = do + v <- (peekByteOff buf 0:: IO WORD) + return $ case v of + (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel + (#const PROCESSOR_ARCHITECTURE_MIPS) -> PaMips + (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha + (#const PROCESSOR_ARCHITECTURE_PPC) -> PaPpc + (#const PROCESSOR_ARCHITECTURE_IA64) -> PaIa64 +#ifndef __WINE_WINDOWS_H + (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64 +#endif + (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64 + w -> PaUnknown w + +data SYSTEM_INFO = SYSTEM_INFO + { siProcessorArchitecture :: ProcessorArchitecture + , siPageSize :: DWORD + , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID + , siActiveProcessorMask :: DWORD + , siNumberOfProcessors :: DWORD + , siProcessorType :: DWORD + , siAllocationGranularity :: DWORD + , siProcessorLevel :: WORD + , siProcessorRevision :: WORD + } deriving (Show) + +instance Storable SYSTEM_INFO where + sizeOf = const #size SYSTEM_INFO + alignment _ = #alignment SYSTEM_INFO + poke buf si = do + (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si) + (#poke SYSTEM_INFO, dwPageSize) buf (siPageSize si) + (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si) + (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si) + (#poke SYSTEM_INFO, dwActiveProcessorMask) buf (siActiveProcessorMask si) + (#poke SYSTEM_INFO, dwNumberOfProcessors) buf (siNumberOfProcessors si) + (#poke SYSTEM_INFO, dwProcessorType) buf (siProcessorType si) + (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si) + (#poke SYSTEM_INFO, wProcessorLevel) buf (siProcessorLevel si) + (#poke SYSTEM_INFO, wProcessorRevision) buf (siProcessorRevision si) + + peek buf = do + processorArchitecture <- + (#peek SYSTEM_INFO, wProcessorArchitecture) buf + pageSize <- (#peek SYSTEM_INFO, dwPageSize) buf + minimumApplicationAddress <- + (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf + maximumApplicationAddress <- + (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf + activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf + numberOfProcessors <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf + processorType <- (#peek SYSTEM_INFO, dwProcessorType) buf + allocationGranularity <- + (#peek SYSTEM_INFO, dwAllocationGranularity) buf + processorLevel <- (#peek SYSTEM_INFO, wProcessorLevel) buf + processorRevision <- (#peek SYSTEM_INFO, wProcessorRevision) buf + return $ SYSTEM_INFO { + siProcessorArchitecture = processorArchitecture, + siPageSize = pageSize, + siMinimumApplicationAddress = minimumApplicationAddress, + siMaximumApplicationAddress = maximumApplicationAddress, + siActiveProcessorMask = activeProcessorMask, + siNumberOfProcessors = numberOfProcessors, + siProcessorType = processorType, + siAllocationGranularity = allocationGranularity, + siProcessorLevel = processorLevel, + siProcessorRevision = processorRevision + } + +foreign import WINDOWS_CCONV unsafe "windows.h GetSystemInfo" + c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO () + +---------------------------------------------------------------- +-- System metrics +---------------------------------------------------------------- + +type SMSetting = UINT + +#{enum SMSetting, + , sM_ARRANGE = SM_ARRANGE + , sM_CLEANBOOT = SM_CLEANBOOT + , sM_CMETRICS = SM_CMETRICS + , sM_CMOUSEBUTTONS = SM_CMOUSEBUTTONS + , sM_CXBORDER = SM_CXBORDER + , sM_CYBORDER = SM_CYBORDER + , sM_CXCURSOR = SM_CXCURSOR + , sM_CYCURSOR = SM_CYCURSOR + , sM_CXDLGFRAME = SM_CXDLGFRAME + , sM_CYDLGFRAME = SM_CYDLGFRAME + , sM_CXDOUBLECLK = SM_CXDOUBLECLK + , sM_CYDOUBLECLK = SM_CYDOUBLECLK + , sM_CXDRAG = SM_CXDRAG + , sM_CYDRAG = SM_CYDRAG + , sM_CXEDGE = SM_CXEDGE + , sM_CYEDGE = SM_CYEDGE + , sM_CXFRAME = SM_CXFRAME + , sM_CYFRAME = SM_CYFRAME + , sM_CXFULLSCREEN = SM_CXFULLSCREEN + , sM_CYFULLSCREEN = SM_CYFULLSCREEN + , sM_CXHSCROLL = SM_CXHSCROLL + , sM_CYVSCROLL = SM_CYVSCROLL + , sM_CXICON = SM_CXICON + , sM_CYICON = SM_CYICON + , sM_CXICONSPACING = SM_CXICONSPACING + , sM_CYICONSPACING = SM_CYICONSPACING + , sM_CXMAXIMIZED = SM_CXMAXIMIZED + , sM_CYMAXIMIZED = SM_CYMAXIMIZED + , sM_CXMENUCHECK = SM_CXMENUCHECK + , sM_CYMENUCHECK = SM_CYMENUCHECK + , sM_CXMENUSIZE = SM_CXMENUSIZE + , sM_CYMENUSIZE = SM_CYMENUSIZE + , sM_CXMIN = SM_CXMIN + , sM_CYMIN = SM_CYMIN + , sM_CXMINIMIZED = SM_CXMINIMIZED + , sM_CYMINIMIZED = SM_CYMINIMIZED + , sM_CXMINTRACK = SM_CXMINTRACK + , sM_CYMINTRACK = SM_CYMINTRACK + , sM_CXSCREEN = SM_CXSCREEN + , sM_CYSCREEN = SM_CYSCREEN + , sM_CXSIZE = SM_CXSIZE + , sM_CYSIZE = SM_CYSIZE + , sM_CXSIZEFRAME = SM_CXSIZEFRAME + , sM_CYSIZEFRAME = SM_CYSIZEFRAME + , sM_CXSMICON = SM_CXSMICON + , sM_CYSMICON = SM_CYSMICON + , sM_CXSMSIZE = SM_CXSMSIZE + , sM_CYSMSIZE = SM_CYSMSIZE + , sM_CXVSCROLL = SM_CXVSCROLL + , sM_CYHSCROLL = SM_CYHSCROLL + , sM_CYVTHUMB = SM_CYVTHUMB + , sM_CYCAPTION = SM_CYCAPTION + , sM_CYKANJIWINDOW = SM_CYKANJIWINDOW + , sM_CYMENU = SM_CYMENU + , sM_CYSMCAPTION = SM_CYSMCAPTION + , sM_DBCSENABLED = SM_DBCSENABLED + , sM_DEBUG = SM_DEBUG + , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT + , sM_MIDEASTENABLED = SM_MIDEASTENABLED + , sM_MOUSEPRESENT = SM_MOUSEPRESENT + , sM_NETWORK = SM_NETWORK + , sM_PENWINDOWS = SM_PENWINDOWS + , sM_SECURE = SM_SECURE + , sM_SHOWSOUNDS = SM_SHOWSOUNDS + , sM_SLOWMACHINE = SM_SLOWMACHINE + , sM_SWAPBUTTON = SM_SWAPBUTTON + } + +-- %fun GetSystemMetrics :: SMSetting -> IO Int + +---------------------------------------------------------------- +-- Thread Desktops +---------------------------------------------------------------- + +-- %fun GetThreadDesktop :: ThreadId -> IO HDESK +-- %fun SetThreadDesktop :: ThreadId -> HDESK -> IO () + +---------------------------------------------------------------- +-- User name +---------------------------------------------------------------- + +-- %fun GetUserName :: IO String + +foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW" + c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/Info/Version.hsc b/System/Win32/Info/Version.hsc --- a/System/Win32/Info/Version.hsc +++ b/System/Win32/Info/Version.hsc @@ -19,6 +19,7 @@ -- * Verify OS version , isVistaOrLater, is7OrLater ) where + import Foreign.Ptr ( Ptr, plusPtr ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Storable ( Storable(..) ) diff --git a/System/Win32/Mem.hsc b/System/Win32/Mem.hsc --- a/System/Win32/Mem.hsc +++ b/System/Win32/Mem.hsc @@ -17,7 +17,90 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Mem where +module System.Win32.Mem + ( MEMORY_BASIC_INFORMATION(..) + , copyMemory + , moveMemory + , fillMemory + , zeroMemory + , memset + , getProcessHeap +#ifndef __WINE_WINDOWS_H + , getProcessHeaps +#endif + , HGLOBAL + -- * Global allocation + , GlobalAllocFlags + , gMEM_INVALID_HANDLE + , gMEM_FIXED + , gMEM_MOVEABLE + , gPTR + , gHND + , gMEM_DDESHARE + , gMEM_SHARE + , gMEM_LOWER + , gMEM_NOCOMPACT + , gMEM_NODISCARD + , gMEM_NOT_BANKED + , gMEM_NOTIFY + , gMEM_ZEROINIT + , globalAlloc + , globalFlags + , globalFree + , globalHandle + , globalLock + , globalReAlloc + , globalSize + , globalUnlock + + -- * Heap allocation + , HeapAllocFlags + , hEAP_GENERATE_EXCEPTIONS + , hEAP_NO_SERIALIZE + , hEAP_ZERO_MEMORY + , heapAlloc + , heapCompact + , heapCreate + , heapDestroy + , heapFree + , heapLock + , heapReAlloc + , heapSize + , heapUnlock + , heapValidate + + -- * Virtual allocation + -- ** Allocation + , virtualAlloc + , virtualAllocEx + , VirtualAllocFlags + , mEM_COMMIT + , mEM_RESERVE + -- ** Locking + , virtualLock + , virtualUnlock + -- ** Protection + , virtualProtect + , virtualProtectEx + , virtualQueryEx + , ProtectFlags + , pAGE_READONLY + , pAGE_READWRITE + , pAGE_EXECUTE + , pAGE_EXECUTE_READ + , pAGE_EXECUTE_READWRITE + , pAGE_GUARD + , pAGE_NOACCESS + , pAGE_NOCACHE + -- ** Freeing + , virtualFree + , virtualFreeEx + , FreeFlags + , mEM_DECOMMIT + , mEM_RELEASE + + + ) where import System.Win32.Types 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. -- @@ -31,10 +36,9 @@ #if MIN_VERSION_base(4,6,0) import Control.Exception (catch) #endif -import Data.List (isPrefixOf, isInfixOf, isSuffixOf) +import Data.List (isInfixOf) import Foreign import Foreign.C.Types -import System.FilePath (takeFileName) #if __GLASGOW_HASKELL__ < 711 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) @@ -51,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 @@ -62,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 @@ -91,11 +97,8 @@ return False cygwinMSYSCheck :: String -> Bool -cygwinMSYSCheck fn = ("cygwin-" `isPrefixOf` fn' || "msys-" `isPrefixOf` fn') && - "-pty" `isInfixOf` fn' && - "-master" `isSuffixOf` fn' - where - fn' = takeFileName fn +cygwinMSYSCheck fn = ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) && + "-pty" `isInfixOf` fn -- Note that GetFileInformationByHandleEx might return a filepath like: -- -- \msys-dd50a72ab4668b33-pty1-to-master @@ -105,8 +108,16 @@ -- \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master -- -- This means we can't rely on "\cygwin-" or "\msys-" being at the very start --- of the filepath. Therefore, we must take care to first call takeFileName --- before checking for "cygwin" or "msys" at the start using `isPrefixOf`. +-- of the filepath. As a result, we use `isPrefixOf` to check for "cygwin" and +-- "msys". +-- +-- It's unclear if "-master" will always appear in the filepath name. Recent +-- versions of MinTTY have been known to give filepaths like this (#186): +-- +-- \msys-dd50a72ab4668b33-pty0-to-master-nat +-- +-- Just in case MinTTY ever changes this convention, we don't bother checking +-- for the presence of "-master" in the filepath name at all. getFileNameByHandle :: HANDLE -> IO String getFileNameByHandle h = do diff --git a/System/Win32/NLS.hsc b/System/Win32/NLS.hsc --- a/System/Win32/NLS.hsc +++ b/System/Win32/NLS.hsc @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | @@ -15,6 +16,9 @@ module System.Win32.NLS ( module System.Win32.NLS, +#if MIN_VERSION_base(4,15,0) + CodePage, +#endif -- defined in System.Win32.Types LCID, LANGID, SortID, SubLANGID, PrimaryLANGID, @@ -22,17 +26,45 @@ mAKELANGID, pRIMARYLANGID, sUBLANGID ) where +import System.Win32.String (withTStringBufferLen) import System.Win32.Types +import System.Win32.Utils (trySized) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad (when) +import Data.IORef (modifyIORef, newIORef, readIORef) import Foreign import Foreign.C +#if MIN_VERSION_base(4,15,0) +import GHC.IO.Encoding.CodePage (CodePage) +#endif +import Text.Printf (printf) ##include "windows_cconv.h" +-- Somewhere, WINVER and _WIN32_WINNT are being defined as less than 0x0600 - +-- that is, before Windows Vista. Support for Windows XP was dropped in +-- GHC 8.0.1 of May 2016. This forces them to be at least 0x0600. +#if WINVER < 0x0600 +#undef WINVER +#define WINVER 0x0600 +#endif +#if _WIN32_WINNT < 0x0600 +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 +#endif + #include +#include "alignment.h" #include "errors.h" #include "win32debug.h" +#include "winnls_compat.h" +#include "winnt_compat.h" +type NLS_FUNCTION = DWORD + #{enum LCID, , lOCALE_SYSTEM_DEFAULT = LOCALE_SYSTEM_DEFAULT , lOCALE_USER_DEFAULT = LOCALE_USER_DEFAULT @@ -42,9 +74,11 @@ foreign import WINDOWS_CCONV unsafe "windows.h ConvertDefaultLocale" convertDefaultLocale :: LCID -> IO LCID --- ToDo: various enum functions. +-- TODO: various enum functions. +#if !MIN_VERSION_base(4,15,0) type CodePage = UINT +#endif #{enum CodePage, , cP_ACP = CP_ACP @@ -60,37 +94,237 @@ type LCTYPE = UINT +-- The following locale information constants are excluded from the `enum` list +-- below, for the reason indicated: +-- LOCALE_IDIALINGCODE -- Introduced in Windows 10 but not supported. Synonym + -- for LOCALE_ICOUNTRY. +-- LOCALE_INEGATIVEPERCENT -- Introduced in Windows 7 but not supported. +-- LOCALE_IPOSITIVEPERCENT -- Introduced in Windows 7 but not supported. +-- LOCALE_IREADINGLAYOUT -- Introduced in Windows 7 but not supported. +-- LOCALE_SAM -- Introduced by Windows 10 but not supported. Synonym for + -- LOCALE_S1159. +-- LOCALE_SENGLISHDISPLAYNAME -- Introduced in Windows 7 but not supported. +-- LOCALE_SIETFLANGUAGE -- Not supported (deprecated from Windows Vista). +-- LOCALE_SNATIVEDISPLAYNAME -- Introduced in Windows 7 but not supported. +-- LOCALE_SNATIVELANGUAGENAME -- Introduced in Windows 7 but not supported. +-- LOCALE_SPERCENT -- Introduced in Windows 7 but not supported. +-- LOCALE_SPM -- Introduced in Windows 10 but not supported. Synonym for + -- LOCALE_S2359. +-- LOCALE_SSHORTESTAM -- Not supported. +-- LOCALE_SSHORTESTPM -- Not supported. +-- LOCALE_SSHORTTIME -- Introduced in Windows 7 but not supported. + +-- The following locale information constant is included in the list below, but +-- note: +-- LOCALE_IINTLCURRDIGITS -- Not supported by Windows 10, use + -- LOCALE_ICURRDIGITS. + #{enum LCTYPE, + , lOCALE_FONTSIGNATURE = LOCALE_FONTSIGNATURE , lOCALE_ICALENDARTYPE = LOCALE_ICALENDARTYPE - , lOCALE_SDATE = LOCALE_SDATE + , lOCALE_ICENTURY = LOCALE_ICENTURY + , lOCALE_ICOUNTRY = LOCALE_ICOUNTRY , lOCALE_ICURRDIGITS = LOCALE_ICURRDIGITS - , lOCALE_SDECIMAL = LOCALE_SDECIMAL , lOCALE_ICURRENCY = LOCALE_ICURRENCY - , lOCALE_SGROUPING = LOCALE_SGROUPING + , lOCALE_IDATE = LOCALE_IDATE + , lOCALE_IDAYLZERO = LOCALE_IDAYLZERO + , lOCALE_IDEFAULTANSICODEPAGE = LOCALE_IDEFAULTANSICODEPAGE + , lOCALE_IDEFAULTCODEPAGE = LOCALE_IDEFAULTCODEPAGE + , lOCALE_IDEFAULTCOUNTRY = LOCALE_IDEFAULTCOUNTRY + , lOCALE_IDEFAULTEBCDICCODEPAGE = LOCALE_IDEFAULTEBCDICCODEPAGE + , lOCALE_IDEFAULTLANGUAGE = LOCALE_IDEFAULTLANGUAGE + , lOCALE_IDEFAULTMACCODEPAGE = LOCALE_IDEFAULTMACCODEPAGE , lOCALE_IDIGITS = LOCALE_IDIGITS - , lOCALE_SLIST = LOCALE_SLIST + , lOCALE_IDIGITSUBSTITUTION = LOCALE_IDIGITSUBSTITUTION , lOCALE_IFIRSTDAYOFWEEK = LOCALE_IFIRSTDAYOFWEEK - , lOCALE_SLONGDATE = LOCALE_SLONGDATE , lOCALE_IFIRSTWEEKOFYEAR = LOCALE_IFIRSTWEEKOFYEAR - , lOCALE_SMONDECIMALSEP = LOCALE_SMONDECIMALSEP + , lOCALE_IGEOID = LOCALE_IGEOID + , lOCALE_IINTLCURRDIGITS = LOCALE_IINTLCURRDIGITS + , lOCALE_ILANGUAGE = LOCALE_ILANGUAGE + , lOCALE_ILDATE = LOCALE_ILDATE , lOCALE_ILZERO = LOCALE_ILZERO - , lOCALE_SMONGROUPING = LOCALE_SMONGROUPING , lOCALE_IMEASURE = LOCALE_IMEASURE - , lOCALE_SMONTHOUSANDSEP = LOCALE_SMONTHOUSANDSEP + , lOCALE_IMONLZERO = LOCALE_IMONLZERO , lOCALE_INEGCURR = LOCALE_INEGCURR - , lOCALE_SNEGATIVESIGN = LOCALE_SNEGATIVESIGN , lOCALE_INEGNUMBER = LOCALE_INEGNUMBER + , lOCALE_INEGSEPBYSPACE = LOCALE_INEGSEPBYSPACE + , lOCALE_INEGSIGNPOSN = LOCALE_INEGSIGNPOSN + , lOCALE_INEGSYMPRECEDES = LOCALE_INEGSYMPRECEDES + , lOCALE_IOPTIONALCALENDAR = LOCALE_IOPTIONALCALENDAR + , lOCALE_PAPERSIZE = LOCALE_IPAPERSIZE + , lOCALE_IPOSSEPBYSPACE = LOCALE_IPOSSEPBYSPACE + , lOCALE_IPOSSIGNPOSN = LOCALE_IPOSSIGNPOSN + , lOCALE_IPSSYMPRECEDES = LOCALE_IPOSSYMPRECEDES + , lOCALE_ITIME = LOCALE_ITIME + , lOCALE_ITIMEMARKPOSN = LOCALE_ITIMEMARKPOSN + , lOCALE_ITLZERO = LOCALE_ITLZERO + , lOCALE_RETURN_NUMBER = LOCALE_RETURN_NUMBER + , lOCALE_S1159 = LOCALE_S1159 + , lOCALE_S2359 = LOCALE_S2359 + , lOCALE_SABBREVCTRYNAME = LOCALE_SABBREVCTRYNAME + , lOCALE_SABBREVDAYNAME1 = LOCALE_SABBREVDAYNAME1 + , lOCALE_SABBREVDAYNAME2 = LOCALE_SABBREVDAYNAME2 + , lOCALE_SABBREVDAYNAME3 = LOCALE_SABBREVDAYNAME3 + , lOCALE_SABBREVDAYNAME4 = LOCALE_SABBREVDAYNAME4 + , lOCALE_SABBREVDAYNAME5 = LOCALE_SABBREVDAYNAME5 + , lOCALE_SABBREVDAYNAME6 = LOCALE_SABBREVDAYNAME6 + , lOCALE_SABBREVDAYNAME7 = LOCALE_SABBREVDAYNAME7 + , lOCALE_SABBREVLANGNAME = LOCALE_SABBREVLANGNAME + , lOCALE_SABBREVMONTHNAME1 = LOCALE_SABBREVMONTHNAME1 + , lOCALE_SABBREVMONTHNAME2 = LOCALE_SABBREVMONTHNAME2 + , lOCALE_SABBREVMONTHNAME3 = LOCALE_SABBREVMONTHNAME3 + , lOCALE_SABBREVMONTHNAME4 = LOCALE_SABBREVMONTHNAME4 + , lOCALE_SABBREVMONTHNAME5 = LOCALE_SABBREVMONTHNAME5 + , lOCALE_SABBREVMONTHNAME6 = LOCALE_SABBREVMONTHNAME6 + , lOCALE_SABBREVMONTHNAME7 = LOCALE_SABBREVMONTHNAME7 + , lOCALE_SABBREVMONTHNAME8 = LOCALE_SABBREVMONTHNAME8 + , lOCALE_SABBREVMONTHNAME9 = LOCALE_SABBREVMONTHNAME9 + , lOCALE_SABBREVMONTHNAME10 = LOCALE_SABBREVMONTHNAME10 + , lOCALE_SABBREVMONTHNAME11 = LOCALE_SABBREVMONTHNAME11 + , lOCALE_SABBREVMONTHNAME12 = LOCALE_SABBREVMONTHNAME12 + , lOCALE_SABBREVMONTHNAME13 = LOCALE_SABBREVMONTHNAME13 + , lOCALE_SCONSOLEFALLBACKNAME = LOCALE_SCONSOLEFALLBACKNAME + , lOCALE_SCURRENCY = LOCALE_SCURRENCY + , lOCALE_SDATE = LOCALE_SDATE + , lOCALE_SDAYNAME1 = LOCALE_SDAYNAME1 + , lOCALE_SDAYNAME2 = LOCALE_SDAYNAME2 + , lOCALE_SDAYNAME3 = LOCALE_SDAYNAME3 + , lOCALE_SDAYNAME4 = LOCALE_SDAYNAME4 + , lOCALE_SDAYNAME5 = LOCALE_SDAYNAME5 + , lOCALE_SDAYNAME6 = LOCALE_SDAYNAME6 + , lOCALE_SDAYNAME7 = LOCALE_SDAYNAME7 + , lOCALE_SDECIMAL = LOCALE_SDECIMAL + , lOCALE_SDURATION = LOCALE_SDURATION + , lOCALE_SENGCURRNAME = LOCALE_SENGCURRNAME + , lOCALE_SENGLISHCOUNTRYNAME = LOCALE_SENGLISHCOUNTRYNAME + , lOCALE_SENGLISHLANGUAGENAME = LOCALE_SENGLISHLANGUAGENAME + , lOCALE_SGROUPING = LOCALE_SGROUPING + , lOCALE_SINTLSYMBOL = LOCALE_SINTLSYMBOL + , lOCALE_SISO3166CTRYNAME = LOCALE_SISO3166CTRYNAME + , lOCALE_SISO3166CTRYNAME2 = LOCALE_SISO3166CTRYNAME2 + , lOCALE_SISO639LANGNAME = LOCALE_SISO639LANGNAME + , lOCALE_SISO639LANGNAME2 = LOCALE_SISO639LANGNAME2 + , lOCALE_SKEYBOARDSTOINSTALL = LOCALE_SKEYBOARDSTOINSTALL + , lOCALE_SLIST = LOCALE_SLIST + , lOCALE_SLONGDATE = LOCALE_SLONGDATE + , lOCALE_SMONDECIMALSEP = LOCALE_SMONDECIMALSEP + , lOCALE_SMONGROUPING = LOCALE_SMONGROUPING + , lOCALE_SMONTHNAME1 = LOCALE_SMONTHNAME1 + , lOCALE_SMONTHNAME2 = LOCALE_SMONTHNAME2 + , lOCALE_SMONTHNAME3 = LOCALE_SMONTHNAME3 + , lOCALE_SMONTHNAME4 = LOCALE_SMONTHNAME4 + , lOCALE_SMONTHNAME5 = LOCALE_SMONTHNAME5 + , lOCALE_SMONTHNAME6 = LOCALE_SMONTHNAME6 + , lOCALE_SMONTHNAME7 = LOCALE_SMONTHNAME7 + , lOCALE_SMONTHNAME8 = LOCALE_SMONTHNAME8 + , lOCALE_SMONTHNAME9 = LOCALE_SMONTHNAME9 + , lOCALE_SMONTHNAME10 = LOCALE_SMONTHNAME10 + , lOCALE_SMONTHNAME11 = LOCALE_SMONTHNAME11 + , lOCALE_SMONTHNAME12 = LOCALE_SMONTHNAME12 + , lOCALE_SMONTHNAME13 = LOCALE_SMONTHNAME13 + , lOCALE_SMONTHOUSANDSEP = LOCALE_SMONTHOUSANDSEP + , lOCALE_SNAME = LOCALE_SNAME + , lOCALE_SNAN = LOCALE_SNAN + , lOCALE_SNATIVECOUNTRYNAME = LOCALE_SNATIVECOUNTRYNAME + , lOCALE_SNATIVECURRNAME = LOCALE_SNATIVECURRNAME + , lOCALE_SNATIVEDIGITS = LOCALE_SNATIVEDIGITS + , lOCALE_SNEGATIVESIGN = LOCALE_SNEGATIVESIGN + , lOCALE_SNEGINFINITY = LOCALE_SNEGINFINITY + , lOCALE_SPARENT = LOCALE_SPARENT + , lOCALE_SPOSINFINITY = LOCALE_SPOSINFINITY , lOCALE_SPOSITIVESIGN = LOCALE_SPOSITIVESIGN + , lOCALE_SSCRIPTS = LOCALE_SSCRIPTS , lOCALE_SSHORTDATE = LOCALE_SSHORTDATE - , lOCALE_ITIME = LOCALE_ITIME + , lOCALE_SSHORTESTDAYNAME1 = LOCALE_SSHORTESTDAYNAME1 + , lOCALE_SSHORTESTDAYNAME2 = LOCALE_SSHORTESTDAYNAME2 + , lOCALE_SSHORTESTDAYNAME3 = LOCALE_SSHORTESTDAYNAME3 + , lOCALE_SSHORTESTDAYNAME4 = LOCALE_SSHORTESTDAYNAME4 + , lOCALE_SSHORTESTDAYNAME5 = LOCALE_SSHORTESTDAYNAME5 + , lOCALE_SSHORTESTDAYNAME6 = LOCALE_SSHORTESTDAYNAME6 + , lOCALE_SSHORTESTDAYNAME7 = LOCALE_SSHORTESTDAYNAME7 + , lOCALE_SSORTNAME = LOCALE_SSORTNAME , lOCALE_STHOUSAND = LOCALE_STHOUSAND - , lOCALE_S1159 = LOCALE_S1159 , lOCALE_STIME = LOCALE_STIME - , lOCALE_S2359 = LOCALE_S2359 , lOCALE_STIMEFORMAT = LOCALE_STIMEFORMAT - , lOCALE_SCURRENCY = LOCALE_SCURRENCY + , lOCALE_SYEARMONTH = LOCALE_SYEARMONTH } +-- |Type representing locale data +data LCData + -- | Data in the form of a Unicode string. + = LCTextualData !String + -- | Data in the form of a number. See 'lOCAL_RETURN_NUMBER' and @LOCAL_I*@ + -- locate information constants. + | LCNumericData !DWORD + -- | Data in the fomr of a 'LOCALESIGNATURE'. See 'lOCAL_FONTSIGNATURE' locale + -- information constant. + | LCSignatureData !LOCALESIGNATURE + deriving (Eq, Show) + +data LOCALESIGNATURE = LOCALESIGNATURE + { lsUsb :: !UnicodeSubsetBitfield + , lsCsbDefault :: !DDWORD + , lsCsbSupported :: !DDWORD + } deriving (Eq, Show) + +instance Storable LOCALESIGNATURE where + sizeOf = const #{size LOCALESIGNATURE} + alignment _ = #alignment LOCALESIGNATURE + peek buf = do + lsUsb' <- (#peek LOCALESIGNATURE, lsUsb) buf + lsCsbDefault' <- (#peek LOCALESIGNATURE, lsCsbDefault) buf + lsCsbSupported' <- (#peek LOCALESIGNATURE, lsCsbSupported) buf + return $ LOCALESIGNATURE lsUsb' lsCsbDefault' lsCsbSupported' + poke buf info = do + (#poke LOCALESIGNATURE, lsUsb) buf (lsUsb info) + (#poke LOCALESIGNATURE, lsCsbDefault) buf (lsCsbDefault info) + (#poke LOCALESIGNATURE, lsCsbSupported) buf (lsCsbSupported info) + +-- | Type representing 128-bit Unicode subset bitfields, as the @base@ package +-- does include a module exporting a 128-bit unsigned integer type. +data UnicodeSubsetBitfield = UnicodeSubsetBitfield + { usbLow :: !DDWORD + , usbHigh :: !DDWORD + } deriving (Eq, Show) + +instance Storable UnicodeSubsetBitfield where + sizeOf _ = 2 * sizeOf (undefined :: DDWORD) + alignment _ = alignment (undefined :: DWORD) + peek buf = do + usbLow' <- (peekByteOff buf 0 :: IO DDWORD) + usbHigh' <- (peekByteOff buf (sizeOf (undefined :: DDWORD)) :: IO DDWORD) + return $ UnicodeSubsetBitfield usbLow' usbHigh' + poke buf info = do + pokeByteOff buf 0 (usbLow info) + pokeByteOff buf (sizeOf (undefined :: DDWORD)) (usbHigh info) + +getLocaleInfoEx :: Maybe String -> LCTYPE -> IO LCData +getLocaleInfoEx locale ty + | ty == lOCALE_FONTSIGNATURE = + getLocaleInfoEx' LCSignatureData localSigCharCount + + | ty .&. lOCALE_RETURN_NUMBER /= 0 = + getLocaleInfoEx' LCNumericData dWORDCharCount + + | otherwise = maybeWith withTString locale $ \c_locale -> + LCTextualData <$> trySized cFuncName (c_GetLocaleInfoEx c_locale ty) + where + cFuncName = "GetLocaleInfoEx" + -- See https://docs.microsoft.com/en-us/windows/win32/api/winnls/nf-winnls-getlocaleinfoex + localSigCharCount = (#size LOCALESIGNATURE) `div` (#size WCHAR) + dWORDCharCount = (#size DWORD) `div` (#size WCHAR) + + getLocaleInfoEx' constructor bufSize = maybeWith withTString locale $ + \c_locale -> do + value <- alloca $ \buf -> do + _ <- failIfZero cFuncName + $ c_GetLocaleInfoEx c_locale ty (castPtr buf) bufSize + peek buf + return $ constructor value + +foreign import WINDOWS_CCONV unsafe "windows.h GetLocaleInfoEx" + c_GetLocaleInfoEx :: LPCWSTR -> LCTYPE -> LPWSTR -> CInt -> IO CInt + setLocaleInfo :: LCID -> LCTYPE -> String -> IO () setLocaleInfo locale ty info = withTString info $ \ c_info -> @@ -101,25 +335,153 @@ type LCMapFlags = DWORD #{enum LCMapFlags, - , lCMAP_BYTEREV = LCMAP_BYTEREV - , lCMAP_FULLWIDTH = LCMAP_FULLWIDTH - , lCMAP_HALFWIDTH = LCMAP_HALFWIDTH - , lCMAP_HIRAGANA = LCMAP_HIRAGANA - , lCMAP_KATAKANA = LCMAP_KATAKANA - , lCMAP_LOWERCASE = LCMAP_LOWERCASE - , lCMAP_SORTKEY = LCMAP_SORTKEY - , lCMAP_UPPERCASE = LCMAP_UPPERCASE - , nORM_IGNORECASE = NORM_IGNORECASE - , nORM_IGNORENONSPACE = NORM_IGNORENONSPACE - , nORM_IGNOREKANATYPE = NORM_IGNOREKANATYPE - , nORM_IGNORESYMBOLS = NORM_IGNORESYMBOLS - , nORM_IGNOREWIDTH = NORM_IGNOREWIDTH - , sORT_STRINGSORT = SORT_STRINGSORT - , lCMAP_LINGUISTIC_CASING = LCMAP_LINGUISTIC_CASING - , lCMAP_SIMPLIFIED_CHINESE = LCMAP_SIMPLIFIED_CHINESE - , lCMAP_TRADITIONAL_CHINESE = LCMAP_TRADITIONAL_CHINESE + , lCMAP_BYTEREV = LCMAP_BYTEREV + , lCMAP_FULLWIDTH = LCMAP_FULLWIDTH + , lCMAP_HALFWIDTH = LCMAP_HALFWIDTH + , lCMAP_HIRAGANA = LCMAP_HIRAGANA + , lCMAP_KATAKANA = LCMAP_KATAKANA + , lCMAP_LINGUISTIC_CASING = LCMAP_LINGUISTIC_CASING + , lCMAP_LOWERCASE = LCMAP_LOWERCASE + , lCMAP_SIMPLIFIED_CHINESE = LCMAP_SIMPLIFIED_CHINESE + , lCMAP_SORTKEY = LCMAP_SORTKEY + , lCMAP_TRADITIONAL_CHINESE = LCMAP_TRADITIONAL_CHINESE + , lCMAP_UPPERCASE = LCMAP_UPPERCASE + , lINGUISTIC_IGNORECASE = LINGUISTIC_IGNORECASE + , lINGUISTIC_IGNOREDIACRITIC = LINGUISTIC_IGNOREDIACRITIC + , nORM_IGNORECASE = NORM_IGNORECASE + , nORM_IGNORENONSPACE = NORM_IGNORENONSPACE + , nORM_IGNOREKANATYPE = NORM_IGNOREKANATYPE + , nORM_IGNORESYMBOLS = NORM_IGNORESYMBOLS + , nORM_IGNOREWIDTH = NORM_IGNOREWIDTH + , nORM_LINGUISTIC_CASING = NORM_LINGUISTIC_CASING + , sORT_STRINGSORT = SORT_STRINGSORT } +data NLSVERSIONINFOEX = NLSVERSIONINFOEX + { dwNLSVersionInfoSize :: DWORD + , dwNLSVersion :: DWORD + , dwDefinedVersion :: DWORD + , dwEffectiveId :: DWORD + , guidCustomVersion :: GUID + } deriving (Eq, Show) + +instance Storable NLSVERSIONINFOEX where + sizeOf = const #{size NLSVERSIONINFOEX} + alignment _ = #alignment NLSVERSIONINFOEX + peek buf = do + dwNLSVersionInfoSize' <- (#peek NLSVERSIONINFOEX, dwNLSVersionInfoSize) buf + dwNLSVersion' <- (#peek NLSVERSIONINFOEX, dwNLSVersion) buf + dwDefinedVersion' <- (#peek NLSVERSIONINFOEX, dwDefinedVersion) buf + dwEffectiveId' <- (#peek NLSVERSIONINFOEX, dwEffectiveId) buf + guidCustomVersion' <- (#peek NLSVERSIONINFOEX, guidCustomVersion) buf + return $ NLSVERSIONINFOEX dwNLSVersionInfoSize' dwNLSVersion' + dwDefinedVersion' dwEffectiveId' guidCustomVersion' + poke buf info = do + (#poke NLSVERSIONINFOEX, dwNLSVersionInfoSize) buf + (dwNLSVersionInfoSize info) + (#poke NLSVERSIONINFOEX, dwNLSVersion) buf (dwNLSVersion info) + (#poke NLSVERSIONINFOEX, dwDefinedVersion) buf (dwDefinedVersion info) + (#poke NLSVERSIONINFOEX, dwEffectiveId) buf (dwEffectiveId info) + (#poke NLSVERSIONINFOEX, guidCustomVersion) buf (guidCustomVersion info) + +-- Based on the `UnpackedUUID` type of package `uuid-types`. +data GUID = GUID + !Word32 + !Word16 + !Word16 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + deriving (Eq) + +instance Show GUID where + show (GUID data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8) = + printf "{%.8x-%.4x-%.4x-%.2x%2x-%.2x%.2x%.2x%.2x%.2x%.2x}" data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8 + +instance Storable GUID where + sizeOf _ = 16 + alignment _ = 4 + peekByteOff p off = GUID + <$> peekByteOff p off + <*> peekByteOff p (off + 4) + <*> peekByteOff p (off + 6) + <*> peekByteOff p (off + 8) + <*> peekByteOff p (off + 9) + <*> peekByteOff p (off + 10) + <*> peekByteOff p (off + 11) + <*> peekByteOff p (off + 12) + <*> peekByteOff p (off + 13) + <*> peekByteOff p (off + 14) + <*> peekByteOff p (off + 15) + pokeByteOff p off (GUID data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8) = do + pokeByteOff p off data1 + pokeByteOff p (off + 4) data2 + pokeByteOff p (off + 6) data3 + pokeByteOff p (off + 8) b1 + pokeByteOff p (off + 9) b2 + pokeByteOff p (off + 10) b3 + pokeByteOff p (off + 11) b4 + pokeByteOff p (off + 12) b5 + pokeByteOff p (off + 13) b6 + pokeByteOff p (off + 14) b7 + pokeByteOff p (off + 15) b8 + +getNLSVersionEx :: Maybe String -> IO NLSVERSIONINFOEX +getNLSVersionEx locale = maybeWith withTString locale $ \c_locale -> + with defaultVersionInfo $ \c_versionInfo -> do + failIfFalse_ "GetNLSVersionEx" $ + c_GetNLSVersionEx function c_locale c_versionInfo + peek c_versionInfo + where + function = #{const COMPARE_STRING} + defaultVersionInfo = NLSVERSIONINFOEX + { dwNLSVersionInfoSize = #{size NLSVERSIONINFOEX} + , dwNLSVersion = 0 + , dwDefinedVersion = 0 + , dwEffectiveId = 0 + , guidCustomVersion = GUID 0 0 0 0 0 0 0 0 0 0 0 + } +foreign import WINDOWS_CCONV unsafe "windows.h GetNLSVersionEx" + c_GetNLSVersionEx :: NLS_FUNCTION + -> LPCWSTR + -> Ptr NLSVERSIONINFOEX + -> IO Bool + +lCMapStringEx :: Maybe String + -> LCMapFlags + -> String + -> NLSVERSIONINFOEX + -> IO String +lCMapStringEx locale flags src versionInfo = + maybeWith withTString locale $ \c_locale -> + withTStringLen src $ \(c_src, src_len) -> + with versionInfo $ \c_versionInfo -> do + let c_src_len = fromIntegral src_len + c_func s l = c_LCMapStringEx c_locale + flags + c_src c_src_len + s l + c_versionInfo + nullPtr -- Reserved, must be NULL + 0 -- Reserved, must be 0 + trySized "LCMapStringEx" c_func +foreign import WINDOWS_CCONV unsafe "windows.h LCMapStringEx" + c_LCMapStringEx :: LPCWSTR + -> LCMapFlags + -> LPCWSTR + -> CInt + -> LPWSTR + -> CInt + -> Ptr NLSVERSIONINFOEX + -> LPVOID + -> LPARAM + -> IO CInt + lCMapString :: LCID -> LCMapFlags -> String -> Int -> IO String lCMapString locale flags src dest_size = withTStringLen src $ \ (c_src, src_len) -> @@ -137,9 +499,63 @@ , lCID_SUPPORTED = LCID_SUPPORTED } +isValidLocaleName :: Maybe String -> IO Bool +isValidLocaleName lpLocaleName = + maybeWith withTString lpLocaleName c_IsValidLocaleName +foreign import WINDOWS_CCONV unsafe "windows.h IsValidLocaleName" + c_IsValidLocaleName :: LPCWSTR -> IO Bool + foreign import WINDOWS_CCONV unsafe "windows.h IsValidLocale" isValidLocale :: LCID -> LocaleTestFlags -> IO Bool +type EnumLocalesFlag = DWORD + +-- The following locale enumeration flag constants are excluded from the `enum` +-- list below, for the reason indicated: +-- LOCALE_NEUTRALDATA -- Introduced in Windows 7 but not supported. + +#{enum EnumLocalesFlag, + , lOCALE_ALL = LOCALE_ALL + , lOCALE_ALTERNATE_SORTS = LOCALE_ALTERNATE_SORTS + , lOCALE_REPLACEMENT = LOCALE_REPLACEMENT + , lOCALE_SUPPLEMENTAL = LOCALE_SUPPLEMENTAL + , lOCALE_WINDOWS = LOCALE_WINDOWS + } + +type LOCALE_ENUMPROCEX = LPWSTR -> EnumLocalesFlag -> LPARAM -> IO BOOL +foreign import WINDOWS_CCONV "wrapper" + mkLOCALE_ENUMPROCEX :: LOCALE_ENUMPROCEX -> IO (FunPtr LOCALE_ENUMPROCEX) + +enumSystemLocalesEx :: LOCALE_ENUMPROCEX -> EnumLocalesFlag -> LPARAM -> IO () +enumSystemLocalesEx callback dwFlags lParam = do + c_callback <- mkLOCALE_ENUMPROCEX callback + failIfFalse_ "EnumSystemLocalesEx" $ + c_EnumSystemLocalesEx c_callback dwFlags lParam nullPtr + freeHaskellFunPtr c_callback +foreign import WINDOWS_CCONV safe "windows.h EnumSystemLocalesEx" + c_EnumSystemLocalesEx :: (FunPtr LOCALE_ENUMPROCEX) + -> DWORD + -> LPARAM + -> LPVOID + -> IO Bool + +enumSystemLocalesEx' :: EnumLocalesFlag + -> Maybe Bool + -- ^ Maybe include (or exclude) replacement locales? + -> IO [String] +enumSystemLocalesEx' dwFlags mIsReplacement = do + store <- newIORef [] + let localeEnumProcEx c_locale arg2 _ = do + locale <- peekTString c_locale + case mIsReplacement of + Nothing -> modifyIORef store (locale:) + Just isReplacement -> + when (isReplacement == (arg2 .&. lOCALE_REPLACEMENT /= 0)) $ + modifyIORef store (locale:) + return True + enumSystemLocalesEx localeEnumProcEx dwFlags 0 + reverse <$> readIORef store + foreign import WINDOWS_CCONV unsafe "windows.h IsValidCodePage" isValidCodePage :: CodePage -> IO Bool @@ -149,6 +565,42 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLangID" getUserDefaultLangID :: LANGID +-- #define LOCALE_NAME_INVARIANT L"" +lOCALE_NAME_INVARIANT :: Maybe String +lOCALE_NAME_INVARIANT = Just "" + + -- #define LOCALE_NAME_SYSTEM_DEFAULT L"!x-sys-default-locale" +lOCALE_NAME_SYSTEM_DEFAULT :: Maybe String +lOCALE_NAME_SYSTEM_DEFAULT = Just "!x-sys-default-locale" + + -- #define LOCALE_NAME_USER_DEFAULT NULL +lOCALE_NAME_USER_DEFAULT :: Maybe String +lOCALE_NAME_USER_DEFAULT = Nothing + +getUserDefaultLocaleName :: IO String +getUserDefaultLocaleName = + getDefaultLocaleName "GetUserDefaultLocaleName" c_GetUserDefaultLocaleName +foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLocaleName" + c_GetUserDefaultLocaleName :: LPWSTR -> CInt -> IO CInt + +#{enum CInt, + , lOCALE_NAME_MAX_LENGTH = LOCALE_NAME_MAX_LENGTH + } + +-- |Helper function for use with 'c_GetUserDefaultLocaleName' or +-- 'c_GetSystemDefaultLocaleName'. See 'getUserDefaultLocaleName' and +-- 'getSystemUserDefaultLocaleName'. +getDefaultLocaleName :: String -> (LPWSTR -> CInt -> IO CInt) -> IO String +getDefaultLocaleName cDefaultLocaleFuncName cDefaultLocaleFunc = + withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- failIfZero cDefaultLocaleFuncName $ + cDefaultLocaleFunc buf c_len + let len' = fromIntegral c_len' + peekTStringLen (buf, len' - 1) -- Drop final null character + where + maxLength = fromIntegral lOCALE_NAME_MAX_LENGTH + foreign import WINDOWS_CCONV unsafe "windows.h GetThreadLocale" getThreadLocale :: IO LCID @@ -158,6 +610,12 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLangID" getSystemDefaultLangID :: LANGID +getSystemDefaultLocaleName :: IO String +getSystemDefaultLocaleName = + getDefaultLocaleName "GetSystemDefaultLocaleName" c_GetSystemDefaultLocaleName +foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLocaleName" + c_GetSystemDefaultLocaleName :: LPWSTR -> CInt -> IO CInt + foreign import WINDOWS_CCONV unsafe "windows.h GetOEMCP" getOEMCP :: CodePage @@ -343,7 +801,7 @@ -- ---------------------------------------------------------------------------- --- | The `System.IO` input functions (e.g. `getLine`) don't +-- | The `System.IO` input functions (e.g., `getLine`) don't -- automatically convert to Unicode, so this function is provided to -- make the conversion from a multibyte string in the given code page -- to a proper Unicode string. To get the code page for the console, diff --git a/System/Win32/NamedPipes.hsc b/System/Win32/NamedPipes.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/NamedPipes.hsc @@ -0,0 +1,276 @@ +#include +#include + +#include "namedpipeapi_compat.h" + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} + +-- | For full details on the Windows named pipes API see +-- +-- +module System.Win32.NamedPipes ( + + -- * Named pipe server APIs + createNamedPipe, + pIPE_UNLIMITED_INSTANCES, + + -- ** Parameter types + LPSECURITY_ATTRIBUTES, + OpenMode, + pIPE_ACCESS_DUPLEX, + pIPE_ACCESS_INBOUND, + pIPE_ACCESS_OUTBOUND, + fILE_FLAG_OVERLAPPED, + PipeMode, + pIPE_TYPE_BYTE, + pIPE_TYPE_MESSAGE, + pIPE_READMODE_BYTE, + pIPE_READMODE_MESSAGE, + pIPE_WAIT, + pIPE_NOWAIT, + pIPE_ACCEPT_REMOTE_CLIENTS, + pIPE_REJECT_REMOTE_CLIENTS, + + -- * Named pipe client APIs + -- ** connect to a named pipe + connect, + + -- ** waiting for named pipe instances + waitNamedPipe, + + TimeOut, + nMPWAIT_USE_DEFAULT_WAIT, + nMPWAIT_WAIT_FOREVER, + ) where + + +import Control.Exception +import Control.Monad (when) +import Foreign.C.String (withCString) + +import System.Win32.Types hiding (try) +import System.Win32.File + +-- | The named pipe open mode. +-- +-- This must specify one of: +-- +-- * 'pIPE_ACCESS_DUPLEX' +-- * 'pIPE_ACCESS_INBOUND' +-- * 'pIPE_ACCESS_OUTBOUND' +-- +-- It may also specify: +-- +-- * 'fILE_FLAG_WRITE_THROUGH' +-- * 'fILE_FLAG_OVERLAPPED' +-- +-- It may also specify any combination of: +-- +-- * 'wRITE_DAC' +-- * 'wRITE_OWNER' +-- * 'aCCESS_SYSTEM_SECURITY' +-- +type OpenMode = UINT + +#{enum OpenMode, + , pIPE_ACCESS_DUPLEX = PIPE_ACCESS_DUPLEX + , pIPE_ACCESS_INBOUND = PIPE_ACCESS_INBOUND + , pIPE_ACCESS_OUTBOUND = PIPE_ACCESS_OUTBOUND + } + +-- | The pipe mode. +-- +-- One of the following type modes can be specified. The same type mode must be +-- specified for each instance of the pipe. +-- +-- * 'pIPE_TYPE_BYTE' +-- * 'pIPE_TYPE_MESSAGE' +-- +-- One of the following read modes can be specified. Different instances of the +-- same pipe can specify different read modes. +-- +-- * 'pIPE_READMODE_BYTE' +-- * 'pIPE_READMODE_MESSAGE' +-- +-- One of the following wait modes can be specified. Different instances of the +-- same pipe can specify different wait modes. +-- +-- * 'pIPE_WAIT' +-- * 'pIPE_NOWAIT' +-- +-- One of the following remote-client modes can be specified. Different +-- instances of the same pipe can specify different remote-client modes. +-- +-- * 'pIPE_ACCEPT_REMOTE_CLIENT' +-- * 'pIPE_REJECT_REMOTE_CLIENT' +-- +type PipeMode = UINT + +#{enum PipeMode, + , pIPE_TYPE_BYTE = PIPE_TYPE_BYTE + , pIPE_TYPE_MESSAGE = PIPE_TYPE_MESSAGE + , pIPE_READMODE_BYTE = PIPE_READMODE_BYTE + , pIPE_READMODE_MESSAGE = PIPE_READMODE_MESSAGE + , pIPE_WAIT = PIPE_WAIT + , pIPE_NOWAIT = PIPE_NOWAIT + , pIPE_ACCEPT_REMOTE_CLIENTS = PIPE_ACCEPT_REMOTE_CLIENTS + , pIPE_REJECT_REMOTE_CLIENTS = PIPE_REJECT_REMOTE_CLIENTS + } + +-- | If the 'createNamedPipe' @nMaxInstances@ parameter is +-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created +-- is limited only by the availability of system resources. +pIPE_UNLIMITED_INSTANCES :: DWORD +pIPE_UNLIMITED_INSTANCES = #const PIPE_UNLIMITED_INSTANCES + +-- | Creates an instance of a named pipe and returns a handle for subsequent +-- pipe operations. A named pipe server process uses this function either to +-- create the first instance of a specific named pipe and establish its basic +-- attributes or to create a new instance of an existing named pipe. +-- +-- For full details see +-- +-- +-- To create a named pipe which can be associate with IO completion port on +-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument, +-- e.g. +-- +-- > Win32.createNamedPipe pipeName +-- > (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED) +-- > (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE) +-- > pIPE_UNLIMITED_INSTANCES +-- > 512 +-- > 512 +-- > 0 +-- > NothinROR +-- +-- +createNamedPipe :: String -- ^ A unique pipe name of the form @\\\\.\\pipe\\{pipename}@ + -- The `pipename` part of the name can include any + -- character other than a backslash, including + -- numbers and special characters. The entire pipe + -- name string can be up to 256 characters long. + -- Pipe names are not case sensitive. + -> OpenMode + -> PipeMode + -> DWORD -- ^ nMaxInstances + -> DWORD -- ^ nOutBufferSize + -> DWORD -- ^ nInBufferSize + -> DWORD -- ^ nDefaultTimeOut + -> Maybe LPSECURITY_ATTRIBUTES + -> IO HANDLE +createNamedPipe name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut mb_attr = + withTString name $ \ c_name -> + failIf (==iNVALID_HANDLE_VALUE) ("CreateNamedPipe ('" ++ name ++ "')") $ + c_CreateNamedPipe c_name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut (maybePtr mb_attr) + +foreign import ccall unsafe "windows.h CreateNamedPipeW" + c_CreateNamedPipe :: LPCTSTR + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> LPSECURITY_ATTRIBUTES + -> IO HANDLE + + +-- | Timeout in milliseconds. +-- +-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to +-- 'createNamedPipe' should be used. +-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named +-- pipe instance is available. +-- +type TimeOut = DWORD +#{enum TimeOut, + , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT + , nMPWAIT_WAIT_FOREVER = NMPWAIT_WAIT_FOREVER + } + + +-- | Wait until a named pipe instance is available. If there is no instance at +-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e. +-- @invalid argument (The semaphore timeout period has expired)@ +-- +-- It returns 'True' if there is an available instance, subsequent 'createFile' +-- might still fail, if another thread will take turn and connect before, or if +-- the other end shuts down the name pipe. +-- +-- It returns 'False' if timeout fired. +-- +waitNamedPipe :: String -- ^ pipe name + -> TimeOut -- ^ nTimeOut + -> IO Bool +waitNamedPipe name timeout = + withCString name $ \ c_name -> do + r <- c_WaitNamedPipe c_name timeout + e <- getLastError + if | r -> pure r + | e == eRROR_SEM_TIMEOUT -> pure False + | otherwise -> failWith "waitNamedPipe" e + + +-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import. +foreign import ccall safe "windows.h WaitNamedPipeA" + c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName + -> DWORD -- nTimeOut + -> IO BOOL + +-- | A reliable connect call, as designed in +-- +-- +-- The arguments are passed directly to 'createFile'. +-- +-- Note we pick the more familiar posix naming convention, do not confuse this +-- function with 'connectNamedPipe' (which corresponds to posix 'accept') +-- +connect :: String -- ^ file name + -> AccessMode -- ^ dwDesiredAccess + -> ShareMode -- ^ dwSharedMode + -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes + -> CreateMode -- ^ dwCreationDisposition + -> FileAttributeOrFlag -- ^ dwFlagsAndAttributes + -> Maybe HANDLE -- ^ hTemplateFile + -> IO HANDLE +connect fileName dwDesiredAccess dwSharedMode lpSecurityAttributes dwCreationDisposition dwFlagsAndAttributes hTemplateFile = connectLoop + where + connectLoop = do + -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is + -- caused by `ERROR_SHARING_VIOLATION`. + mh <- try $ + createFile fileName + dwDesiredAccess + dwSharedMode + lpSecurityAttributes + dwCreationDisposition + dwFlagsAndAttributes + hTemplateFile + case mh :: Either IOException HANDLE of + Left e -> do + errorCode <- getLastError + when (errorCode /= eRROR_PIPE_BUSY) + $ throwIO e + -- all pipe instance were busy, wait 20s and retry; we ignore the + -- result + _ <- waitNamedPipe fileName 5000 + connectLoop + + Right h -> pure h + + +-- | [ERROR_PIPE_BUSY](https://docs.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-#ERROR_PIPE_BUSY): +-- all pipe instances are busy. +-- +eRROR_PIPE_BUSY :: ErrCode +eRROR_PIPE_BUSY = #const ERROR_PIPE_BUSY + +eRROR_SEM_TIMEOUT :: ErrCode +eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT diff --git a/System/Win32/Path.hsc b/System/Win32/Path.hsc --- a/System/Win32/Path.hsc +++ b/System/Win32/Path.hsc @@ -22,6 +22,7 @@ , pathRelativePathTo ) where +import System.Win32.Path.Internal import System.Win32.Types import System.Win32.File @@ -53,5 +54,3 @@ _ <- localFree p_AbsPath return path -foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW" - c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT diff --git a/System/Win32/Path/Internal.hsc b/System/Win32/Path/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Path/Internal.hsc @@ -0,0 +1,29 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Path.Internal +-- Copyright : (c) Tamar Christina, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Tamar Christina +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.Path.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +#include + +foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW" + c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT diff --git a/System/Win32/Process.hsc b/System/Win32/Process.hsc --- a/System/Win32/Process.hsc +++ b/System/Win32/Process.hsc @@ -17,7 +17,49 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Process where +module System.Win32.Process + ( -- * Sleeping + iNFINITE + , sleep + -- * Processes pperations + , ProcessId + , ProcessHandle + , ProcessAccessRights + , pROCESS_ALL_ACCESS + , pROCESS_CREATE_PROCESS + , pROCESS_CREATE_THREAD + , pROCESS_DUP_HANDLE + , pROCESS_QUERY_INFORMATION + , pROCESS_SET_QUOTA + , pROCESS_SET_INFORMATION + , pROCESS_TERMINATE + , pROCESS_VM_OPERATION + , pROCESS_VM_READ + , pROCESS_VM_WRITE + , openProcess + , getProcessId + , getCurrentProcessId + , getCurrentProcess + -- * Terminating + , terminateProcessById + -- * Toolhelp32 + , Th32SnapHandle + , Th32SnapFlags + , tH32CS_SNAPALL + , tH32CS_SNAPHEAPLIST + , tH32CS_SNAPMODULE + , tH32CS_SNAPMODULE32 + , tH32CS_SNAPMODULE64 + , tH32CS_SNAPPROCESS + , tH32CS_SNAPTHREAD + , ProcessEntry32 + , ModuleEntry32 + , createToolhelp32Snapshot + , withTh32Snap + , th32SnapEnumProcesses + , th32SnapEnumModules + ) where + import Control.Exception ( bracket ) import Control.Monad ( liftM5 ) import Foreign ( Ptr, peekByteOff, allocaBytes, pokeByteOff @@ -168,7 +210,7 @@ ok' <- c_Process32Next h pe readAndNext ok' pe (entry:res) --- | Enumerate moduless using Module32First and Module32Next +-- | Enumerate modules using Module32First and Module32Next th32SnapEnumModules :: Th32SnapHandle -> IO [ModuleEntry32] th32SnapEnumModules h = allocaBytes (#size MODULEENTRY32W) $ \pe -> do (#poke MODULEENTRY32W, dwSize) pe ((#size MODULEENTRY32W)::DWORD) diff --git a/System/Win32/Registry.hsc b/System/Win32/Registry.hsc --- a/System/Win32/Registry.hsc +++ b/System/Win32/Registry.hsc @@ -14,43 +14,102 @@ ----------------------------------------------------------------------------- module System.Win32.Registry - ( module System.Win32.Registry - ) where -{- What's really on offer: - ( - regCloseKey -- :: HKEY -> IO () - , regConnectRegistry -- :: Maybe String -> HKEY -> IO HKEY - , regCreateKey -- :: HKEY -> String -> IO HKEY - , regCreateKeyEx -- :: HKEY -> String -> Maybe String - -- -> RegCreateOptions -> REGSAM - -- -> Maybe LPSECURITY_ATTRIBUTES - -- -> IO (HKEY, Bool) - , regDeleteKey -- :: HKEY -> String -> IO () - , regDeleteValue -- :: HKEY -> String -> IO () - , regEnumKeys -- :: HKEY -> IO [String] - , regEnumKey -- :: HKEY -> DWORD -> Addr -> DWORD -> IO String - , regEnumKeyValue -- :: HKEY -> DWORD -> Addr -> DWORD -> Addr -> DWORD -> IO String - , regFlushKey -- :: HKEY -> IO () - , regLoadKey -- :: HKEY -> String -> String -> IO () - , regNotifyChangeKeyValue -- :: HKEY -> Bool -> RegNotifyOptions - -- -> HANDLE -> Bool -> IO () - , regOpenKey -- :: HKEY -> String -> IO HKEY - , regOpenKeyEx -- :: HKEY -> String -> REGSAM -> IO HKEY - , regQueryInfoKey -- :: HKEY -> IO RegInfoKey - , regQueryValue -- :: HKEY -> Maybe String -> IO String - , regQueryDefaultValue -- :: HKEY -> String -> IO String - , regQueryValueEx -- :: HKEY -> String -> Addr -> Int -> IO RegValueType - , regReplaceKey -- :: HKEY -> Maybe String -> String -> String -> IO () - , regRestoreKey -- :: HKEY -> String -> RegRestoreFlags -> IO () - , regSaveKey -- :: HKEY -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO () - , regGetValue -- :: HKEY -> Maybe String -> Maybe String -> RegTypeRestriction - -- -> Maybe LPDWORD -> Maybe LPVOID -> Maybe LPDWORD -> IO () - , regSetValue -- :: HKEY -> String -> String -> IO () - , regSetValueEx -- :: HKEY -> String -> RegValueType -> LPTSTR -> Int -> IO () - , regSetStringValue -- :: HKEY -> String -> String -> IO () - , regUnloadKey -- :: HKEY -> String -> IO () - ) where --} + ( + -- * HKEY + HKEY + , hKEY_CLASSES_ROOT + , hKEY_CURRENT_CONFIG + , hKEY_CURRENT_USER + , hKEY_LOCAL_MACHINE + , hKEY_USERS + + -- * Creation options + , RegCreateOptions + , rEG_OPTION_NON_VOLATILE + , rEG_OPTION_VOLATILE + + -- * REGSAM + , REGSAM + , kEY_ALL_ACCESS + , kEY_CREATE_LINK + , kEY_CREATE_SUB_KEY + , kEY_ENUMERATE_SUB_KEYS + , kEY_EXECUTE + , kEY_NOTIFY + , kEY_QUERY_VALUE + , kEY_READ + , kEY_SET_VALUE + , kEY_WRITE + + -- * Registry operations + , regCloseKey + , regConnectRegistry + , regCreateKey + , regCreateKeyEx + , regDeleteKey + , regDeleteValue + , regEnumKeys + , regEnumKeyVals + , regEnumKey + , regEnumValue + , regFlushKey + , regLoadKey + , regUnLoadKey + , regNotifyChangeKeyValue + , RegNotifyOptions + , rEG_NOTIFY_CHANGE_NAME + , rEG_NOTIFY_CHANGE_ATTRIBUTES + , rEG_NOTIFY_CHANGE_LAST_SET + , rEG_NOTIFY_CHANGE_SECURITY + + , regOpenKey + , regOpenKeyEx + , regQueryInfoKey + , RegInfoKey(..) + , regQueryValue + , regQueryValueKey + , regQueryDefaultValue + , regQueryValueEx + , regReplaceKey + , RegRestoreFlags + , rEG_WHOLE_HIVE_VOLATILE + , rEG_REFRESH_HIVE + , rEG_NO_LAZY_FLUSH + , regRestoreKey + , regSaveKey + , regGetValue + , RegTypeRestriction + , rRF_RT_ANY + , rRF_RT_DWORD + , rRF_RT_QWORD + , rRF_RT_REG_BINARY + , rRF_RT_REG_DWORD + , rRF_RT_REG_EXPAND_SZ + , rRF_RT_REG_MULTI_SZ + , rRF_RT_REG_NONE + , rRF_RT_REG_QWORD + , rRF_RT_REG_SZ + , rRF_NOEXPAND + , rRF_ZEROONFAILURE + , rRF_SUBKEY_WOW6464KEY + , rRF_SUBKEY_WOW6432KEY + + , regSetValue + , regSetValueEx + , RegValueType + , rEG_BINARY + , rEG_DWORD + , rEG_DWORD_LITTLE_ENDIAN + , rEG_DWORD_BIG_ENDIAN + , rEG_EXPAND_SZ + , rEG_LINK + , rEG_MULTI_SZ + , rEG_NONE + , rEG_RESOURCE_LIST + , rEG_SZ + + , regSetStringValue -- :: HKEY -> String -> String -> IO () + ) where {- Registry API omissions: diff --git a/System/Win32/Security.hsc b/System/Win32/Security.hsc --- a/System/Win32/Security.hsc +++ b/System/Win32/Security.hsc @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. +-- The above warning suppression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings diff --git a/System/Win32/Semaphore.hsc b/System/Win32/Semaphore.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Semaphore.hsc @@ -0,0 +1,146 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Semaphore +-- Copyright : (c) Sam Derbyshire, 2022 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Sam Derbyshire +-- Stability : provisional +-- Portability : portable +-- +-- Windows Semaphore objects and operations +-- +----------------------------------------------------------------------------- + +module System.Win32.Semaphore + ( -- * Semaphores + Semaphore(..) + + -- * Access modes + , AccessMode + , sEMAPHORE_ALL_ACCESS + , sEMAPHORE_MODIFY_STATE + + -- * Managing semaphores + , createSemaphore + , openSemaphore + , releaseSemaphore + ) where + +import System.Win32.File +import System.Win32.Types + +import Data.Maybe (fromMaybe) +import Foreign hiding (void) +import Foreign.C (withCAString) + +##include "windows_cconv.h" + +#include + +---------------------------------------------------------------- +-- Semaphore access modes +---------------------------------------------------------------- + +#{enum AccessMode, + , sEMAPHORE_ALL_ACCESS = SEMAPHORE_ALL_ACCESS + , sEMAPHORE_MODIFY_STATE = SEMAPHORE_MODIFY_STATE + } + +---------------------------------------------------------------- +-- Semaphores +---------------------------------------------------------------- + +-- | A Windows semaphore. +-- +-- To obtain a 'Semaphore', use 'createSemaphore' to create a new one, +-- or 'openSemaphore' to open an existing one. +-- +-- To wait on a semaphore, use 'System.Win32.Event.waitForSingleObject'. +-- +-- To release resources on a semaphore, use 'releaseSemaphore'. +-- +-- To free a semaphore, use 'System.Win32.File.closeHandle'. +-- The semaphore object is destroyed when its last handle has been closed. +-- Closing the handle does not affect the semaphore count; therefore, be sure to call +-- 'releaseSemaphore' before closing the handle or before the process terminates. +-- Otherwise, pending wait operations will either time out or continue indefinitely, +-- depending on whether a time-out value has been specified. +newtype Semaphore = Semaphore { semaphoreHandle :: HANDLE } + +-- | Open a 'Semaphore' with the given name, or create a new semaphore +-- if no such semaphore exists, with initial count @i@ and maximum count @m@. +-- +-- The counts must satisfy @i >= 0@, @m > 0@ and @i <= m@. +-- +-- The returned 'Bool' is 'True' if the function found an existing semaphore +-- with the given name, in which case a handle to that semaphore is returned +-- and the counts are ignored. +-- +-- Use 'openSemaphore' if you don't want to create a new semaphore. +createSemaphore :: Maybe SECURITY_ATTRIBUTES + -> LONG -- ^ initial count @i@ with @0 <= i <= m@ + -> LONG -- ^ maximum count @m > 0@ + -> Maybe String -- ^ (optional) semaphore name + -- (case-sensitive, limited to MAX_PATH characters) + -> IO (Semaphore, Bool) +createSemaphore mb_sec initial_count max_count mb_name = + maybeWith with mb_sec $ \ c_sec -> do + maybeWith withCAString mb_name $ \ c_name -> do + handle <- c_CreateSemaphore c_sec initial_count max_count c_name + err_code <- getLastError + already_exists <- + case err_code of + (# const ERROR_INVALID_HANDLE) -> + errorWin $ "createSemaphore: semaphore name '" + ++ fromMaybe "" mb_name + ++ "' matches non-semaphore" + (# const ERROR_ALREADY_EXISTS) -> + return True + _ -> + return False + if handle == nullPtr + then errorWin "createSemaphore" + else return (Semaphore handle, already_exists) + +foreign import WINDOWS_CCONV unsafe "windows.h CreateSemaphoreA" + c_CreateSemaphore :: LPSECURITY_ATTRIBUTES -> LONG -> LONG -> LPCSTR -> IO HANDLE + +-- | Open an existing 'Semaphore'. +openSemaphore :: AccessMode -- ^ desired access mode + -> Bool -- ^ should child processes inherit the handle? + -> String -- ^ name of the semaphore to open (case-sensitive) + -> IO Semaphore +openSemaphore amode inherit name = + withTString name $ \c_name -> do + handle <- failIfNull ("openSemaphore: '" ++ name ++ "'") $ + c_OpenSemaphore (fromIntegral amode) inherit c_name + return (Semaphore handle) + +foreign import WINDOWS_CCONV unsafe "windows.h OpenSemaphoreW" + c_OpenSemaphore :: DWORD -> BOOL -> LPCWSTR -> IO HANDLE + +-- | Increase the count of the 'Semaphore' by the specified amount. +-- +-- Returns the count of the semaphore before the increase. +-- +-- Throws an error if the count would exceeded the maximum count +-- of the semaphore. +releaseSemaphore :: Semaphore -> LONG -> IO LONG +releaseSemaphore (Semaphore handle) count = + with 0 $ \ ptr_prevCount -> do + failIfFalse_ "releaseSemaphore" $ c_ReleaseSemaphore handle count ptr_prevCount + peek ptr_prevCount + +foreign import WINDOWS_CCONV unsafe "windows.h ReleaseSemaphore" + c_ReleaseSemaphore :: HANDLE -> LONG -> Ptr LONG -> IO BOOL + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/Shell.hsc b/System/Win32/Shell.hsc --- a/System/Win32/Shell.hsc +++ b/System/Win32/Shell.hsc @@ -32,13 +32,13 @@ sHGFP_TYPE_DEFAULT ) where +import System.Win32.Shell.Internal import System.Win32.Types import Graphics.Win32.GDI.Types (HWND) import Foreign import Foreign.C import Control.Monad -import System.IO.Error ##include "windows_cconv.h" @@ -79,11 +79,3 @@ r <- c_SHGetFolderPath hwnd csidl hdl flags pstr when (r < 0) $ raiseUnsupported "sHGetFolderPath" peekTString pstr - -raiseUnsupported :: String -> IO () -raiseUnsupported loc = - ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation") - -foreign import WINDOWS_CCONV unsafe "SHGetFolderPathW" - c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR - -> IO HRESULT diff --git a/System/Win32/Shell/Internal.hsc b/System/Win32/Shell/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Shell/Internal.hsc @@ -0,0 +1,50 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Shell.Internal +-- Copyright : (c) The University of Glasgow 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Win32 stuff from shell32.dll +-- +----------------------------------------------------------------------------- + +module System.Win32.Shell.Internal ( + c_SHGetFolderPath + , raiseUnsupported + ) where + +import System.Win32.Types +import Graphics.Win32.GDI.Types (HWND) + +import Foreign.C +import System.IO.Error + +##include "windows_cconv.h" + +-- for SHGetFolderPath stuff +#define _WIN32_IE 0x500 +#include +#include + +---------------------------------------------------------------- +-- SHGetFolderPath +-- +-- XXX: this is deprecated in Vista and later +---------------------------------------------------------------- + +raiseUnsupported :: String -> IO () +raiseUnsupported loc = + ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation") + +foreign import WINDOWS_CCONV unsafe "SHGetFolderPathW" + c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR + -> IO HRESULT diff --git a/System/Win32/SimpleMAPI.hsc b/System/Win32/SimpleMAPI.hsc --- a/System/Win32/SimpleMAPI.hsc +++ b/System/Win32/SimpleMAPI.hsc @@ -35,8 +35,7 @@ -- Apparently, simple MAPI does not support unicode and probably never will, -- so this module will just mangle any Unicode in your strings import Graphics.Win32.GDI.Types ( HWND) -import System.Win32.DLL ( loadLibrary, c_GetProcAddress, freeLibrary - , c_FreeLibraryFinaliser ) +import System.Win32.DLL ( loadLibrary, freeLibrary, getProcAddress ) import System.Win32.Types ( DWORD, LPSTR, HMODULE, failIfNull ) ##include "windows_cconv.h" @@ -108,9 +107,9 @@ , ((#const MAPI_E_TEXT_TOO_LARGE) , "Text too large") , ((#const MAPI_E_INVALID_SESSION) , "Invalid session") , ((#const MAPI_E_TYPE_NOT_SUPPORTED) , "Type not supported") - , ((#const MAPI_E_AMBIGUOUS_RECIPIENT) , "Ambigious recipient") + , ((#const MAPI_E_AMBIGUOUS_RECIPIENT) , "Ambiguous recipient") #ifdef MAPI_E_AMBIGUOUS_RECIP - , ((#const MAPI_E_AMBIGUOUS_RECIP) , "Ambigious recipient") + , ((#const MAPI_E_AMBIGUOUS_RECIP) , "Ambiguous recipient") #endif , ((#const MAPI_E_MESSAGE_IN_USE) , "Message in use") , ((#const MAPI_E_NETWORK_FAILURE) , "Network failure") @@ -171,9 +170,9 @@ (loadProc "MAPISendMail" dll mkMapiSendMail) where loadProc :: String -> HMODULE -> (FunPtr a -> a) -> IO a - loadProc name dll' conv = withCAString name $ \name' -> do + loadProc name dll' conv = do proc <- failIfNull ("loadMapiDll: " ++ dllname ++ ": " ++ name) - $ c_GetProcAddress dll' name' + $ getProcAddress dll' name return $ conv $ castPtrToFunPtr proc -- | loadMapiDll :: String -> IO (MapiFuncs, HMODULE) @@ -203,6 +202,11 @@ loadOne l = case l of [] -> fail $ "loadMapi: Failed to load any of DLLs: " ++ show dlls x:y -> handleIOException (const $ loadOne y) (loadMapiDll x) + + +{-# CFILES cbits/HsWin32.c #-} +foreign import ccall "HsWin32.h &FreeLibraryFinaliser" + c_FreeLibraryFinaliser :: FunPtr (HMODULE -> IO ()) -- | withMapiLoaded :: MapiLoaded -> (MapiFuncs -> IO a) -> IO a diff --git a/System/Win32/SymbolicLink.hsc b/System/Win32/SymbolicLink.hsc --- a/System/Win32/SymbolicLink.hsc +++ b/System/Win32/SymbolicLink.hsc @@ -10,45 +10,77 @@ Handling symbolic link using Win32 API. [Vista of later and desktop app only] - Note: You should worry about UAC (User Account Control) when use this module's function in your application: + Note: When using the createSymbolicLink* functions without the + SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE flag, you should worry about UAC + (User Account Control) when use this module's function in your application: * require to use 'Run As Administrator' to run your application. - * or modify your application's manifect file to add + * or modify your application's manifest file to add \. + + Starting from Windows 10 version 1703 (Creators Update), after enabling + Developer Mode, users can create symbolic links without requiring the + Administrator privilege in the current process. Supply a 'True' flag in + addition to the target and link name to enable this behavior. -} module System.Win32.SymbolicLink - ( module System.Win32.SymbolicLink + ( SymbolicLinkFlags + , sYMBOLIC_LINK_FLAG_FILE + , sYMBOLIC_LINK_FLAG_DIRECTORY + , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + , createSymbolicLink + , createSymbolicLink' + , createSymbolicLinkFile + , createSymbolicLinkDirectory ) where +import System.Win32.SymbolicLink.Internal +import Data.Bits ((.|.)) import System.Win32.Types import System.Win32.File ( failIfFalseWithRetry_ ) ##include "windows_cconv.h" -type SymbolicLinkFlags = DWORD -#{enum SymbolicLinkFlags, - , sYMBOLIC_LINK_FLAG_FILE = 0x0 - , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 -} - -- | createSymbolicLink* functions don't check that file is exist or not. -- -- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix, -- except 'createSymbolicLink''. --- +-- -- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead. createSymbolicLink :: FilePath -- ^ Target file path -> FilePath -- ^ Symbolic link name -> SymbolicLinkFlags -> IO () createSymbolicLink = flip createSymbolicLink' -createSymbolicLinkFile :: FilePath -> FilePath -> IO () -createSymbolicLinkFile target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_FILE +createSymbolicLinkFile :: FilePath -- ^ Target file path + -> FilePath -- ^ Symbolic link name + -> Bool -- ^ Create the symbolic link with the unprivileged mode + -> IO () +createSymbolicLinkFile target link unprivileged = + createSymbolicLink' + link + target + ( if unprivileged + then sYMBOLIC_LINK_FLAG_FILE .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + else sYMBOLIC_LINK_FLAG_FILE + ) -createSymbolicLinkDirectory :: FilePath -> FilePath -> IO () -createSymbolicLinkDirectory target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_DIRECTORY +createSymbolicLinkDirectory :: FilePath -- ^ Target file path + -> FilePath -- ^ Symbolic link name + -> Bool -- ^ Create the symbolic link with the unprivileged mode + -> IO () +createSymbolicLinkDirectory target link unprivileged = + createSymbolicLink' + link + target + ( if unprivileged + then + sYMBOLIC_LINK_FLAG_DIRECTORY + .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + else sYMBOLIC_LINK_FLAG_DIRECTORY + ) createSymbolicLink' :: FilePath -- ^ Symbolic link name -> FilePath -- ^ Target file path @@ -59,5 +91,3 @@ failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $ c_CreateSymbolicLink c_link c_target flag -foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW" - c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL diff --git a/System/Win32/SymbolicLink/Internal.hsc b/System/Win32/SymbolicLink/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/SymbolicLink/Internal.hsc @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.SymbolicLink.Internal + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) +-} +module System.Win32.SymbolicLink.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +type SymbolicLinkFlags = DWORD + +#{enum SymbolicLinkFlags, + , sYMBOLIC_LINK_FLAG_FILE = 0x0 + , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 + , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2 +} + +foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW" + c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL diff --git a/System/Win32/Thread.hs b/System/Win32/Thread.hs --- a/System/Win32/Thread.hs +++ b/System/Win32/Thread.hs @@ -15,14 +15,10 @@ ( THANDLE, TID , getCurrentThread , suspendThread - , c_SuspendThread , resumeThread - , c_ResumeThread , withSuspendedThread , getThreadId - , c_GetThreadId , getCurrentThreadId - , c_GetCurrentThreadId ) where import System.Win32.DebugApi diff --git a/System/Win32/Time.hsc b/System/Win32/Time.hsc --- a/System/Win32/Time.hsc +++ b/System/Win32/Time.hsc @@ -16,153 +16,86 @@ -- A collection of FFI declarations for interfacing with Win32 Time API. -- ----------------------------------------------------------------------------- -module System.Win32.Time where +module System.Win32.Time + ( FILETIME(..) + , SYSTEMTIME(..) + , TIME_ZONE_INFORMATION(..) + , TimeZoneId(..) + , getSystemTime + , setSystemTime + , getSystemTimeAsFileTime + , getLocalTime + , setLocalTime + , getSystemTimeAdjustment + , getTickCount + , getLastInputInfo + , getIdleTime + , setSystemTimeAdjustment + , getTimeZoneInformation + , systemTimeToFileTime + , fileTimeToSystemTime + , getFileTime + , setFileTime + , invalidFileTime + , fileTimeToLocalFileTime + , localFileTimeToFileTime + , queryPerformanceFrequency + , queryPerformanceCounter + , GetTimeFormatFlags + , lOCALE_NOUSEROVERRIDE + , lOCALE_USE_CP_ACP + , tIME_NOMINUTESORSECONDS + , tIME_NOSECONDS + , tIME_NOTIMEMARKER + , tIME_FORCE24HOURFORMAT + , getTimeFormatEx + , getTimeFormat + ) where -import System.Win32.Types ( DWORD, WORD, LONG, BOOL, failIf, failIf_, HANDLE - , peekTStringLen, LCID, LPTSTR, LPCTSTR, DDWORD - , LARGE_INTEGER, ddwordToDwords, dwordsToDdword ) +import System.Win32.Time.Internal +import System.Win32.String ( peekTStringLen, withTString ) +import System.Win32.Types ( DWORD, HANDLE, LCID + , failIf + , failIfFalse_, failIf_ ) +import System.Win32.Utils ( trySized ) -import Control.Monad ( when, liftM3, liftM ) -import Data.Word ( Word8 ) -import Foreign ( Storable(sizeOf, alignment, peekByteOff, peek, - pokeByteOff, poke) - , Ptr, nullPtr, castPtr, plusPtr, advancePtr - , with, alloca, allocaBytes, copyArray ) -import Foreign.C ( CInt(..), CWchar(..) - , peekCWString, withCWStringLen, withCWString ) +import Control.Monad ( liftM3, liftM ) +import Foreign ( Storable(sizeOf, peek) + , Ptr, nullPtr, castPtr + , with, alloca, allocaBytes ) +import Foreign.C ( CWchar(..) + , withCWString ) import Foreign.Marshal.Utils (maybeWith) ##include "windows_cconv.h" #include #include "alignment.h" +#include "winnls_compat.h" ----------------------------------------------------------------- --- data types ----------------------------------------------------------------- -newtype FILETIME = FILETIME DDWORD deriving (Show, Eq, Ord) - -data SYSTEMTIME = SYSTEMTIME { - wYear, wMonth, wDayOfWeek, wDay, wHour, wMinute, wSecond, wMilliseconds :: WORD } - deriving (Show, Eq, Ord) - -data TIME_ZONE_INFORMATION = TIME_ZONE_INFORMATION - { tziBias :: LONG - , tziStandardName :: String - , tziStandardDate :: SYSTEMTIME - , tziStandardBias :: LONG - , tziDaylightName :: String - , tziDaylightDate :: SYSTEMTIME - , tziDaylightBias :: LONG - } deriving (Show,Eq,Ord) - -data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight - deriving (Show, Eq, Ord) - ----------------------------------------------------------------- --- Instances ----------------------------------------------------------------- - -instance Storable FILETIME where - sizeOf = const (#size FILETIME) - alignment _ = #alignment FILETIME - poke buf (FILETIME n) = do - (#poke FILETIME, dwLowDateTime) buf low - (#poke FILETIME, dwHighDateTime) buf hi - where (hi,low) = ddwordToDwords n - peek buf = do - low <- (#peek FILETIME, dwLowDateTime) buf - hi <- (#peek FILETIME, dwHighDateTime) buf - return $ FILETIME $ dwordsToDdword (hi,low) - -instance Storable SYSTEMTIME where - sizeOf _ = #size SYSTEMTIME - alignment _ = #alignment SYSTEMTIME - poke buf st = do - (#poke SYSTEMTIME, wYear) buf (wYear st) - (#poke SYSTEMTIME, wMonth) buf (wMonth st) - (#poke SYSTEMTIME, wDayOfWeek) buf (wDayOfWeek st) - (#poke SYSTEMTIME, wDay) buf (wDay st) - (#poke SYSTEMTIME, wHour) buf (wHour st) - (#poke SYSTEMTIME, wMinute) buf (wMinute st) - (#poke SYSTEMTIME, wSecond) buf (wSecond st) - (#poke SYSTEMTIME, wMilliseconds) buf (wMilliseconds st) - peek buf = do - year <- (#peek SYSTEMTIME, wYear) buf - month <- (#peek SYSTEMTIME, wMonth) buf - dow <- (#peek SYSTEMTIME, wDayOfWeek) buf - day <- (#peek SYSTEMTIME, wDay) buf - hour <- (#peek SYSTEMTIME, wHour) buf - mins <- (#peek SYSTEMTIME, wMinute) buf - sec <- (#peek SYSTEMTIME, wSecond) buf - ms <- (#peek SYSTEMTIME, wMilliseconds) buf - return $ SYSTEMTIME year month dow day hour mins sec ms - -instance Storable TIME_ZONE_INFORMATION where - sizeOf _ = (#size TIME_ZONE_INFORMATION) - alignment _ = #alignment TIME_ZONE_INFORMATION - poke buf tzi = do - (#poke TIME_ZONE_INFORMATION, Bias) buf (tziBias tzi) - (#poke TIME_ZONE_INFORMATION, StandardDate) buf (tziStandardDate tzi) - (#poke TIME_ZONE_INFORMATION, StandardBias) buf (tziStandardBias tzi) - (#poke TIME_ZONE_INFORMATION, DaylightDate) buf (tziDaylightDate tzi) - (#poke TIME_ZONE_INFORMATION, DaylightBias) buf (tziDaylightBias tzi) - write buf (#offset TIME_ZONE_INFORMATION, StandardName) (tziStandardName tzi) - write buf (#offset TIME_ZONE_INFORMATION, DaylightName) (tziDaylightName tzi) - where - write buf_ offset str = withCWStringLen str $ \(c_str,len) -> do - when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string." - let len' = len * sizeOf (undefined :: CWchar) - start = (advancePtr (castPtr buf_) offset) - end = advancePtr start len' - copyArray start (castPtr c_str :: Ptr Word8) len' - poke (castPtr end) (0 :: CWchar) - - peek buf = do - bias <- (#peek TIME_ZONE_INFORMATION, Bias) buf - sdat <- (#peek TIME_ZONE_INFORMATION, StandardDate) buf - sbia <- (#peek TIME_ZONE_INFORMATION, StandardBias) buf - ddat <- (#peek TIME_ZONE_INFORMATION, DaylightDate) buf - dbia <- (#peek TIME_ZONE_INFORMATION, DaylightBias) buf - snam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, StandardName)) - dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName)) - return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia - -foreign import WINDOWS_CCONV "windows.h GetSystemTime" - c_GetSystemTime :: Ptr SYSTEMTIME -> IO () getSystemTime :: IO SYSTEMTIME getSystemTime = alloca $ \res -> do c_GetSystemTime res peek res -foreign import WINDOWS_CCONV "windows.h SetSystemTime" - c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL setSystemTime :: SYSTEMTIME -> IO () setSystemTime st = with st $ \c_st -> failIf_ not "setSystemTime: SetSystemTime" $ c_SetSystemTime c_st -foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime" - c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () getSystemTimeAsFileTime :: IO FILETIME getSystemTimeAsFileTime = alloca $ \ret -> do c_GetSystemTimeAsFileTime ret peek ret -foreign import WINDOWS_CCONV "windows.h GetLocalTime" - c_GetLocalTime :: Ptr SYSTEMTIME -> IO () getLocalTime :: IO SYSTEMTIME getLocalTime = alloca $ \res -> do c_GetLocalTime res peek res -foreign import WINDOWS_CCONV "windows.h SetLocalTime" - c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL setLocalTime :: SYSTEMTIME -> IO () setLocalTime st = with st $ \c_st -> failIf_ not "setLocalTime: SetLocalTime" $ c_SetLocalTime c_st -foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment" - c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL getSystemTimeAdjustment :: IO (Maybe (Int, Int)) getSystemTimeAdjustment = alloca $ \ta -> alloca $ \ti -> alloca $ \enabled -> do failIf_ not "getSystemTimeAdjustment: GetSystemTimeAdjustment" $ @@ -175,10 +108,19 @@ return $ Just (fromIntegral ta', fromIntegral ti') else return Nothing -foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD +getLastInputInfo :: IO DWORD +getLastInputInfo = + with (LASTINPUTINFO 0) $ \lii_p -> do + failIfFalse_ "GetLastInputInfo" $ c_GetLastInputInfo lii_p + LASTINPUTINFO lii <- peek lii_p + return lii -foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment" - c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL +getIdleTime :: IO Integer +getIdleTime = do + lii <- getLastInputInfo + now <- getTickCount + return $ fromIntegral $ now - lii + setSystemTimeAdjustment :: Maybe Int -> IO () setSystemTimeAdjustment ta = failIf_ not "setSystemTimeAjustment: SetSystemTimeAdjustment" $ @@ -188,8 +130,6 @@ Nothing -> (0,True) Just x -> (fromIntegral x,False) -foreign import WINDOWS_CCONV "windows.h GetTimeZoneInformation" - c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD getTimeZoneInformation :: IO (TimeZoneId, TIME_ZONE_INFORMATION) getTimeZoneInformation = alloca $ \tzi -> do tz <- failIf (==(#const TIME_ZONE_ID_INVALID)) "getTimeZoneInformation: GetTimeZoneInformation" $ @@ -201,48 +141,43 @@ (#const TIME_ZONE_ID_DAYLIGHT) -> TzIdDaylight _ -> TzIdUnknown -- to remove warning -foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime" - c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL systemTimeToFileTime :: SYSTEMTIME -> IO FILETIME systemTimeToFileTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "systemTimeToFileTime: SystemTimeToFileTime" $ c_SystemTimeToFileTime c_s ret peek ret -foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime" - c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL fileTimeToSystemTime :: FILETIME -> IO SYSTEMTIME fileTimeToSystemTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "fileTimeToSystemTime: FileTimeToSystemTime" $ c_FileTimeToSystemTime c_s ret peek ret -foreign import WINDOWS_CCONV "windows.h GetFileTime" - c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL getFileTime :: HANDLE -> IO (FILETIME,FILETIME,FILETIME) getFileTime h = alloca $ \crt -> alloca $ \acc -> alloca $ \wrt -> do failIf_ not "getFileTime: GetFileTime" $ c_GetFileTime h crt acc wrt liftM3 (,,) (peek crt) (peek acc) (peek wrt) -foreign import WINDOWS_CCONV "windows.h SetFileTime" - c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL -setFileTime :: HANDLE -> FILETIME -> FILETIME -> FILETIME -> IO () -setFileTime h crt acc wrt = with crt $ - \c_crt -> with acc $ - \c_acc -> with wrt $ +invalidFileTime :: FILETIME +invalidFileTime = FILETIME 0 + +setFileTime :: HANDLE -> Maybe FILETIME -> Maybe FILETIME -> Maybe FILETIME -> IO () +setFileTime h crt acc wrt = withTime crt $ + \c_crt -> withTime acc $ + \c_acc -> withTime wrt $ \c_wrt -> do failIf_ not "setFileTime: SetFileTime" $ c_SetFileTime h c_crt c_acc c_wrt + where + withTime :: Maybe FILETIME -> (Ptr FILETIME -> IO a) -> IO a + withTime Nothing k = k nullPtr + withTime (Just t) k = with t k -foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime" - c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL fileTimeToLocalFileTime :: FILETIME -> IO FILETIME fileTimeToLocalFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "fileTimeToLocalFileTime: FileTimeToLocalFileTime" $ c_FileTimeToLocalFileTime c_ft res peek res -foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime" - c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL localFileTimeToFileTime :: FILETIME -> IO FILETIME localFileTimeToFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "localFileTimeToFileTime: LocalFileTimeToFileTime" @@ -278,34 +213,31 @@ peek res -} -foreign import WINDOWS_CCONV "windows.h QueryPerformanceFrequency" - c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL queryPerformanceFrequency :: IO Integer queryPerformanceFrequency = alloca $ \res -> do failIf_ not "queryPerformanceFrequency: QueryPerformanceFrequency" $ c_QueryPerformanceFrequency res liftM fromIntegral $ peek res -foreign import WINDOWS_CCONV "windows.h QueryPerformanceCounter" - c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL queryPerformanceCounter:: IO Integer queryPerformanceCounter= alloca $ \res -> do failIf_ not "queryPerformanceCounter: QueryPerformanceCounter" $ c_QueryPerformanceCounter res liftM fromIntegral $ peek res -type GetTimeFormatFlags = DWORD -#{enum GetTimeFormatFlags, - , lOCALE_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE - , lOCALE_USE_CP_ACP = LOCALE_USE_CP_ACP - , tIME_NOMINUTESORSECONDS = TIME_NOMINUTESORSECONDS - , tIME_NOSECONDS = TIME_NOSECONDS - , tIME_NOTIMEMARKER = TIME_NOTIMEMARKER - , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT - } -foreign import WINDOWS_CCONV "windows.h GetTimeFormatW" - c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt +getTimeFormatEx :: Maybe String + -> GetTimeFormatFlags + -> Maybe SYSTEMTIME + -> Maybe String + -> IO String +getTimeFormatEx locale flags st fmt = + maybeWith withTString locale $ \c_locale -> + maybeWith with st $ \c_st -> + maybeWith withTString fmt $ \c_fmt -> do + let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt + trySized "GetTimeFormatEx" c_func + getTimeFormat :: LCID -> GetTimeFormatFlags -> Maybe SYSTEMTIME -> Maybe String -> IO String getTimeFormat locale flags st fmt = maybeWith with st $ \c_st -> diff --git a/System/Win32/Time/Internal.hsc b/System/Win32/Time/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Time/Internal.hsc @@ -0,0 +1,245 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Time.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Time API. +-- +----------------------------------------------------------------------------- +module System.Win32.Time.Internal where + +import System.Win32.Types ( BOOL, DDWORD, DWORD, HANDLE, LARGE_INTEGER, LCID + , LONG, LPCTSTR, LPCWSTR, LPTSTR, LPWSTR, UINT, WORD + , dwordsToDdword, ddwordToDwords + ) +import Control.Monad ( when ) +import Data.Word ( Word8 ) +import Foreign ( Storable(sizeOf, alignment, peekByteOff, peek, + pokeByteOff, poke) + , Ptr, castPtr, plusPtr, advancePtr + , copyArray ) +import Foreign.C ( CInt(..), CWchar(..) + , peekCWString, withCWStringLen ) + +##include "windows_cconv.h" +#include +#include "alignment.h" +#include "winnls_compat.h" + +---------------------------------------------------------------- +-- data types +---------------------------------------------------------------- + +newtype FILETIME = FILETIME DDWORD deriving (Show, Eq, Ord) + +data SYSTEMTIME = SYSTEMTIME { + wYear, wMonth, wDayOfWeek, wDay, wHour, wMinute, wSecond, wMilliseconds :: WORD } + deriving (Show, Eq, Ord) + +data TIME_ZONE_INFORMATION = TIME_ZONE_INFORMATION + { tziBias :: LONG + , tziStandardName :: String + , tziStandardDate :: SYSTEMTIME + , tziStandardBias :: LONG + , tziDaylightName :: String + , tziDaylightDate :: SYSTEMTIME + , tziDaylightBias :: LONG + } deriving (Show,Eq,Ord) + +data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight + deriving (Show, Eq, Ord) + +data LASTINPUTINFO = LASTINPUTINFO DWORD deriving (Show) + +---------------------------------------------------------------- +-- Instances +---------------------------------------------------------------- + +instance Storable FILETIME where + sizeOf = const (#size FILETIME) + alignment _ = #alignment FILETIME + poke buf (FILETIME n) = do + (#poke FILETIME, dwLowDateTime) buf low + (#poke FILETIME, dwHighDateTime) buf hi + where (hi,low) = ddwordToDwords n + peek buf = do + low <- (#peek FILETIME, dwLowDateTime) buf + hi <- (#peek FILETIME, dwHighDateTime) buf + return $ FILETIME $ dwordsToDdword (hi,low) + +instance Storable SYSTEMTIME where + sizeOf _ = #size SYSTEMTIME + alignment _ = #alignment SYSTEMTIME + poke buf st = do + (#poke SYSTEMTIME, wYear) buf (wYear st) + (#poke SYSTEMTIME, wMonth) buf (wMonth st) + (#poke SYSTEMTIME, wDayOfWeek) buf (wDayOfWeek st) + (#poke SYSTEMTIME, wDay) buf (wDay st) + (#poke SYSTEMTIME, wHour) buf (wHour st) + (#poke SYSTEMTIME, wMinute) buf (wMinute st) + (#poke SYSTEMTIME, wSecond) buf (wSecond st) + (#poke SYSTEMTIME, wMilliseconds) buf (wMilliseconds st) + peek buf = do + year <- (#peek SYSTEMTIME, wYear) buf + month <- (#peek SYSTEMTIME, wMonth) buf + dow <- (#peek SYSTEMTIME, wDayOfWeek) buf + day <- (#peek SYSTEMTIME, wDay) buf + hour <- (#peek SYSTEMTIME, wHour) buf + mins <- (#peek SYSTEMTIME, wMinute) buf + sec <- (#peek SYSTEMTIME, wSecond) buf + ms <- (#peek SYSTEMTIME, wMilliseconds) buf + return $ SYSTEMTIME year month dow day hour mins sec ms + +instance Storable TIME_ZONE_INFORMATION where + sizeOf _ = (#size TIME_ZONE_INFORMATION) + alignment _ = #alignment TIME_ZONE_INFORMATION + poke buf tzi = do + (#poke TIME_ZONE_INFORMATION, Bias) buf (tziBias tzi) + (#poke TIME_ZONE_INFORMATION, StandardDate) buf (tziStandardDate tzi) + (#poke TIME_ZONE_INFORMATION, StandardBias) buf (tziStandardBias tzi) + (#poke TIME_ZONE_INFORMATION, DaylightDate) buf (tziDaylightDate tzi) + (#poke TIME_ZONE_INFORMATION, DaylightBias) buf (tziDaylightBias tzi) + write buf (#offset TIME_ZONE_INFORMATION, StandardName) (tziStandardName tzi) + write buf (#offset TIME_ZONE_INFORMATION, DaylightName) (tziDaylightName tzi) + where + write buf_ offset str = withCWStringLen str $ \(c_str,len) -> do + when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string." + let len' = len * sizeOf (undefined :: CWchar) + start = (advancePtr (castPtr buf_) offset) + end = advancePtr start len' + copyArray start (castPtr c_str :: Ptr Word8) len' + poke (castPtr end) (0 :: CWchar) + + peek buf = do + bias <- (#peek TIME_ZONE_INFORMATION, Bias) buf + sdat <- (#peek TIME_ZONE_INFORMATION, StandardDate) buf + sbia <- (#peek TIME_ZONE_INFORMATION, StandardBias) buf + ddat <- (#peek TIME_ZONE_INFORMATION, DaylightDate) buf + dbia <- (#peek TIME_ZONE_INFORMATION, DaylightBias) buf + snam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, StandardName)) + dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName)) + return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia + +instance Storable LASTINPUTINFO where + sizeOf = const (#size LASTINPUTINFO) + alignment = sizeOf + poke buf (LASTINPUTINFO t) = do + (#poke LASTINPUTINFO, cbSize) buf ((#size LASTINPUTINFO) :: UINT) + (#poke LASTINPUTINFO, dwTime) buf t + peek buf = do + t <- (#peek LASTINPUTINFO, dwTime) buf + return $ LASTINPUTINFO t + +foreign import WINDOWS_CCONV "windows.h GetSystemTime" + c_GetSystemTime :: Ptr SYSTEMTIME -> IO () + +foreign import WINDOWS_CCONV "windows.h SetSystemTime" + c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime" + c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () + +foreign import WINDOWS_CCONV "windows.h GetLocalTime" + c_GetLocalTime :: Ptr SYSTEMTIME -> IO () + +foreign import WINDOWS_CCONV "windows.h SetLocalTime" + c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment" + c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD + +foreign import WINDOWS_CCONV unsafe "windows.h GetLastInputInfo" + c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool + +foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment" + c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetTimeZoneInformation" + c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime" + c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime" + c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetFileTime" + c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetFileTime" + c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime" + c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime" + c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +{- +-- Windows XP SP1 +foreign import WINDOWS_CCONV "windows.h GetSystemTimes" + c_GetSystemTimes :: Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL +getSystemTimes :: IO (FILETIME,FILETIME,FILETIME) +getSystemTimes = alloca $ \idle -> alloca $ \kernel -> alloca $ \user -> do + failIf not "getSystemTimes: GetSystemTimes" $ c_GetSystemTimes idle kernel user + liftM3 (,,) (peek idle) (peek kernel) (peek user) +-} + +{- +-- Windows XP +foreign import WINDOWS_CCONV "windows.h SystemTimeToTzSpecificLocalTime" + c_SystemTimeToTzSpecificLocalTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL +systemTimeToTzSpecificLocalTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME +systemTimeToTzSpecificLocalTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do + failIf not "systemTimeToTzSpecificLocalTime: SystemTimeToTzSpecificLocalTime" $ + c_SystemTimeToTzSpecificLocalTime tzi st res + peek res + +foreign import WINDOWS_CCONV "windows.h TzSpecificLocalTimeToSystemTime" + c_TzSpecificLocalTimeToSystemTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL +tzSpecificLocalTimeToSystemTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME +tzSpecificLocalTimeToSystemTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do + failIf not "tzSpecificLocalTimeToSystemTime: TzSpecificLocalTimeToSystemTime" $ + c_TzSpecificLocalTimeToSystemTime tzi st res + peek res +-} + +foreign import WINDOWS_CCONV "windows.h QueryPerformanceFrequency" + c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h QueryPerformanceCounter" + c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL + +type GetTimeFormatFlags = DWORD +#{enum GetTimeFormatFlags, + , lOCALE_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE + , lOCALE_USE_CP_ACP = LOCALE_USE_CP_ACP + , tIME_NOMINUTESORSECONDS = TIME_NOMINUTESORSECONDS + , tIME_NOSECONDS = TIME_NOSECONDS + , tIME_NOTIMEMARKER = TIME_NOTIMEMARKER + , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT + } + +foreign import WINDOWS_CCONV "windows.h GetTimeFormatEx" + c_GetTimeFormatEx :: LPCWSTR + -> GetTimeFormatFlags + -> Ptr SYSTEMTIME + -> LPCWSTR + -> LPWSTR + -> CInt + -> IO CInt + +foreign import WINDOWS_CCONV "windows.h GetTimeFormatW" + c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt 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__(..)) @@ -56,6 +57,21 @@ finiteBitSize = bitSize #endif +##if defined(__IO_MANAGER_WINIO__) +import Control.Monad (when, liftM2) +import Foreign.C.Types (CUIntPtr(..)) +import Foreign.Marshal.Utils (fromBool, with) +import Foreign (peek) +import Foreign.Ptr (ptrToWordPtr) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows +import GHC.IO.IOMode +import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle(), ConsoleHandle(), + toHANDLE, handleToMode, optimizeFileAccess) +import qualified GHC.Event.Windows as Mgr +import GHC.IO.Device (IODeviceType(..), devType) +##endif + #include #include ##include "windows_cconv.h" @@ -164,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 @@ -172,6 +189,7 @@ -- UTF-16 version: type TCHAR = CWchar withTString = withCWString +withFilePath path = useAsCWStringSafe path withTStringLen = withCWStringLen peekTString = peekCWString peekTStringLen = peekCWStringLen @@ -186,6 +204,25 @@ newTString = newCString -} +-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are +-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660 +useAsCWStringSafe :: FilePath -> (CWString -> IO a) -> IO a +useAsCWStringSafe path f = + if '\NUL' `elem` path + then ioError err + else withCWString path f + where + err = + IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "useAsCWStringSafe" + , ioe_description = "Windows filepaths must not contain internal NUL codepoints." + , ioe_errno = Nothing + , ioe_filename = Just path + } + + ---------------------------------------------------------------- -- Handles ---------------------------------------------------------------- @@ -222,6 +259,9 @@ iNVALID_HANDLE_VALUE :: HANDLE iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound +iNVALID_SET_FILE_POINTER :: DWORD +iNVALID_SET_FILE_POINTER = #const INVALID_SET_FILE_POINTER + foreign import ccall "_open_osfhandle" _open_osfhandle :: CIntPtr -> CInt -> IO CInt @@ -241,9 +281,63 @@ -- Then although you can use @stdout2@ to write to standard output, it is not -- the case that @'IO.stdout' == stdout2@. hANDLEToHandle :: HANDLE -> IO Handle -hANDLEToHandle handle = - _open_osfhandle (fromIntegral (ptrToIntPtr handle)) (#const _O_BINARY) >>= fdToHandle +hANDLEToHandle handle = posix +##if defined(__IO_MANAGER_WINIO__) + native +##endif + where +##if defined(__IO_MANAGER_WINIO__) + native = do + -- Attach the handle to the I/O manager's CompletionPort. This allows the + -- I/O manager to service requests for this Handle. + Mgr.associateHandle' handle + let hwnd = fromHANDLE handle :: Io NativeHandle + _type <- devType hwnd + -- Use the rts to enforce any file locking we may need. + mode <- handleToMode handle + let write_lock = mode /= ReadMode + + case _type of + -- Regular files need to be locked. + -- See also Note [RTS File locking] + RegularFile -> do + optimizeFileAccess handle -- Set a few optimization flags on file handles. + (unique_dev, unique_ino) <- getUniqueFileInfo handle + r <- internal_lockFile + (fromIntegral $ ptrToWordPtr handle) unique_dev unique_ino + (fromBool write_lock) + when (r == -1) $ + ioException (IOError Nothing ResourceBusy "hANDLEToHandle" + "file is locked" Nothing Nothing) + + -- I don't see a reason for blocking directories. So unlike the FD + -- implementation I'll allow it. + _ -> return () + mkHandleFromHANDLE hwnd Stream ("hwnd:" ++ show handle) mode Nothing + + -- | getUniqueFileInfo assumes the C call to getUniqueFileInfo + -- succeeds. + getUniqueFileInfo :: HANDLE -> IO (Word64, Word64) + getUniqueFileInfo hnl = do + with 0 $ \devptr -> do + with 0 $ \inoptr -> do + internal_getUniqueFileInfo hnl devptr inoptr + liftM2 (,) (peek devptr) (peek inoptr) +##endif + posix = _open_osfhandle (fromIntegral (ptrToIntPtr handle)) + (#const _O_BINARY) >>= fdToHandle + +##if defined(__IO_MANAGER_WINIO__) +foreign import ccall unsafe "lockFile" + internal_lockFile :: CUIntPtr -> Word64 -> Word64 -> CInt -> IO CInt + +-- | Returns -1 on error. Otherwise writes two values representing +-- the file into the given ptrs. +foreign import ccall unsafe "get_unique_file_info_hwnd" + internal_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO () +##endif + foreign import ccall unsafe "_get_osfhandle" c_get_osfhandle :: CInt -> IO HANDLE @@ -252,7 +346,15 @@ -- Originally authored by Max Bolingbroke in the ansi-terminal library withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a -withHandleToHANDLE haskell_handle action = +##if defined(__IO_MANAGER_WINIO__) +withHandleToHANDLE = withHandleToHANDLEPosix withHandleToHANDLENative +##else +withHandleToHANDLE = withHandleToHANDLEPosix +##endif + +##if defined(__IO_MANAGER_WINIO__) +withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLENative haskell_handle action = -- Create a stable pointer to the Handle. This prevents the garbage collector -- getting to it while we are doing horrible manipulations with it, and hence -- stops it being finalized (and closed). @@ -261,6 +363,36 @@ let write_handle_mvar = case haskell_handle of FileHandle _ handle_mvar -> handle_mvar DuplexHandle _ _ handle_mvar -> handle_mvar + + -- This is "write" MVar, we could also take the "read" one + windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE + + -- Do what the user originally wanted + action windows_handle + where + -- | Turn an existing Handle into a Win32 HANDLE. This function throws an + -- IOError if the Handle does not reference a HANDLE + handle_ToHANDLE :: Handle__ -> IO HANDLE + handle_ToHANDLE (Handle__{haDevice = dev}) = + case (cast dev :: Maybe (Io NativeHandle), cast dev :: Maybe (Io ConsoleHandle)) of + (Just hwnd, Nothing) -> return $ toHANDLE hwnd + (Nothing, Just hwnd) -> return $ toHANDLE hwnd + _ -> throwErr "not a known HANDLE" + + throwErr msg = ioException $ IOError (Just haskell_handle) + InappropriateType "withHandleToHANDLENative" msg Nothing Nothing +##endif + +withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLEPosix haskell_handle action = + -- Create a stable pointer to the Handle. This prevents the garbage collector + -- getting to it while we are doing horrible manipulations with it, and hence + -- stops it being finalized (and closed). + withStablePtr haskell_handle $ const $ do + -- Grab the write handle variable from the Handle + let write_handle_mvar = case haskell_handle of + FileHandle _ handle_mvar -> handle_mvar + DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one -- Get the FD from the algebraic data type @@ -269,7 +401,6 @@ -- Finally, turn that (C-land) FD into a HANDLE using msvcrt windows_handle <- c_get_osfhandle fd - -- Do what the user originally wanted action windows_handle @@ -325,6 +456,8 @@ eRROR_PROC_NOT_FOUND :: ErrCode eRROR_PROC_NOT_FOUND = #const ERROR_PROC_NOT_FOUND +eERROR_ENVVAR_NOT_FOUND :: ErrCode +eERROR_ENVVAR_NOT_FOUND = #const ERROR_ENVVAR_NOT_FOUND errorWin :: String -> IO a errorWin fn_name = do diff --git a/System/Win32/Utils.hs b/System/Win32/Utils.hs --- a/System/Win32/Utils.hs +++ b/System/Win32/Utils.hs @@ -10,24 +10,34 @@ Utilities for calling Win32 API -} module System.Win32.Utils - ( try, tryWithoutNull, try' + ( try, tryWithoutNull, trySized, try' -- * Maybe values , maybePtr, ptrToMaybe, maybeNum, numToMaybe , peekMaybe, withMaybe + -- * Format picture translation + , fromDateFormatPicture + , fromTimeFormatPicture ) where + import Control.Monad ( unless ) +import Foreign.C.Types ( CInt ) import Foreign.Marshal.Array ( allocaArray, peekArray ) import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( Ptr, nullPtr ) import Foreign.Storable ( Storable(..) ) -import System.Win32.Types ( failIfZero - , failWith, getLastError, eRROR_INSUFFICIENT_BUFFER ) +import Text.ParserCombinators.ReadP ( ReadP, (<++), between, char, count + , readP_to_S, satisfy ) + + +import System.Win32.String ( LPTSTR, peekTString, peekTStringLen + , withTStringBufferLen ) +import System.Win32.Types ( BOOL, UINT, eRROR_INSUFFICIENT_BUFFER + , failIfZero, failWith, getLastError + , maybeNum, maybePtr, numToMaybe + , ptrToMaybe ) import qualified System.Win32.Types ( try ) -import System.Win32.String ( LPTSTR, peekTString ) -import System.Win32.Types ( BOOL, UINT, maybePtr, ptrToMaybe, maybeNum, numToMaybe ) import System.Win32.Word ( DWORD, PDWORD ) - -- | Support for API calls that are passed a fixed-size buffer and tell -- you via the return value if the buffer was too small. In that -- case, we extend the buffer size and try again. @@ -39,7 +49,7 @@ tryWithoutNull loc f n = do e <- allocaArray (fromIntegral n) $ \lptstr -> do r <- failIfZero loc $ f lptstr n - if (r > n) then return (Left r) else do + if r > n then return (Left r) else do str <- peekTString lptstr return (Right str) case e of @@ -56,16 +66,28 @@ unless (err_code == eRROR_INSUFFICIENT_BUFFER) $ failWith loc err_code r <- peek n' - if (r > n) then return (Left r) else do + if r > n then return (Left r) else do str <- peekArray (fromIntegral r) lptstr return (Right str) case e of Left r' -> try' loc f r' Right str -> return str +-- | Support for API calls that return the required size, in characters +-- including a null character, of the buffer when passed a buffer size of zero. +trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO String +trySized wh f = do + c_len <- failIfZero wh $ f nullPtr 0 + let len = fromIntegral c_len + withTStringBufferLen len $ \(buf', len') -> do + let c_len' = fromIntegral len' + c_len'' <- failIfZero wh $ f buf' c_len' + let len'' = fromIntegral c_len'' + peekTStringLen (buf', len'' - 1) -- Drop final null character + -- | See also: 'Foreign.Marshal.Utils.maybePeek' function. peekMaybe :: Storable a => Ptr a -> IO (Maybe a) -peekMaybe p = +peekMaybe p = if p == nullPtr then return Nothing else Just `fmap` peek p @@ -74,3 +96,315 @@ withMaybe :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b withMaybe Nothing action = action nullPtr withMaybe (Just x) action = with x action + +-- | Type representing components of a Windows API day, month, year and era +-- format picture. +data DateFormatPicture + = Day + | Day0 -- Padded with zeros + | DayShort + | DayLong + | Month + | Month0 -- Padded with zeros + | MonthShort + | MonthLong + | YearVeryShort -- Year represented only by the last digit + | YearShort + | Year + | Era + | DateOther String + deriving (Eq, Show) + +fromDFP :: DateFormatPicture -> String +fromDFP Day = "%-e" -- No padding +fromDFP Day0 = "%d" -- Padded with zeros +fromDFP DayShort = "%a" -- eg Tue +fromDFP DayLong = "%A" -- eg Tuesday +fromDFP Month = "%-m" -- No padding +fromDFP Month0 = "%m" -- Padded with zeros +fromDFP MonthShort = "%b" -- eg Jan +fromDFP MonthLong = "%B" -- eg January +fromDFP YearVeryShort = "%-y" -- No direct equivalent of a one digit year, so + -- do not distinguish from a short year without + -- padding +fromDFP YearShort = "%y" +fromDFP Year = "%Y" +fromDFP Era = "" -- No equivalent +fromDFP (DateOther cs) = escape cs + +escape :: String -> String +escape [] = [] +escape (c:cs) = escape' c ++ escape cs + where + escape' '%' = "%%" + escape' '\t' = "%t" + escape' '\n' = "%n" + escape' c' = [c'] + +d :: ReadP Char +d = char 'd' + +day :: ReadP DateFormatPicture +day = do + _ <- d + return Day + +day0 :: ReadP DateFormatPicture +day0 = do + _ <- count 2 d + return Day0 + +dayShort :: ReadP DateFormatPicture +dayShort = do + _ <- count 3 d + return DayShort + +dayLong :: ReadP DateFormatPicture +dayLong = do + _ <- count 4 d + return DayLong + +days :: ReadP DateFormatPicture +days = dayLong <++ dayShort <++ day0 <++ day + +bigM :: ReadP Char +bigM = char 'M' + +month :: ReadP DateFormatPicture +month = do + _ <- bigM + return Month + +month0 :: ReadP DateFormatPicture +month0 = do + _ <- count 2 bigM + return Month0 + +monthShort :: ReadP DateFormatPicture +monthShort = do + _ <- count 3 bigM + return MonthShort + +monthLong :: ReadP DateFormatPicture +monthLong = do + _ <- count 4 bigM + return MonthLong + +months :: ReadP DateFormatPicture +months = monthLong <++ monthShort <++ month0 <++ month + +y :: ReadP Char +y = char 'y' + +yearVeryShort :: ReadP DateFormatPicture +yearVeryShort = do + _ <- y + return YearVeryShort + +yearShort :: ReadP DateFormatPicture +yearShort = do + _ <- count 2 y + return YearShort + +year :: ReadP DateFormatPicture +year = do + _ <- count 5 y <++ count 4 y + return Year + +years :: ReadP DateFormatPicture +years = year <++ yearShort <++ yearVeryShort + +g :: ReadP Char +g = char 'g' + +era :: ReadP DateFormatPicture +era = do + _ <- count 2 g <++ count 1 g + return Era + +quote :: ReadP Char +quote = char '\'' + +notQuote :: ReadP Char +notQuote = satisfy (/= '\'') + +escQuote :: ReadP Char +escQuote = do + _ <- count 2 quote + return '\'' + +quotedChars :: ReadP String +quotedChars = between quote quote $ greedy (escQuote <++ notQuote) + +-- | Although not documented at +-- https://docs.microsoft.com/en-us/windows/win32/intl/day--month--year--and-era-format-pictures +-- the format pictures used by Windows do not require all such characters to be +-- enclosed in single quotation marks. +nonDateSpecial :: ReadP Char +nonDateSpecial = satisfy (\c -> c `notElem` ['d', 'M', 'y', 'g', '\'']) + +nonDateSpecials :: ReadP String +nonDateSpecials = greedy1 nonDateSpecial + +dateOther :: ReadP DateFormatPicture +dateOther = do + chars <- greedy1 (nonDateSpecials <++ quotedChars) + return $ DateOther $ concat chars + +datePicture :: ReadP [DateFormatPicture] +datePicture = greedy (days <++ months <++ years <++ era <++ dateOther) + +-- | Type representing components of a Windows API hours, minute, and second +-- format picture. +data TimeFormatPicture + = Hours12 + | Hours012 -- Padded with zeros + | Hours24 + | Hours024 -- Padded with zeros + | Minutes + | Minutes0 -- Padded with zeros + | Seconds + | Seconds0 -- Padded with zeros + | TimeMarkerShort -- One-character time marker string, eg "A" and "P" + | TimeMarker -- Multi-character time marker string, eg "AM" and "PM" + | TimeOther String + deriving (Eq, Show) + +fromTFP :: TimeFormatPicture -> String +fromTFP Hours12 = "%-l" -- No padding +fromTFP Hours012 = "%I" -- Padded with zeros +fromTFP Hours24 = "%-k" -- No padding +fromTFP Hours024 = "%H" -- Padded with zeros +fromTFP Minutes = "%-M" -- No padding +fromTFP Minutes0 = "%M" -- Padded with zeros +fromTFP Seconds = "%-S" -- No padding +fromTFP Seconds0 = "%S" -- Padded with zeros +fromTFP TimeMarkerShort = "%p" -- No direct equivalent, so do not distinguish + -- from TimeMarker +fromTFP TimeMarker = "%p" +fromTFP (TimeOther cs) = escape cs + +h :: ReadP Char +h = char 'h' + +hours12 :: ReadP TimeFormatPicture +hours12 = do + _ <- h + return Hours12 + +hours012 :: ReadP TimeFormatPicture +hours012 = do + _ <- count 2 h + return Hours012 + +bigH :: ReadP Char +bigH = char 'H' + +hours24 :: ReadP TimeFormatPicture +hours24 = do + _ <- bigH + return Hours24 + +hours024 :: ReadP TimeFormatPicture +hours024 = do + _ <- count 2 bigH + return Hours024 + +hours :: ReadP TimeFormatPicture +hours = hours012 <++ hours12 <++ hours024 <++ hours24 + +m :: ReadP Char +m = char 'm' + +minute :: ReadP TimeFormatPicture +minute = do + _ <- m + return Minutes + +minute0 :: ReadP TimeFormatPicture +minute0 = do + _ <- count 2 m + return Minutes0 + +minutes :: ReadP TimeFormatPicture +minutes = minute0 <++ minute + +s :: ReadP Char +s = char 's' + +second :: ReadP TimeFormatPicture +second = do + _ <- s + return Seconds + +second0 :: ReadP TimeFormatPicture +second0 = do + _ <- count 2 s + return Seconds0 + +seconds :: ReadP TimeFormatPicture +seconds = second0 <++ second + +t :: ReadP Char +t = char 't' + +timeMarkerShort :: ReadP TimeFormatPicture +timeMarkerShort = do + _ <- t + return TimeMarkerShort + +timeMarker :: ReadP TimeFormatPicture +timeMarker = do + _ <- count 2 t + return TimeMarker + +timeMarkers :: ReadP TimeFormatPicture +timeMarkers = timeMarker <++ timeMarkerShort + +-- | Although not documented at +-- https://docs.microsoft.com/en-us/windows/win32/intl/hour--minute--and-second-format-pictures +-- the format pictures used by Windows do not require all such characters to be +-- enclosed in single quotation marks. +nonTimeSpecial :: ReadP Char +nonTimeSpecial = satisfy (\c -> c `notElem` ['h', 'H', 'm', 's', 't', '\'']) + +nonTimeSpecials :: ReadP String +nonTimeSpecials = greedy1 nonTimeSpecial + +timeOther :: ReadP TimeFormatPicture +timeOther = do + chars <- greedy1 (nonTimeSpecials <++ quotedChars) + return $ TimeOther $ concat chars + +timePicture :: ReadP [TimeFormatPicture] +timePicture = greedy (hours <++ minutes <++ seconds <++ timeMarkers <++ + timeOther) + +greedy :: ReadP a -> ReadP [a] +greedy p = greedy1 p <++ return [] + +greedy1 :: ReadP a -> ReadP [a] +greedy1 p = do + first <- p + rest <- greedy p + return (first : rest) + +parseMaybe :: ReadP a -> String -> Maybe a +parseMaybe parser input = + case readP_to_S parser input of + [] -> Nothing + ((result, _):_) -> Just result + +-- | Translate from a Windows API day, month, year, and era format picture to +-- the closest corresponding format string used by +-- 'Data.Time.Format.formatTime'. +fromDateFormatPicture :: String -> Maybe String +fromDateFormatPicture dfp = + fmap (concatMap fromDFP) $ parseMaybe datePicture dfp + +-- | Translate from a Windows API hours, minute, and second format picture to +-- the closest corresponding format string used by +-- 'Data.Time.Format.formatTime'. +fromTimeFormatPicture :: String -> Maybe String +fromTimeFormatPicture tfp = + fmap (concatMap fromTFP) $ parseMaybe timePicture tfp diff --git a/System/Win32/WindowsString/Console.hsc b/System/Win32/WindowsString/Console.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Console.hsc @@ -0,0 +1,180 @@ +{-# LANGUAGE PackageImports #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.Console +-- Copyright : (c) University of Glasgow 2023 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Console API (WindowsString variant) +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Console ( + -- * Console mode + getConsoleMode, + setConsoleMode, + eNABLE_ECHO_INPUT, + eNABLE_EXTENDED_FLAGS, + eNABLE_INSERT_MODE, + eNABLE_LINE_INPUT, + eNABLE_MOUSE_INPUT, + eNABLE_PROCESSED_INPUT, + eNABLE_QUICK_EDIT_MODE, + eNABLE_WINDOW_INPUT, + eNABLE_VIRTUAL_TERMINAL_INPUT, + eNABLE_PROCESSED_OUTPUT, + eNABLE_WRAP_AT_EOL_OUTPUT, + eNABLE_VIRTUAL_TERMINAL_PROCESSING, + dISABLE_NEWLINE_AUTO_RETURN, + eNABLE_LVB_GRID_WORLDWIDE, + -- * Console code pages + getConsoleCP, + setConsoleCP, + getConsoleOutputCP, + setConsoleOutputCP, + -- * Ctrl events + CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT, + generateConsoleCtrlEvent, + -- * Command line + commandLineToArgv, + getCommandLineW, + getArgs, + -- * Screen buffer + CONSOLE_SCREEN_BUFFER_INFO(..), + CONSOLE_SCREEN_BUFFER_INFOEX(..), + COORD(..), + SMALL_RECT(..), + COLORREF, + getConsoleScreenBufferInfo, + getCurrentConsoleScreenBufferInfo, + getConsoleScreenBufferInfoEx, + getCurrentConsoleScreenBufferInfoEx, + + -- * Env + getEnv, + getEnvironment + ) where + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "wincon_compat.h" + +import System.Win32.WindowsString.Types +import System.Win32.WindowsString.String (withTStringBufferLen) +import System.Win32.Console.Internal +import System.Win32.Console hiding (getArgs, commandLineToArgv, getEnv, getEnvironment) +import System.OsString.Windows +import System.OsString.Internal.Types + +import Foreign.C.Types (CWchar) +import Foreign.C.String (CWString) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, peekArray0) +import Foreign.Marshal.Alloc (alloca) +import GHC.IO (bracket) +import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) + +import Prelude hiding (break, length, tail) +import qualified Prelude as P + +#if !MIN_VERSION_filepath(1,5,0) +import Data.Coerce +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC + +tail :: WindowsString -> WindowsString +tail = coerce BC.tail + +break :: (WindowsChar -> Bool) -> WindowsString -> (WindowsString, WindowsString) +break = coerce BC.break +#endif + + +-- | This function can be used to parse command line arguments and return +-- the split up arguments as elements in a list. +commandLineToArgv :: WindowsString -> IO [WindowsString] +commandLineToArgv arg + | arg == mempty = return [] + | otherwise = withTString arg $ \c_arg -> do + alloca $ \c_size -> do + res <- c_CommandLineToArgvW c_arg c_size + size <- peek c_size + args <- peekArray (fromIntegral size) res + _ <- localFree res + mapM peekTString args + +-- | Based on 'GetCommandLineW'. This behaves slightly different +-- than 'System.Environment.getArgs'. See the online documentation: +-- +getArgs :: IO [WindowsString] +getArgs = do + getCommandLineW >>= peekTString >>= commandLineToArgv + + +-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD +getEnv :: WindowsString -> IO (Maybe WindowsString) +getEnv name = + withTString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- c_GetEnvironmentVariableW c_name buf c_len + case c_len' of + 0 -> do + err_code <- getLastError + if err_code == eERROR_ENVVAR_NOT_FOUND + then return Nothing + else errorWin "GetEnvironmentVariableW" + _ | c_len' > fromIntegral maxLength -> + -- shouldn't happen, because we provide maxLength + ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) + | otherwise -> do + let len' = fromIntegral c_len' + Just <$> peekTStringLen (buf, len') + where + -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew + -- max characters (wide chars): 32767 + -- => bytes = 32767 * 2 = 65534 + -- +1 byte for NUL (although not needed I think) + maxLength :: Int + maxLength = 65535 + + +getEnvironment :: IO [(WindowsString, WindowsString)] +getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do + strs <- builder lpwstr + return (divvy <$> strs) + where + divvy :: WindowsString -> (WindowsString, WindowsString) + divvy str = + case break (== unsafeFromChar '=') str of + (xs,ys) + | ys == mempty -> (xs,ys) -- don't barf (like Posix.getEnvironment) + (name, ys) -> let value = tail ys in (name,value) + + builder :: LPWSTR -> IO [WindowsString] + builder ptr = go 0 + where + go :: Int -> IO [WindowsString] + go off = do + (str, l) <- peekCWStringOff ptr off + if l == 0 + then pure [] + else (str:) <$> go (((l + 1) * 2) + off) + + +peekCWStringOff :: CWString -> Int -> IO (WindowsString, Int) +peekCWStringOff cp off = do + cs <- peekArray0 wNUL (cp `plusPtr` off) + return (cWcharsToChars cs, P.length cs) + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> WindowsString +cWcharsToChars = pack . fmap (WindowsChar . fromIntegral) + diff --git a/System/Win32/WindowsString/DLL.hsc b/System/Win32/WindowsString/DLL.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/DLL.hsc @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.DLL +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.DLL + ( module System.Win32.WindowsString.DLL + , module System.Win32.DLL + ) where + +import System.Win32.DLL hiding + ( disableThreadLibraryCalls + , freeLibrary + , getModuleFileName + , getModuleHandle + , getProcAddress + , loadLibrary + , loadLibraryEx + , setDllDirectory + , lOAD_LIBRARY_AS_DATAFILE + , lOAD_WITH_ALTERED_SEARCH_PATH + ) +import System.Win32.DLL.Internal +import System.Win32.WindowsString.Types + +import Foreign +import Data.Maybe (fromMaybe) +import System.OsString.Windows +import GHC.IO.Encoding.UTF16 ( mkUTF16le ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) + +getModuleFileName :: HMODULE -> IO WindowsString +getModuleFileName hmod = + allocaArray 512 $ \ c_str -> do + failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512 + peekTString c_str + +getModuleHandle :: Maybe WindowsString -> IO HMODULE +getModuleHandle mb_name = + maybeWith withTString mb_name $ \ c_name -> + failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name + +loadLibrary :: WindowsString -> IO HMODULE +loadLibrary name = + withTString name $ \ c_name -> + failIfNull "LoadLibrary" $ c_LoadLibrary c_name + +loadLibraryEx :: WindowsString -> HANDLE -> LoadLibraryFlags -> IO HMODULE +loadLibraryEx name h flags = + withTString name $ \ c_name -> + failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags + +setDllDirectory :: Maybe WindowsString -> IO () +setDllDirectory name = + maybeWith withTString name $ \ c_name -> do + let nameS = name >>= either (const Nothing) Just . decodeWith (mkUTF16le TransliterateCodingFailure) + failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" nameS]) $ c_SetDllDirectory c_name + diff --git a/System/Win32/WindowsString/DebugApi.hsc b/System/Win32/WindowsString/DebugApi.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/DebugApi.hsc @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.DebugApi +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for using Windows DebugApi. +-- +----------------------------------------------------------------------------- +module System.Win32.WindowsString.DebugApi + ( module System.Win32.WindowsString.DebugApi + , module System.Win32.DebugApi + ) where + +import System.Win32.DebugApi.Internal +import System.Win32.DebugApi hiding (outputDebugString) +import System.Win32.WindowsString.Types ( withTString ) +import System.OsString.Windows + +##include "windows_cconv.h" +#include "windows.h" + + +-------------------------------------------------------------------------- +-- On process being debugged + +outputDebugString :: WindowsString -> IO () +outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s + diff --git a/System/Win32/WindowsString/File.hsc b/System/Win32/WindowsString/File.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/File.hsc @@ -0,0 +1,269 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.File +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.File + ( deleteFile + , copyFile + , moveFile + , moveFileEx + , setCurrentDirectory + , createDirectory + , createDirectoryEx + , removeDirectory + , getBinaryType + , createFile + , setFileAttributes + , getFileAttributes + , getFileAttributesExStandard + , getTempFileName + , findFirstChangeNotification + , getFindDataFileName + , findFirstFile + , defineDosDevice + , getDiskFreeSpace + , setVolumeLabel + , getFileExInfoStandard + , getFileExMaxInfoLevel + , replaceFile + , module System.Win32.File + ) where + +import System.Win32.File.Internal +import System.Win32.File hiding ( + deleteFile + , copyFile + , moveFile + , moveFileEx + , setCurrentDirectory + , createDirectory + , createDirectoryEx + , removeDirectory + , getBinaryType + , createFile + , setFileAttributes + , getFileAttributes + , getFileAttributesExStandard + , getTempFileName + , findFirstChangeNotification + , getFindDataFileName + , findFirstFile + , defineDosDevice + , getDiskFreeSpace + , setVolumeLabel + , getFileExInfoStandard + , getFileExMaxInfoLevel + , replaceFile + ) +import System.Win32.WindowsString.Types +import System.OsString.Windows +import Unsafe.Coerce (unsafeCoerce) +import Data.Maybe (fromMaybe) + +import Foreign hiding (void) + +##include "windows_cconv.h" + +#include +#include "alignment.h" + +deleteFile :: WindowsString -> IO () +deleteFile name = + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $ + c_DeleteFile c_name + +copyFile :: WindowsString -> WindowsString -> Bool -> IO () +copyFile src dest over = + 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 = + 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 = + 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 = + withFilePath name $ \ c_name -> + failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $ + c_SetCurrentDirectory c_name + +createDirectory :: WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO () +createDirectory name mb_attr = + 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 = + 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 = + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $ + c_RemoveDirectory c_name + +getBinaryType :: WindowsString -> IO BinaryType +getBinaryType name = + withFilePath name $ \ c_name -> + alloca $ \ p_btype -> do + failIfFalse_ (unwords ["GetBinaryType",show name]) $ + c_GetBinaryType c_name p_btype + peek p_btype + +---------------------------------------------------------------- +-- HANDLE operations +---------------------------------------------------------------- + +createFile :: WindowsString -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE +createFile name access share mb_attr mode flag mb_h = + 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 = + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["SetFileAttributes",show name]) + $ c_SetFileAttributes c_name attr + +getFileAttributes :: WindowsString -> IO FileAttributeOrFlag +getFileAttributes 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 + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ "getFileAttributesExStandard" $ + c_GetFileAttributesEx c_name (unsafeCoerce getFileExInfoStandard) res + peek res + +-- | Get a unique temporary filename. +-- +-- Calls 'GetTempFileNameW'. +getTempFileName :: WindowsString -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long) + -> WindowsString -- ^ prefix for the temporary file name + -> Maybe UINT -- ^ if 'Nothing', a unique name is generated + -- otherwise a non-zero value is used as the unique part + -> IO (WindowsString, UINT) +getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do + uid <- withFilePath dir $ \c_dir -> + withFilePath prefix $ \ c_prefix -> do + failIfZero "getTempFileName" $ + c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf + fname <- peekTString c_buf + pure (fname, uid) + +replaceFile :: WindowsString -> WindowsString -> Maybe WindowsString -> DWORD -> IO () +replaceFile replacedFile replacementFile mBackupFile replaceFlags = + withFilePath replacedFile $ \ c_replacedFile -> + withFilePath replacementFile $ \ c_replacementFile -> + let getResult f = + case mBackupFile of + Nothing -> f nullPtr + Just backupFile -> withFilePath backupFile f + in getResult $ \ c_backupFile -> + failIfFalse_ "ReplaceFile" $ c_ReplaceFile c_replacedFile c_replacementFile c_backupFile replaceFlags nullPtr nullPtr + +---------------------------------------------------------------- +-- File Notifications +-- +-- Use these to initialise, "increment" and close a HANDLE you can wait +-- on. +---------------------------------------------------------------- + +findFirstChangeNotification :: WindowsString -> Bool -> FileNotificationFlag -> IO HANDLE +findFirstChangeNotification path watch flag = + withFilePath path $ \ c_path -> + failIfNull (unwords ["FindFirstChangeNotification",show path]) $ + c_FindFirstChangeNotification c_path watch flag + + +---------------------------------------------------------------- +-- Directories +---------------------------------------------------------------- + + +getFindDataFileName :: FindData -> IO WindowsString +getFindDataFileName fd = case unsafeCoerce fd of + (FindData fp) -> + withForeignPtr fp $ \p -> + peekTString ((# ptr WIN32_FIND_DATAW, cFileName ) p) + +findFirstFile :: WindowsString -> IO (HANDLE, FindData) +findFirstFile str = do + fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) ) + withForeignPtr fp_finddata $ \p_finddata -> do + handle <- withFilePath str $ \tstr -> do + failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $ + c_FindFirstFile tstr p_finddata + return (handle, unsafeCoerce (FindData fp_finddata)) + + +---------------------------------------------------------------- +-- DOS Device flags +---------------------------------------------------------------- + +defineDosDevice :: DefineDosDeviceFlags -> WindowsString -> Maybe WindowsString -> IO () +defineDosDevice flags name path = + maybeWith withFilePath path $ \ c_path -> + withFilePath name $ \ c_name -> + failIfFalse_ "DefineDosDevice" $ c_DefineDosDevice flags c_name c_path + +---------------------------------------------------------------- + + +-- %fun GetDriveType :: Maybe String -> IO DriveType + +getDiskFreeSpace :: Maybe WindowsString -> IO (DWORD,DWORD,DWORD,DWORD) +getDiskFreeSpace path = + maybeWith withFilePath path $ \ c_path -> + alloca $ \ p_sectors -> + alloca $ \ p_bytes -> + alloca $ \ p_nfree -> + alloca $ \ p_nclusters -> do + failIfFalse_ "GetDiskFreeSpace" $ + c_GetDiskFreeSpace c_path p_sectors p_bytes p_nfree p_nclusters + sectors <- peek p_sectors + bytes <- peek p_bytes + nfree <- peek p_nfree + nclusters <- peek p_nclusters + return (sectors, bytes, nfree, nclusters) + +setVolumeLabel :: Maybe WindowsString -> Maybe WindowsString -> IO () +setVolumeLabel path name = + maybeWith withFilePath path $ \ c_path -> + maybeWith withFilePath name $ \ c_name -> + failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/WindowsString/FileMapping.hsc b/System/Win32/WindowsString/FileMapping.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/FileMapping.hsc @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.FileMapping +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 mapped files. +-- +----------------------------------------------------------------------------- +module System.Win32.WindowsString.FileMapping + ( module System.Win32.WindowsString.FileMapping + , module System.Win32.FileMapping + ) where + +import System.Win32.FileMapping hiding + ( + mapFile + , withMappedFile + , createFileMapping + , openFileMapping + ) + +import System.Win32.FileMapping.Internal +import System.Win32.WindowsString.Types ( HANDLE, BOOL, withTString + , failIf, DDWORD, ddwordToDwords + , iNVALID_HANDLE_VALUE ) +import System.Win32.Mem +import System.Win32.WindowsString.File +import System.OsString.Windows +import System.OsPath.Windows + +import Control.Exception ( mask_, bracket ) +import Foreign ( nullPtr, maybeWith + , ForeignPtr, newForeignPtr ) + +##include "windows_cconv.h" + +#include "windows.h" + +--------------------------------------------------------------------------- +-- Derived functions +--------------------------------------------------------------------------- + +-- | Maps file fully and returns ForeignPtr and length of the mapped area. +-- The mapped file is opened read-only and shared reading. +mapFile :: WindowsPath -> IO (ForeignPtr a, Int) +mapFile path = do + bracket + (createFile path gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) + (closeHandle) + $ \fh -> bracket + (createFileMapping (Just fh) pAGE_READONLY 0 Nothing) + (closeHandle) + $ \fm -> do + fi <- getFileInformationByHandle fh + fp <- mask_ $ do + ptr <- mapViewOfFile fm fILE_MAP_READ 0 0 + newForeignPtr c_UnmapViewOfFileFinaliser ptr + return (fp, fromIntegral $ bhfiSize fi) + +-- | Opens an existing file and creates mapping object to it. +withMappedFile + :: WindowsPath -- ^ Path + -> Bool -- ^ Write? (False = read-only) + -> Maybe Bool -- ^ Sharing mode, no sharing, share read, share read+write + -> (Integer -> MappedObject -> IO a) -- ^ Action + -> IO a +withMappedFile path write share act = + bracket + (createFile path access share' Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) + (closeHandle) + $ \fh -> bracket + (createFileMapping (Just fh) page 0 Nothing) + (closeHandle) + $ \fm -> do + bhfi <- getFileInformationByHandle fh + act (fromIntegral $ bhfiSize bhfi) (MappedObject fh fm mapaccess) + where + access = if write then gENERIC_READ+gENERIC_WRITE else gENERIC_READ + page = if write then pAGE_READWRITE else pAGE_READONLY + mapaccess = if write then fILE_MAP_ALL_ACCESS else fILE_MAP_READ + share' = case share of + Nothing -> fILE_SHARE_NONE + Just False -> fILE_SHARE_READ + Just True -> fILE_SHARE_READ + fILE_SHARE_WRITE + +--------------------------------------------------------------------------- +-- API in Haskell +--------------------------------------------------------------------------- +createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe WindowsString -> IO HANDLE +createFileMapping mh flags mosize name = + maybeWith withTString name $ \c_name -> + failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow c_name + where + (moshi,moslow) = ddwordToDwords mosize + handle = maybe iNVALID_HANDLE_VALUE id mh + +openFileMapping :: FileMapAccess -> BOOL -> Maybe WindowsString -> IO HANDLE +openFileMapping access inherit name = + maybeWith withTString name $ \c_name -> + failIf (==nullPtr) "openFileMapping: OpenFileMapping" $ + c_OpenFileMapping access inherit c_name + diff --git a/System/Win32/WindowsString/HardLink.hs b/System/Win32/WindowsString/HardLink.hs new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/HardLink.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.HardLink + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling hard link using Win32 API. [NTFS only] + + Note: You should worry about file system type when use this module's function in your application: + + * NTFS only supprts this functionality. + + * ReFS doesn't support hard link currently. +-} +module System.Win32.WindowsString.HardLink + ( createHardLink + , createHardLink' + ) where + +import System.Win32.HardLink.Internal +import System.Win32.WindowsString.File ( failIfFalseWithRetry_ ) +import System.Win32.WindowsString.String ( withTString ) +import System.Win32.WindowsString.Types ( nullPtr ) +import System.OsPath.Windows + +#include "windows_cconv.h" + +-- | NOTE: createHardLink is /flipped arguments/ to provide compatibility for Unix. +-- +-- If you want to create hard link by Windows way, use 'createHardLink'' instead. +createHardLink :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Hard link name + -> IO () +createHardLink = flip createHardLink' + +createHardLink' :: WindowsPath -- ^ Hard link name + -> WindowsPath -- ^ Target file path + -> IO () +createHardLink' link target = + withTString target $ \c_target -> + withTString link $ \c_link -> + failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $ + c_CreateHardLink c_link c_target nullPtr diff --git a/System/Win32/WindowsString/Info.hsc b/System/Win32/WindowsString/Info.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Info.hsc @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Info +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Info + ( module System.Win32.WindowsString.Info + , module System.Win32.Info + ) where + +import System.Win32.Info.Internal +import System.Win32.Info hiding ( + getSystemDirectory + , getWindowsDirectory + , getCurrentDirectory + , getTemporaryDirectory + , getFullPathName + , getLongPathName + , getShortPathName + , searchPath + , getUserName + ) +import Control.Exception (catch) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Utils (with, maybeWith) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (nullPtr) +import Foreign.Storable (Storable(..)) +import System.IO.Error (isDoesNotExistError) +import System.Win32.WindowsString.Types (failIfFalse_, peekTStringLen, withTString, try) +import System.OsPath.Windows + +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif + +##include "windows_cconv.h" + +#include +#include "alignment.h" + +---------------------------------------------------------------- +-- Standard Directories +---------------------------------------------------------------- + +getSystemDirectory :: IO WindowsString +getSystemDirectory = try "GetSystemDirectory" c_getSystemDirectory 512 + +getWindowsDirectory :: IO WindowsString +getWindowsDirectory = try "GetWindowsDirectory" c_getWindowsDirectory 512 + +getCurrentDirectory :: IO WindowsString +getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512 + +getTemporaryDirectory :: IO WindowsString +getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 + +getFullPathName :: WindowsPath -> IO WindowsPath +getFullPathName name = do + withTString name $ \ c_name -> + try "getFullPathName" + (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512 + +getLongPathName :: WindowsPath -> IO WindowsPath +getLongPathName name = do + withTString name $ \ c_name -> + try "getLongPathName" + (c_GetLongPathName c_name) 512 + +getShortPathName :: WindowsPath -> IO WindowsPath +getShortPathName name = do + withTString name $ \ c_name -> + try "getShortPathName" + (c_GetShortPathName c_name) 512 + +searchPath :: Maybe WindowsString -> WindowsPath -> Maybe WindowsString -> IO (Maybe WindowsPath) +searchPath path filename ext = + maybe ($ nullPtr) withTString path $ \p_path -> + withTString filename $ \p_filename -> + maybeWith withTString ext $ \p_ext -> + alloca $ \ppFilePart -> (do + s <- try "searchPath" (\buf len -> c_SearchPath p_path p_filename p_ext + len buf ppFilePart) 512 + return (Just s)) + `catch` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +---------------------------------------------------------------- +-- User name +---------------------------------------------------------------- + +-- %fun GetUserName :: IO String + +getUserName :: IO WindowsString +getUserName = + allocaArray 512 $ \ c_str -> + with 512 $ \ c_len -> do + failIfFalse_ "GetUserName" $ c_GetUserName c_str c_len + len <- peek c_len + peekTStringLen (c_str, fromIntegral len - 1) + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/WindowsString/Path.hsc b/System/Win32/WindowsString/Path.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Path.hsc @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Path +-- Copyright : (c) Tamar Christina, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Tamar Christina +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Path ( + filepathRelativePathTo + , pathRelativePathTo + ) where + +import System.Win32.Path.Internal +import System.Win32.WindowsString.Types +import System.Win32.WindowsString.File +import System.OsPath.Windows + +import Foreign + +##include "windows_cconv.h" + +#include + +filepathRelativePathTo :: WindowsPath -> WindowsPath -> IO WindowsPath +filepathRelativePathTo from to = + withTString from $ \p_from -> + withTString to $ \p_to -> + allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do + _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from fILE_ATTRIBUTE_DIRECTORY + p_to fILE_ATTRIBUTE_NORMAL) + path <- peekTString p_AbsPath + _ <- localFree p_AbsPath + return path + +pathRelativePathTo :: WindowsPath -> FileAttributeOrFlag -> WindowsPath -> FileAttributeOrFlag -> IO WindowsPath +pathRelativePathTo from from_attr to to_attr = + withTString from $ \p_from -> + withTString to $ \p_to -> + allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do + _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from from_attr + p_to to_attr) + path <- peekTString p_AbsPath + _ <- localFree p_AbsPath + return path + diff --git a/System/Win32/WindowsString/Shell.hsc b/System/Win32/WindowsString/Shell.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Shell.hsc @@ -0,0 +1,59 @@ +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.Shell +-- Copyright : (c) The University of Glasgow 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Win32 stuff from shell32.dll +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Shell ( + sHGetFolderPath, + CSIDL, + cSIDL_PROFILE, + cSIDL_APPDATA, + cSIDL_WINDOWS, + cSIDL_PERSONAL, + cSIDL_LOCAL_APPDATA, + cSIDL_DESKTOPDIRECTORY, + cSIDL_PROGRAM_FILES, + SHGetFolderPathFlags, + sHGFP_TYPE_CURRENT, + sHGFP_TYPE_DEFAULT + ) where + +import System.OsString.Windows (WindowsString) +import System.Win32.Shell.Internal +import System.Win32.Shell hiding (sHGetFolderPath) +import System.Win32.WindowsString.Types +import Graphics.Win32.GDI.Types (HWND) + +import Foreign +import Control.Monad + +##include "windows_cconv.h" + +-- for SHGetFolderPath stuff +#define _WIN32_IE 0x500 +#include +#include + +---------------------------------------------------------------- +-- SHGetFolderPath +-- +-- XXX: this is deprecated in Vista and later +---------------------------------------------------------------- + + +sHGetFolderPath :: HWND -> CSIDL -> HANDLE -> SHGetFolderPathFlags -> IO WindowsString +sHGetFolderPath hwnd csidl hdl flags = + allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pstr -> do + r <- c_SHGetFolderPath hwnd csidl hdl flags pstr + when (r < 0) $ raiseUnsupported "sHGetFolderPath" + peekTString pstr diff --git a/System/Win32/WindowsString/String.hs b/System/Win32/WindowsString/String.hs new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/String.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE PackageImports #-} + +{- | + Module : System.Win32.String + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Utilities for primitive marshalling of Windows' C strings. +-} +module System.Win32.WindowsString.String + ( LPSTR, LPCSTR, LPWSTR, LPCWSTR + , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_ + , withTString, withTStringLen, peekTString, peekTStringLen + , newTString + , withTStringBuffer, withTStringBufferLen + ) where + +import System.Win32.String hiding + ( withTStringBuffer + , withTStringBufferLen + , withTString + , withTStringLen + , peekTString + , peekTStringLen + , newTString + ) +import System.Win32.WindowsString.Types +import System.OsString.Internal.Types +#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 +-- using temporary storage. +-- +-- * the Haskell string is created by length parameter. And the Haskell +-- string contains /only/ NUL characters. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withTStringBuffer :: Int -> (LPTSTR -> IO a) -> IO a +withTStringBuffer maxLength + = let dummyBuffer = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul + in withTString dummyBuffer + +-- | Marshal a dummy Haskell string into a C wide string (i.e. wide +-- character array) in temporary storage, with explicit length +-- information. +-- +-- * the Haskell string is created by length parameter. And the Haskell +-- string contains /only/ NUL characters. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withTStringBufferLen :: Int -> ((LPTSTR, Int) -> IO a) -> IO a +withTStringBufferLen maxLength + = let dummyBuffer = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul + in withTStringLen dummyBuffer + + +_nul :: Word8 +_nul = 0x00 diff --git a/System/Win32/WindowsString/SymbolicLink.hsc b/System/Win32/WindowsString/SymbolicLink.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/SymbolicLink.hsc @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.SymbolicLink + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling symbolic link using Win32 API. [Vista of later and desktop app only] + + Note: When using the createSymbolicLink* functions without the + SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE flag, you should worry about UAC + (User Account Control) when use this module's function in your application: + + * require to use 'Run As Administrator' to run your application. + + * or modify your application's manifect file to add + \. + + Starting from Windows 10 version 1703 (Creators Update), after enabling + Developer Mode, users can create symbolic links without requiring the + Administrator privilege in the current process. Supply a 'True' flag in + addition to the target and link name to enable this behavior. +-} +module System.Win32.WindowsString.SymbolicLink + ( SymbolicLinkFlags + , sYMBOLIC_LINK_FLAG_FILE + , sYMBOLIC_LINK_FLAG_DIRECTORY + , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + , createSymbolicLink + , createSymbolicLink' + , createSymbolicLinkFile + , createSymbolicLinkDirectory + ) where + +import System.Win32.SymbolicLink.Internal +import Data.Bits ((.|.)) +import System.Win32.WindowsString.Types +import System.Win32.WindowsString.File ( failIfFalseWithRetry_ ) +import System.OsPath.Windows +import Unsafe.Coerce (unsafeCoerce) + +##include "windows_cconv.h" + +-- | createSymbolicLink* functions don't check that file is exist or not. +-- +-- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix, +-- except 'createSymbolicLink''. +-- +-- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead. +createSymbolicLink :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Symbolic link name + -> SymbolicLinkFlags -> IO () +createSymbolicLink = flip createSymbolicLink' + +createSymbolicLinkFile :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Symbolic link name + -> Bool -- ^ Create the symbolic link with the unprivileged mode + -> IO () +createSymbolicLinkFile target link unprivileged = + createSymbolicLink' + link + target + ( if unprivileged + then sYMBOLIC_LINK_FLAG_FILE .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + else sYMBOLIC_LINK_FLAG_FILE + ) + +createSymbolicLinkDirectory :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Symbolic link name + -> Bool -- ^ Create the symbolic link with the unprivileged mode + -> IO () +createSymbolicLinkDirectory target link unprivileged = + createSymbolicLink' + link + target + ( if unprivileged + then + sYMBOLIC_LINK_FLAG_DIRECTORY + .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + else sYMBOLIC_LINK_FLAG_DIRECTORY + ) + +createSymbolicLink' :: WindowsPath -- ^ Symbolic link name + -> WindowsPath -- ^ Target file path + -> SymbolicLinkFlags -> IO () +createSymbolicLink' link target flag = do + withTString link $ \c_link -> + withTString target $ \c_target -> + failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $ + c_CreateSymbolicLink c_link c_target (unsafeCoerce flag) + diff --git a/System/Win32/WindowsString/Time.hsc b/System/Win32/WindowsString/Time.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Time.hsc @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Time +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Time API. +-- +----------------------------------------------------------------------------- +module System.Win32.WindowsString.Time + ( module System.Win32.WindowsString.Time + , module System.Win32.Time + ) where + +import System.Win32.Time.Internal +import System.Win32.Time hiding (getTimeFormatEx, getTimeFormat) + +import System.Win32.WindowsString.String ( peekTStringLen, withTString ) +import System.Win32.WindowsString.Types ( LCID, failIf ) +import System.Win32.Utils ( trySized ) + +import Foreign ( Storable(sizeOf) + , nullPtr, castPtr + , with, allocaBytes ) +import Foreign.C ( CWchar(..) + , withCWString ) +import Foreign.Marshal.Utils (maybeWith) +import System.OsString.Windows + +##include "windows_cconv.h" +#include +#include "alignment.h" +#include "winnls_compat.h" + + +getTimeFormatEx :: Maybe WindowsString + -> GetTimeFormatFlags + -> Maybe SYSTEMTIME + -> Maybe WindowsString + -> IO String +getTimeFormatEx locale flags st fmt = + maybeWith withTString locale $ \c_locale -> + maybeWith with st $ \c_st -> + maybeWith withTString fmt $ \c_fmt -> do + let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt + trySized "GetTimeFormatEx" c_func + +getTimeFormat :: LCID -> GetTimeFormatFlags -> Maybe SYSTEMTIME -> Maybe String -> IO WindowsString +getTimeFormat locale flags st fmt = + maybeWith with st $ \c_st -> + maybeWith withCWString fmt $ \c_fmt -> do + size <- c_GetTimeFormat locale flags c_st c_fmt nullPtr 0 + allocaBytes ((fromIntegral size) * (sizeOf (undefined::CWchar))) $ \out -> do + size' <- failIf (==0) "getTimeFormat: GetTimeFormat" $ + c_GetTimeFormat locale flags c_st c_fmt (castPtr out) size + peekTStringLen (out,fromIntegral size') diff --git a/System/Win32/WindowsString/Types.hsc b/System/Win32/WindowsString/Types.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Types.hsc @@ -0,0 +1,214 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Types +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Types + ( module System.Win32.WindowsString.Types + , module System.Win32.Types + ) where + +import System.Win32.Types hiding ( + withTString + , withTStringLen + , peekTString + , peekTStringLen + , newTString + , failIf + , failIf_ + , failIfNeg + , failIfNull + , failIfZero + , failIfFalse_ + , failUnlessSuccess + , failUnlessSuccessOr + , errorWin + , failWith + , try + , withFilePath + , useAsCWStringSafe + ) + +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 +#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, + useAsCWStringLen, + newCWString + ) +import Data.Bifunctor (first) +import Data.Char (isSpace) +import Numeric (showHex) +import qualified System.IO as IO () +import System.IO.Error (ioeSetErrorString) +import Foreign (allocaArray) +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) +#endif + +import GHC.IO.Encoding.UTF16 ( mkUTF16le ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) + +#include +#include +#include +##include "windows_cconv.h" + + +---------------------------------------------------------------- +-- Chars and strings +---------------------------------------------------------------- + +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 +newTString :: WindowsString -> IO LPCTSTR + +-- 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 +---------------------------------------------------------------- + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +failIf_ :: (a -> Bool) -> String -> IO a -> IO () +failIf_ p wh act = do + v <- act + if p v then errorWin wh else return () + +failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a +failIfNeg = failIf (< 0) + +failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +failIfNull = failIf (== nullPtr) + +failIfZero :: (Eq a, Num a) => String -> IO a -> IO a +failIfZero = failIf (== 0) + +failIfFalse_ :: String -> IO Bool -> IO () +failIfFalse_ = failIf_ not + +failUnlessSuccess :: String -> IO ErrCode -> IO () +failUnlessSuccess fn_name act = do + r <- act + if r == 0 then return () else failWith fn_name r + +failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool +failUnlessSuccessOr val fn_name act = do + r <- act + if r == 0 then return False + else if r == val then return True + else failWith fn_name r + + +errorWin :: String -> IO a +errorWin fn_name = do + err_code <- getLastError + failWith fn_name err_code + +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = do + c_msg <- getErrorMessage err_code + + msg <- either (fail . show) pure . decodeWith (mkUTF16le TransliterateCodingFailure) =<< if c_msg == nullPtr + then either (fail . show) pure . encodeWith (mkUTF16le TransliterateCodingFailure) $ "Error 0x" ++ Numeric.showHex err_code "" + else do msg <- peekTString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + -- turn GetLastError() into errno, which errnoToIOError knows how to convert + -- to an IOException we can throw. + errno <- c_maperrno_func err_code + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + throwIO ioerror + + +-- Support for API calls that are passed a fixed-size buffer and tell +-- you via the return value if the buffer was too small. In that +-- case, we double the buffer size and try again. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +try loc f n = do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + r <- failIfZero loc $ f lptstr n + if (r > n) then return (Left r) else do + str <- peekTStringLen (lptstr, fromIntegral r) + return (Right str) + case e of + Left n' -> try loc f n' + Right str -> return str diff --git a/System/Win32/WindowsString/Utils.hs b/System/Win32/WindowsString/Utils.hs new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Utils.hs @@ -0,0 +1,63 @@ +{- | + Module : System.Win32.Utils + Copyright : 2009 Balazs Komuves, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Utilities for calling Win32 API +-} +module System.Win32.WindowsString.Utils + ( module System.Win32.WindowsString.Utils + , module System.Win32.Utils + ) where + +import Foreign.C.Types ( CInt ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Ptr ( nullPtr ) + +import System.Win32.Utils hiding + ( try + , tryWithoutNull + , trySized + ) +import System.Win32.WindowsString.String ( LPTSTR, peekTString, peekTStringLen + , withTStringBufferLen ) +import System.Win32.WindowsString.Types ( UINT + , failIfZero + ) +import qualified System.Win32.WindowsString.Types ( try ) +import System.OsString.Windows + + +-- | Support for API calls that are passed a fixed-size buffer and tell +-- you via the return value if the buffer was too small. In that +-- case, we extend the buffer size and try again. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +try = System.Win32.WindowsString.Types.try +{-# INLINE try #-} + +tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +tryWithoutNull loc f n = do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + r <- failIfZero loc $ f lptstr n + if r > n then return (Left r) else do + str <- peekTString lptstr + return (Right str) + case e of + Left r' -> tryWithoutNull loc f r' + Right str -> return str + +-- | Support for API calls that return the required size, in characters +-- including a null character, of the buffer when passed a buffer size of zero. +trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO WindowsString +trySized wh f = do + c_len <- failIfZero wh $ f nullPtr 0 + let len = fromIntegral c_len + withTStringBufferLen len $ \(buf', len') -> do + let c_len' = fromIntegral len' + c_len'' <- failIfZero wh $ f buf' c_len' + let len'' = fromIntegral c_len'' + peekTStringLen (buf', len'' - 1) -- Drop final null character diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,22 +1,35 @@ -name: Win32 -version: 2.8.5.0 -license: BSD3 -license-file: LICENSE -author: Alastair Reid, shelarcy, Tamar Christina -copyright: Alastair Reid, 1999-2003; shelarcy, 2012-2013; Tamar Christina, 2016-2018 -maintainer: Haskell Libraries +cabal-version: 2.0 +name: Win32 +version: 2.14.2.2 +license: BSD3 +license-file: LICENSE +author: Alastair Reid, shelarcy, Tamar Christina +copyright: Alastair Reid, 1999-2003; shelarcy, 2012-2013; Tamar Christina, 2016-2020 +maintainer: Haskell Libraries bug-reports: https://github.com/haskell/win32/issues homepage: https://github.com/haskell/win32 -category: System, Graphics -synopsis: A binding to Windows Win32 API. -description: This library contains direct bindings to the Windows Win32 APIs for Haskell. +category: System, Graphics +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 - changelog.md + include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h + include/Win32Aux.h include/win32debug.h include/alignment.h +extra-doc-files: + changelog.md +tested-with: + GHC == 9.2.7, + GHC == 9.4.5, + GHC == 9.6.7, + GHC == 9.8.4, + GHC == 9.10.1, + GHC == 9.12.1 +flag os-string + description: Use the new os-string package + default: False + manual: False + Library default-language: Haskell2010 default-extensions: ForeignFunctionInterface, CPP @@ -28,11 +41,19 @@ build-depends: unbuildable<0 buildable: False - build-depends: base >= 4.5 && < 5, bytestring, filepath + build-depends: base >= 4.5 && < 5 + + -- AFPP support + if impl(ghc >= 8.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 - ghc-options: -Wall -fno-warn-name-shadowing - cc-options: -fno-strict-aliasing + ghc-options: -Wall -fno-warn-name-shadowing + cc-options: -fno-strict-aliasing exposed-modules: Graphics.Win32.GDI Graphics.Win32.GDI.Bitmap @@ -69,8 +90,10 @@ System.Win32 System.Win32.DebugApi System.Win32.DLL + System.Win32.Event System.Win32.File System.Win32.FileMapping + System.Win32.NamedPipes System.Win32.Info System.Win32.Path System.Win32.Mem @@ -82,6 +105,7 @@ System.Win32.Time System.Win32.Console System.Win32.Security + System.Win32.Semaphore System.Win32.Types System.Win32.Shell System.Win32.Automation @@ -102,12 +126,42 @@ System.Win32.Utils System.Win32.Word + -- 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 + System.Win32.WindowsString.Shell + System.Win32.WindowsString.String + System.Win32.WindowsString.File + System.Win32.WindowsString.Time + System.Win32.WindowsString.Info + System.Win32.WindowsString.FileMapping + System.Win32.WindowsString.HardLink + System.Win32.WindowsString.Path + System.Win32.WindowsString.SymbolicLink + System.Win32.WindowsString.Utils + + other-modules: + System.Win32.Console.Internal + System.Win32.DebugApi.Internal + System.Win32.DLL.Internal + System.Win32.File.Internal + System.Win32.FileMapping.Internal + System.Win32.HardLink.Internal + System.Win32.Info.Internal + System.Win32.Path.Internal + System.Win32.Shell.Internal + System.Win32.SymbolicLink.Internal + System.Win32.Time.Internal + extra-libraries: "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32" ghc-options: -Wall include-dirs: include - includes: "alphablend.h", "diatemp.h", "dumpBMP.h", "ellipse.h", "errors.h", "HsGDI.h", "HsWin32.h", "Win32Aux.h", "win32debug.h", "windows_cconv.h", "WndProc.h", "alignment.h" - install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "winternl_compat.h", "winuser_compat.h", "winreg_compat.h", "tlhelp32_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 @@ -121,4 +175,4 @@ source-repository head type: git - location: git://github.com/haskell/win32 + location: https://github.com/haskell/win32 diff --git a/cbits/dumpBMP.c b/cbits/dumpBMP.c --- a/cbits/dumpBMP.c +++ b/cbits/dumpBMP.c @@ -64,7 +64,7 @@ // if BitCount != 0, color table will be retrieved // bmi.bmiHeader.biSize = 0x28; // GDI need this to work - bmi.bmiHeader.biBitCount = 0; // dont get the color table + bmi.bmiHeader.biBitCount = 0; // don't get the color table if ((GetDIBits(hDC, hBmp, 0, 0, (LPSTR)NULL, &bmi, DIB_RGB_COLORS)) == 0) { fprintf(stderr, "GetDIBits failed!"); return; @@ -81,7 +81,7 @@ } // - // Note: 24 bits per pixel has no color table. So, we dont have to + // Note: 24 bits per pixel has no color table. So, we don't have to // allocate memory for retrieving that. Otherwise, we do. // pbmi = &bmi; // assume no color table @@ -113,7 +113,7 @@ goto ErrExit1; } // - // Now that weve a bigger chunk of memory, lets copy the Bitmap + // Now that we've a bigger chunk of memory, lets copy the Bitmap // info header data over // pjTmp = (PBYTE)pbmi; diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,135 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) -## *Unreleased version* +## 2.14.2.2 May 2026 + +* Fix version bounds for older GHC and drop numeric underscore + +## 2.14.2.1 June 2025 + +* Fix compilation of `ReplaceFileW` on some GHC versions [#245](https://github.com/haskell/win32/issues/245) + +## 2.14.2.0 May 2025 + +* Add ReplaceFileW +* Add support for Windows on Arm +* Add ReadConsoleInput + +## 2.14.1.0 November 2024 + +* Add getTempFileName +* Add WindowsString variant for getEnv etc +* Implement getEnv and getEnvironment + +## 2.14.0.0 January 2023 + +* Add support for named pipes [#220](https://github.com/haskell/win32/pull/220) +* Ensure that FilePaths don't contain interior NULs wrt [#218](https://github.com/haskell/win32/pull/218) +* Add support for GetCommandLineW [#218](https://github.com/haskell/win32/pull/221) +* Support filepath >= 1.5.0.0 and os-string [#226](https://github.com/haskell/win32/pull/226) +* Remove unused imports [#225](https://github.com/haskell/win32/pull/225) + +## 2.13.4.0 October 2022 + +* Add support for semaphores with `System.Win32.Semaphore` (See #214). +* Add function `createFile_NoRetry` (see #208) +* The type signatures for `loadLibrary` and `loadLibraryEx` now refer to + `HMODULE` instead of `HINSTANCE` for consistency with the official Win32 + API documentation. Note that `HMODULE` and `HINSTANCE` are both type synonyms + for the same thing, so this only changes the presentation of these functions' + type signatures, not their behavior. + +## 2.13.3.0 July 2022 + +* Add AFPP support (see #198) + +## 2.13.2.1 July 2022 + +* Add function `createIcon` (see #194) +* Add `WindowMessage` value `wM_SETICON` (see #194) +* Add `WPARAM` values `iCON_SMALL`, `iCON_BIG` (see #194) +* Add functions `getConsoleScreenBufferInfoEx` and + `getCurrentConsoleScreenBufferInfoEx` + +## 2.13.2.0 November 2021 + +* Set maximum string size for getComputerName. (See #190) +* Update withHandleToHANDLENative to handle duplex and console handles (See #191) + +## 2.13.1.0 November 2021 + +* Fix a bug in which `System.Win32.MinTTY.isMinTTY` would incorrectly return + `False` on recent versions of MinTTY. (See #187) +* Add all flags for CreateToolhelp32Snapshot. (See #185) + +## 2.13.0.0 August 2021 + +* Fix type of c_SetWindowLongPtr. See #180 + +## 2.12.0.1 June 2021 + +* A small fix for WinIO usage. See #177 + +## 2.12.0.0 March 2021 + +* Win32 for GHC 9.2.x +* Add export lists to all modules, hiding numerous internal `c_` bindings. +* Update the type of `setFileTime` to reflect the fact that the `FILETIME` + arguments are in fact `Maybe`s. + +## 2.11.1.0 February 2021 + +* Make `System.Win32.NLS` re-export `CodePage` from `GHC.IO.Encoding.CodePage` + in `base` when compiled with `base-4.15` or later. + +## 2.11.0.0 January 2021 + +* Remove function `mapFileBs`. + +## 2.10.1.0 October 2020 + +* Add `System.Win32.Event` module +* Add function `openEvent` +* Add function `createEvent` +* Add function `duplicateHandle` +* Add function `setEvent` +* Add function `resetEvent` +* Add function `pulseEvent` +* Add function `signalObjectAndWait` +* Add function `waitForSingleObject` +* Add function `waitForSingleObjectEx` +* Add function `waitForMultipleObjects` +* Add function `waitForMultipleObjectsEx` +* Add enums `DUPLICATE_CLOSE_SOURCE`, `DUPLICATE_SAME_ACCESS`, + `EVENT_ALL_ACCESS`, `EVENT_MODIFY_STATE`, `WAIT_ABANDONED`, + `WAIT_IO_COMPLETION`, `WAIT_OBJECT_0`, `WAIT_TIMEOUT` and `WAIT_FAILED`. +* Add struct `SECURITY_ATTRIBUTES` + +## 2.10.0.0 September 2020 + +* Add function `isWindowVisible` +* Add function `getLastInputInfo` +* Add function `getTickCount` +* Add function `getIdleTime` +* Add `enumSystemLocalesEx`, `enumSystemLocalesEx'`, + `getSystemDefaultLocaleName`, `getUserDefaultLocaleName`, `isValidLocaleName`, + `getLocaleInfoEx`, `getTimeFormatEx` and `lCMapStringEx` +* Add `trySized` - similar to `try` but for API calls that return the required + size of the buffer when passed a buffer size of zero. +* Add `fromDateFormatPciture` and `fromTimeFormatPicture`, to translate from + Windows date and time format pictures to format strings used by the `time` + package. +* Renamed fields of `COORD` and `SMALL_RECT` to avoid name clashes. (See #157) + +## 2.9.0.0 June 2020 + +* `setWindowClosure` now returns the old window closure. +* `defWindowProc` now assumes the data stored in `GWLP\_USERDATA` + is the window closure (in line with `setWindowClosure` and + the supplied C `genericWndProc`) +* `defWindowProc` now frees the window closure +* `getMessage` and `peekMessage` test for -1 to identify the error condition +* Support creating symbolic links without Administrator privilege (See #147) +* Support for `winio` the new Windows I/O manager. ## 2.8.5.0 Dec 2019 diff --git a/include/alphablend.h b/include/alphablend.h --- a/include/alphablend.h +++ b/include/alphablend.h @@ -1,6 +1,6 @@ #ifndef _ALPHABLEND_H #define _ALPHABLEND_H -#define WINVER 0x0500 + #include BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest diff --git a/include/namedpipeapi_compat.h b/include/namedpipeapi_compat.h new file mode 100644 --- /dev/null +++ b/include/namedpipeapi_compat.h @@ -0,0 +1,16 @@ +/* The version of wincon.h provided by the version of MSYS2 included with x86 + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef NAMEDPIPEAPI_COMPAT_H +#define NAMEDPIPEAPI_COMPAT_H + +#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 +# +#else + +#define PIPE_ACCEPT_REMOTE_CLIENTS 0x0 +#define PIPE_REJECT_REMOTE_CLIENTS 0x8 +#endif /* GHC version check */ +#endif /* NAMEDPIPEAPI_COMPAT_H */ diff --git a/include/tlhelp32_compat.h b/include/tlhelp32_compat.h --- a/include/tlhelp32_compat.h +++ b/include/tlhelp32_compat.h @@ -4,12 +4,23 @@ * tlhelp32.h is not included in MinGW, which was shipped with the 32-bit * Windows version of GHC prior to the 7.10.3 release. */ -#if __GLASGOW_HASKELL__ > 708 +#if __GLASGOW_HASKELL__ >= 710 #else -// Some declarations from tlhelp32.h that we need in Win32 +// Declarations from tlhelp32.h that Win32 requires #include +// CreateToolhelp32Snapshot Flags +// https://docs.microsoft.com/en-us/windows/win32/api/tlhelp32/nf-tlhelp32-createtoolhelp32snapshot + +#define TH32CS_INHERIT 0x80000000 + +#define TH32CS_SNAPHEAPLIST 0x00000001 +#define TH32CS_SNAPPROCESS 0x00000002 +#define TH32CS_SNAPTHREAD 0x00000004 +#define TH32CS_SNAPMODULE 0x00000008 #define TH32CS_SNAPMODULE32 0x00000010 + +#define TH32CS_SNAPALL (TH32CS_SNAPHEAPLIST|TH32CS_SNAPPROCESS|TH32CS_SNAPTHREAD|TH32CS_SNAPMODULE) #endif #endif /* TLHELP32_COMPAT_H */ diff --git a/include/wincon_compat.h b/include/wincon_compat.h new file mode 100644 --- /dev/null +++ b/include/wincon_compat.h @@ -0,0 +1,26 @@ +/* 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 WINCON_COMPAT_H +#define WINCON_COMPAT_H + +#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 +# +#else + +typedef struct _CONSOLE_SCREEN_BUFFER_INFOEX { + ULONG cbSize; + COORD dwSize; + COORD dwCursorPosition; + WORD wAttributes; + SMALL_RECT srWindow; + COORD dwMaximumWindowSize; + WORD wPopupAttributes; + WINBOOL bFullscreenSupported; + COLORREF ColorTable[16]; +} CONSOLE_SCREEN_BUFFER_INFOEX, *PCONSOLE_SCREEN_BUFFER_INFOEX; + +#endif /* GHC version check */ +#endif /* WINCON_COMPAT_H */ diff --git a/include/windows_cconv.h b/include/windows_cconv.h --- a/include/windows_cconv.h +++ b/include/windows_cconv.h @@ -3,7 +3,7 @@ #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch diff --git a/include/winnls_compat.h b/include/winnls_compat.h new file mode 100644 --- /dev/null +++ b/include/winnls_compat.h @@ -0,0 +1,105 @@ +/* The version of winnls.h provided by the version of MSYS2 included with + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef WINNLS_COMPAT_H +#define WINNLS_COMPAT_H + +#if __GLASGOW_HASKELL__ < 710 +// Locale information constants +#define LOCALE_IGEOID 0x0000005b +#define LOCALE_SCONSOLEFALLBACKNAME 0x0000006e +#define LOCALE_SDURATION 0x0000005d +#define LOCALE_SENGLISHCOUNTRYNAME 0x00001002 +#define LOCALE_SENGLISHLANGUAGENAME 0x00001001 +#define LOCALE_SISO3166CTRYNAME2 0x00000068 +#define LOCALE_SISO639LANGNAME2 0x00000067 +#define LOCALE_SKEYBOARDSTOINSTALL 0x0000005e +#define LOCALE_SNAME 0x0000005c +#define LOCALE_SNAN 0x00000069 +#define LOCALE_SNATIVECOUNTRYNAME 0x00000008 +#define LOCALE_SNEGINFINITY 0x0000006b +#define LOCALE_SPARENT 0x0000006d +#define LOCALE_SPOSINFINITY 0x0000006a +#define LOCALE_SSCRIPTS 0x0000006c +#define LOCALE_SSHORTESTDAYNAME1 0x00000060 +#define LOCALE_SSHORTESTDAYNAME2 0x00000061 +#define LOCALE_SSHORTESTDAYNAME3 0x00000062 +#define LOCALE_SSHORTESTDAYNAME4 0x00000063 +#define LOCALE_SSHORTESTDAYNAME5 0x00000064 +#define LOCALE_SSHORTESTDAYNAME6 0x00000065 +#define LOCALE_SSHORTESTDAYNAME7 0x00000066 +// Locale map flag constants +#define LINGUISTIC_IGNORECASE 0x00000010 +#define LINGUISTIC_IGNOREDIACRITIC 0x00000020 +#define NORM_LINGUISTIC_CASING 0x08000000 +// Locale enumeration flag constants +#define LOCALE_ALL 0 +#define LOCALE_ALTERNATE_SORTS 0x00000004 +#define LOCALE_REPLACEMENT 0x00000008 +#define LOCALE_SUPPLEMENTAL 0x00000002 +#define LOCALE_WINDOWS 0x00000001 +// Other +WINBASEAPI WINBOOL WINAPI IsValidLocaleName (LPCWSTR lpLocaleName); +#endif + +#if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH) +// Locale information constants +#define LOCALE_IDEFAULTMACCODEPAGE 0x00001011 +// Other +typedef struct _nlsversioninfoex { + DWORD dwNLSVersionInfoSize; + DWORD dwNLSVersion; + DWORD dwDefinedVersion; + DWORD dwEffectiveId; + GUID guidCustomVersion; +} NLSVERSIONINFOEX, *LPNLSVERSIONINFOEX; + +WINBASEAPI int WINAPI GetLocaleInfoEx( + LPCWSTR lpLocaleName, + LCTYPE LCType, + LPWSTR lpLCData, + int cchData +); + +WINBASEAPI WINBOOL WINAPI GetNLSVersionEx( + NLS_FUNCTION function, + LPCWSTR lpLocaleName, + LPNLSVERSIONINFOEX lpVersionInformation +); + +WINBASEAPI int WINAPI LCMapStringEx( + LPCWSTR lpLocaleName, + DWORD dwMapFlags, + LPCWSTR lpSrcStr, + int cchSrc, + LPWSTR lpDestStr, + int cchDest, + LPNLSVERSIONINFO lpVersionInformation, + LPVOID lpReserved, + LPARAM lParam +); + + +WINBASEAPI int WINAPI GetTimeFormatEx( + LPCWSTR lpLocaleName, + DWORD dwFlags, + const SYSTEMTIME *lpTime, + LPCWSTR lpFormat, + LPWSTR lpTimeStr, + int cchTime +); + +WINBASEAPI int WINAPI GetSystemDefaultLocaleName( + LPWSTR lpLocaleName, + int cchLocaleName +); + +WINBASEAPI int WINAPI GetUserDefaultLocaleName( + LPWSTR lpLocaleName, + int cchLocaleName +); +#endif + +#endif /* #ifndef WINNLS_COMPAT_H */ diff --git a/include/winnt_compat.h b/include/winnt_compat.h new file mode 100644 --- /dev/null +++ b/include/winnt_compat.h @@ -0,0 +1,13 @@ +/* The version of winnt.h provided by the version of MSYS2 included with + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef WINNT_COMPAT_H +#define WINNT_COMPAT_H + +#if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH) +#define LOCALE_NAME_MAX_LENGTH 85 +#endif + +#endif /* #ifndef WINNT_COMPAT_H */