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,15 @@ 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" @@ -52,16 +50,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/Window.hsc b/Graphics/Win32/Window.hsc --- a/Graphics/Win32/Window.hsc +++ b/Graphics/Win32/Window.hsc @@ -16,7 +16,7 @@ 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) @@ -24,6 +24,7 @@ import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (allocaArray) import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, castPtr, nullPtr) +import Foreign.Ptr (intPtrToPtr, castPtrToFunPtr, freeHaskellFunPtr) 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,24 @@ foreign import WINDOWS_CCONV "wrapper" mkWindowClosure :: WindowClosure -> IO (FunPtr WindowClosure) -setWindowClosure :: HWND -> WindowClosure -> IO () +-- | 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}) + fpOld <- c_SetWindowLongPtr wnd (#{const GWLP_USERDATA}) (castPtr (castFunPtrToPtr fp)) - return () + if fpOld == nullPtr + then return Nothing + else return $ Just $ castPtrToFunPtr fpOld {- Note [SetWindowLongPtrW] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -228,6 +242,20 @@ #endif c_SetWindowLongPtr :: HWND -> INT -> Ptr LONG -> IO (Ptr LONG) +#if defined(i386_HOST_ARCH) +foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongW" +#elif defined(x86_64_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 +264,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 +282,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 +293,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 @@ -717,7 +780,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 +792,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/System/Win32/SymbolicLink.hsc b/System/Win32/SymbolicLink.hsc --- a/System/Win32/SymbolicLink.hsc +++ b/System/Win32/SymbolicLink.hsc @@ -10,17 +10,25 @@ 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 \. + + 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 ) where +import Data.Bits ((.|.)) import System.Win32.Types import System.Win32.File ( failIfFalseWithRetry_ ) @@ -31,24 +39,47 @@ #{enum SymbolicLinkFlags, , sYMBOLIC_LINK_FLAG_FILE = 0x0 , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 + , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2 } -- | 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 diff --git a/System/Win32/Types.hsc b/System/Win32/Types.hsc --- a/System/Win32/Types.hsc +++ b/System/Win32/Types.hsc @@ -56,6 +56,15 @@ finiteBitSize = bitSize #endif +##if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows +import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle(), + handleToMode, optimizeFileAccess) +import qualified GHC.Event.Windows as Mgr +import GHC.IO.Device (IODeviceType(..)) +##endif + #include #include ##include "windows_cconv.h" @@ -241,8 +250,24 @@ -- 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 + optimizeFileAccess handle + let hwnd = fromHANDLE handle :: Io NativeHandle + -- Not sure if I need to use devType here.. + mode <- handleToMode handle + mkHandleFromHANDLE hwnd Stream ("hwnd:" ++ show handle) mode Nothing +##endif + posix = _open_osfhandle (fromIntegral (ptrToIntPtr handle)) + (#const _O_BINARY) >>= fdToHandle foreign import ccall unsafe "_get_osfhandle" c_get_osfhandle :: CInt -> IO HANDLE @@ -252,11 +277,30 @@ -- 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). withStablePtr haskell_handle $ const $ do + windows_handle <- handleToHANDLE haskell_handle + -- Do what the user originally wanted + action windows_handle +#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 @@ -269,7 +313,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 diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,21 +1,21 @@ -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 +name: Win32 +version: 2.9.0.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 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 + changelog.md Library default-language: Haskell2010 @@ -28,11 +28,11 @@ build-depends: unbuildable<0 buildable: False - build-depends: base >= 4.5 && < 5, bytestring, filepath + build-depends: base >= 4.5 && < 5, bytestring, filepath -- 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,15 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) -## *Unreleased version* +## 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