Win32 2.8.5.0 → 2.9.0.0

raw patch · 6 files changed

+186/−49 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Graphics/Win32/LayeredWindow.hsc +4/−13
• Graphics/Win32/Window.hsc +72/−9
• System/Win32/SymbolicLink.hsc +37/−6
• System/Win32/Types.hsc +47/−4
• Win32.cabal +16/−16
• changelog.md +10/−1

@@ -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 <windows.h>
 ##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
  }
+

@@ -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

@@ -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
        \<requestedExecutionLevel level='requireAdministrator' uiAccess='false'/\>.
+
+   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

@@ -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 <fcntl.h> #include <windows.h> ##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 

@@ -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 <libraries@haskell.org>+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 <libraries@haskell.org> 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

@@ -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