Win32 2.3.1.1 → 2.14.2.2
raw patch · 111 files changed
Files
- Graphics/Win32.hs +12/−2
- Graphics/Win32/Control.hsc +0/−2
- Graphics/Win32/Dialogue.hsc +1/−1
- Graphics/Win32/GDI.hs +2/−4
- Graphics/Win32/GDI/AlphaBlend.hsc +74/−0
- Graphics/Win32/GDI/Bitmap.hsc +1/−1
- Graphics/Win32/GDI/Brush.hsc +1/−1
- Graphics/Win32/GDI/Clip.hsc +13/−1
- Graphics/Win32/GDI/Font.hsc +1/−1
- Graphics/Win32/GDI/Graphics2D.hs +2/−2
- Graphics/Win32/GDI/HDC.hs +12/−1
- Graphics/Win32/GDI/Palette.hsc +1/−1
- Graphics/Win32/GDI/Path.hs +1/−1
- Graphics/Win32/GDI/Pen.hsc +5/−5
- Graphics/Win32/GDI/Region.hs +1/−1
- Graphics/Win32/GDI/Types.hsc +0/−2
- Graphics/Win32/Icon.hs +8/−1
- Graphics/Win32/Key.hsc +222/−74
- Graphics/Win32/LayeredWindow.hsc +57/−0
- Graphics/Win32/Menu.hsc +12/−12
- Graphics/Win32/Message.hsc +4/−1
- Graphics/Win32/Misc.hsc +5/−5
- Graphics/Win32/Resource.hsc +1/−1
- Graphics/Win32/Window.hsc +139/−26
- Graphics/Win32/Window/AnimateWindow.hsc +40/−0
- Graphics/Win32/Window/ForegroundWindow.hs +47/−0
- Graphics/Win32/Window/HotKey.hsc +65/−0
- Graphics/Win32/Window/IMM.hsc +110/−0
- Graphics/Win32/Window/PostMessage.hsc +48/−0
- LICENSE +1/−0
- Media/Win32.hs +48/−0
- Setup.hs +0/−6
- System/Win32.hs +16/−1
- System/Win32/Automation.hs +15/−0
- System/Win32/Automation/Input.hsc +130/−0
- System/Win32/Automation/Input/Key.hsc +55/−0
- System/Win32/Automation/Input/Mouse.hsc +76/−0
- System/Win32/Console.hsc +209/−19
- System/Win32/Console/CtrlHandler.hs +52/−0
- System/Win32/Console/HWND.hs +34/−0
- System/Win32/Console/Internal.hsc +336/−0
- System/Win32/Console/Title.hsc +46/−0
- System/Win32/DLL.hsc +24/−33
- System/Win32/DLL/Internal.hsc +57/−0
- System/Win32/DebugApi.hsc +159/−115
- System/Win32/DebugApi/Internal.hsc +80/−0
- System/Win32/Encoding.hs +99/−0
- System/Win32/Event.hsc +163/−0
- System/Win32/Exception/Unsupported.hs +70/−0
- System/Win32/File.hsc +307/−382
- System/Win32/File/Internal.hsc +548/−0
- System/Win32/FileMapping.hsc +39/−55
- System/Win32/FileMapping/Internal.hsc +72/−0
- System/Win32/HardLink.hs +94/−0
- System/Win32/HardLink/Internal.hs +31/−0
- System/Win32/Info.hsc +139/−277
- System/Win32/Info/Computer.hsc +237/−0
- System/Win32/Info/Internal.hsc +313/−0
- System/Win32/Info/Version.hsc +165/−0
- System/Win32/Mem.hsc +97/−11
- System/Win32/MinTTY.hsc +245/−0
- System/Win32/NLS.hsc +492/−36
- System/Win32/NamedPipes.hsc +276/−0
- System/Win32/Path.hsc +56/−0
- System/Win32/Path/Internal.hsc +29/−0
- System/Win32/Process.hsc +109/−12
- System/Win32/Registry.hsc +177/−77
- System/Win32/Security.hsc +19/−21
- System/Win32/Semaphore.hsc +146/−0
- System/Win32/Shell.hsc +2/−10
- System/Win32/Shell/Internal.hsc +50/−0
- System/Win32/SimpleMAPI.hsc +44/−33
- System/Win32/String.hs +51/−0
- System/Win32/SymbolicLink.hsc +93/−0
- System/Win32/SymbolicLink/Internal.hsc +26/−0
- System/Win32/Thread.hs +42/−0
- System/Win32/Time.hsc +115/−177
- System/Win32/Time/Internal.hsc +245/−0
- System/Win32/Types.hs +0/−328
- System/Win32/Types.hsc +578/−0
- System/Win32/Utils.hs +410/−0
- System/Win32/WindowsString/Console.hsc +180/−0
- System/Win32/WindowsString/DLL.hsc +67/−0
- System/Win32/WindowsString/DebugApi.hsc +33/−0
- System/Win32/WindowsString/File.hsc +269/−0
- System/Win32/WindowsString/FileMapping.hsc +107/−0
- System/Win32/WindowsString/HardLink.hs +47/−0
- System/Win32/WindowsString/Info.hsc +114/−0
- System/Win32/WindowsString/Path.hsc +52/−0
- System/Win32/WindowsString/Shell.hsc +59/−0
- System/Win32/WindowsString/String.hs +73/−0
- System/Win32/WindowsString/SymbolicLink.hsc +94/−0
- System/Win32/WindowsString/Time.hsc +60/−0
- System/Win32/WindowsString/Types.hsc +214/−0
- System/Win32/WindowsString/Utils.hs +63/−0
- System/Win32/Word.hs +23/−0
- Win32.cabal +121/−24
- cbits/alphablend.c +15/−0
- cbits/dumpBMP.c +3/−3
- changelog.md +246/−0
- include/alignment.h +3/−0
- include/alphablend.h +10/−0
- include/namedpipeapi_compat.h +16/−0
- include/tlhelp32_compat.h +26/−0
- include/wincon_compat.h +26/−0
- include/windows_cconv.h +1/−1
- include/winnls_compat.h +105/−0
- include/winnt_compat.h +13/−0
- include/winreg_compat.h +32/−0
- include/winternl_compat.h +39/−0
- include/winuser_compat.h +113/−0
Graphics/Win32.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -31,7 +31,12 @@ module Graphics.Win32.Message, module Graphics.Win32.Misc, module Graphics.Win32.Resource,- module Graphics.Win32.Window+ module Graphics.Win32.Window,+ module Graphics.Win32.LayeredWindow,+ module Graphics.Win32.Window.AnimateWindow,+ module Graphics.Win32.Window.ForegroundWindow,+ module Graphics.Win32.Window.IMM,+ module Graphics.Win32.Window.PostMessage ) where import System.Win32.Types@@ -45,3 +50,8 @@ import Graphics.Win32.Misc import Graphics.Win32.Resource import Graphics.Win32.Window+import Graphics.Win32.LayeredWindow+import Graphics.Win32.Window.AnimateWindow+import Graphics.Win32.Window.ForegroundWindow+import Graphics.Win32.Window.IMM+import Graphics.Win32.Window.PostMessage
Graphics/Win32/Control.hsc view
@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.Control
Graphics/Win32/Dialogue.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI.hs view
@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.GDI@@ -18,10 +16,10 @@ ----------------------------------------------------------------------------- {-# 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--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings+-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module Graphics.Win32.GDI (
+ Graphics/Win32/GDI/AlphaBlend.hsc view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.GDI.AlphaBlend + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provides alpha blending functionality. +-} +module Graphics.Win32.GDI.AlphaBlend where +import Foreign.Storable ( Storable(..) ) +import Foreign.Ptr ( Ptr ) +import Graphics.Win32.GDI.Types ( HDC ) +import System.Win32.Types ( BOOL, BYTE, UINT ) + +#include <windows.h> +#include "alignment.h" +##include "windows_cconv.h" + +foreign import ccall unsafe "alphablend.h" + c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> PBLENDFUNCTION -> IO BOOL +{- +We use C wrapper function to call this API. +Because foreign stacall/ccall/capi doesn't work with non-pointer user defined type. + +We think that capi should support that when user defined type has Storable class instance +and using CTYPE pragma in the scope. + +{-# LANGUAGE CApiFFI #-} + +data {-# CTYPE "windows.h" "BLENDFUNCTION" #-} BLENDFUNCTION = + +foreign import capi unsafe "windows.h AlphaBlend" + c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> BLENDFUNCTION -> IO BOOL +-} + +foreign import WINDOWS_CCONV unsafe "windows.h TransparentBlt" + c_TransparentBlt :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> UINT -> IO BOOL + +aC_SRC_OVER :: BYTE +aC_SRC_OVER = #const AC_SRC_OVER + +aC_SRC_ALPHA :: BYTE +aC_SRC_ALPHA = #const AC_SRC_ALPHA + +type PBLENDFUNCTION = Ptr BLENDFUNCTION +type LPBLENDFUNCTION = Ptr BLENDFUNCTION + +data BLENDFUNCTION = BLENDFUNCTION + { blendOp :: BYTE + , blendFlags :: BYTE + , sourceConstantAlpha :: BYTE + , alphaFormat :: BYTE + } deriving (Show) + +instance Storable BLENDFUNCTION where + sizeOf = const #size BLENDFUNCTION + alignment _ = #alignment BLENDFUNCTION + poke buf func = do + (#poke BLENDFUNCTION, BlendOp) buf (blendOp func) + (#poke BLENDFUNCTION, BlendFlags) buf (blendFlags func) + (#poke BLENDFUNCTION, SourceConstantAlpha) buf (sourceConstantAlpha func) + (#poke BLENDFUNCTION, AlphaFormat) buf (alphaFormat func) + + peek buf = do + blendOp' <- (#peek BLENDFUNCTION, BlendOp) buf + blendFlags' <- (#peek BLENDFUNCTION, BlendFlags) buf + sourceConstantAlpha' <- + (#peek BLENDFUNCTION, SourceConstantAlpha) buf + alphaFormat' <- (#peek BLENDFUNCTION, AlphaFormat) buf + return $ BLENDFUNCTION blendOp' blendFlags' sourceConstantAlpha' alphaFormat'
Graphics/Win32/GDI/Bitmap.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Brush.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Clip.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -22,11 +22,17 @@ import Control.Monad import Graphics.Win32.GDI.Types import System.Win32.Types+import Graphics.Win32.Message ( WindowMessage ) import Foreign ##include "windows_cconv.h" +#undef WINVER+#define WINVER 0x0600+#undef _WIN32_WINNT+#define _WIN32_WINNT 0x0600+ #include <windows.h> type ClipboardFormat = UINT@@ -55,7 +61,13 @@ , cF_TEXT = CF_TEXT , cF_WAVE = CF_WAVE , cF_TIFF = CF_TIFF+ , cF_DIBV5 = CF_DIBV5+ , cF_GDIOBJLAST = CF_GDIOBJLAST+ , cF_UNICODETEXT = CF_UNICODETEXT }++wM_CLIPBOARDUPDATE :: WindowMessage+wM_CLIPBOARDUPDATE = 0x031D -- #const WM_CLIPBOARDUPDATE -- Can't use constant due to GHC 7.8.x support. -- % , CF_UNICODETEXT -- WinNT only
Graphics/Win32/GDI/Font.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Graphics2D.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -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 ()
Graphics/Win32/GDI/HDC.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -42,6 +42,17 @@ efficient (fromIntegral is optimized away,) and conveys the idea we simply want the same representational value. -}++----------------------+-- Implement GetPixel+----------------------++getPixel :: HDC -> Int -> Int -> IO COLORREF+getPixel dc x y = c_GetPixel dc x y+foreign import WINDOWS_CCONV unsafe "windows.h GetPixel"+ c_GetPixel :: HDC -> Int -> Int -> IO COLORREF++---------------------- setArcDirection :: HDC -> ArcDirection -> IO ArcDirection setArcDirection dc dir =
Graphics/Win32/GDI/Palette.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Path.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Pen.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -56,7 +56,7 @@ type PenStyle = INT -#{enum PenStyle, // Pick one of these+#{enum PenStyle, , pS_SOLID = PS_SOLID // default , pS_DASH = PS_DASH // ------- , pS_DOT = PS_DOT // .......@@ -69,14 +69,14 @@ , pS_STYLE_MASK = PS_STYLE_MASK // all the above } -#{enum PenStyle , // "or" with one of these+#{enum PenStyle, , pS_ENDCAP_ROUND = PS_ENDCAP_ROUND // default , pS_ENDCAP_SQUARE = PS_ENDCAP_SQUARE , pS_ENDCAP_FLAT = PS_ENDCAP_FLAT , pS_ENDCAP_MASK = PS_ENDCAP_MASK // all the above } -#{enum PenStyle, // "or" with one of these+#{enum PenStyle, , pS_JOIN_ROUND = PS_JOIN_ROUND // default , pS_JOIN_BEVEL = PS_JOIN_BEVEL , pS_JOIN_MITER = PS_JOIN_MITER@@ -87,7 +87,7 @@ you'll have to define it. -} -#{enum PenStyle, // "or" with one of these+#{enum PenStyle, , pS_COSMETIC = PS_COSMETIC // default , pS_GEOMETRIC = PS_GEOMETRIC , pS_TYPE_MASK = PS_TYPE_MASK // all the above
Graphics/Win32/GDI/Region.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Types.hsc view
@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.GDI.Types
Graphics/Win32/Icon.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -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 =
Graphics/Win32/Key.hsc view
@@ -1,12 +1,12 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.Key--- Copyright : (c) Alastair Reid, 1997-2003+-- Copyright : (c) Alastair Reid, 1997-2003, 2013 shelarcy -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>@@ -21,88 +21,170 @@ import Control.Monad (liftM) import Graphics.Win32.GDI.Types (HWND)-import System.Win32.Types (DWORD, UINT, WORD, ptrToMaybe)+import System.Win32.Types ( DWORD, UINT, WORD, ptrToMaybe, BOOL, SHORT,+ failIfFalse_, failIfZero )+import Control.Exception ( bracket )+import Foreign.Ptr ( Ptr, nullPtr )+import Foreign.C.Types ( CWchar(..) )+import Foreign.Marshal.Array ( allocaArray, peekArray )+import System.Win32.String ( LPTSTR, LPCTSTR+ , withTString, withTStringBuffer, peekTString )+import System.Win32.Thread ( TID, getCurrentThreadId ) ##include "windows_cconv.h" #include <windows.h>+#include "winuser_compat.h" type VKey = DWORD #{enum VKey,- , vK_LBUTTON = VK_LBUTTON- , vK_RBUTTON = VK_RBUTTON- , vK_CANCEL = VK_CANCEL- , vK_MBUTTON = VK_MBUTTON- , vK_BACK = VK_BACK- , vK_TAB = VK_TAB- , vK_CLEAR = VK_CLEAR- , vK_RETURN = VK_RETURN- , vK_SHIFT = VK_SHIFT- , vK_CONTROL = VK_CONTROL- , vK_MENU = VK_MENU- , vK_PAUSE = VK_PAUSE- , vK_CAPITAL = VK_CAPITAL- , vK_ESCAPE = VK_ESCAPE- , vK_SPACE = VK_SPACE- , vK_PRIOR = VK_PRIOR- , vK_NEXT = VK_NEXT- , vK_END = VK_END- , vK_HOME = VK_HOME- , vK_LEFT = VK_LEFT- , vK_UP = VK_UP- , vK_RIGHT = VK_RIGHT- , vK_DOWN = VK_DOWN- , vK_SELECT = VK_SELECT- , vK_EXECUTE = VK_EXECUTE- , vK_SNAPSHOT = VK_SNAPSHOT- , vK_INSERT = VK_INSERT- , vK_DELETE = VK_DELETE- , vK_HELP = VK_HELP- , vK_NUMPAD0 = VK_NUMPAD0- , vK_NUMPAD1 = VK_NUMPAD1- , vK_NUMPAD2 = VK_NUMPAD2- , vK_NUMPAD3 = VK_NUMPAD3- , vK_NUMPAD4 = VK_NUMPAD4- , vK_NUMPAD5 = VK_NUMPAD5- , vK_NUMPAD6 = VK_NUMPAD6- , vK_NUMPAD7 = VK_NUMPAD7- , vK_NUMPAD8 = VK_NUMPAD8- , vK_NUMPAD9 = VK_NUMPAD9- , vK_MULTIPLY = VK_MULTIPLY- , vK_ADD = VK_ADD- , vK_SEPARATOR = VK_SEPARATOR- , vK_SUBTRACT = VK_SUBTRACT- , vK_DECIMAL = VK_DECIMAL- , vK_DIVIDE = VK_DIVIDE- , vK_F1 = VK_F1- , vK_F2 = VK_F2- , vK_F3 = VK_F3- , vK_F4 = VK_F4- , vK_F5 = VK_F5- , vK_F6 = VK_F6- , vK_F7 = VK_F7- , vK_F8 = VK_F8- , vK_F9 = VK_F9- , vK_F10 = VK_F10- , vK_F11 = VK_F11- , vK_F12 = VK_F12- , vK_F13 = VK_F13- , vK_F14 = VK_F14- , vK_F15 = VK_F15- , vK_F16 = VK_F16- , vK_F17 = VK_F17- , vK_F18 = VK_F18- , vK_F19 = VK_F19- , vK_F20 = VK_F20- , vK_F21 = VK_F21- , vK_F22 = VK_F22- , vK_F23 = VK_F23- , vK_F24 = VK_F24- , vK_NUMLOCK = VK_NUMLOCK- , vK_SCROLL = VK_SCROLL+ , vK_LBUTTON = VK_LBUTTON+ , vK_RBUTTON = VK_RBUTTON+ , vK_CANCEL = VK_CANCEL+ , vK_MBUTTON = VK_MBUTTON+ , vK_BACK = VK_BACK+ , vK_TAB = VK_TAB+ , vK_CLEAR = VK_CLEAR+ , vK_RETURN = VK_RETURN+ , vK_SHIFT = VK_SHIFT+ , vK_CONTROL = VK_CONTROL+ , vK_MENU = VK_MENU+ , vK_PAUSE = VK_PAUSE+ , vK_CAPITAL = VK_CAPITAL+ , vK_ESCAPE = VK_ESCAPE+ , vK_SPACE = VK_SPACE+ , vK_PRIOR = VK_PRIOR+ , vK_NEXT = VK_NEXT+ , vK_END = VK_END+ , vK_HOME = VK_HOME+ , vK_LEFT = VK_LEFT+ , vK_UP = VK_UP+ , vK_RIGHT = VK_RIGHT+ , vK_DOWN = VK_DOWN+ , vK_SELECT = VK_SELECT+ , vK_EXECUTE = VK_EXECUTE+ , vK_SNAPSHOT = VK_SNAPSHOT+ , vK_INSERT = VK_INSERT+ , vK_DELETE = VK_DELETE+ , vK_HELP = VK_HELP+ , vK_NUMPAD0 = VK_NUMPAD0+ , vK_NUMPAD1 = VK_NUMPAD1+ , vK_NUMPAD2 = VK_NUMPAD2+ , vK_NUMPAD3 = VK_NUMPAD3+ , vK_NUMPAD4 = VK_NUMPAD4+ , vK_NUMPAD5 = VK_NUMPAD5+ , vK_NUMPAD6 = VK_NUMPAD6+ , vK_NUMPAD7 = VK_NUMPAD7+ , vK_NUMPAD8 = VK_NUMPAD8+ , vK_NUMPAD9 = VK_NUMPAD9+ , vK_MULTIPLY = VK_MULTIPLY+ , vK_ADD = VK_ADD+ , vK_SEPARATOR = VK_SEPARATOR+ , vK_SUBTRACT = VK_SUBTRACT+ , vK_DECIMAL = VK_DECIMAL+ , vK_DIVIDE = VK_DIVIDE+ , vK_F1 = VK_F1+ , vK_F2 = VK_F2+ , vK_F3 = VK_F3+ , vK_F4 = VK_F4+ , vK_F5 = VK_F5+ , vK_F6 = VK_F6+ , vK_F7 = VK_F7+ , vK_F8 = VK_F8+ , vK_F9 = VK_F9+ , vK_F10 = VK_F10+ , vK_F11 = VK_F11+ , vK_F12 = VK_F12+ , vK_F13 = VK_F13+ , vK_F14 = VK_F14+ , vK_F15 = VK_F15+ , vK_F16 = VK_F16+ , vK_F17 = VK_F17+ , vK_F18 = VK_F18+ , vK_F19 = VK_F19+ , vK_F20 = VK_F20+ , vK_F21 = VK_F21+ , vK_F22 = VK_F22+ , vK_F23 = VK_F23+ , vK_F24 = VK_F24+ , vK_NUMLOCK = VK_NUMLOCK+ , vK_SCROLL = VK_SCROLL+ , vK_XBUTTON1 = VK_XBUTTON1+ , vK_XBUTTON2 = VK_XBUTTON2+ , vK_KANA = VK_KANA+ , vK_HANGUL = VK_HANGUL+ , vK_JUNJA = VK_JUNJA+ , vK_FINAL = VK_FINAL+ , vK_HANJA = VK_HANJA+ , vK_KANJI = VK_KANJI+ , vK_CONVERT = VK_CONVERT+ , vK_NONCONVERT = VK_NONCONVERT+ , vK_ACCEPT = VK_ACCEPT+ , vK_MODECHANGE = VK_MODECHANGE+ , vK_PRINT = VK_PRINT+ , vK_APPS = VK_APPS+ , vK_SLEEP = VK_SLEEP+ , vK_LWIN = VK_LWIN+ , vK_RWIN = VK_RWIN+ , vK_LSHIFT = VK_LSHIFT+ , vK_RSHIFT = VK_RSHIFT+ , vK_LCONTROL = VK_LCONTROL+ , vK_RCONTROL = VK_RCONTROL+ , vK_LMENU = VK_LMENU+ , vK_RMENU = VK_RMENU+ , vK_BROWSER_BACK = VK_BROWSER_BACK+ , vK_BROWSER_FORWARD = VK_BROWSER_FORWARD+ , vK_BROWSER_REFRESH = VK_BROWSER_REFRESH+ , vK_BROWSER_STOP = VK_BROWSER_STOP+ , vK_BROWSER_SEARCH = VK_BROWSER_SEARCH+ , vK_BROWSER_FAVORITES = VK_BROWSER_FAVORITES+ , vK_BROWSER_HOME = VK_BROWSER_HOME+ , vK_VOLUME_MUTE = VK_VOLUME_MUTE+ , vK_VOLUME_DOWN = VK_VOLUME_DOWN+ , vK_VOLUME_UP = VK_VOLUME_UP+ , vK_MEDIA_NEXT_TRACK = VK_MEDIA_NEXT_TRACK+ , vK_MEDIA_PREV_TRACK = VK_MEDIA_PREV_TRACK+ , vK_MEDIA_STOP = VK_MEDIA_STOP+ , vK_MEDIA_PLAY_PAUSE = VK_MEDIA_PLAY_PAUSE+ , vK_LAUNCH_MAIL = VK_LAUNCH_MAIL+ , vK_LAUNCH_MEDIA_SELECT = VK_LAUNCH_MEDIA_SELECT+ , vK_LAUNCH_APP1 = VK_LAUNCH_APP1+ , vK_LAUNCH_APP2 = VK_LAUNCH_APP2+ , vK_OEM_1 = VK_OEM_1+ , vK_OEM_PLUS = VK_OEM_PLUS+ , vK_OEM_COMMA = VK_OEM_COMMA+ , vK_OEM_MINUS = VK_OEM_MINUS+ , vK_OEM_PERIOD = VK_OEM_PERIOD+ , vK_OEM_2 = VK_OEM_2+ , vK_OEM_3 = VK_OEM_3+ , vK_OEM_4 = VK_OEM_4+ , vK_OEM_5 = VK_OEM_5+ , vK_OEM_6 = VK_OEM_6+ , vK_OEM_7 = VK_OEM_7+ , vK_OEM_8 = VK_OEM_8+ , vK_OEM_102 = VK_OEM_102+ , vK_PROCESSKEY = VK_PROCESSKEY+ , vK_PACKET = VK_PACKET+ , vK_ATTN = VK_ATTN+ , vK_CRSEL = VK_CRSEL+ , vK_EXSEL = VK_EXSEL+ , vK_EREOF = VK_EREOF+ , vK_PLAY = VK_PLAY+ , vK_ZOOM = VK_ZOOM+ , vK_NONAME = VK_NONAME+ , vK_PA1 = VK_PA1+ , vK_OEM_CLEAR = VK_OEM_CLEAR }+foreign import WINDOWS_CCONV unsafe "windows.h VkKeyScanExW"+ c_VkKeyScanEx :: CWchar -> HKL -> IO SHORT +foreign import WINDOWS_CCONV unsafe "windows.h MapVirtualKeyW"+ c_MapVirtualKey :: VKey -> UINT -> IO UINT++foreign import WINDOWS_CCONV unsafe "windows.h MapVirtualKeyExW"+ c_MapVirtualKeyEx :: VKey -> UINT -> HKL -> IO UINT+ foreign import WINDOWS_CCONV unsafe "windows.h EnableWindow" enableWindow :: HWND -> Bool -> IO Bool @@ -124,3 +206,69 @@ foreign import WINDOWS_CCONV unsafe "windows.h IsWindowEnabled" isWindowEnabled :: HWND -> IO Bool++getCurrentKeyboardLayout :: IO HKL+getCurrentKeyboardLayout = do+ tid <- getCurrentThreadId+ c_GetKeyboardLayout tid++getKeyboardLayoutList :: IO [HKL]+getKeyboardLayoutList = do+ len' <- failIfZero "GetKeyboardLayoutList" $ c_GetKeyboardLayoutList 0 nullPtr+ let len = fromIntegral len'+ allocaArray len $ \buf -> do+ _ <- failIfZero "GetKeyboardLayoutList" $ c_GetKeyboardLayoutList len buf+ peekArray len buf++getKeyboardLayoutName :: IO String+getKeyboardLayoutName+ = withTStringBuffer 256 $ \buf -> do+ failIfFalse_ "GetKeyboardLayoutName" $ c_GetKeyboardLayoutName buf+ peekTString buf++withLoadKeyboardLayout :: KeyLayoutFlags -> (HKL -> IO a) -> IO a+withLoadKeyboardLayout flag io+ = withTStringBuffer 256 $ \buf -> do+ failIfFalse_ "GetKeyboardLayoutName" $ c_GetKeyboardLayoutName buf+ bracket (c_LoadKeyboardLayout buf flag)+ unloadKeyboardLayout+ io++withLoadKeyboardLayoutWithName :: String -> KeyLayoutFlags -> (HKL -> IO a) -> IO a+withLoadKeyboardLayoutWithName str flag io+ = withTString str $ \c_str ->+ bracket (c_LoadKeyboardLayout c_str flag)+ unloadKeyboardLayout+ io++unloadKeyboardLayout :: HKL -> IO ()+unloadKeyboardLayout+ = failIfFalse_ "UnloadKeyboardLayout" . c_UnloadKeyboardLayout++foreign import WINDOWS_CCONV unsafe "windows.h GetKeyboardLayout"+ c_GetKeyboardLayout :: TID -> IO HKL++foreign import WINDOWS_CCONV unsafe "windows.h GetKeyboardLayoutList"+ c_GetKeyboardLayoutList :: Int -> (Ptr HKL) -> IO UINT++foreign import WINDOWS_CCONV unsafe "windows.h GetKeyboardLayoutNameW"+ c_GetKeyboardLayoutName :: LPTSTR -> IO BOOL++foreign import WINDOWS_CCONV unsafe "windows.h LoadKeyboardLayoutW"+ c_LoadKeyboardLayout :: LPCTSTR -> KeyLayoutFlags -> IO HKL++foreign import WINDOWS_CCONV unsafe "windows.h UnloadKeyboardLayout"+ c_UnloadKeyboardLayout :: HKL -> IO BOOL++type HKL = Ptr ()++type KeyLayoutFlags = UINT++#{enum KeyLayoutFlags,+ , kLF_ACTIVATE = KLF_ACTIVATE+ , kLF_NOTELLSHELL = KLF_NOTELLSHELL+ , kLF_REORDER = KLF_REORDER+ , kLF_REPLACELANG = KLF_REPLACELANG+ , kLF_SUBSTITUTE_OK = KLF_SUBSTITUTE_OK+ , kLF_SETFORPROCESS = KLF_SETFORPROCESS+ }
+ Graphics/Win32/LayeredWindow.hsc view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.LayeredWindow + Copyright : 2012-2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provides LayeredWindow functionality. +-} +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 Graphics.Win32.GDI.AlphaBlend ( BLENDFUNCTION ) +import Graphics.Win32.GDI.Types ( COLORREF, HDC, SIZE, SIZE, POINT ) +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" +#include "winuser_compat.h" + +toLayeredWindow :: HANDLE -> IO () +toLayeredWindow w = do + flg <- c_GetWindowLongPtr w gWL_EXSTYLE + void $ c_SetWindowLongPtr w gWL_EXSTYLE (flg .|. (fromIntegral wS_EX_LAYERED)) + +-- test w = c_SetLayeredWindowAttributes w 0 128 lWA_ALPHA + +gWL_EXSTYLE :: INT +gWL_EXSTYLE = #const GWL_EXSTYLE + +wS_EX_LAYERED :: WindowStyleEx +wS_EX_LAYERED = #const WS_EX_LAYERED + +lWA_COLORKEY, lWA_ALPHA :: DWORD +lWA_COLORKEY = #const LWA_COLORKEY +lWA_ALPHA = #const LWA_ALPHA + +foreign import WINDOWS_CCONV unsafe "windows.h SetLayeredWindowAttributes" + c_SetLayeredWindowAttributes :: HANDLE -> COLORREF -> BYTE -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetLayeredWindowAttributes" + c_GetLayeredWindowAttributes :: HANDLE -> COLORREF -> Ptr BYTE -> Ptr DWORD -> IO BOOL + +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 + +#{enum DWORD, + , uLW_ALPHA = ULW_ALPHA + , uLW_COLORKEY = ULW_COLORKEY + , uLW_OPAQUE = ULW_OPAQUE + } +
Graphics/Win32/Menu.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -79,7 +79,7 @@ checkMenuItem :: HMENU -> MenuItem -> MenuFlag -> IO Bool checkMenuItem menu item check = do- rv <- failIf (== -1) "CheckMenuItem" $ c_CheckMenuItem menu item check+ rv <- failIf (== maxBound) "CheckMenuItem" $ c_CheckMenuItem menu item check return (rv == mF_CHECKED) foreign import WINDOWS_CCONV unsafe "windows.h CheckMenuItem" c_CheckMenuItem :: HMENU -> UINT -> UINT -> IO DWORD@@ -230,13 +230,13 @@ getMenuDefaultItem :: HMENU -> Bool -> GMDIFlag -> IO MenuItem getMenuDefaultItem menu bypos flags =- failIf (== -1) "GetMenuDefaultItem" $ c_GetMenuDefaultItem menu bypos flags+ failIf (== maxBound) "GetMenuDefaultItem" $ c_GetMenuDefaultItem menu bypos flags foreign import WINDOWS_CCONV unsafe "windows.h GetMenuDefaultItem" c_GetMenuDefaultItem :: HMENU -> Bool -> UINT -> IO UINT getMenuState :: HMENU -> MenuItem -> MenuFlag -> IO MenuState getMenuState menu item flags =- failIf (== -1) "GetMenuState" $ c_GetMenuState menu item flags+ failIf (== maxBound) "GetMenuState" $ c_GetMenuState menu item flags foreign import WINDOWS_CCONV unsafe "windows.h GetMenuState" c_GetMenuState :: HMENU -> UINT -> UINT -> IO MenuState @@ -254,7 +254,7 @@ getMenuItemCount :: HMENU -> IO Int getMenuItemCount menu =- failIf (== -1) "GetMenuItemCount" $ c_GetMenuItemCount menu+ failIf (== maxBound) "GetMenuItemCount" $ c_GetMenuItemCount menu foreign import WINDOWS_CCONV unsafe "windows.h GetMenuItemCount" c_GetMenuItemCount :: HMENU -> IO Int @@ -262,7 +262,7 @@ getMenuItemID :: HMENU -> MenuItem -> IO MenuID getMenuItemID menu item =- failIf (== -1) "GetMenuItemID" $ c_GetMenuItemID menu item+ failIf (== maxBound) "GetMenuItemID" $ c_GetMenuItemID menu item foreign import WINDOWS_CCONV unsafe "windows.h GetMenuItemID" c_GetMenuItemID :: HMENU -> UINT -> IO MenuID @@ -446,23 +446,23 @@ -- Note: these 3 assume the flags don't include MF_BITMAP or MF_OWNERDRAW -- (which are hidden by this interface) -appendMenu :: HMENU -> MenuFlag -> MenuID -> String -> IO ()+appendMenu :: HMENU -> MenuFlag -> MenuID -> Maybe String -> IO () appendMenu menu flags id_item name =- withTString name $ \ c_name ->+ maybeWith withTString name $ \ c_name -> failIfFalse_ "AppendMenu" $ c_AppendMenu menu flags id_item c_name foreign import WINDOWS_CCONV unsafe "windows.h AppendMenuW" c_AppendMenu :: HMENU -> UINT -> MenuID -> LPCTSTR -> IO Bool -insertMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> String -> IO ()+insertMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> Maybe String -> IO () insertMenu menu item flags id_item name =- withTString name $ \ c_name ->+ maybeWith withTString name $ \ c_name -> failIfFalse_ "InsertMenu" $ c_InsertMenu menu item flags id_item c_name foreign import WINDOWS_CCONV unsafe "windows.h InsertMenuW" c_InsertMenu :: HMENU -> UINT -> UINT -> MenuID -> LPCTSTR -> IO Bool -modifyMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> String -> IO ()+modifyMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> Maybe String -> IO () modifyMenu menu item flags id_item name =- withTString name $ \ c_name ->+ maybeWith withTString name $ \ c_name -> failIfFalse_ "ModifyMenu" $ c_ModifyMenu menu item flags id_item c_name foreign import WINDOWS_CCONV unsafe "windows.h ModifyMenuW" c_ModifyMenu :: HMENU -> UINT -> UINT -> MenuID -> LPCTSTR -> IO Bool
Graphics/Win32/Message.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -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 } ----------------------------------------------------------------
Graphics/Win32/Misc.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -128,12 +128,12 @@ -- Note: if the error is ever raised, we're in a very sad way! -messageBox :: HWND -> String -> String -> MBStyle -> IO MBStatus+messageBox :: Maybe HWND -> String -> String -> MBStyle -> IO MBStatus messageBox wnd text caption style = withTString text $ \ c_text -> withTString caption $ \ c_caption ->- failIfZero "MessageBox" $ c_MessageBox wnd c_text c_caption style-foreign import WINDOWS_CCONV unsafe "windows.h MessageBoxW"+ failIfZero "MessageBox" $ c_MessageBox (maybePtr wnd) c_text c_caption style+foreign import WINDOWS_CCONV safe "windows.h MessageBoxW" c_MessageBox :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus ----------------------------------------------------------------@@ -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
Graphics/Win32/Resource.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/Window.hsc view
@@ -1,7 +1,5 @@ {-# LANGUAGE CApiFFI #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.Window@@ -18,24 +16,29 @@ module Graphics.Win32.Window where -import Control.Monad (liftM)+import Control.Monad (liftM, when, unless) import Data.Maybe (fromMaybe)-import Data.Word (Word32)+import Data.Int (Int32) import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (maybeWith) import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, castPtr, nullPtr)+import Foreign.Marshal.Array (allocaArray)+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) import Graphics.Win32.GDI.Types (HBRUSH, HICON, HMENU, prim_ChildWindowFromPoint) 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, LPVOID, withTString)-import System.Win32.Types (failIf, failIf_, failIfFalse_, failIfNull, maybeNum)+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" @@ -51,7 +54,7 @@ type ClassName = LPCTSTR --- Note: this is one of those rare functions which doesnt free all+-- Note: this is one of those rare functions which doesn't free all -- its String arguments. mkClassName :: String -> ClassName@@ -184,7 +187,10 @@ cW_USEDEFAULT :: Pos -- See Note [Overflow checking and fromIntegral] in Graphics/Win32/GDI/HDC.hs-cW_USEDEFAULT = fromIntegral (#{const CW_USEDEFAULT} :: Word32)+-- Weird way to essentially get a value with the top bit set. But GHC 7.8.4 was+-- rejecting all other sane attempts.+cW_USEDEFAULT = let val = negate (#{const CW_USEDEFAULT}) :: Integer+ in fromIntegral (fromIntegral val :: Int32) :: Pos type Pos = Int @@ -198,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -217,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 ->@@ -232,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@@ -246,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@@ -257,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@@ -319,6 +389,41 @@ c_SetWindowText :: HWND -> LPCTSTR -> IO Bool ----------------------------------------------------------------+-- Getting window text/label+----------------------------------------------------------------+-- For getting the title bar text. +-- If the window has no title bar or text, if the title bar is empty,+-- or if the window or control handle is invalid, the return value is zero.+-- If invalid handle throws exception.+-- If size <= 0 throws exception.++getWindowText :: HWND -> Int -> IO String+getWindowText wnd size + | size <= 0 = errorWin "GetWindowTextW"+ | otherwise = do+ allocaArray size $ \ p_buf -> do+ _ <- c_GetWindowText wnd p_buf size+ failUnlessSuccess "GetWindowTextW" getLastError+ peekTString p_buf+foreign import WINDOWS_CCONV "windows.h GetWindowTextW"+ c_GetWindowText :: HWND -> LPTSTR -> Int -> IO Int++----------------------------------------------------------------+-- Getting window text length+----------------------------------------------------------------+-- For getting the title bar text length. +-- If the window has no text, the return value is zero.+-- If invalid handle throws exception.+ +getWindowTextLength :: HWND -> IO Int+getWindowTextLength wnd = do+ size' <- c_GetWindowTextLength wnd+ failUnlessSuccess "GetWindowTextLengthW" getLastError+ return size'+foreign import WINDOWS_CCONV "windows.h GetWindowTextLengthW"+ c_GetWindowTextLength :: HWND -> IO Int+ +---------------------------------------------------------------- -- Paint struct ---------------------------------------------------------------- @@ -369,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 ----------------------------------------------------------------@@ -469,19 +577,24 @@ foreign import WINDOWS_CCONV unsafe "windows.h EndDeferWindowPos" c_EndDeferWindowPos :: HDWP -> IO Bool -findWindow :: String -> String -> IO (Maybe HWND)+findWindow :: Maybe String -> Maybe String -> IO (Maybe HWND) findWindow cname wname =- withTString cname $ \ c_cname ->- withTString wname $ \ c_wname ->+ maybeWith withTString cname $ \ c_cname ->+ maybeWith withTString wname $ \ c_wname -> liftM ptrToMaybe $ c_FindWindow c_cname c_wname++{-# DEPRECATED findWindowByName "Use 'findWindow Nothing' instead." #-}+findWindowByName :: String -> IO (Maybe HWND)+findWindowByName wname = findWindow Nothing $ Just wname+ foreign import WINDOWS_CCONV unsafe "windows.h FindWindowW" c_FindWindow :: LPCTSTR -> LPCTSTR -> IO HWND -findWindowEx :: HWND -> HWND -> String -> String -> IO (Maybe HWND)+findWindowEx :: Maybe HWND -> Maybe HWND -> Maybe String -> Maybe String -> IO (Maybe HWND) findWindowEx parent after cname wname =- withTString cname $ \ c_cname ->- withTString wname $ \ c_wname ->- liftM ptrToMaybe $ c_FindWindowEx parent after c_cname c_wname+ maybeWith withTString cname $ \ c_cname ->+ maybeWith withTString wname $ \ c_wname ->+ liftM ptrToMaybe $ c_FindWindowEx (maybePtr parent) (maybePtr after) c_cname c_wname foreign import WINDOWS_CCONV unsafe "windows.h FindWindowExW" c_FindWindowEx :: HWND -> HWND -> LPCTSTR -> LPCTSTR -> IO HWND @@ -500,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@@ -642,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
+ Graphics/Win32/Window/AnimateWindow.hsc view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.AnimateWindow + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide AnimatedWindow function and flags. +-} +module Graphics.Win32.Window.AnimateWindow where +import Graphics.Win32.GDI.Types ( HWND ) +import System.Win32.Types ( DWORD, BOOL, failIfFalse_ ) + +#include <windows.h> +##include "windows_cconv.h" +#include "winuser_compat.h" + +type AnimateWindowType = DWORD + +#{enum AnimateWindowType, + , aW_SLIDE = AW_SLIDE + , aW_ACTIVATE = AW_ACTIVATE + , aW_BLEND = AW_BLEND + , aW_HIDE = AW_HIDE + , aW_CENTER = AW_CENTER + , aW_HOR_POSITIVE = AW_HOR_POSITIVE + , aW_HOR_NEGATIVE = AW_HOR_NEGATIVE + , aW_VER_POSITIVE = AW_VER_POSITIVE + , aW_VER_NEGATIVE = AW_VER_NEGATIVE + } + +animateWindow :: HWND -> DWORD -> AnimateWindowType -> IO () +animateWindow hwnd dwTime dwFlags + = failIfFalse_ "AnimateWindow" $ c_AnimateWindow hwnd dwTime dwFlags + +foreign import WINDOWS_CCONV "windows.h AnimateWindow" + c_AnimateWindow :: HWND -> DWORD -> AnimateWindowType -> IO BOOL
+ Graphics/Win32/Window/ForegroundWindow.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.ForegroundWindow + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Get/Set Foreground Window. +-} + +module Graphics.Win32.Window.ForegroundWindow + ( getForegroundWindow + , setForegroundWindow + , c_SetForegroundWindow + , allowSetForegroundWindow + , c_AllowSetForegroundWindow + ) where + +import Control.Monad ( void ) +import Graphics.Win32.GDI.Types ( HWND ) +import Graphics.Win32.Window ( getForegroundWindow ) +import System.Win32.Process ( ProcessId ) + +#include "windows_cconv.h" + +---------------------------------------------------------------- +-- | Setting Window to Foreground. +-- See: <https://github.com/haskell/win32/pull/9>, +-- <http://stackoverflow.com/questions/14297146/win32-setforegroundwindow-in-haskell>. +---------------------------------------------------------------- +setForegroundWindow :: HWND -> IO Bool +setForegroundWindow = c_SetForegroundWindow + +foreign import WINDOWS_CCONV safe "windows.h SetForegroundWindow" + c_SetForegroundWindow :: HWND -> IO Bool + +---------------------------------------------------------------- +-- | Allow other process to set Window to Foreground +-- by using 'setForegroundWindow' function. +allowSetForegroundWindow :: ProcessId -> IO () +allowSetForegroundWindow = void . c_AllowSetForegroundWindow + +foreign import WINDOWS_CCONV safe "windows.h AllowSetForegroundWindow" + c_AllowSetForegroundWindow :: ProcessId -> IO Bool
+ Graphics/Win32/Window/HotKey.hsc view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.HotKey + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + An FFI binding to the hot key part of the Win32 API. +-} +module Graphics.Win32.Window.HotKey where + +import Data.Bits ( (.|.) ) +import Graphics.Win32.GDI.Types ( HWND, MbHWND ) +import Graphics.Win32.Key ( VKey ) +import Graphics.Win32.Message ( WindowMessage ) +import System.Win32.Types ( UINT, BOOL, maybePtr, failIfFalse_ ) +import System.Win32.Exception.Unsupported ( unsupportedVal, upgradeWindowsOS ) +import System.Win32.Info.Version ( is7OrLater ) + +#include <windows.h> +##include "windows_cconv.h" + +type FsModifiers = [FsModifier] +type FsModifier = UINT + +#{enum FsModifier, + , mOD_ALT = MOD_ALT + , mOD_CONTROL = MOD_CONTROL + , mOD_SHIFT = MOD_SHIFT + , mOD_WIN = MOD_WIN +} + +-- | This parameter requires to use Windows 7 or later. +mOD_NOREPEAT :: FsModifier +mOD_NOREPEAT + = unsupportedVal "MOD_NOREPEAT" + is7OrLater (upgradeWindowsOS "Windows 7") 0x4000 +{- + , mOD_NOREPEAT = MOD_NOREPEAT +-} + +wM_HOTKEY :: WindowMessage +wM_HOTKEY = #const WM_HOTKEY + +joinModifiers :: FsModifiers -> FsModifier +joinModifiers = foldr (.|.) 0 + +registerHotKey :: MbHWND -> Int -> FsModifier -> VKey -> IO () +registerHotKey mb_wnd kid md vkey = + failIfFalse_ (unwords ["RegisterHotKey", show mb_wnd, show kid, show md, show vkey]) + $ c_RegisterHotKey (maybePtr mb_wnd) kid md vkey + +foreign import WINDOWS_CCONV "windows.h RegisterHotKey" + c_RegisterHotKey :: HWND -> Int -> UINT -> VKey -> IO BOOL + +unregisterHotKey :: MbHWND -> Int -> IO () +unregisterHotKey mb_wnd kid = + failIfFalse_ (unwords ["UnregisterHotKey", show mb_wnd, show kid]) + $ c_UnregisterHotKey (maybePtr mb_wnd) kid + +foreign import WINDOWS_CCONV "windows.h UnregisterHotKey" + c_UnregisterHotKey :: HWND -> Int -> IO BOOL
+ Graphics/Win32/Window/IMM.hsc view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.IMM + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + An FFI binding to the IMM (Input Method Manager) part of the Win32 API. +-} +module Graphics.Win32.Window.IMM where +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Utils ( fromBool ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( peek ) +import Graphics.Win32.GDI.Types ( HWND ) +import Graphics.Win32.Key ( VKey ) +import System.Win32.Types ( UINT, DWORD, LPDWORD, BOOL, failIfFalse_ ) + +#include <windows.h> +##include "windows_cconv.h" + +type HIMC = Ptr () + +foreign import WINDOWS_CCONV "windows.h ImmGetContext" + immGetContext :: HWND -> IO HIMC + +foreign import WINDOWS_CCONV "windows.h ImmGetOpenStatus" + immGetOpenStatus :: HIMC -> IO BOOL + +immSetOpenStatus :: HIMC -> BOOL -> IO () +immSetOpenStatus imc flg = + failIfFalse_ (unwords ["ImmSetOpenStatus", show imc, show flg]) + $ c_ImmSetOpenStatus imc (fromBool flg) + +foreign import WINDOWS_CCONV "windows.h ImmSetOpenStatus" + c_ImmSetOpenStatus :: HIMC -> UINT -> IO BOOL + + +data IMEMode = IMEMode DWORD DWORD + +immGetConversionStatus :: HIMC -> IO IMEMode +immGetConversionStatus imc = + alloca $ \lpConv -> + alloca $ \lpStnc -> do + failIfFalse_ (unwords ["ImmGetConversionStatus", show imc, show lpConv, show lpStnc]) $ + c_ImmGetConversionStatus imc lpConv lpStnc + conv <- peek lpConv + stnc <- peek lpStnc + return $ IMEMode conv stnc + +foreign import WINDOWS_CCONV "windows.h ImmGetConversionStatus" + c_ImmGetConversionStatus :: HIMC -> LPDWORD -> LPDWORD -> IO BOOL + +immSetConversionStatus :: HIMC -> IMEMode -> IO () +immSetConversionStatus imc (IMEMode conv stnc) = + failIfFalse_ (unwords ["ImmSetConversionStatus", show imc, show conv, show stnc]) + $ c_ImmSetConversionStatus imc conv stnc + +foreign import WINDOWS_CCONV "windows.h ImmSetConversionStatus" + c_ImmSetConversionStatus :: HIMC -> DWORD -> DWORD -> IO BOOL + +-- iMN_SETCONVERSIONSTATUS = #const IMN_SETCONVERSIONSTATUS + +#{enum DWORD, + , iME_CMODE_ALPHANUMERIC = IME_CMODE_ALPHANUMERIC + , iME_CMODE_CHARCODE = IME_CMODE_CHARCODE + , iME_CMODE_EUDC = IME_CMODE_EUDC + , iME_CMODE_FIXED = IME_CMODE_FIXED + , iME_CMODE_FULLSHAPE = IME_CMODE_FULLSHAPE + , iME_CMODE_HANJACONVERT = IME_CMODE_HANJACONVERT + , iME_CMODE_KATAKANA = IME_CMODE_KATAKANA + , iME_CMODE_NATIVE = IME_CMODE_NATIVE + , iME_CMODE_NOCONVERSION = IME_CMODE_NOCONVERSION + , iME_CMODE_ROMAN = IME_CMODE_ROMAN + , iME_CMODE_SOFTKBD = IME_CMODE_SOFTKBD + , iME_CMODE_SYMBOL = IME_CMODE_SYMBOL + } + +#{enum DWORD, + , iME_SMODE_AUTOMATIC = IME_SMODE_AUTOMATIC + , iME_SMODE_NONE = IME_SMODE_NONE + , iME_SMODE_PHRASEPREDICT = IME_SMODE_PHRASEPREDICT + , iME_SMODE_PLAURALCLAUSE = IME_SMODE_PLAURALCLAUSE + , iME_SMODE_SINGLECONVERT = IME_SMODE_SINGLECONVERT + } +{- + , iME_SMODE_CONVERSATION = IME_SMODE_CONVERSATION +-} + +immReleaseContext :: HWND -> HIMC -> IO () +immReleaseContext wnd imc = + failIfFalse_ (unwords ["ImmSetOpenStatus", show wnd, show imc]) + $ c_ImmReleaseContext wnd imc + +foreign import WINDOWS_CCONV "windows.h ImmReleaseContext" + c_ImmReleaseContext :: HWND -> HIMC -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h ImmGetVirtualKey" + immGetVirtualKey :: HWND -> IO VKey + +immSimulateHotKey :: HWND -> DWORD -> IO () +immSimulateHotKey hwd hkey = + failIfFalse_ (unwords ["ImmSimulateHotKey", show hwd, show hkey]) + $ c_ImmSimulateHotKey hwd hkey + +foreign import WINDOWS_CCONV "windows.h ImmSimulateHotKey" + c_ImmSimulateHotKey :: HWND -> DWORD -> IO BOOL
+ Graphics/Win32/Window/PostMessage.hsc view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.PostMessage + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide PostMessage function and friends. +-} +module Graphics.Win32.Window.PostMessage where + +import Foreign.C.Types ( CIntPtr(..) ) +import Graphics.Win32.GDI.Types ( HWND, MbHWND ) +import Graphics.Win32.Message ( WindowMessage ) +import System.Win32.Types ( DWORD, WPARAM, LPARAM, BOOL + , maybePtr, castUINTPtrToPtr, failIfFalse_ ) + +#include <windows.h> +##include "windows_cconv.h" + +postMessage :: MbHWND -> WindowMessage -> WPARAM -> LPARAM -> IO () +postMessage mb_wnd msg w l = + failIfFalse_ (unwords ["PostMessage", show mb_wnd, show msg, show w, show l]) $ + c_PostMessage (maybePtr mb_wnd) msg w l + +foreign import WINDOWS_CCONV "windows.h PostMessageW" + c_PostMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h PostQuitMessage" + postQuitMessage :: Int -> IO () + +postThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO () +postThreadMessage tId msg w l = + failIfFalse_ (unwords ["PostThreadMessage", show tId, show msg, show w, show l]) $ + c_PostThreadMessage tId msg w l + +foreign import WINDOWS_CCONV "windows.h PostThreadMessageW" + c_PostThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL + +#{enum HWND, castUINTPtrToPtr + , hWND_BROADCAST = (UINT_PTR)HWND_BROADCAST + } + +foreign import WINDOWS_CCONV "windows.h InSendMessage" + inSendMessage :: IO Bool
LICENSE view
@@ -1,5 +1,6 @@ Copyright (c) 1997-2003, Alastair Reid Copyright (c) 2006, Esa Ilari Vuokko+Copyright (c) 2012-2013, shelarcy All rights reserved. Redistribution and use in source and binary forms, with or without
+ Media/Win32.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-} +{- | + Module : Media.Win32 + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Multimedia API. TODO: provide more functions ... +-} + +module Media.Win32 + ( module Media.Win32 + ) where +import Control.Monad ( unless ) +import Prelude hiding ( ioError, userError ) +import System.IO.Error ( ioError, userError ) +import System.Win32.Encoding ( encodeMultiByte, getCurrentCodePage ) +import System.Win32.Types +import System.Win32.String ( withTStringBufferLen ) + +type MCIERROR = DWORD + +#include "windows_cconv.h" + +mciSendString :: String -> IO () +mciSendString cmd + = withTString cmd $ \sendCmd -> do + err <- c_mciSendString sendCmd nullPtr 0 nullPtr + unless (err == 0) + $ mciGetErrorString err + +foreign import WINDOWS_CCONV safe "windows.h mciSendStringW" + c_mciSendString :: LPCTSTR -> LPTSTR -> UINT -> HANDLE -> IO MCIERROR + +mciGetErrorString :: MCIERROR -> IO () +mciGetErrorString err + = withTStringBufferLen 256 $ \(cstr, len) -> do + failIfFalse_ (unwords ["mciGetErrorString", show err]) $ + c_mciGetErrorString err cstr $ fromIntegral len + msg <- peekTString cstr + cp <- getCurrentCodePage + ioError $ userError $ encodeMultiByte cp msg + +foreign import WINDOWS_CCONV unsafe "windows.h mciGetErrorStringW" + c_mciGetErrorString :: MCIERROR -> LPTSTR -> UINT -> IO BOOL
− Setup.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMainWithHooks autoconfUserHooks
System/Win32.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -19,10 +19,12 @@ module System.Win32 ( module System.Win32.DLL+ , module System.Win32.Event , module System.Win32.File , module System.Win32.FileMapping , module System.Win32.Info , module System.Win32.Mem+ , module System.Win32.MinTTY , module System.Win32.NLS , module System.Win32.Process , module System.Win32.Registry@@ -31,13 +33,20 @@ , module System.Win32.Security , module System.Win32.Types , module System.Win32.Shell+ , module System.Win32.Automation+ , module System.Win32.HardLink+ , module System.Win32.SymbolicLink+ , module System.Win32.Thread+ , module System.Win32.Utils ) where import System.Win32.DLL+import System.Win32.Event import System.Win32.File import System.Win32.FileMapping import System.Win32.Info import System.Win32.Mem+import System.Win32.MinTTY import System.Win32.NLS hiding ( LCID, LANGID, SortID, SubLANGID , PrimaryLANGID, mAKELCID, lANGIDFROMLCID , sORTIDFROMLCID, mAKELANGID, pRIMARYLANGID@@ -49,6 +58,12 @@ import System.Win32.Types import System.Win32.Security import System.Win32.Shell++import System.Win32.Automation+import System.Win32.HardLink+import System.Win32.SymbolicLink+import System.Win32.Thread+import System.Win32.Utils hiding ( try ) ---------------------------------------------------------------- -- End
+ System/Win32/Automation.hs view
@@ -0,0 +1,15 @@+{- | + Module : System.Win32.Automation + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide sendInput function and INPUT types. +-} +module System.Win32.Automation + ( module System.Win32.Automation.Input + ) where +import System.Win32.Automation.Input
+ System/Win32/Automation/Input.hsc view
@@ -0,0 +1,130 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Automation.Input + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide sendInput function and INPUT types. +-} +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 + +import Data.Bits ( (.|.) ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable(..) ) +import Foreign.Marshal.Array ( withArrayLen ) +import Foreign.C.Types ( CIntPtr(..) ) +import Graphics.Win32.Key ( VKey, c_MapVirtualKey ) +import System.Win32.Automation.Input.Key +import System.Win32.Automation.Input.Mouse ( MOUSEINPUT ) +import System.Win32.Automation.Input.Mouse hiding ( MOUSEINPUT(..) ) +import System.Win32.Types ( UINT, LPARAM, failIfZero ) +import System.Win32.Word ( DWORD, WORD ) + +#include <windows.h> +#include "alignment.h" +##include "windows_cconv.h" +#include "winuser_compat.h" + +sendInput :: [INPUT] -> IO UINT +sendInput input + = withArrayLen input $ \len c_input -> + sendInputPtr len c_input + +{-# INLINE sendInputPtr #-} +-- | Raw pointer of array version of 'sendInput'. +-- Use this function to support non-list sequence. +sendInputPtr :: Int -> Ptr INPUT -> IO UINT +sendInputPtr len c_input + = failIfZero "SendInput" $ + c_SendInput (fromIntegral len) c_input $ sizeOf (undefined :: INPUT) + +foreign import WINDOWS_CCONV unsafe "windows.h SendInput" + c_SendInput :: UINT -> LPINPUT -> Int -> IO UINT + +makeKeyboardInput :: VKey -> Maybe DWORD -> IO INPUT +makeKeyboardInput vkey flag = do + let flag' = maybe kEYEVENTF_EXTENDEDKEY (kEYEVENTF_EXTENDEDKEY .|.) flag + scan <- c_MapVirtualKey vkey 0 + dwExtraInfo' <- getMessageExtraInfo + return $ Keyboard + $ KEYBDINPUT { + wVk = fromIntegral vkey + , wScan = fromIntegral scan + , dwFlags = flag' + , time = 0 + , dwExtraInfo = fromIntegral $ dwExtraInfo' + } + +type PINPUT = Ptr INPUT +type LPINPUT = Ptr INPUT + +data INPUT = Mouse MOUSEINPUT | Keyboard KEYBDINPUT | OtherHardware HARDWAREINPUT + deriving Show + +instance Storable INPUT where + sizeOf = const #{size INPUT} + alignment _ = #alignment INPUT + + poke buf (Mouse mouse) = do + (#poke INPUT, type) buf (#{const INPUT_MOUSE}:: DWORD) + (#poke INPUT, mi) buf mouse + poke buf (Keyboard key) = do + (#poke INPUT, type) buf (#{const INPUT_KEYBOARD} :: DWORD) + (#poke INPUT, ki) buf key + poke buf (OtherHardware hard) = do + (#poke INPUT, type) buf (#{const INPUT_HARDWARE} :: DWORD) + (#poke INPUT, hi) buf hard + + peek buf = do + type' <- (#peek INPUT, type) buf :: IO DWORD + case type' of + #{const INPUT_MOUSE} -> + Mouse `fmap` (#peek INPUT, mi) buf + #{const INPUT_KEYBOARD} -> + Keyboard `fmap` (#peek INPUT, ki) buf + _ -> OtherHardware `fmap` (#peek INPUT, hi) buf + + +type PHARDWAREINPUT = Ptr HARDWAREINPUT + +data HARDWAREINPUT = HARDWAREINPUT + { uMsg :: DWORD + , wParamL :: WORD + , wParamH :: WORD + } deriving Show + +instance Storable HARDWAREINPUT where + sizeOf = const #{size HARDWAREINPUT} + alignment _ = #alignment HARDWAREINPUT + poke buf input = do + (#poke HARDWAREINPUT, uMsg) buf (uMsg input) + (#poke HARDWAREINPUT, wParamL) buf (wParamL input) + (#poke HARDWAREINPUT, wParamH) buf (wParamH input) + peek buf = do + uMsg' <- (#peek HARDWAREINPUT, uMsg) buf + wParamL' <- (#peek HARDWAREINPUT, wParamL) buf + wParamH' <- (#peek HARDWAREINPUT, wParamH) buf + return $ HARDWAREINPUT uMsg' wParamL' wParamH' + +foreign import WINDOWS_CCONV unsafe "windows.h GetMessageExtraInfo" + getMessageExtraInfo :: IO LPARAM + +foreign import WINDOWS_CCONV unsafe "windows.h SetMessageExtraInfo" + setMessageExtraInfo :: LPARAM -> IO LPARAM
+ System/Win32/Automation/Input/Key.hsc view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Automation.Input.Key + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Keyboard input events +-} +module System.Win32.Automation.Input.Key where +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.Types ( ULONG_PTR ) +import System.Win32.Word ( DWORD, WORD ) + +#include <windows.h> +#include "winuser_compat.h" +#include "alignment.h" + +type PKEYBDINPUT = Ptr KEYBDINPUT + +data KEYBDINPUT = KEYBDINPUT + { wVk :: WORD + , wScan :: WORD + , dwFlags :: DWORD + , time :: DWORD + , dwExtraInfo :: ULONG_PTR + } deriving Show + +instance Storable KEYBDINPUT where + sizeOf = const #{size KEYBDINPUT} + alignment _ = #alignment KEYBDINPUT + poke buf input = do + (#poke KEYBDINPUT, wVk) buf (wVk input) + (#poke KEYBDINPUT, wScan) buf (wScan input) + (#poke KEYBDINPUT, dwFlags) buf (dwFlags input) + (#poke KEYBDINPUT, time) buf (time input) + (#poke KEYBDINPUT, dwExtraInfo) buf (dwExtraInfo input) + peek buf = do + wVk' <- (#peek KEYBDINPUT, wVk) buf + wScan' <- (#peek KEYBDINPUT, wScan) buf + dwFlags' <- (#peek KEYBDINPUT, dwFlags) buf + time' <- (#peek KEYBDINPUT, time) buf + dwExtraInfo' <- (#peek KEYBDINPUT, dwExtraInfo) buf + return $ KEYBDINPUT wVk' wScan' dwFlags' time' dwExtraInfo' + +#{enum DWORD, + , kEYEVENTF_EXTENDEDKEY = KEYEVENTF_EXTENDEDKEY + , kEYEVENTF_KEYUP = KEYEVENTF_KEYUP + , kEYEVENTF_SCANCODE = KEYEVENTF_SCANCODE + , kEYEVENTF_UNICODE = KEYEVENTF_UNICODE + }
+ System/Win32/Automation/Input/Mouse.hsc view
@@ -0,0 +1,76 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Automation.Input.Mouse + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Mouse input events +-} +module System.Win32.Automation.Input.Mouse where +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.Types ( LONG, ULONG_PTR ) +import System.Win32.Word ( DWORD ) + +#include <windows.h> +#include "winuser_compat.h" +#include "alignment.h" + +type PMOUSEINPUT = Ptr MOUSEINPUT + +data MOUSEINPUT = MOUSEINPUT + { dx :: LONG + , dy :: LONG + , mouseData :: DWORD + , dwFlags :: DWORD + , time :: DWORD + , dwExtraInfo :: ULONG_PTR + } deriving Show + +instance Storable MOUSEINPUT where + sizeOf = const #{size MOUSEINPUT} + alignment _ = #alignment MOUSEINPUT + poke buf input = do + (#poke MOUSEINPUT, dx) buf (dx input) + (#poke MOUSEINPUT, dy) buf (dy input) + (#poke MOUSEINPUT, mouseData) buf (mouseData input) + (#poke MOUSEINPUT, dwFlags) buf (dwFlags input) + (#poke MOUSEINPUT, time) buf (time input) + (#poke MOUSEINPUT, dwExtraInfo) buf (dwExtraInfo input) + peek buf = do + dx' <- (#peek MOUSEINPUT, dx) buf + dy' <- (#peek MOUSEINPUT, dy) buf + mouseData' <- (#peek MOUSEINPUT, mouseData) buf + dwFlags' <- (#peek MOUSEINPUT, dwFlags) buf + time' <- (#peek MOUSEINPUT, time) buf + dwExtraInfo' <- (#peek MOUSEINPUT, dwExtraInfo) buf + return $ MOUSEINPUT dx' dy' mouseData' dwFlags' time' dwExtraInfo' + +#{enum DWORD, + , xBUTTON1 = XBUTTON1 + , xBUTTON2 = XBUTTON2 + } + +#{enum DWORD, + , mOUSEEVENTF_ABSOLUTE = MOUSEEVENTF_ABSOLUTE + , mOUSEEVENTF_MOVE = MOUSEEVENTF_MOVE + , mOUSEEVENTF_LEFTDOWN = MOUSEEVENTF_LEFTDOWN + , mOUSEEVENTF_LEFTUP = MOUSEEVENTF_LEFTUP + , mOUSEEVENTF_RIGHTDOWN = MOUSEEVENTF_RIGHTDOWN + , mOUSEEVENTF_RIGHTUP = MOUSEEVENTF_RIGHTUP + , mOUSEEVENTF_MIDDLEDOWN = MOUSEEVENTF_MIDDLEDOWN + , mOUSEEVENTF_MIDDLEUP = MOUSEEVENTF_MIDDLEUP + , mOUSEEVENTF_WHEEL = MOUSEEVENTF_WHEEL + , mOUSEEVENTF_XDOWN = MOUSEEVENTF_XDOWN + , mOUSEEVENTF_XUP = MOUSEEVENTF_XUP + } + +{- + , mOUSEEVENTF_VIRTUALDESK = MOUSEEVENTF_VIRTUALDESK -- I don't know why we can't find this + , mOUSEEVENTF_HWHEEL = MOUSEEVENTF_HWHEEL + , mOUSEEVENTF_MOVE_NOCOALESCE = MOUSEEVENTF_MOVE_NOCOALESCE +-}
System/Win32/Console.hsc view
@@ -1,7 +1,7 @@ #if __GLASGOW_HASKELL__ >= 709 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} +#else +{-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | @@ -18,6 +18,23 @@ ----------------------------------------------------------------------------- module System.Win32.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, @@ -25,30 +42,84 @@ setConsoleOutputCP, -- * Ctrl events CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT, - generateConsoleCtrlEvent + 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, + -- * Console I/O + KEY_EVENT_RECORD(..), + MOUSE_EVENT_RECORD(..), + WINDOW_BUFFER_SIZE_RECORD(..), + MENU_EVENT_RECORD(..), + FOCUS_EVENT_RECORD(..), + INPUT_RECORD(..), + readConsoleInput ) where +#include <windows.h> +#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) -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP" - getConsoleCP :: IO UINT +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.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, peekArray0) +import Foreign.Marshal.Alloc (alloca) -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCP" - setConsoleCP :: UINT -> IO () -foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleOutputCP" - getConsoleOutputCP :: IO UINT +getConsoleMode :: HANDLE -> IO DWORD +getConsoleMode h = alloca $ \ptr -> do + failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr + peek ptr -foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleOutputCP" - setConsoleOutputCP :: UINT -> IO () +setConsoleMode :: HANDLE -> DWORD -> IO () +setConsoleMode h mode = failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h mode -type CtrlEvent = DWORD -#{enum CtrlEvent, - , cTRL_C_EVENT = 0 - , cTRL_BREAK_EVENT = 1 - } +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 :: DWORD +eNABLE_ECHO_INPUT = 4 +eNABLE_EXTENDED_FLAGS = 128 +eNABLE_INSERT_MODE = 32 +eNABLE_LINE_INPUT = 2 +eNABLE_MOUSE_INPUT = 16 +eNABLE_PROCESSED_INPUT = 1 +eNABLE_QUICK_EDIT_MODE = 64 +eNABLE_WINDOW_INPUT = 8 +eNABLE_VIRTUAL_TERMINAL_INPUT = 512 +eNABLE_PROCESSED_OUTPUT = 1 +eNABLE_WRAP_AT_EOL_OUTPUT = 2 +eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 +dISABLE_NEWLINE_AUTO_RETURN = 8 +eNABLE_LVB_GRID_WORLDWIDE = 16 generateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO () generateConsoleCtrlEvent e p @@ -56,7 +127,126 @@ "generateConsoleCtrlEvent" $ c_GenerateConsoleCtrlEvent e p -foreign import WINDOWS_CCONV safe "windows.h GenerateConsoleCtrlEvent" - c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL +-- | 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 [] +commandLineToArgv arg = + do withCWString 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 --- ToDo: lots more +-- | Based on 'GetCommandLineW'. This behaves slightly different +-- than 'System.Environment.getArgs'. See the online documentation: +-- <https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getcommandlinew> +getArgs :: IO [String] +getArgs = do + getCommandLineW >>= peekTString >>= commandLineToArgv + +getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO +getConsoleScreenBufferInfo h = alloca $ \ptr -> do + failIfFalse_ "GetConsoleScreenBufferInfo" $ c_GetConsoleScreenBufferInfo h ptr + peek ptr + +getCurrentConsoleScreenBufferInfo :: IO CONSOLE_SCREEN_BUFFER_INFO +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
+ System/Win32/Console/CtrlHandler.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Console.CtrlHandler + Copyright : 2008-2013 Judah Jacobson, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Set handlers of console Ctrl events. +-} +module System.Win32.Console.CtrlHandler + ( CtrlEvent, Handler, PHANDLER_ROUTINE + , withConsoleCtrlHandler + , setConsoleCtrlHandler, c_SetConsoleCtrlHandler + , mkHandler + , cTRL_C_EVENT, cTRL_BREAK_EVENT + ) where + +import Control.Exception ( bracket ) +import Control.Monad ( void ) +import Foreign.Ptr ( FunPtr ) +import System.Win32.Console ( CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT ) +import System.Win32.Types ( BOOL, failIfFalse_ ) + +#include "windows_cconv.h" + +type Handler = CtrlEvent -> IO BOOL +-- type HandlerRoutine = Handler +type PHANDLER_ROUTINE = FunPtr Handler + +withConsoleCtrlHandler :: Handler -> IO a -> IO a +withConsoleCtrlHandler handler io + = bracket (do hd <- mkHandler handler + -- don't fail if we can't set the Ctrl-C handler + -- for example, we might not be attached to a console? + void $ c_SetConsoleCtrlHandler hd True + return hd) + (\hd -> void $ c_SetConsoleCtrlHandler hd False) + $ const io + +-- | This function isn't suitable when we want to set the cTRL_C_EVENT handler. +-- If you want to set the cTRL_C_EVENT handler, use 'c_SetConsoleCtrlHandler' instead. +setConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO () +setConsoleCtrlHandler handler flag + = failIfFalse_ "SetConsoleCtrlHandler" + $ c_SetConsoleCtrlHandler handler flag + +foreign import WINDOWS_CCONV "wrapper" mkHandler :: Handler -> IO PHANDLER_ROUTINE +foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" + c_SetConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO BOOL
+ System/Win32/Console/HWND.hs view
@@ -0,0 +1,34 @@+{- | + Module : System.Win32.Console.HWND + Copyright : 2009 Balazs Komuves, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Get the handle of the current console window. +-} +module System.Win32.Console.HWND (getConsoleHWND) where +import Control.Concurrent ( threadDelay ) +import Control.Exception ( bracket ) +import Foreign.Ptr ( nullPtr ) +import Graphics.Win32.Window ( c_FindWindow ) +import Graphics.Win32.GDI.Types ( HWND ) +import System.Win32.Console.Title ( getConsoleTitle, setConsoleTitle ) +import System.Win32.Process ( getCurrentProcessId ) +import System.Win32.String ( withTString ) +import System.Win32.Time ( getTickCount ) + +-- | Get the handle of the current console window by using window's title. +-- See: <http://support.microsoft.com/kb/124103> +getConsoleHWND :: IO HWND +getConsoleHWND + = bracket getConsoleTitle setConsoleTitle $ \_ -> do + time <- getTickCount + pid <- getCurrentProcessId + let unique = show time ++ show pid + setConsoleTitle unique + threadDelay (42*1000) + withTString unique $ \punique -> + c_FindWindow nullPtr punique
+ System/Win32/Console/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- Internals for Console modules.+--+-----------------------------------------------------------------------------++module System.Win32.Console.Internal where++#include <windows.h>+#include "alignment.h"+##include "windows_cconv.h"+#include "wincon_compat.h"++import System.Win32.Types+import Graphics.Win32.GDI.Types (COLORREF)++import Foreign.C.Types (CInt(..), 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
+ System/Win32/Console/Title.hsc view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Console.Title + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Get/Set the title for the current console window. +-} +module System.Win32.Console.Title + ( getConsoleTitle + , setConsoleTitle + ) where + +import System.Win32.String ( LPTSTR, LPCTSTR + , withTStringBufferLen, withTString, peekTStringLen ) +import System.Win32.Types ( BOOL, failIfFalse_, failIfZero ) +import System.Win32.Word ( DWORD ) + +#include <windows.h> +##include "windows_cconv.h" + +getConsoleTitle :: IO String +getConsoleTitle = + withTStringBufferLen maxLength $ \(buf, len) -> do + len' <- failIfZero "GetConsoleTitle" + $ c_GetConsoleTitle buf (fromIntegral len) + peekTStringLen (buf, (fromIntegral len')) + where + maxLength = #const MAX_PATH + +setConsoleTitle :: String -> IO () +setConsoleTitle title = + withTString title $ \buf -> + failIfFalse_ (unwords ["SetConsoleTitle", title]) + $ c_SetConsoleTitle buf + +foreign import WINDOWS_CCONV "windows.h GetConsoleTitleW" + c_GetConsoleTitle :: LPTSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h SetConsoleTitleW" + c_SetConsoleTitle :: LPCTSTR -> IO BOOL +
System/Win32/DLL.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,72 +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--##include "windows_cconv.h"--#include <windows.h>+import Data.Maybe (fromMaybe) 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+
+ System/Win32/DLL/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- 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 <windows.h>++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
System/Win32/DebugApi.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -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@@ -66,7 +115,7 @@ | SingleStep | StackOverflow deriving (Show)- + data DebugEventInfo = UnknownDebugEvent | Exception ExceptionInfo Exception@@ -94,12 +143,12 @@ where dwZero = 0 :: DWORD wZero = 0 :: WORD- - rest (#const EXCEPTION_DEBUG_EVENT) p = do- chance <- (#peek EXCEPTION_DEBUG_INFO, dwFirstChance) p- flags <- (#peek EXCEPTION_RECORD, ExceptionFlags) p- addr <- (#peek EXCEPTION_RECORD, ExceptionAddress) p- code <- (#peek EXCEPTION_RECORD, ExceptionCode) p++ rest (#const EXCEPTION_DEBUG_EVENT) p' = do+ chance <- (#peek EXCEPTION_DEBUG_INFO, dwFirstChance) p'+ flags <- (#peek EXCEPTION_RECORD, ExceptionFlags) p'+ addr <- (#peek EXCEPTION_RECORD, ExceptionAddress) p'+ code <- (#peek EXCEPTION_RECORD, ExceptionCode) p' e <- case code::DWORD of (#const EXCEPTION_ACCESS_VIOLATION) -> return $ AccessViolation False 0 (#const EXCEPTION_ARRAY_BOUNDS_EXCEEDED) -> return ArrayBoundsExceeded@@ -121,55 +170,55 @@ (#const EXCEPTION_PRIV_INSTRUCTION) -> return PrivilegedInstruction (#const EXCEPTION_SINGLE_STEP) -> return SingleStep (#const EXCEPTION_STACK_OVERFLOW) -> return StackOverflow- _ -> return UnknownException + _ -> return UnknownException return $ Exception (chance/=dwZero, flags==dwZero, addr) e - rest (#const CREATE_THREAD_DEBUG_EVENT) p = do- handle <- (#peek CREATE_THREAD_DEBUG_INFO, hThread) p- local <- (#peek CREATE_THREAD_DEBUG_INFO, lpThreadLocalBase) p- start <- (#peek CREATE_THREAD_DEBUG_INFO, lpStartAddress) p+ rest (#const CREATE_THREAD_DEBUG_EVENT) p' = do+ handle <- (#peek CREATE_THREAD_DEBUG_INFO, hThread) p'+ local <- (#peek CREATE_THREAD_DEBUG_INFO, lpThreadLocalBase) p'+ start <- (#peek CREATE_THREAD_DEBUG_INFO, lpStartAddress) p' return $ CreateThread (handle, local, start) - rest (#const CREATE_PROCESS_DEBUG_EVENT) p = do- file <- (#peek CREATE_PROCESS_DEBUG_INFO, hFile) p- proc <- (#peek CREATE_PROCESS_DEBUG_INFO, hProcess) p- thread <- (#peek CREATE_PROCESS_DEBUG_INFO, hThread) p- imgbase <- (#peek CREATE_PROCESS_DEBUG_INFO, lpBaseOfImage) p- dbgoff <- (#peek CREATE_PROCESS_DEBUG_INFO, dwDebugInfoFileOffset) p- dbgsize <- (#peek CREATE_PROCESS_DEBUG_INFO, nDebugInfoSize) p- local <- (#peek CREATE_PROCESS_DEBUG_INFO, lpThreadLocalBase) p- start <- (#peek CREATE_PROCESS_DEBUG_INFO, lpStartAddress) p- imgname <- (#peek CREATE_PROCESS_DEBUG_INFO, lpImageName) p- --unicode <- (#peek CREATE_PROCESS_DEBUG_INFO, fUnicode) p- return $ CreateProcess proc + rest (#const CREATE_PROCESS_DEBUG_EVENT) p' = do+ file <- (#peek CREATE_PROCESS_DEBUG_INFO, hFile) p'+ proc <- (#peek CREATE_PROCESS_DEBUG_INFO, hProcess) p'+ thread <- (#peek CREATE_PROCESS_DEBUG_INFO, hThread) p'+ imgbase <- (#peek CREATE_PROCESS_DEBUG_INFO, lpBaseOfImage) p'+ dbgoff <- (#peek CREATE_PROCESS_DEBUG_INFO, dwDebugInfoFileOffset) p'+ dbgsize <- (#peek CREATE_PROCESS_DEBUG_INFO, nDebugInfoSize) p'+ local <- (#peek CREATE_PROCESS_DEBUG_INFO, lpThreadLocalBase) p'+ start <- (#peek CREATE_PROCESS_DEBUG_INFO, lpStartAddress) p'+ imgname <- (#peek CREATE_PROCESS_DEBUG_INFO, lpImageName) p'+ --unicode <- (#peek CREATE_PROCESS_DEBUG_INFO, fUnicode) p'+ return $ CreateProcess proc (file, imgbase, dbgoff, dbgsize, imgname) --, unicode/=wZero) (thread, local, start)- - rest (#const EXIT_THREAD_DEBUG_EVENT) p =- (#peek EXIT_THREAD_DEBUG_INFO, dwExitCode) p >>= return.ExitThread- - rest (#const EXIT_PROCESS_DEBUG_EVENT) p =- (#peek EXIT_PROCESS_DEBUG_INFO, dwExitCode) p >>= return.ExitProcess- - rest (#const LOAD_DLL_DEBUG_EVENT) p = do- file <- (#peek LOAD_DLL_DEBUG_INFO, hFile) p- imgbase <- (#peek LOAD_DLL_DEBUG_INFO, lpBaseOfDll) p- dbgoff <- (#peek LOAD_DLL_DEBUG_INFO, dwDebugInfoFileOffset) p- dbgsize <- (#peek LOAD_DLL_DEBUG_INFO, nDebugInfoSize) p- imgname <- (#peek LOAD_DLL_DEBUG_INFO, lpImageName) p- --unicode <- (#peek LOAD_DLL_DEBUG_INFO, fUnicode) p- return $ ++ rest (#const EXIT_THREAD_DEBUG_EVENT) p' =+ (#peek EXIT_THREAD_DEBUG_INFO, dwExitCode) p' >>= return.ExitThread++ rest (#const EXIT_PROCESS_DEBUG_EVENT) p' =+ (#peek EXIT_PROCESS_DEBUG_INFO, dwExitCode) p' >>= return.ExitProcess++ rest (#const LOAD_DLL_DEBUG_EVENT) p' = do+ file <- (#peek LOAD_DLL_DEBUG_INFO, hFile) p'+ imgbase <- (#peek LOAD_DLL_DEBUG_INFO, lpBaseOfDll) p'+ dbgoff <- (#peek LOAD_DLL_DEBUG_INFO, dwDebugInfoFileOffset) p'+ dbgsize <- (#peek LOAD_DLL_DEBUG_INFO, nDebugInfoSize) p'+ imgname <- (#peek LOAD_DLL_DEBUG_INFO, lpImageName) p'+ --unicode <- (#peek LOAD_DLL_DEBUG_INFO, fUnicode) p'+ return $ LoadDll (file, imgbase, dbgoff, dbgsize, imgname)--, unicode/=wZero) - rest (#const OUTPUT_DEBUG_STRING_EVENT) p = do- dat <- (#peek OUTPUT_DEBUG_STRING_INFO, lpDebugStringData) p- unicode <- (#peek OUTPUT_DEBUG_STRING_INFO, fUnicode) p- length <- (#peek OUTPUT_DEBUG_STRING_INFO, nDebugStringLength) p- return $ DebugString dat (unicode/=wZero) length- - rest (#const UNLOAD_DLL_DEBUG_EVENT) p =- (#peek UNLOAD_DLL_DEBUG_INFO, lpBaseOfDll) p >>= return.UnloadDll+ rest (#const OUTPUT_DEBUG_STRING_EVENT) p' = do+ dat <- (#peek OUTPUT_DEBUG_STRING_INFO, lpDebugStringData) p'+ unicode <- (#peek OUTPUT_DEBUG_STRING_INFO, fUnicode) p'+ len <- (#peek OUTPUT_DEBUG_STRING_INFO, nDebugStringLength) p'+ return $ DebugString dat (unicode/=wZero) len + rest (#const UNLOAD_DLL_DEBUG_EVENT) p' =+ (#peek UNLOAD_DLL_DEBUG_INFO, lpBaseOfDll) p' >>= return.UnloadDll+ rest _ _ = return UnknownDebugEvent @@ -191,9 +240,9 @@ where getMore e = case e of Nothing -> return []- Just e -> do+ Just e' -> do rest <- waitForDebugEvent (Just 0) >>= getMore- return $ e:rest+ return $ e':rest continueDebugEvent :: DebugEventId -> Bool -> IO () continueDebugEvent (pid,tid) cont =@@ -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,7 +427,8 @@ 6 -> (#offset CONTEXT, Dr6) 7 -> (#offset CONTEXT, Dr7) _ -> undefined- +#endif+ setReg :: Ptr a -> Int -> DWORD -> IO () setReg = pokeByteOff @@ -362,50 +451,5 @@ -- On process being debugged outputDebugString :: String -> IO ()-outputDebugString s = withTString s $ \s -> c_OutputDebugString 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+outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s -foreign import WINDOWS_CCONV "windows.h DebugBreak"- debugBreak :: IO ()
+ System/Win32/DebugApi/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- 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 ()
+ System/Win32/Encoding.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Encoding + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Enocode/Decode mutibyte character using Win32 API. +-} + +module System.Win32.Encoding + ( getCurrentCodePage + , encodeMultiByte + , encodeMultiByteIO + , decodeMultiByte + , decodeMultiByteIO + , wideCharToMultiByte + , multiByteToWideChar + ) where + +import Foreign.C.Types (CInt(..)) +import Foreign.C.String (peekCAStringLen, withCWStringLen) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Marshal.Unsafe (unsafeLocalState) +import System.Win32.Console +import System.Win32.NLS +import System.Win32.Types + +#include "windows_cconv.h" + +-- note CodePage = UInt which might not work on Win64. But the Win32 package +-- also has this issue. +getCurrentCodePage :: IO DWORD +getCurrentCodePage = do + conCP <- getConsoleCP + if conCP > 0 + then return conCP + else getACP + +-- | 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 +-- code page for the console, use `getCurrentCodePage`. +-- +encodeMultiByte :: CodePage -> String -> String +encodeMultiByte cp = unsafeLocalState . encodeMultiByteIO cp + +encodeMultiByteIO :: CodePage -> String -> IO String +encodeMultiByteIO _ "" = return "" + -- WideCharToMultiByte doesn't handle empty strings +encodeMultiByteIO cp wstr = + withCWStringLen wstr $ \(cwstr,len) -> do + mbchars' <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte + cp + 0 + cwstr + (fromIntegral len) + nullPtr 0 + nullPtr nullPtr + -- mbchar' is the length of buffer required + allocaArray (fromIntegral mbchars') $ \mbstr -> do + mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte + cp + 0 + cwstr + (fromIntegral len) + mbstr mbchars' + nullPtr nullPtr + peekCAStringLen (mbstr,fromIntegral mbchars) -- converts [Char] to UTF-16 + +foreign import WINDOWS_CCONV "WideCharToMultiByte" + wideCharToMultiByte + :: CodePage + -> DWORD -- dwFlags, + -> LPCWSTR -- lpWideCharStr + -> CInt -- cchWideChar + -> LPSTR -- lpMultiByteStr + -> CInt -- cbMultiByte + -> LPCSTR -- lpMultiByteStr + -> LPBOOL -- lpbFlags + -> IO CInt + +-- | 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, +-- use `getCurrentCodePage`. +decodeMultiByte :: CodePage -> String -> String +decodeMultiByte cp = unsafeLocalState . decodeMultiByteIO cp + +-- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO` +-- for alias of `stringToUnicode`. +decodeMultiByteIO :: CodePage -> String -> IO String +decodeMultiByteIO = stringToUnicode +{-# INLINE decodeMultiByteIO #-}
+ System/Win32/Event.hsc view
@@ -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 <ei@vuokko.info>+-- 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
+ System/Win32/Exception/Unsupported.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveDataTypeable #-} +{- | + Module : System.Win32.Exception.Unsupported + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Exception handling if using unsupported Win32 API. +-} + +module System.Win32.Exception.Unsupported + ( module System.Win32.Exception.Unsupported + ) where + +import Control.Exception ( Exception(..), throwIO ) +import Data.Typeable ( Typeable ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.Marshal.Unsafe ( unsafeLocalState ) + +---------------------------------------------------------------- +-- Exception type of Unsupported +---------------------------------------------------------------- +data Unsupported = MissingLibrary FilePath String + | MissingFunction String String + | MissingValue String String + deriving Typeable + +instance Show Unsupported where + show (MissingLibrary name reason) + = "Can't load library \"" ++ name ++ "\". " ++ reason + show (MissingFunction name reason) + = "Can't find \"" ++ name ++ "\" function. " ++ reason + show (MissingValue name reason) + = "Can't use \"" ++ name ++ "\" value. " ++ reason + +instance Exception Unsupported + +missingLibrary :: FilePath -> Unsupported +missingFunction, missingValue :: String -> Unsupported +missingLibrary name = MissingLibrary name "" +missingFunction name = MissingFunction name "" +missingValue name = MissingValue name "" + +missingWin32Function, missingWin32Value :: String -> String -> Unsupported +missingWin32Function name reason = MissingFunction name $ doesn'tSupport ++ '\n':reason +missingWin32Value name reason = MissingValue name $ doesn'tSupport ++ '\n':reason + +doesn'tSupport, upgradeVista, removed :: String +doesn'tSupport = "Because it's not supported on this OS." +upgradeVista = upgradeWindowsOS "Windows Vista" +removed = "It's removed. " + +upgradeWindowsOS :: String -> String +upgradeWindowsOS ver + = "If you want to use it, please upgrade your OS to " + ++ ver ++ " or higher." + +unsupportedIfNull :: Unsupported -> IO (Ptr a) -> IO (Ptr a) +unsupportedIfNull wh act = do + v <- act + if v /= nullPtr then return v else throwIO wh + +unsupportedVal :: String -> IO Bool -> String -> a -> a +unsupportedVal name checkVer reason val = unsafeLocalState $ do + cv <- checkVer + if cv then return val else throwIO $ MissingValue name reason +
System/Win32/File.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -18,294 +18,249 @@ ----------------------------------------------------------------------------- module System.Win32.File-{-- ( AccessMode, ShareMode, CreateMode, FileAttributeOrFlag- , CreateFile, CloseHandle, DeleteFile, CopyFile- , MoveFileFlag, MoveFile, MoveFileEx,- )--}-where--import System.Win32.Types-import System.Win32.Time--import Foreign hiding (void)-import Control.Monad-import Control.Concurrent--##include "windows_cconv.h"--#include <windows.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- }--------------------------------------------------------------------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- }+ ( -- * 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_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- }+ -- * 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 BinaryType = DWORD+ -- * Drive types+ , DriveType+ , dRIVE_UNKNOWN+ , dRIVE_NO_ROOT_DIR+ , dRIVE_REMOVABLE+ , dRIVE_FIXED+ , dRIVE_REMOTE+ , dRIVE_CDROM+ , dRIVE_RAMDISK -#{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- }+ -- * 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 FileNotificationFlag = 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 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- }+ -- * 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 FileType = DWORD+ -- * GetFileEx information levels+ , GET_FILEEX_INFO_LEVELS+ , getFileExInfoStandard+ , getFileExMaxInfoLevel -#{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- }+ -- * 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 = sizeOf- 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 = sizeOf- 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 <windows.h>+#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@@ -335,166 +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 -> String -> MoveFileFlag -> IO ()+moveFileEx :: String -> Maybe String -> MoveFileFlag -> IO () moveFileEx src dest flags =- withTString src $ \ c_src ->- 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---type OVERLAPPED =--- (DWORD, -- Offset--- DWORD, -- OffsetHigh--- HANDLE) -- hEvent--type LPOVERLAPPED = Ptr ()--type MbLPOVERLAPPED = Maybe LPOVERLAPPED- --Sigh - I give up & prefix win32_ to the next two to avoid -- senseless Prelude name clashes. --sof. @@ -503,20 +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 --- missing Seek functioinality; GSL ???--- Dont have Word64; ADR--- %fun SetFilePointer :: HANDLE -> Word64 -> FilePtrDirection -> IO Word64+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 ---------------------------------------------------------------- -- File Notifications@@ -527,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 ->@@ -562,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@@ -580,56 +499,31 @@ 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 ---------------------------------------------------------------- -defineDosDevice :: DefineDosDeviceFlags -> String -> String -> IO ()+defineDosDevice :: DefineDosDeviceFlags -> String -> Maybe String -> IO () defineDosDevice flags name path =- 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 ->@@ -641,16 +535,47 @@ 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 :: String -> String -> IO ()+setVolumeLabel :: Maybe String -> Maybe String -> IO () setVolumeLabel path name =- withTString path $ \ c_path ->- 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+----------------------------------------------------------------++-- | Locks a given range in a file handle, To lock an entire file+-- use 0xFFFFFFFFFFFFFFFF for size and 0 for offset.+lockFile :: HANDLE -- ^ CreateFile handle+ -> LockMode -- ^ Locking mode+ -> DWORD64 -- ^ Size of region to lock+ -> DWORD64 -- ^ Beginning offset of file to lock+ -> IO BOOL -- ^ Indicates if locking was successful, if not query+ -- getLastError.+lockFile hwnd mode size f_offset =+ do let s_low = fromIntegral (size .&. 0xFFFFFFFF)+ s_hi = fromIntegral (size `shiftR` 32)+ o_low = fromIntegral (f_offset .&. 0xFFFFFFFF)+ o_hi = fromIntegral (f_offset `shiftR` 32)+ ovlp = OVERLAPPED 0 0 o_low o_hi nullPtr+ with ovlp $ \ptr -> c_LockFileEx hwnd mode 0 s_low s_hi ptr++-- | 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+ -> DWORD64 -- ^ Size of region to unlock+ -> DWORD64 -- ^ Beginning offset of file to unlock+ -> IO BOOL -- ^ Indicates if unlocking was successful, if not query+ -- getLastError.+unlockFile hwnd size f_offset =+ do let s_low = fromIntegral (size .&. 0xFFFFFFFF)+ s_hi = fromIntegral (size `shiftR` 32)+ o_low = fromIntegral (f_offset .&. 0xFFFFFFFF)+ 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 ---------------------------------------------------------------- -- End
+ System/Win32/File/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- 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 <windows.h>+#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+----------------------------------------------------------------
System/Win32/FileMapping.hsc view
@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -14,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@@ -24,9 +54,7 @@ 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 ) ##include "windows_cconv.h"@@ -54,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@@ -107,42 +127,24 @@ (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 createFileMapping mh flags mosize name =- maybeWith withTString name $ \name ->- failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow 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 String -> IO HANDLE openFileMapping access inherit name =- maybeWith withTString name $ \name ->+ maybeWith withTString name $ \c_name -> failIf (==nullPtr) "openFileMapping: OpenFileMapping" $- c_OpenFileMapping access inherit name+ c_OpenFileMapping access inherit c_name mapViewOfFileEx :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> Ptr a -> IO (Ptr b)-mapViewOfFileEx h access offset size base = +mapViewOfFileEx h access offset size base = failIfNull "mapViewOfFile(Ex): c_MapViewOfFileEx" $ c_MapViewOfFileEx h access ohi olow size base where@@ -154,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 ())
+ System/Win32/FileMapping/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- 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 ())
+ System/Win32/HardLink.hs view
@@ -0,0 +1,94 @@+{-# 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 supports this functionality. + + * ReFS doesn't support hard link currently. +-} +module System.Win32.HardLink + ( createHardLink + , createHardLink' + ) where + +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. +-- +-- If you want to create hard link by Windows way, use 'createHardLink'' instead. +createHardLink :: FilePath -- ^ Target file path + -> FilePath -- ^ Hard link name + -> IO () +createHardLink = flip createHardLink' + +createHardLink' :: FilePath -- ^ Hard link name + -> FilePath -- ^ 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 + + +{- +-- We plan to check file system type internally. + +-- We are thinking about API design, currently... +data VolumeInformation = VolumeInformation + { volumeName :: String + , volumeSerialNumber :: DWORD + , maximumComponentLength :: DWORD + , fileSystemFlags :: DWORD + , fileSystemName :: String + } deriving Show + +getVolumeInformation :: Maybe String -> IO VolumeInformation +getVolumeInformation drive = + maybeWith withTString drive $ \c_drive -> + withTStringBufferLen 256 $ \(vnBuf, vnLen) -> + alloca $ \serialNum -> + alloca $ \maxLen -> + alloca $ \fsFlags -> + withTStringBufferLen 256 $ \(fsBuf, fsLen) -> do + failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $ + c_GetVolumeInformation c_drive vnBuf (fromIntegral vnLen) + serialNum maxLen fsFlags + fsBuf (fromIntegral fsLen) + return VolumeInformation + <*> peekTString vnBuf + <*> peek serialNum + <*> peek maxLen + <*> peek fsFlags + <*> peekTString fsBuf + +-- Which is better? +getVolumeFileType :: String -> IO String +getVolumeFileType drive = fileSystemName <$> getVolumeInformation drive + +getVolumeFileType :: String -> IO String +getVolumeFileType drive = + withTString drive $ \c_drive -> + withTStringBufferLen 256 $ \(buf, len) -> do + failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $ + c_GetVolumeInformation c_drive nullPtr 0 nullPtr nullPtr nullPtr buf (fromIntegral len) + peekTString buf + +foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW" + c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL +-}
+ System/Win32/HardLink/Internal.hs view
@@ -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
System/Win32/Info.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,16 +17,127 @@ -- ----------------------------------------------------------------------------- -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, LPCTSTR, LPTSTR, LPVOID, UINT, WORD)-import System.Win32.Types (failIfZero, peekTStringLen, withTString)+import System.Win32.Types (failIfFalse_, peekTStringLen, withTString, try) #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch)@@ -35,6 +146,7 @@ ##include "windows_cconv.h" #include <windows.h>+#include "alignment.h" ---------------------------------------------------------------- -- Environment Strings@@ -63,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 ---------------------------------------------------------------- @@ -109,6 +186,7 @@ getCurrentDirectory :: IO String getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512+ getTemporaryDirectory :: IO String getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 @@ -118,11 +196,23 @@ try "getFullPathName" (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512 -searchPath :: Maybe String -> FilePath -> String -> IO (Maybe FilePath)+getLongPathName :: FilePath -> IO FilePath+getLongPathName name = do+ withTString name $ \ c_name ->+ try "getLongPathName"+ (c_GetLongPathName c_name) 512++getShortPathName :: FilePath -> IO FilePath+getShortPathName name = do+ withTString name $ \ c_name ->+ try "getShortPathName"+ (c_GetShortPathName c_name) 512++searchPath :: Maybe String -> FilePath -> Maybe String -> IO (Maybe FilePath) searchPath path filename ext = maybe ($ nullPtr) withTString path $ \p_path -> withTString filename $ \p_filename ->- withTString ext $ \p_ext ->+ 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@@ -131,212 +221,15 @@ then return Nothing else ioError e --- 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 String-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--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 "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 = sizeOf- 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 ----------------------------------------------------------------@@ -352,44 +245,13 @@ -- %fun GetUserName :: IO String -------------------------------------------------------------------- Version Info--------------------------------------------------------------------- %fun GetVersionEx :: IO VersionInfo------ typedef struct _OSVERSIONINFO{--- DWORD dwOSVersionInfoSize;--- DWORD dwMajorVersion;--- DWORD dwMinorVersion;--- DWORD dwBuildNumber;--- DWORD dwPlatformId;--- TCHAR szCSDVersion[ 128 ];--- } OSVERSIONINFO;--------------------------------------------------------------------- Processor features------------------------------------------------------------------------ Including these lines causes problems on Win95--- %fun IsProcessorFeaturePresent :: ProcessorFeature -> Bool------ type ProcessorFeature = DWORD--- %dis processorFeature x = dWORD x------ %const ProcessorFeature--- % [ PF_FLOATING_POINT_PRECISION_ERRATA--- % , PF_FLOATING_POINT_EMULATED--- % , PF_COMPARE_EXCHANGE_DOUBLE--- % , PF_MMX_INSTRUCTIONS_AVAILABLE--- % ]--------------------------------------------------------------------- System Parameter Information--------------------------------------------------------------------- %fun SystemParametersInfo :: ?? -> Bool -> IO ??+getUserName :: IO String+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
+ System/Win32/Info/Computer.hsc view
@@ -0,0 +1,237 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Info.Computer + Copyright : 2012-2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Information about your computer. +-} +module System.Win32.Info.Computer + ( -- * Environment Strings + expandEnvironmentStrings, c_ExpandEnvironmentStrings + + -- * Computer Name + , getComputerName, setComputerName + , c_GetComputerName, c_SetComputerName + + -- * System metrics + , getSystemMetrics + , sM_CMONITORS + , sM_IMMENABLED + , sM_MOUSEWHEELPRESENT + , sM_REMOTESESSION + , sM_SAMEDISPLAYFORMAT + , sM_XVIRTUALSCREEN + , sM_YVIRTUALSCREEN + , sM_SERVERR2 + , sM_MEDIACENTER + , sM_STARTER + , sM_TABLETPC + + -- * User name + , getUserName, c_GetUserName + + -- * Version Info + , OSVERSIONINFOEX(..), POSVERSIONINFOEX, LPOSVERSIONINFOEX + , ProductType(..) + , getVersionEx, c_GetVersionEx + + -- * Processor features + , ProcessorFeature + , isProcessorFeaturePresent + , pF_3DNOW_INSTRUCTIONS_AVAILABLE + , pF_COMPARE_EXCHANGE_DOUBLE + , pF_FLOATING_POINT_EMULATED + , pF_FLOATING_POINT_PRECISION_ERRATA + , pF_MMX_INSTRUCTIONS_AVAILABLE + , pF_PAE_ENABLED + , pF_RDTSC_INSTRUCTION_AVAILABLE + , pF_XMMI_INSTRUCTIONS_AVAILABLE + , pF_XMMI64_INSTRUCTIONS_AVAILABLE + ) where + +import Foreign.Marshal.Utils ( with ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.Info ( SMSetting ) +import System.Win32.Info.Version +import System.Win32.String ( LPCTSTR, LPTSTR, withTString, withTStringBuffer + , peekTString, peekTStringLen ) +import System.Win32.Types ( BOOL, failIfFalse_ ) +import System.Win32.Utils ( tryWithoutNull ) +import System.Win32.Word ( DWORD, LPDWORD ) + +#include <windows.h> +#include <lmcons.h> +#include "alignment.h" +##include "windows_cconv.h" + +---------------------------------------------------------------- +-- Environment Strings +---------------------------------------------------------------- +expandEnvironmentStrings :: String -> IO String +expandEnvironmentStrings name = + withTString name $ \ c_name -> + tryWithoutNull (unwords ["ExpandEnvironmentStrings", name]) + (\buf len -> c_ExpandEnvironmentStrings c_name buf len) 512 + +foreign import WINDOWS_CCONV unsafe "windows.h ExpandEnvironmentStringsW" + c_ExpandEnvironmentStrings :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD + +---------------------------------------------------------------- +-- Computer Name +---------------------------------------------------------------- + +getComputerName :: IO String +getComputerName = + withTStringBuffer maxLength $ \buf -> + with (fromIntegral maxLength) $ \len -> do + failIfFalse_ "GetComputerName" + $ c_GetComputerName buf len + len' <- peek len + peekTStringLen (buf, (fromIntegral len')) + where + maxLength = #const MAX_PATH + +foreign import WINDOWS_CCONV unsafe "GetComputerNameW" + c_GetComputerName :: LPTSTR -> LPDWORD -> IO Bool + +setComputerName :: String -> IO () +setComputerName name = + withTString name $ \buf -> + failIfFalse_ (unwords ["SetComputerName", name]) + $ c_SetComputerName buf + +foreign import WINDOWS_CCONV unsafe "SetComputerNameW" + c_SetComputerName :: LPTSTR -> IO Bool +{- +type COMPUTER_NAME_FORMAT = UINT +{enum COMPUTER_NAME_FORMAT, + , computerNameNetBIOS = ComputerNameNetBIOS + , computerNameDnsHostname = ComputerNameDnsHostname + , computerNameDnsDomain = ComputerNameDnsDomain + , computerNameDnsFullyQualified = ComputerNameDnsFullyQualified + , computerNamePhysicalNetBIOS = ComputerNamePhysicalNetBIOS + , computerNamePhysicalDnsHostname = ComputerNamePhysicalDnsHostname + , computerNamePhysicalDnsDomain = ComputerNamePhysicalDnsFullyQualified + , computerNamePhysicalDnsFullyQualified = ComputerNamePhysicalDnsFullyQualified + , computerNameMax = ComputerNameMax + } +-} + +---------------------------------------------------------------- +-- Hardware Profiles +---------------------------------------------------------------- +{- +-- TODO: Decide HW_PROFILE_INFO type design + +type LPHW_PROFILE_INFO = Ptr HW_PROFILE_INFO + +data HW_PROFILE_INFO = HW_PROFILE_INFO + { dwDockInfo :: DWORD + , szHwProfileGuid :: String -- Should we use GUID type instead of String? + , szHwProfileName :: String + } deriving Show + +instance Storable HW_PROFILE_INFO where + sizeOf = const #{size HW_PROFILE_INFOW} + alignment _ = #alignment HW_PROFILE_INFOW + poke buf info = do + (#poke HW_PROFILE_INFOW, dwDockInfo) buf (dwDockInfo info) + withTString (szHwProfileGuid info) $ \szHwProfileGuid' -> + (#poke HW_PROFILE_INFOW, szHwProfileGuid) buf szHwProfileGuid' + withTString (szHwProfileName info) $ \szHwProfileName' -> + (#poke HW_PROFILE_INFOW, szHwProfileName) buf szHwProfileName' + + peek buf = do + dockInfo <- (#peek HW_PROFILE_INFOW, dwDockInfo) buf + hwProfileGuid <- peekTString $ (#ptr HW_PROFILE_INFOW, szHwProfileGuid) buf + hwProfileName <- peekTString $ (#ptr HW_PROFILE_INFOW, szHwProfileName) buf + return $ HW_PROFILE_INFO dockInfo hwProfileGuid hwProfileName + +getCurrentHwProfile :: IO HW_PROFILE_INFO +getCurrentHwProfile = + alloca $ \buf -> do + failIfFalse_ "GetCurrentHwProfile" + $ c_GetCurrentHwProfile buf + peek buf + +foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentHwProfileW" + c_GetCurrentHwProfile :: LPHW_PROFILE_INFO -> IO Bool +-} + +---------------------------------------------------------------- +-- System metrics +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h GetSystemMetrics" + getSystemMetrics :: SMSetting -> IO Int + +#{enum SMSetting, + , sM_CMONITORS = SM_CMONITORS + , sM_IMMENABLED = SM_IMMENABLED + , sM_MOUSEWHEELPRESENT = SM_MOUSEWHEELPRESENT + , sM_REMOTESESSION = SM_REMOTESESSION + , sM_SAMEDISPLAYFORMAT = SM_SAMEDISPLAYFORMAT + , sM_XVIRTUALSCREEN = SM_XVIRTUALSCREEN + , sM_YVIRTUALSCREEN = SM_YVIRTUALSCREEN + , sM_SERVERR2 = SM_SERVERR2 + , sM_MEDIACENTER = SM_MEDIACENTER + , sM_STARTER = SM_STARTER + , sM_TABLETPC = SM_TABLETPC + } + +---------------------------------------------------------------- +-- User name +---------------------------------------------------------------- + +-- | Get user name. See: <https://github.com/haskell/win32/issues/8>, <http://lpaste.net/41521> +getUserName :: IO String +getUserName = + withTStringBuffer maxLength $ \buf -> + with (fromIntegral maxLength) $ \len -> do + failIfFalse_ "GetComputerName" + $ c_GetUserName buf len + -- GetUserNameW includes NUL character. + peekTString buf + where + -- This requires Lmcons.h + maxLength = #const UNLEN + +foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW" + c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool + +---------------------------------------------------------------- +-- Processor features +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h IsProcessorFeaturePresent" + isProcessorFeaturePresent :: ProcessorFeature -> IO BOOL + +type ProcessorFeature = DWORD + +#{enum ProcessorFeature, + , pF_3DNOW_INSTRUCTIONS_AVAILABLE = PF_3DNOW_INSTRUCTIONS_AVAILABLE + , pF_COMPARE_EXCHANGE_DOUBLE = PF_COMPARE_EXCHANGE_DOUBLE + , pF_FLOATING_POINT_EMULATED = PF_FLOATING_POINT_EMULATED + , pF_FLOATING_POINT_PRECISION_ERRATA = PF_FLOATING_POINT_PRECISION_ERRATA + , pF_MMX_INSTRUCTIONS_AVAILABLE = PF_MMX_INSTRUCTIONS_AVAILABLE + , pF_PAE_ENABLED = PF_PAE_ENABLED + , pF_RDTSC_INSTRUCTION_AVAILABLE = PF_RDTSC_INSTRUCTION_AVAILABLE + , pF_XMMI_INSTRUCTIONS_AVAILABLE = PF_XMMI_INSTRUCTIONS_AVAILABLE + , pF_XMMI64_INSTRUCTIONS_AVAILABLE = PF_XMMI64_INSTRUCTIONS_AVAILABLE + } + +{- + , pF_CHANNELS_ENABLED = PF_CHANNELS_ENABLED + , pF_NX_ENABLED = PF_NX_ENABLED + , pF_COMPARE_EXCHANGE128 = PF_COMPARE_EXCHANGE128 + , pF_COMPARE64_EXCHANGE128 = PF_COMPARE64_EXCHANGE128 + , pF_SECOND_LEVEL_ADDRESS_TRANSLATION = PF_SECOND_LEVEL_ADDRESS_TRANSLATION + , pF_SSE3_INSTRUCTIONS_AVAILABLE = PF_SSE3_INSTRUCTIONS_AVAILABLE + , pF_VIRT_FIRMWARE_ENABLED = PF_VIRT_FIRMWARE_ENABLED + , pF_XSAVE_ENABLED = PF_XSAVE_ENABLED +-}
+ System/Win32/Info/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- 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 <windows.h>+#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+----------------------------------------------------------------
+ System/Win32/Info/Version.hsc view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Info.Version + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Version information about your computer. +-} +module System.Win32.Info.Version + ( -- * Version Info + OSVERSIONINFOEX(..), POSVERSIONINFOEX, LPOSVERSIONINFOEX + , ProductType(..) + , getVersionEx, c_GetVersionEx + + -- * Verify OS version + , isVistaOrLater, is7OrLater + ) where + +import Foreign.Ptr ( Ptr, plusPtr ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.String ( withTString, peekTString ) +import System.Win32.Types ( BOOL, BYTE, failIfFalse_ ) +import System.Win32.Word ( WORD, DWORD ) + +#include <windows.h> +#include "alignment.h" +##include "windows_cconv.h" + +---------------------------------------------------------------- +-- Version Info +---------------------------------------------------------------- +getVersionEx :: IO OSVERSIONINFOEX +getVersionEx = + alloca $ \buf -> do + (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf + $ sizeOf (undefined::OSVERSIONINFOEX) + failIfFalse_ "GetVersionEx" + $ c_GetVersionEx buf + peek buf + +data ProductType = VerUnknow BYTE | VerNTWorkStation | VerNTDomainControler | VerNTServer + deriving (Show,Eq) + +instance Storable ProductType where + sizeOf _ = sizeOf (undefined::BYTE) + alignment _ = alignment (undefined::BYTE) + poke buf v = pokeByteOff buf 0 $ case v of + VerUnknow w -> w + VerNTWorkStation -> #const VER_NT_WORKSTATION + VerNTDomainControler -> #const VER_NT_DOMAIN_CONTROLLER + VerNTServer -> #const VER_NT_SERVER + peek buf = do + v <- peekByteOff buf 0 + return $ case v of + (#const VER_NT_WORKSTATION) -> VerNTWorkStation + (#const VER_NT_DOMAIN_CONTROLLER) -> VerNTDomainControler + (#const VER_NT_SERVER) -> VerNTServer + w -> VerUnknow w + +type POSVERSIONINFOEX = Ptr OSVERSIONINFOEX +type LPOSVERSIONINFOEX = Ptr OSVERSIONINFOEX + +data OSVERSIONINFOEX = OSVERSIONINFOEX + { dwMajorVersion :: DWORD + , dwMinorVersion :: DWORD + , dwBuildNumber :: DWORD + , dwPlatformId :: DWORD + , szCSDVersion :: String + , wServicePackMajor :: WORD + , wServicePackMinor :: WORD + , wSuiteMask :: WORD + , wProductType :: ProductType + } deriving Show + +instance Storable OSVERSIONINFOEX where + sizeOf = const #{size struct _OSVERSIONINFOEXW} + alignment _ = #alignment OSVERSIONINFOEX + poke buf info = do + (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf (sizeOf info) + (#poke OSVERSIONINFOEXW, dwMajorVersion) buf (dwMajorVersion info) + (#poke OSVERSIONINFOEXW, dwMinorVersion) buf (dwMinorVersion info) + (#poke OSVERSIONINFOEXW, dwBuildNumber) buf (dwBuildNumber info) + (#poke OSVERSIONINFOEXW, dwPlatformId) buf (dwPlatformId info) + withTString (szCSDVersion info) $ \szCSDVersion' -> + (#poke OSVERSIONINFOEXW, szCSDVersion) buf szCSDVersion' + (#poke OSVERSIONINFOEXW, wServicePackMajor) buf (wServicePackMajor info) + (#poke OSVERSIONINFOEXW, wServicePackMinor) buf (wServicePackMinor info) + (#poke OSVERSIONINFOEXW, wSuiteMask) buf (wSuiteMask info) + (#poke OSVERSIONINFOEXW, wProductType) buf (wProductType info) + (#poke OSVERSIONINFOEXW, wReserved) buf (0::BYTE) + + peek buf = do + majorVersion <- (#peek OSVERSIONINFOEXW, dwMajorVersion) buf + minorVersion <- (#peek OSVERSIONINFOEXW, dwMinorVersion) buf + buildNumber <- (#peek OSVERSIONINFOEXW, dwBuildNumber) buf + platformId <- (#peek OSVERSIONINFOEXW, dwPlatformId) buf + cSDVersion <- peekTString $ (#ptr OSVERSIONINFOEXW, szCSDVersion) buf + servicePackMajor <- (#peek OSVERSIONINFOEXW, wServicePackMajor) buf + servicePackMinor <- (#peek OSVERSIONINFOEXW, wServicePackMinor) buf + suiteMask <- (#peek OSVERSIONINFOEXW, wSuiteMask) buf + productType <- (#peek OSVERSIONINFOEXW, wProductType) buf + return $ OSVERSIONINFOEX majorVersion minorVersion + buildNumber platformId cSDVersion + servicePackMajor servicePackMinor + suiteMask productType + +foreign import WINDOWS_CCONV unsafe "windows.h GetVersionExW" + c_GetVersionEx :: LPOSVERSIONINFOEX -> IO BOOL + +---------------------------------------------------------------- +-- Verify OS version +---------------------------------------------------------------- +-- See: http://msdn.microsoft.com/en-us/library/windows/desktop/ms724833(v=vs.85).aspx + +isVistaOrLater, is7OrLater :: IO Bool +isVistaOrLater = do + ver <- getVersionEx + return $ 6 <= dwMajorVersion ver + +is7OrLater = do + ver <- getVersionEx + return $ 6 <= dwMajorVersion ver + && 1 <= dwMinorVersion ver + +{- +We don't use VerifyVersionInfo function to above functions. + +Because VerifyVersionInfo is more difficult than GetVersionEx and accessing field in Haskell. + +-- | See: http://support.microsoft.com/kb/225013/ +-- http://msdn.microsoft.com/en-us/library/windows/desktop/ms725491(v=vs.85).aspx + +bIsWindowsVersionOK :: DWORD -> DWORD -> WORD -> IO BOOL +bIsWindowsVersionOK dwMajor dwMinor dwSPMajor = + alloca $ \buf -> do + zeroMemory buf + (#{size OSVERSIONINFOEXW}::DWORD) + (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf + (#{size OSVERSIONINFOEXW}::DWORD) + (#poke OSVERSIONINFOEXW, dwMajorVersion) buf dwMajor + (#poke OSVERSIONINFOEXW, dwMinorVersion) buf dwMinor + (#poke OSVERSIONINFOEXW, wServicePackMajor) buf dwSPMajor + -- Set up the condition mask. + let dwlConditionMask = 0 + flag = #const VER_MAJORVERSION + .|. #const VER_MINORVERSION + .|. #const VER_SERVICEPACKMAJOR + dwlConditionMask' <- vER_SET_CONDITION dwlConditionMask #{const VER_MAJORVERSION} #{const VER_GREATER_EQUAL} + dwlConditionMask'' <- vER_SET_CONDITION dwlConditionMask' #{const VER_MINORVERSION} #{const VER_MINORVERSION} + dwlConditionMask''' <- vER_SET_CONDITION dwlConditionMask'' #{const VER_SERVICEPACKMAJOR} #{const VER_SERVICEPACKMAJOR} + verifyVersionInfo buf flag dwlConditionMask''' + +type ULONGLONG = DWORDLONG + +foreign import capi unsafe "windows.h VER_SET_CONDITION" + vER_SET_CONDITION :: ULONGLONG -> DWORD -> BYTE -> IO ULONGLONG + +foreign import WINDOWS_CCONV unsafe "windows.h VerifyVersionInfoW" + verifyVersionInfo :: LPOSVERSIONINFOEX -> DWORD -> DWORDLONG -> IO BOOL +-}
System/Win32/Mem.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,8 +17,91 @@ -- ----------------------------------------------------------------------------- -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 import Foreign@@ -27,6 +110,7 @@ ##include "windows_cconv.h" #include <windows.h>+#include "alignment.h" ---------------------------------------------------------------- -- Data types@@ -48,7 +132,7 @@ instance Storable MEMORY_BASIC_INFORMATION where sizeOf _ = #size MEMORY_BASIC_INFORMATION- alignment = sizeOf+ alignment _ = #alignment MEMORY_BASIC_INFORMATION poke buf mbi = do (#poke MEMORY_BASIC_INFORMATION, BaseAddress) buf (mbiBaseAddress mbi) (#poke MEMORY_BASIC_INFORMATION, AllocationBase) buf (mbiAllocationBase mbi)@@ -267,10 +351,11 @@ foreign import WINDOWS_CCONV unsafe "windows.h VirtualAlloc" c_VirtualAlloc :: Addr -> DWORD -> DWORD -> DWORD -> IO Addr --- %fun VirtualAllocEx :: HANDLE -> Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags ->IO Addr--- %code extern LPVOID WINAPI VirtualAllocEx(HANDLE,LPVOID,DWORD,DWORD,DWORD);--- % LPVOID res1=VirtualAllocEx(arg1,arg2,arg3,arg4,arg5);--- %fail {res1==NULL}{ErrorWin("VirtualAllocEx")}+virtualAllocEx :: HANDLE -> Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags -> IO Addr+virtualAllocEx proc addt size ty flags =+ failIfNull "VirtualAllocEx" $ c_VirtualAllocEx proc addt size ty flags+foreign import WINDOWS_CCONV unsafe "windows.h VirtualAllocEx"+ c_VirtualAllocEx :: HANDLE -> Addr -> DWORD -> DWORD -> DWORD -> IO Addr virtualFree :: Addr -> DWORD -> FreeFlags -> IO () virtualFree addr size flags =@@ -278,10 +363,11 @@ foreign import WINDOWS_CCONV unsafe "windows.h VirtualFree" c_VirtualFree :: Addr -> DWORD -> FreeFlags -> IO Bool --- %fun VirtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO ()--- %code extern BOOL WINAPI VirtualFreeEx(HANDLE,LPVOID,DWORD,DWORD);--- % BOOL res1=VirtualFreeEx(arg1,arg2,arg3,arg4);--- %fail {res1=0}{ErrorWin("VirtualFreeEx")}+virtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO ()+virtualFreeEx proc addr size flags =+ failIfFalse_ "VirtualFreeEx" $ c_VirtualFreeEx proc addr size flags+foreign import WINDOWS_CCONV unsafe "windows.h VirtualFreeEx"+ c_VirtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO Bool virtualLock :: Addr -> DWORD -> IO () virtualLock addr size =
+ System/Win32/MinTTY.hsc view
@@ -0,0 +1,245 @@+{-# LANGUAGE ScopedTypeVariables #-}++#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.MinTTY+-- Copyright : (c) University of Glasgow 2006+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- 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.+--+-----------------------------------------------------------------------------++module System.Win32.MinTTY (isMinTTY, isMinTTYHandle) where++import Graphics.Win32.Misc+import System.Win32.DLL+import System.Win32.File+import System.Win32.Types++#if MIN_VERSION_base(4,6,0)+import Control.Exception (catch)+#endif+import Data.List (isInfixOf)+import Foreign+import Foreign.C.Types++#if __GLASGOW_HASKELL__ < 711+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif++-- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP.+-- Since we need some structs that are only available with Vista or later,+-- we must manually set WINVER/_WIN32_WINNT accordingly.+#undef WINVER+#define WINVER 0x0600+#undef _WIN32_WINNT+#define _WIN32_WINNT 0x0600+##include "windows_cconv.h"+#include <windows.h>+#include "winternl_compat.h"++-- | 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+ `catch` \(_ :: IOError) ->+ return nullHANDLE+ if h == nullHANDLE+ then return False+ else isMinTTYHandle h++-- | 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+ if fileType /= fILE_TYPE_PIPE+ then return False+ else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h+ -- GetFileNameByHandleEx is only available on Vista and later (hence+ -- the name isMinTTYVista). If we're on an older version of Windows,+ -- getProcAddress will throw an IOException when it fails to find+ -- GetFileNameByHandleEx, and thus we will default to using+ -- NtQueryObject (isMinTTYCompat).++isMinTTYVista :: HANDLE -> IO Bool+isMinTTYVista h = do+ fn <- getFileNameByHandle h+ return $ cygwinMSYSCheck fn+ `catch` \(_ :: IOError) ->+ return False++isMinTTYCompat :: HANDLE -> IO Bool+isMinTTYCompat h = do+ fn <- ntQueryObjectNameInformation h+ return $ cygwinMSYSCheck fn+ `catch` \(_ :: IOError) ->+ return False++cygwinMSYSCheck :: String -> Bool+cygwinMSYSCheck fn = ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) &&+ "-pty" `isInfixOf` fn+-- Note that GetFileInformationByHandleEx might return a filepath like:+--+-- \msys-dd50a72ab4668b33-pty1-to-master+--+-- But NtQueryObject might return something like:+--+-- \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. 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+ let sizeOfDWORD = sizeOf (undefined :: DWORD)+ -- note: implicitly assuming that DWORD has stronger alignment than wchar_t+ bufSize = sizeOfDWORD + mAX_PATH * sizeOfTCHAR+ allocaBytes bufSize $ \buf -> do+ getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize)+ fni <- peek buf+ return $ fniFileName fni++getFileInformationByHandleEx+ :: HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO ()+getFileInformationByHandleEx h cls buf bufSize = do+ lib <- getModuleHandle (Just "kernel32.dll")+ ptr <- getProcAddress lib "GetFileInformationByHandleEx"+ let c_GetFileInformationByHandleEx =+ mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr)+ failIfFalse_ "getFileInformationByHandleEx"+ (c_GetFileInformationByHandleEx h cls buf bufSize)++ntQueryObjectNameInformation :: HANDLE -> IO String+ntQueryObjectNameInformation h = do+ let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION)+ bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR+ allocaBytes bufSize $ \buf ->+ alloca $ \p_len -> do+ hwnd <- getModuleHandle (Just "ntdll.exe")+ addr <- getProcAddress hwnd "NtQueryObject"+ let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr addr)+ _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject+ h objectNameInformation buf (fromIntegral bufSize) p_len+ oni <- peek buf+ return $ usBuffer $ oniName oni++fileNameInfo :: CInt+fileNameInfo = #const FileNameInfo++mAX_PATH :: Num a => a+mAX_PATH = #const MAX_PATH++objectNameInformation :: CInt+objectNameInformation = #const ObjectNameInformation++type F_NtQueryObject = HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION+ -> ULONG -> Ptr ULONG -> IO NTSTATUS++foreign import WINDOWS_CCONV "dynamic"+ mk_NtQueryObject :: FunPtr F_NtQueryObject -> F_NtQueryObject++type F_GetFileInformationByHandleEx =+ HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL++foreign import WINDOWS_CCONV "dynamic"+ mk_GetFileInformationByHandleEx+ :: FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx++data FILE_NAME_INFO = FILE_NAME_INFO+ { fniFileNameLength :: DWORD+ , fniFileName :: String+ } deriving Show++instance Storable FILE_NAME_INFO where+ sizeOf _ = #size FILE_NAME_INFO+ alignment _ = #alignment FILE_NAME_INFO+ poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do+ let len' = (min mAX_PATH len) * sizeOfTCHAR+ start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName)+ end = advancePtr start len'+ (#poke FILE_NAME_INFO, FileNameLength) buf len'+ copyArray start (castPtr str :: Ptr Word8) len'+ poke (castPtr end) (0 :: TCHAR)+ peek buf = do+ vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf+ let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR+ vfniFileName <- peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len)+ return $ FILE_NAME_INFO+ { fniFileNameLength = vfniFileNameLength+ , fniFileName = vfniFileName+ }++type NTSTATUS = #type NTSTATUS++newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION+ { oniName :: UNICODE_STRING+ } deriving Show++instance Storable OBJECT_NAME_INFORMATION where+ sizeOf _ = #size OBJECT_NAME_INFORMATION+ alignment _ = #alignment OBJECT_NAME_INFORMATION+ poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni)+ peek buf = fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf++data UNICODE_STRING = UNICODE_STRING+ { usLength :: USHORT+ , usMaximumLength :: USHORT+ , usBuffer :: String+ } deriving Show++instance Storable UNICODE_STRING where+ sizeOf _ = #size UNICODE_STRING+ alignment _ = #alignment UNICODE_STRING+ poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do+ let len' = (min mAX_PATH len) * sizeOfTCHAR+ start = advancePtr (castPtr buf) (#size UNICODE_STRING)+ end = advancePtr start len'+ (#poke UNICODE_STRING, Length) buf len'+ (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR)+ (#poke UNICODE_STRING, Buffer) buf start+ copyArray start (castPtr str :: Ptr Word8) len'+ poke (castPtr end) (0 :: TCHAR)+ peek buf = do+ vusLength <- (#peek UNICODE_STRING, Length) buf+ vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf+ vusBufferPtr <- (#peek UNICODE_STRING, Buffer) buf+ let len = fromIntegral vusLength `div` sizeOfTCHAR+ vusBuffer <- peekTStringLen (vusBufferPtr, len)+ return $ UNICODE_STRING+ { usLength = vusLength+ , usMaximumLength = vusMaximumLength+ , usBuffer = vusBuffer+ }++sizeOfTCHAR :: Int+sizeOfTCHAR = sizeOf (undefined :: TCHAR)
System/Win32/NLS.hsc view
@@ -1,6 +1,5 @@-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : System.Win32.NLS@@ -17,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,@@ -24,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 <windows.h>+#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@@ -44,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@@ -62,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 ->@@ -103,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) ->@@ -139,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 @@ -151,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 @@ -160,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 @@ -345,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,@@ -364,13 +820,13 @@ nullPtr 0 -- wchars is the length of buffer required allocaArray (fromIntegral wchars) $ \cwstr -> do- wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar+ wchars' <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar cp 0 cstr (fromIntegral len) cwstr wchars- peekCWStringLen (cwstr,fromIntegral wchars) -- converts UTF-16 to [Char]+ peekCWStringLen (cwstr,fromIntegral wchars') -- converts UTF-16 to [Char] foreign import WINDOWS_CCONV unsafe "MultiByteToWideChar" multiByteToWideChar
+ System/Win32/NamedPipes.hsc view
@@ -0,0 +1,276 @@+#include <fcntl.h>+#include <windows.h>++#include "namedpipeapi_compat.h"++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}++-- | For full details on the Windows named pipes API see+-- <https://docs.microsoft.com/en-us/windows/desktop/ipc/named-pipes>+--+module System.Win32.NamedPipes (++ -- * Named pipe server APIs+ createNamedPipe,+ pIPE_UNLIMITED_INSTANCES,++ -- ** Parameter types+ LPSECURITY_ATTRIBUTES,+ OpenMode,+ pIPE_ACCESS_DUPLEX,+ pIPE_ACCESS_INBOUND,+ pIPE_ACCESS_OUTBOUND,+ fILE_FLAG_OVERLAPPED,+ PipeMode,+ pIPE_TYPE_BYTE,+ pIPE_TYPE_MESSAGE,+ pIPE_READMODE_BYTE,+ pIPE_READMODE_MESSAGE,+ pIPE_WAIT,+ pIPE_NOWAIT,+ pIPE_ACCEPT_REMOTE_CLIENTS,+ pIPE_REJECT_REMOTE_CLIENTS,++ -- * Named pipe client APIs+ -- ** connect to a named pipe+ connect,++ -- ** waiting for named pipe instances+ waitNamedPipe,++ TimeOut,+ nMPWAIT_USE_DEFAULT_WAIT,+ nMPWAIT_WAIT_FOREVER,+ ) where+++import Control.Exception+import Control.Monad (when)+import Foreign.C.String (withCString)++import System.Win32.Types hiding (try)+import System.Win32.File++-- | The named pipe open mode.+--+-- This must specify one of:+--+-- * 'pIPE_ACCESS_DUPLEX'+-- * 'pIPE_ACCESS_INBOUND'+-- * 'pIPE_ACCESS_OUTBOUND'+--+-- It may also specify:+--+-- * 'fILE_FLAG_WRITE_THROUGH'+-- * 'fILE_FLAG_OVERLAPPED'+--+-- It may also specify any combination of:+--+-- * 'wRITE_DAC'+-- * 'wRITE_OWNER'+-- * 'aCCESS_SYSTEM_SECURITY'+--+type OpenMode = UINT++#{enum OpenMode,+ , pIPE_ACCESS_DUPLEX = PIPE_ACCESS_DUPLEX+ , pIPE_ACCESS_INBOUND = PIPE_ACCESS_INBOUND+ , pIPE_ACCESS_OUTBOUND = PIPE_ACCESS_OUTBOUND+ }++-- | The pipe mode.+--+-- One of the following type modes can be specified. The same type mode must be+-- specified for each instance of the pipe.+--+-- * 'pIPE_TYPE_BYTE'+-- * 'pIPE_TYPE_MESSAGE'+--+-- One of the following read modes can be specified. Different instances of the+-- same pipe can specify different read modes.+--+-- * 'pIPE_READMODE_BYTE'+-- * 'pIPE_READMODE_MESSAGE'+--+-- One of the following wait modes can be specified. Different instances of the+-- same pipe can specify different wait modes.+--+-- * 'pIPE_WAIT'+-- * 'pIPE_NOWAIT'+--+-- One of the following remote-client modes can be specified. Different+-- instances of the same pipe can specify different remote-client modes.+--+-- * 'pIPE_ACCEPT_REMOTE_CLIENT'+-- * 'pIPE_REJECT_REMOTE_CLIENT'+--+type PipeMode = UINT++#{enum PipeMode,+ , pIPE_TYPE_BYTE = PIPE_TYPE_BYTE+ , pIPE_TYPE_MESSAGE = PIPE_TYPE_MESSAGE+ , pIPE_READMODE_BYTE = PIPE_READMODE_BYTE+ , pIPE_READMODE_MESSAGE = PIPE_READMODE_MESSAGE+ , pIPE_WAIT = PIPE_WAIT+ , pIPE_NOWAIT = PIPE_NOWAIT+ , pIPE_ACCEPT_REMOTE_CLIENTS = PIPE_ACCEPT_REMOTE_CLIENTS+ , pIPE_REJECT_REMOTE_CLIENTS = PIPE_REJECT_REMOTE_CLIENTS+ }++-- | If the 'createNamedPipe' @nMaxInstances@ parameter is+-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created+-- is limited only by the availability of system resources.+pIPE_UNLIMITED_INSTANCES :: DWORD+pIPE_UNLIMITED_INSTANCES = #const PIPE_UNLIMITED_INSTANCES++-- | Creates an instance of a named pipe and returns a handle for subsequent+-- pipe operations. A named pipe server process uses this function either to+-- create the first instance of a specific named pipe and establish its basic+-- attributes or to create a new instance of an existing named pipe.+--+-- For full details see+-- <https://docs.microsoft.com/en-us/windows/desktop/api/winbase/nf-winbase-createnamedpipea>+--+-- To create a named pipe which can be associate with IO completion port on+-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument,+-- e.g.+--+-- > Win32.createNamedPipe pipeName+-- > (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED)+-- > (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE)+-- > pIPE_UNLIMITED_INSTANCES+-- > 512+-- > 512+-- > 0+-- > NothinROR+--+--+createNamedPipe :: String -- ^ A unique pipe name of the form @\\\\.\\pipe\\{pipename}@+ -- The `pipename` part of the name can include any+ -- character other than a backslash, including+ -- numbers and special characters. The entire pipe+ -- name string can be up to 256 characters long.+ -- Pipe names are not case sensitive.+ -> OpenMode+ -> PipeMode+ -> DWORD -- ^ nMaxInstances+ -> DWORD -- ^ nOutBufferSize+ -> DWORD -- ^ nInBufferSize+ -> DWORD -- ^ nDefaultTimeOut+ -> Maybe LPSECURITY_ATTRIBUTES+ -> IO HANDLE+createNamedPipe name openMode pipeMode+ nMaxInstances nOutBufferSize nInBufferSize+ nDefaultTimeOut mb_attr =+ withTString name $ \ c_name ->+ failIf (==iNVALID_HANDLE_VALUE) ("CreateNamedPipe ('" ++ name ++ "')") $+ c_CreateNamedPipe c_name openMode pipeMode+ nMaxInstances nOutBufferSize nInBufferSize+ nDefaultTimeOut (maybePtr mb_attr)++foreign import ccall unsafe "windows.h CreateNamedPipeW"+ c_CreateNamedPipe :: LPCTSTR+ -> DWORD+ -> DWORD+ -> DWORD+ -> DWORD+ -> DWORD+ -> DWORD+ -> LPSECURITY_ATTRIBUTES+ -> IO HANDLE+++-- | Timeout in milliseconds.+--+-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to+-- 'createNamedPipe' should be used.+-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named+-- pipe instance is available.+--+type TimeOut = DWORD+#{enum TimeOut,+ , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT+ , nMPWAIT_WAIT_FOREVER = NMPWAIT_WAIT_FOREVER+ }+++-- | Wait until a named pipe instance is available. If there is no instance at+-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e.+-- @invalid argument (The semaphore timeout period has expired)@+--+-- It returns 'True' if there is an available instance, subsequent 'createFile'+-- might still fail, if another thread will take turn and connect before, or if+-- the other end shuts down the name pipe.+--+-- It returns 'False' if timeout fired.+--+waitNamedPipe :: String -- ^ pipe name+ -> TimeOut -- ^ nTimeOut+ -> IO Bool+waitNamedPipe name timeout =+ withCString name $ \ c_name -> do+ r <- c_WaitNamedPipe c_name timeout+ e <- getLastError+ if | r -> pure r+ | e == eRROR_SEM_TIMEOUT -> pure False+ | otherwise -> failWith "waitNamedPipe" e+++-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import.+foreign import ccall safe "windows.h WaitNamedPipeA"+ c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName+ -> DWORD -- nTimeOut+ -> IO BOOL++-- | A reliable connect call, as designed in+-- <https://docs.microsoft.com/en-us/windows/win32/ipc/named-pipe-client>+--+-- The arguments are passed directly to 'createFile'.+--+-- Note we pick the more familiar posix naming convention, do not confuse this+-- function with 'connectNamedPipe' (which corresponds to posix 'accept')+--+connect :: String -- ^ file name+ -> AccessMode -- ^ dwDesiredAccess+ -> ShareMode -- ^ dwSharedMode+ -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes+ -> CreateMode -- ^ dwCreationDisposition+ -> FileAttributeOrFlag -- ^ dwFlagsAndAttributes+ -> Maybe HANDLE -- ^ hTemplateFile+ -> IO HANDLE+connect fileName dwDesiredAccess dwSharedMode lpSecurityAttributes dwCreationDisposition dwFlagsAndAttributes hTemplateFile = connectLoop+ where+ connectLoop = do+ -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is+ -- caused by `ERROR_SHARING_VIOLATION`.+ mh <- try $+ createFile fileName+ dwDesiredAccess+ dwSharedMode+ lpSecurityAttributes+ dwCreationDisposition+ dwFlagsAndAttributes+ hTemplateFile+ case mh :: Either IOException HANDLE of+ Left e -> do+ errorCode <- getLastError+ when (errorCode /= eRROR_PIPE_BUSY)+ $ throwIO e+ -- all pipe instance were busy, wait 20s and retry; we ignore the+ -- result+ _ <- waitNamedPipe fileName 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
+ System/Win32/Path.hsc view
@@ -0,0 +1,56 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Path+-- Copyright : (c) Tamar Christina, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Tamar Christina <tamar@zhox.com>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Path (+ filepathRelativePathTo+ , pathRelativePathTo+ ) where++import System.Win32.Path.Internal+import System.Win32.Types+import System.Win32.File++import Foreign++##include "windows_cconv.h"++#include <windows.h>++filepathRelativePathTo :: FilePath -> FilePath -> IO FilePath+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 :: FilePath -> FileAttributeOrFlag -> FilePath -> FileAttributeOrFlag -> IO FilePath+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+
+ System/Win32/Path/Internal.hsc view
@@ -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 <tamar@zhox.com>+-- 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 <windows.h>++foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW"+ c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT
System/Win32/Process.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,18 +17,63 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Process where-import Control.Exception ( bracket )-import Control.Monad ( liftM5 )-import Foreign ( Ptr, peekByteOff, allocaBytes, pokeByteOff- , plusPtr )-import System.Win32.File ( closeHandle )+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+ , plusPtr )+import Foreign.C.Types ( CUInt(..) )+import System.Win32.File ( closeHandle )+import System.Win32.DebugApi ( ForeignAddress ) import System.Win32.Types ##include "windows_cconv.h" #include <windows.h> #include <tlhelp32.h>+#include "tlhelp32_compat.h" -- constant to wait for a very long time. iNFINITE :: DWORD@@ -37,7 +82,6 @@ foreign import WINDOWS_CCONV unsafe "windows.h Sleep" sleep :: DWORD -> IO () - type ProcessId = DWORD type ProcessHandle = HANDLE type ProcessAccessRights = DWORD@@ -53,13 +97,11 @@ , pROCESS_VM_OPERATION = PROCESS_VM_OPERATION , pROCESS_VM_READ = PROCESS_VM_READ , pROCESS_VM_WRITE = PROCESS_VM_WRITE- , sYNCHORNIZE = SYNCHRONIZE } foreign import WINDOWS_CCONV unsafe "windows.h OpenProcess" c_OpenProcess :: ProcessAccessRights -> BOOL -> ProcessId -> IO ProcessHandle - openProcess :: ProcessAccessRights -> BOOL -> ProcessId -> IO ProcessHandle openProcess r inh i = failIfNull "OpenProcess" $ c_OpenProcess r inh i @@ -69,21 +111,45 @@ getProcessId :: ProcessHandle -> IO ProcessId getProcessId h = failIfZero "GetProcessId" $ c_GetProcessId h +foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcess"+ c_GetCurrentProcess :: IO ProcessHandle++foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcessId"+ c_GetCurrentProcessId :: IO ProcessId++getCurrentProcessId :: IO ProcessId+getCurrentProcessId = c_GetCurrentProcessId++getCurrentProcess :: IO ProcessHandle+getCurrentProcess = c_GetCurrentProcess++foreign import WINDOWS_CCONV unsafe "windows.h TerminateProcess"+ c_TerminateProcess :: ProcessHandle -> CUInt -> IO Bool++terminateProcessById :: ProcessId -> IO ()+terminateProcessById p = bracket+ (openProcess pROCESS_TERMINATE False p)+ closeHandle+ (\h -> failIfFalse_ "TerminateProcess" $ c_TerminateProcess h 1)+ type Th32SnapHandle = HANDLE type Th32SnapFlags = DWORD -- | ProcessId, number of threads, parent ProcessId, process base priority, path of executable file type ProcessEntry32 = (ProcessId, Int, ProcessId, LONG, String)+type ModuleEntry32 = (ForeignAddress, Int, HMODULE, String, String) #{enum Th32SnapFlags, , tH32CS_SNAPALL = TH32CS_SNAPALL , tH32CS_SNAPHEAPLIST = TH32CS_SNAPHEAPLIST , tH32CS_SNAPMODULE = TH32CS_SNAPMODULE+ , tH32CS_SNAPMODULE32 = TH32CS_SNAPMODULE32+ , tH32CS_SNAPMODULE64 = (TH32CS_SNAPMODULE | TH32CS_SNAPMODULE32) , tH32CS_SNAPPROCESS = TH32CS_SNAPPROCESS , tH32CS_SNAPTHREAD = TH32CS_SNAPTHREAD } {- , tH32CS_SNAPGETALLMODS = TH32CS_GETALLMODS- , tH32CS_SNAPNOHEAPS = TH32CS_SNAPNOHEAPS + , tH32CS_SNAPNOHEAPS = TH32CS_SNAPNOHEAPS -} foreign import WINDOWS_CCONV unsafe "tlhelp32.h CreateToolhelp32Snapshot"@@ -95,6 +161,12 @@ foreign import WINDOWS_CCONV unsafe "tlhelp32.h Process32NextW" c_Process32Next :: Th32SnapHandle -> Ptr ProcessEntry32 -> IO BOOL +foreign import WINDOWS_CCONV unsafe "tlhelp32.h Module32FirstW"+ c_Module32First :: Th32SnapHandle -> Ptr ModuleEntry32 -> IO BOOL++foreign import WINDOWS_CCONV unsafe "tlhelp32.h Module32NextW"+ c_Module32Next :: Th32SnapHandle -> Ptr ModuleEntry32 -> IO BOOL+ -- | Create a snapshot of specified resources. Call closeHandle to close snapshot. createToolhelp32Snapshot :: Th32SnapFlags -> Maybe ProcessId -> IO Th32SnapHandle createToolhelp32Snapshot f p@@ -104,7 +176,6 @@ withTh32Snap :: Th32SnapFlags -> Maybe ProcessId -> (Th32SnapHandle -> IO a) -> IO a withTh32Snap f p = bracket (createToolhelp32Snapshot f p) (closeHandle) - peekProcessEntry32 :: Ptr ProcessEntry32 -> IO ProcessEntry32 peekProcessEntry32 buf = liftM5 (,,,,) ((#peek PROCESSENTRY32W, th32ProcessID) buf)@@ -113,6 +184,14 @@ ((#peek PROCESSENTRY32W, pcPriClassBase) buf) (peekTString $ (#ptr PROCESSENTRY32W, szExeFile) buf) +peekModuleEntry32 :: Ptr ModuleEntry32 -> IO ModuleEntry32+peekModuleEntry32 buf = liftM5 (,,,,)+ ((#peek MODULEENTRY32W, modBaseAddr) buf)+ ((#peek MODULEENTRY32W, modBaseSize) buf)+ ((#peek MODULEENTRY32W, hModule) buf)+ (peekTString $ (#ptr MODULEENTRY32W, szModule) buf)+ (peekTString $ (#ptr MODULEENTRY32W, szExePath) buf)+ -- | Enumerate processes using Process32First and Process32Next th32SnapEnumProcesses :: Th32SnapHandle -> IO [ProcessEntry32] th32SnapEnumProcesses h = allocaBytes (#size PROCESSENTRY32W) $ \pe -> do@@ -129,4 +208,22 @@ | otherwise = do entry <- peekProcessEntry32 pe ok' <- c_Process32Next h pe+ readAndNext ok' pe (entry:res)++-- | Enumerate modules using Module32First and Module32Next+th32SnapEnumModules :: Th32SnapHandle -> IO [ModuleEntry32]+th32SnapEnumModules h = allocaBytes (#size MODULEENTRY32W) $ \pe -> do+ (#poke MODULEENTRY32W, dwSize) pe ((#size MODULEENTRY32W)::DWORD)+ ok <- c_Module32First h pe+ readAndNext ok pe []+ where+ readAndNext ok pe res+ | not ok = do+ err <- getLastError+ if err == (#const ERROR_NO_MORE_FILES)+ then return $ reverse res+ else failWith "th32SnapEnumModules: Module32First/Module32Next" err+ | otherwise = do+ entry <- peekModuleEntry32 pe+ ok' <- c_Module32Next h pe readAndNext ok' pe (entry:res)
System/Win32/Registry.hsc view
@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : System.Win32.Registry@@ -16,42 +14,103 @@ ----------------------------------------------------------------------------- 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 -> 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- , regQueryValueKey -- :: HKEY -> Maybe String -> IO String- , regQueryValueEx -- :: HKEY -> String -> Addr -> Int -> IO RegValueType- , regReplaceKey -- :: HKEY -> String -> String -> String -> IO ()- , regRestoreKey -- :: HKEY -> String -> RegRestoreFlags -> IO ()- , regSaveKey -- :: HKEY -> String -> Maybe LPSECURITY_ATTRIBUTES -> 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: @@ -72,12 +131,13 @@ import System.Win32.Time (FILETIME) import System.Win32.Types (DWORD, ErrCode, HKEY, LPCTSTR, PKEY, withTString) import System.Win32.Types (HANDLE, LONG, LPBYTE, newForeignHANDLE, peekTString)-import System.Win32.Types (LPTSTR, TCHAR, failUnlessSuccess, withTStringLen)+import System.Win32.Types (LPTSTR, TCHAR, LPDWORD, LPVOID, failUnlessSuccess) import System.Win32.Types (castUINTPtrToPtr, failUnlessSuccessOr, maybePtr) ##include "windows_cconv.h" #include <windows.h>+#include "winreg_compat.h" #{enum HKEY, (unsafePerformIO . newForeignHANDLE . castUINTPtrToPtr) , hKEY_CLASSES_ROOT = (UINT_PTR)HKEY_CLASSES_ROOT@@ -144,11 +204,11 @@ , kEY_WRITE = KEY_WRITE } -regCreateKeyEx :: HKEY -> String -> String -> RegCreateOptions -> REGSAM -> Maybe LPSECURITY_ATTRIBUTES -> IO (HKEY, Bool)+regCreateKeyEx :: HKEY -> String -> Maybe String -> RegCreateOptions -> REGSAM -> Maybe LPSECURITY_ATTRIBUTES -> IO (HKEY, Bool) regCreateKeyEx key subkey cls opts sam mb_attr = withForeignPtr key $ \ p_key -> withTString subkey $ \ c_subkey ->- withTString cls $ \ c_cls ->+ maybeWith withTString cls $ \ c_cls -> alloca $ \ p_res -> alloca $ \ p_disp -> do failUnlessSuccess "RegCreateKeyEx" $@@ -353,45 +413,54 @@ c_RegQueryInfoKey p_key c_class_string p_class_id nullPtr p_subkeys p_max_subkey_len p_max_class_len p_values p_max_value_name_len p_max_value_len p_sec_len p_lastWrite- class_string <- peekTString c_class_string- class_id <- peek p_class_id- subkeys <- peek p_subkeys- max_subkey_len <- peek p_max_subkey_len- max_class_len <- peek p_max_class_len- values <- peek p_values- max_value_name_len <- peek p_max_value_name_len- max_value_len <- peek p_max_value_len- sec_len <- peek p_sec_len- lastWrite_lo <- #{peek FILETIME,dwLowDateTime} p_lastWrite- lastWrite_hi <- #{peek FILETIME,dwHighDateTime} p_lastWrite+ class_string' <- peekTString c_class_string+ class_id' <- peek p_class_id+ subkeys' <- peek p_subkeys+ max_subkey_len' <- peek p_max_subkey_len+ max_class_len' <- peek p_max_class_len+ values' <- peek p_values+ max_value_name_len' <- peek p_max_value_name_len+ max_value_len' <- peek p_max_value_len+ sec_len' <- peek p_sec_len+ lastWrite_lo' <- #{peek FILETIME,dwLowDateTime} p_lastWrite+ lastWrite_hi' <- #{peek FILETIME,dwHighDateTime} p_lastWrite return $ RegInfoKey- { class_string = class_string- , class_id = fromIntegral class_id- , subkeys = subkeys- , max_subkey_len = max_subkey_len- , max_class_len = max_class_len- , values = values- , max_value_name_len = max_value_name_len- , max_value_len = max_value_len- , sec_len = fromIntegral sec_len- , lastWrite_lo = lastWrite_lo- , lastWrite_hi = lastWrite_hi+ { class_string = class_string'+ , class_id = fromIntegral class_id'+ , subkeys = subkeys'+ , max_subkey_len = max_subkey_len'+ , max_class_len = max_class_len'+ , values = values'+ , max_value_name_len = max_value_name_len'+ , max_value_len = max_value_len'+ , sec_len = fromIntegral sec_len'+ , lastWrite_lo = lastWrite_lo'+ , lastWrite_hi = lastWrite_hi' } foreign import WINDOWS_CCONV unsafe "windows.h RegQueryInfoKeyW" c_RegQueryInfoKey :: PKEY -> LPTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr FILETIME -> IO ErrCode -- RegQueryMultipleValues :: HKEY -> IO ([VALENT],String) --- RegQueryValue() isn't really that, it just allows you to--- get at the default values of keys, so we provide our own--- (and better!) version of it. If you want RegQueryValue()s--- behaviour, use regQueryValueKey.-+{-# DEPRECATED regQueryValueKey "Use regQueryValue instead." #-} regQueryValueKey :: HKEY -> Maybe String -> IO String regQueryValueKey key mb_subkey = withForeignPtr key $ \ p_key -> maybeWith withTString mb_subkey $ \ c_subkey -> alloca $ \ p_value_len -> do+ failUnlessSuccess "RegQueryValueKey" $+ c_RegQueryValue p_key c_subkey nullPtr p_value_len+ value_len <- peek p_value_len+ allocaArray0 (fromIntegral value_len) $ \ c_value -> do+ failUnlessSuccess "RegQueryValueKey" $+ c_RegQueryValue p_key c_subkey c_value p_value_len+ peekTString c_value++regQueryValue :: HKEY -> Maybe String -> IO String+regQueryValue key mb_subkey =+ withForeignPtr key $ \ p_key ->+ maybeWith withTString mb_subkey $ \ c_subkey ->+ alloca $ \ p_value_len -> do failUnlessSuccess "RegQueryValue" $ c_RegQueryValue p_key c_subkey nullPtr p_value_len value_len <- peek p_value_len@@ -402,19 +471,21 @@ foreign import WINDOWS_CCONV unsafe "windows.h RegQueryValueW" c_RegQueryValue :: PKEY -> LPCTSTR -> LPTSTR -> Ptr LONG -> IO ErrCode -regQueryValue :: HKEY -> Maybe String -> IO String-regQueryValue key mb_subkey =+-- Gets the data associated with the default value of a key (assumed to be of+-- type REG_SZ) using RegQeryValueEx.+regQueryDefaultValue :: HKEY -> String -> IO String+regQueryDefaultValue key mb_subkey = withForeignPtr key $ \ p_key ->- maybeWith withTString mb_subkey $ \ c_subkey ->+ withTString mb_subkey $ \ c_subkey -> alloca $ \ p_ty -> alloca $ \ p_value_len -> do- failUnlessSuccess "RegQueryValue" $+ failUnlessSuccess "regQueryDefaultValue" $ c_RegQueryValueEx p_key c_subkey nullPtr p_ty nullPtr p_value_len ty <- peek p_ty- failUnlessSuccess "RegQueryValue" $ return (if ty == rEG_SZ then 0 else 1)+ failUnlessSuccess "regQueryDefaultValue" $ return (if ty == rEG_SZ then 0 else 1) value_len <- peek p_value_len allocaArray0 (fromIntegral value_len) $ \ c_value -> do- failUnlessSuccess "RegQueryValue" $+ failUnlessSuccess "regQueryDefaultValue" $ c_RegQueryValueEx p_key c_subkey nullPtr p_ty c_value p_value_len peekTString (castPtr c_value) @@ -430,10 +501,10 @@ foreign import WINDOWS_CCONV unsafe "windows.h RegQueryValueExW" c_RegQueryValueEx :: PKEY -> LPCTSTR -> Ptr DWORD -> Ptr DWORD -> LPBYTE -> Ptr DWORD -> IO ErrCode -regReplaceKey :: HKEY -> String -> String -> String -> IO ()+regReplaceKey :: HKEY -> Maybe String -> String -> String -> IO () regReplaceKey key subkey newfile oldfile = withForeignPtr key $ \ p_key ->- withTString subkey $ \ c_subkey ->+ maybeWith withTString subkey $ \ c_subkey -> withTString newfile $ \ c_newfile -> withTString oldfile $ \ c_oldfile -> failUnlessSuccess "RegReplaceKey" $@@ -473,13 +544,42 @@ -- 3.1 compat. - only allows storage of REG_SZ values. +regGetValue :: HKEY -> Maybe String -> Maybe String -> RegTypeRestriction -> Maybe LPDWORD -> Maybe LPVOID -> Maybe LPDWORD -> IO ()+regGetValue key m_subkey m_valuename flags m_type m_value m_size =+ withForeignPtr key $ \ p_key ->+ maybeWith withTString m_subkey $ \ c_subkey ->+ maybeWith withTString m_valuename $ \ c_valuename ->+ failUnlessSuccess "RegGetValue" $+ c_RegGetValue p_key c_subkey c_valuename flags (maybePtr m_type) (maybePtr m_value) (maybePtr m_size)+foreign import WINDOWS_CCONV unsafe "windows.h RegGetValueW"+ c_RegGetValue :: PKEY -> LPCTSTR -> LPCTSTR -> DWORD -> LPDWORD -> LPVOID -> LPDWORD -> IO ErrCode++type RegTypeRestriction = DWORD++#{enum RegTypeRestriction,+ , rRF_RT_ANY = RRF_RT_ANY+ , rRF_RT_DWORD = RRF_RT_DWORD+ , rRF_RT_QWORD = RRF_RT_QWORD+ , rRF_RT_REG_BINARY = RRF_RT_REG_BINARY+ , rRF_RT_REG_DWORD = RRF_RT_REG_DWORD+ , rRF_RT_REG_EXPAND_SZ = RRF_RT_REG_EXPAND_SZ+ , rRF_RT_REG_MULTI_SZ = RRF_RT_REG_MULTI_SZ+ , rRF_RT_REG_NONE = RRF_RT_REG_NONE+ , rRF_RT_REG_QWORD = RRF_RT_REG_QWORD+ , rRF_RT_REG_SZ = RRF_RT_REG_SZ+ , rRF_NOEXPAND = RRF_NOEXPAND+ , rRF_ZEROONFAILURE = RRF_ZEROONFAILURE+ , rRF_SUBKEY_WOW6464KEY = RRF_SUBKEY_WOW6464KEY+ , rRF_SUBKEY_WOW6432KEY = RRF_SUBKEY_WOW6432KEY+ }+ regSetValue :: HKEY -> String -> String -> IO () regSetValue key subkey value = withForeignPtr key $ \ p_key -> withTString subkey $ \ c_subkey ->- withTStringLen value $ \ (c_value, value_len) ->+ withTString value $ \ c_value -> failUnlessSuccess "RegSetValue" $- c_RegSetValue p_key c_subkey rEG_SZ c_value value_len+ c_RegSetValue p_key c_subkey rEG_SZ c_value 0 -- cbData is ignored, value needs to be null terminated. foreign import WINDOWS_CCONV unsafe "windows.h RegSetValueW" c_RegSetValue :: PKEY -> LPCTSTR -> DWORD -> LPCTSTR -> Int -> IO ErrCode
System/Win32/Security.hsc view
@@ -1,13 +1,11 @@ {-# 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--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings+-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : System.Win32.Security@@ -22,7 +20,7 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Security ( +module System.Win32.Security ( -- * Types SID, PSID, ACL, PACL,@@ -96,34 +94,34 @@ :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> Ptr SECURITY_DESCRIPTOR_CONTROL -- pControl -> LPDWORD -- lpdwRevision- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorDacl"- c_getSecurityDescriptorDacl + c_getSecurityDescriptorDacl :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> LPBOOL -- lpbDaclPresent -> Ptr PACL -- pDacl -> LPBOOL -- lpbDaclDefaulted- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorGroup" c_getSecurityDescriptorGroup :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> Ptr PSID -- pGroup -> LPBOOL -- lpbGroupDefaulted- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorLength" c_getSecurityDescriptorLength :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor- -> IO DWORD + -> IO DWORD foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorOwner" c_getSecurityDescriptorOwner :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> Ptr PSID -- pOwner -> LPBOOL -- lpbOwnerDefaulted- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorSacl" c_getSecurityDescriptorSacl@@ -131,18 +129,18 @@ -> LPBOOL -- lpbSaclPresent -> Ptr PACL -- pSacl -> LPBOOL -- lpbSaclDefaulted- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h InitializeSecurityDescriptor" c_initializeSecurityDescriptor :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> DWORD -- dwRevision- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h IsValidSecurityDescriptor" c_isValidSecurityDescriptor :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorDacl" c_setSecurityDescriptorDacl@@ -150,21 +148,21 @@ -> BOOL -- bDaclPresent -> PACL -- pDacl -> BOOL -- bDaclDefaulted- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorGroup" c_setSecurityDescriptorGroup :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> PSID -- pGroup -> BOOL -- bGroupDefaulted- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorOwner" c_setSecurityDescriptorOwner :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> PSID -- pOwner -> BOOL -- bOwnerDefaulted- -> IO BOOL + -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorSacl" c_setSecurityDescriptorSacl@@ -172,7 +170,7 @@ -> BOOL -- bSaclPresent -> PACL -- pSacl -> BOOL -- bSaclDefaulted- -> IO BOOL + -> IO BOOL -- --------------------------------------------------------------------------- @@ -190,7 +188,7 @@ -- , pROTECTED_DACL_SECURITY_INFORMATION = PROTECTED_DACL_SECURITY_INFORMATION -- , pROTECTED_SACL_SECURITY_INFORMATION = PROTECTED_SACL_SECURITY_INFORMATION -- , uNPROTECTED_DACL_SECURITY_INFORMATION = UNPROTECTED_DACL_SECURITY_INFORMATION--- , uNPROTECTED_SACL_SECURITY_INFORMATION = UNPROTECTED_SACL_SECURITY_INFORMATION +-- , uNPROTECTED_SACL_SECURITY_INFORMATION = UNPROTECTED_SACL_SECURITY_INFORMATION getFileSecurity :: String@@ -203,7 +201,7 @@ needed <- peek lpnLengthNeeded fpSd <- mallocForeignPtrBytes (fromIntegral needed) withForeignPtr fpSd $ \pSd -> do- failIfFalse_ "getFileSecurity" $ + failIfFalse_ "getFileSecurity" $ c_GetFileSecurity lpFileName si pSd needed lpnLengthNeeded return (SecurityDescriptor fpSd) @@ -214,7 +212,7 @@ -> PSECURITY_DESCRIPTOR -- pSecurityDescriptor -> DWORD -- nLength -> LPDWORD -- lpnLengthNeeded- -> IO BOOL + -> IO BOOL --foreign import WINDOWS_CCONV unsafe "windows.h AccessCheck" -- c_AccessCheck
+ System/Win32/Semaphore.hsc view
@@ -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 <windows.h>++----------------------------------------------------------------+-- 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+----------------------------------------------------------------
System/Win32/Shell.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -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
+ System/Win32/Shell/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- 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 <windows.h>+#include <shlobj.h>++----------------------------------------------------------------+-- 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
System/Win32/SimpleMAPI.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -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"@@ -53,12 +52,6 @@ , mAPI_LOGON_UI = MAPI_LOGON_UI , mAPI_NEW_SESSION = MAPI_NEW_SESSION , mAPI_FORCE_DOWNLOAD = MAPI_FORCE_DOWNLOAD-#ifdef MAPI_LOGOFF_SHARED- , mAPI_LOGOFF_SHARED = MAPI_LOGOFF_SHARED-#endif-#ifdef MAPI_LOGOFF_UI- , mAPI_LOGOFF_UI = MAPI_LOGOFF_UI-#endif , mAPI_DIALOG = MAPI_DIALOG , mAPI_UNREAD_ONLY = MAPI_UNREAD_ONLY , mAPI_LONG_MSGID = MAPI_LONG_MSGID@@ -74,6 +67,19 @@ , mAPI_RECEIPT_REQUESTED = MAPI_RECEIPT_REQUESTED , mAPI_SENT = MAPI_SENT }+-- Have to define enum values outside previous declaration due to+-- hsc2hs bug in --cross-compile mode:+-- https://ghc.haskell.org/trac/ghc/ticket/13620+#ifdef MAPI_LOGOFF_SHARED+#{enum MapiFlag,+ , mAPI_LOGOFF_SHARED = MAPI_LOGOFF_SHARED+}+#endif+#ifdef MAPI_LOGOFF_UI+#{enum MapiFlag,+ , mAPI_LOGOFF_UI = MAPI_LOGOFF_UI+}+#endif mapiErrors :: [(ULONG,String)] mapiErrors =@@ -91,7 +97,7 @@ , ((#const MAPI_E_TOO_MANY_SESSIONS), "Too many open sessions") , ((#const MAPI_E_TOO_MANY_FILES) , "Too many open files") , ((#const MAPI_E_TOO_MANY_RECIPIENTS) , "Too many recipients")- , ((#const MAPI_E_ATTACHMENT_NOT_FOUND) , "Attachemnt not found")+ , ((#const MAPI_E_ATTACHMENT_NOT_FOUND) , "Attachment not found") , ((#const MAPI_E_ATTACHMENT_OPEN_FAILURE) , "Couldn't open attachment") , ((#const MAPI_E_ATTACHMENT_WRITE_FAILURE) , "Couldn't write attachment") , ((#const MAPI_E_UNKNOWN_RECIPIENT) , "Unknown recipient")@@ -101,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")@@ -164,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)@@ -197,6 +203,11 @@ [] -> 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 withMapiLoaded (f,m) act = finally (act f) (touchForeignPtr m)@@ -213,12 +224,12 @@ -> MapiFlag -- ^ None, one or many flags: FORCE_DOWNLOAD, NEW_SESSION, LOGON_UI, PASSWORD_UI -> IO LHANDLE mapiLogon f hwnd ses pw flags =- maybeWith withCAString ses $ \ses ->- maybeWith withCAString pw $ \pw ->- alloca $ \out -> do+ maybeWith withCAString ses $ \c_ses ->+ maybeWith withCAString pw $ \c_pw ->+ alloca $ \out -> do mapiFail_ "MAPILogon: " $ mapifLogon- f (maybeHWND hwnd) - ses pw flags 0 out+ f (maybeHWND hwnd)+ c_ses c_pw flags 0 out peek out -- | End Simple MAPI-session@@ -265,12 +276,12 @@ act buf resolve err rc = case rc of Recip name addr ->- withCAString name $ \name ->- withCAString addr $ \addr ->+ withCAString name $ \c_name ->+ withCAString addr $ \c_addr -> allocaBytes (#size MapiRecipDesc) $ \buf -> do (#poke MapiRecipDesc, ulReserved) buf (0::ULONG)- (#poke MapiRecipDesc, lpszName) buf name- (#poke MapiRecipDesc, lpszAddress) buf addr+ (#poke MapiRecipDesc, lpszName) buf c_name+ (#poke MapiRecipDesc, lpszAddress) buf c_addr (#poke MapiRecipDesc, ulEIDSize) buf (0::ULONG) (#poke MapiRecipDesc, lpEntryID) buf nullPtr a buf@@ -351,18 +362,18 @@ where as = (#size MapiFileDesc) len = length att- write act _ [] = act- write act buf (att:y) =- withCAString (attPath att) $ \path ->- maybeWith withFileTag (attTag att) $ \tag ->- withCAString (maybe (attPath att) id (attName att)) $ \name -> do+ write act' _ [] = act'+ write act' buf (att':y) =+ withCAString (attPath att') $ \path ->+ maybeWith withFileTag (attTag att') $ \tag ->+ withCAString (maybe (attPath att') id (attName att')) $ \name -> do (#poke MapiFileDesc, ulReserved) buf (0::ULONG)- (#poke MapiFileDesc, flFlags) buf (attFlag att)- (#poke MapiFileDesc, nPosition) buf (maybe 0xffffffff id $ attPosition att)+ (#poke MapiFileDesc, flFlags) buf (attFlag att')+ (#poke MapiFileDesc, nPosition) buf (maybe 0xffffffff id $ attPosition att') (#poke MapiFileDesc, lpszPathName) buf path (#poke MapiFileDesc, lpszFileName) buf name (#poke MapiFileDesc, lpFileType) buf tag- write act (plusPtr buf as) y+ write act' (plusPtr buf as) y data Message = Message { msgSubject :: String@@ -410,8 +421,8 @@ act buf mapiSendMail :: MapiFuncs -> LHANDLE -> Maybe HWND -> Message -> MapiFlag -> IO ()-mapiSendMail f ses hwnd msg flag = withMessage f ses msg $ \msg ->- mapiFail_ "MAPISendMail" $ mapifSendMail f ses (maybeHWND hwnd) msg flag 0+mapiSendMail f ses hwnd msg flag = withMessage f ses msg $ \c_msg ->+ mapiFail_ "MAPISendMail" $ mapifSendMail f ses (maybeHWND hwnd) c_msg flag 0 handleIOException :: (IOException -> IO a) -> IO a -> IO a handleIOException = handle
+ System/Win32/String.hs view
@@ -0,0 +1,51 @@+{- | + 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.String + ( LPSTR, LPCSTR, LPWSTR, LPCWSTR + , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_ + , withTString, withTStringLen, peekTString, peekTStringLen + , newTString + , withTStringBuffer, withTStringBufferLen + ) where +import System.Win32.Types + +-- | 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 = replicate maxLength '\0' + 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 = replicate maxLength '\0' + in withTStringLen dummyBuffer +
+ System/Win32/SymbolicLink.hsc view
@@ -0,0 +1,93 @@+{-# 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 manifest 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 + ( 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" + + +-- | 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 -- ^ 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 -- ^ 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 + -> 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 flag +
+ System/Win32/SymbolicLink/Internal.hsc view
@@ -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
+ System/Win32/Thread.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Thread + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + This modules provides just thread control APIs. + This modules doesn't provide thread register control APIs. Because these APIs are used for Debugging. +-} +module System.Win32.Thread + ( THANDLE, TID + , getCurrentThread + , suspendThread + , resumeThread + , withSuspendedThread + , getThreadId + , getCurrentThreadId + ) where + +import System.Win32.DebugApi +import System.Win32.Types ( failIfZero ) + +#include "windows_cconv.h" + +getThreadId :: THANDLE -> IO TID +getThreadId = failIfZero "GetThreadId" . c_GetThreadId + +getCurrentThreadId :: IO TID +getCurrentThreadId = failIfZero "GetThreadId" c_GetCurrentThreadId + +foreign import WINDOWS_CCONV "windows.h GetCurrentThread" + getCurrentThread :: IO THANDLE + +foreign import WINDOWS_CCONV "windows.h GetThreadId" + c_GetThreadId :: THANDLE -> IO TID + +foreign import WINDOWS_CCONV "windows.h GetCurrentThreadId" + c_GetCurrentThreadId :: IO TID
System/Win32/Time.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,166 +16,111 @@ -- 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 <windows.h>+#include "alignment.h"+#include "winnls_compat.h" -#include "windows.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 = sizeOf- 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 = sizeOf- 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- min <- (#peek SYSTEMTIME, wMinute) buf- sec <- (#peek SYSTEMTIME, wSecond) buf- ms <- (#peek SYSTEMTIME, wMilliseconds) buf- return $ SYSTEMTIME year month dow day hour min sec ms--instance Storable TIME_ZONE_INFORMATION where- sizeOf _ = (#size TIME_ZONE_INFORMATION)- alignment = sizeOf- 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 $ \(str,len) -> do- when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string."- let start = (advancePtr (castPtr buf) offset)- end = advancePtr start len- copyArray (castPtr str :: Ptr Word8) start len- poke end 0- 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 $ \st -> failIf_ not "setSystemTime: SetSystemTime" $- c_SetSystemTime st+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 $ \st -> failIf_ not "setLocalTime: SetLocalTime" $- c_SetLocalTime st+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" $ c_GetSystemTimeAdjustment ta ti enabled- enabled <- peek enabled- if enabled+ enabled' <- peek enabled+ if enabled' then do- ta <- peek ta- ti <- peek ti- return $ Just (fromIntegral ta, fromIntegral ti)+ ta' <- peek ta+ ti' <- peek ti+ 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" $@@ -185,62 +130,58 @@ 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" $ c_GetTimeZoneInformation tzi- tzi <- peek tzi- return . flip (,) tzi $ case tz of+ tzi' <- peek tzi+ return . flip (,) tzi' $ case tz of (#const TIME_ZONE_ID_UNKNOWN) -> TzIdUnknown (#const TIME_ZONE_ID_STANDARD) -> TzIdStandard (#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 $ \s -> alloca $ \ret -> do+systemTimeToFileTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "systemTimeToFileTime: SystemTimeToFileTime" $- c_SystemTimeToFileTime s ret+ 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 $ \s -> alloca $ \ret -> do+fileTimeToSystemTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "fileTimeToSystemTime: FileTimeToSystemTime" $- c_FileTimeToSystemTime s ret+ 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 $ \crt -> with acc $ \acc -> with wrt $ \wrt -> do- failIf_ not "setFileTime: SetFileTime" $ c_SetFileTime h crt acc wrt+invalidFileTime :: FILETIME+invalidFileTime = FILETIME 0 -foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime"- c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL+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+ fileTimeToLocalFileTime :: FILETIME -> IO FILETIME-fileTimeToLocalFileTime ft = with ft $ \ft -> alloca $ \res -> do+fileTimeToLocalFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "fileTimeToLocalFileTime: FileTimeToLocalFileTime"- $ c_FileTimeToLocalFileTime ft res+ $ 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 $ \ft -> alloca $ \res -> do+localFileTimeToFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "localFileTimeToFileTime: LocalFileTimeToFileTime"- $ c_LocalFileTimeToFileTime ft res+ $ c_LocalFileTimeToFileTime c_ft res peek res {-@@ -272,40 +213,37 @@ 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-getTimeFormat :: LCID -> GetTimeFormatFlags -> SYSTEMTIME -> String -> IO String+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 =- with st $ \st ->- withCWString fmt $ \fmt -> do- size <- c_GetTimeFormat locale flags st fmt nullPtr 0+ 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 st fmt (castPtr out) size- peekTStringLen (out,fromIntegral size)+ size' <- failIf (==0) "getTimeFormat: GetTimeFormat" $+ c_GetTimeFormat locale flags c_st c_fmt (castPtr out) size+ peekTStringLen (out,fromIntegral size')
+ System/Win32/Time/Internal.hsc view
@@ -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 <ei@vuokko.info>+-- 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 <windows.h>+#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
− System/Win32/Types.hs
@@ -1,328 +0,0 @@-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : System.Win32.Types--- Copyright : (c) Alastair Reid, 1997-2003--- License : BSD-style (see the file libraries/base/LICENSE)------ Maintainer : Esa Ilari Vuokko <ei@vuokko.info>--- Stability : provisional--- Portability : portable------ A collection of FFI declarations for interfacing with Win32.-----------------------------------------------------------------------------------module System.Win32.Types- ( module System.Win32.Types- , nullPtr- ) where--import Control.Exception (throwIO)-import Data.Bits (shiftL, shiftR, (.|.), (.&.))-import Data.Char (isSpace)-import Data.Int (Int32, Int64)-import Data.Maybe (fromMaybe)-import Data.Word (Word8, Word16, Word32, Word64)-import Foreign.C.Error (getErrno, errnoToIOError)-import Foreign.C.String (newCWString, withCWStringLen)-import Foreign.C.String (peekCWString, peekCWStringLen, withCWString)-import Foreign.C.Types (CChar, CUChar, CWchar)-import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_)-import Foreign.Ptr (FunPtr, Ptr, nullPtr)-import Numeric (showHex)-import System.IO.Error (ioeSetErrorString)-import System.IO.Unsafe (unsafePerformIO)--#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif--#if MIN_VERSION_base(4,7,0)-import Data.Bits (finiteBitSize)-#else-import Data.Bits (Bits, bitSize)--finiteBitSize :: (Bits a) => a -> Int-finiteBitSize = bitSize-#endif--#include "windows_cconv.h"--------------------------------------------------------------------- Platform specific definitions------ Most typedefs and prototypes in Win32 are expressed in terms--- of these types. Try to follow suit - it'll make it easier to--- get things working on Win64 (or whatever they call it on Alphas).-------------------------------------------------------------------type BOOL = Bool-type BYTE = Word8-type UCHAR = CUChar-type USHORT = Word16-type UINT = Word32-type INT = Int32-type WORD = Word16-type DWORD = Word32-type LONG = Int32-type FLOAT = Float-type LARGE_INTEGER = Int64--type UINT_PTR = Word---- Not really a basic type, but used in many places-type DDWORD = Word64--------------------------------------------------------------------type MbString = Maybe String-type MbINT = Maybe INT--type ATOM = UINT-type WPARAM = UINT-type LPARAM = LONG-type LRESULT = LONG-type SIZE_T = DWORD--type MbATOM = Maybe ATOM--type HRESULT = LONG--------------------------------------------------------------------- Pointers-------------------------------------------------------------------type Addr = Ptr ()--type LPVOID = Ptr ()-type LPBOOL = Ptr BOOL-type LPBYTE = Ptr BYTE-type PUCHAR = Ptr UCHAR-type LPDWORD = Ptr DWORD-type LPSTR = Ptr CChar-type LPCSTR = LPSTR-type LPWSTR = Ptr CWchar-type LPCWSTR = LPWSTR-type LPTSTR = Ptr TCHAR-type LPCTSTR = LPTSTR-type LPCTSTR_ = LPCTSTR---- Optional things with defaults--maybePtr :: Maybe (Ptr a) -> Ptr a-maybePtr = fromMaybe nullPtr--ptrToMaybe :: Ptr a -> Maybe (Ptr a)-ptrToMaybe p = if p == nullPtr then Nothing else Just p--maybeNum :: Num a => Maybe a -> a-maybeNum = fromMaybe 0--numToMaybe :: (Eq a, Num a) => a -> Maybe a-numToMaybe n = if n == 0 then Nothing else Just n--type MbLPVOID = Maybe LPVOID-type MbLPCSTR = Maybe LPCSTR-type MbLPCTSTR = Maybe LPCTSTR--------------------------------------------------------------------- Chars and strings-------------------------------------------------------------------withTString :: String -> (LPTSTR -> IO a) -> IO a-withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a-peekTString :: LPCTSTR -> IO String-peekTStringLen :: (LPCTSTR, Int) -> IO String-newTString :: String -> IO LPCTSTR---- UTF-16 version:-type TCHAR = CWchar-withTString = withCWString-withTStringLen = withCWStringLen-peekTString = peekCWString-peekTStringLen = peekCWStringLen-newTString = newCWString--{- ANSI version:-type TCHAR = CChar-withTString = withCString-withTStringLen = withCStringLen-peekTString = peekCString-peekTStringLen = peekCStringLen-newTString = newCString--}--------------------------------------------------------------------- Handles-------------------------------------------------------------------type HANDLE = Ptr ()-type ForeignHANDLE = ForeignPtr ()--newForeignHANDLE :: HANDLE -> IO ForeignHANDLE-newForeignHANDLE = newForeignPtr deleteObjectFinaliser--handleToWord :: HANDLE -> UINT_PTR-handleToWord = castPtrToUINTPtr--type HKEY = ForeignHANDLE-type PKEY = HANDLE--nullHANDLE :: HANDLE-nullHANDLE = nullPtr--type MbHANDLE = Maybe HANDLE--type HINSTANCE = Ptr ()-type MbHINSTANCE = Maybe HINSTANCE--type HMODULE = Ptr ()-type MbHMODULE = Maybe HMODULE--nullFinalHANDLE :: ForeignPtr a-nullFinalHANDLE = unsafePerformIO (newForeignPtr_ nullPtr)--iNVALID_HANDLE_VALUE :: HANDLE-iNVALID_HANDLE_VALUE = castUINTPtrToPtr (-1)--------------------------------------------------------------------- Errors-------------------------------------------------------------------type ErrCode = DWORD--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 ()--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 <- if c_msg == nullPtr- then return $ "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- c_maperrno -- turn GetLastError() into errno, which errnoToIOError knows- -- how to convert to an IOException we can throw.- -- XXX we should really do this directly.- errno <- getErrno- let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n- ioerror = errnoToIOError fn_name errno Nothing Nothing- `ioeSetErrorString` msg'- throwIO ioerror---foreign import ccall unsafe "maperrno" -- in base/cbits/Win32Utils.c- c_maperrno :: IO ()--------------------------------------------------------------------- Misc helpers-------------------------------------------------------------------ddwordToDwords :: DDWORD -> (DWORD,DWORD)-ddwordToDwords n =- (fromIntegral (n `shiftR` finiteBitSize (undefined :: DWORD))- ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))--dwordsToDdword:: (DWORD,DWORD) -> DDWORD-dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi)--------------------------------------------------------------------- Primitives-------------------------------------------------------------------{-# CFILES cbits/HsWin32.c #-}-foreign import ccall "HsWin32.h &DeleteObjectFinaliser"- deleteObjectFinaliser :: FunPtr (Ptr a -> IO ())--foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"- localFree :: Ptr a -> IO (Ptr a)--foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"- getLastError :: IO ErrCode--{-# CFILES cbits/errors.c #-}--foreign import ccall unsafe "errors.h"- getErrorMessage :: DWORD -> IO LPWSTR--{-# CFILES cbits/HsWin32.c #-}--foreign import ccall unsafe "HsWin32.h"- lOWORD :: DWORD -> WORD--foreign import ccall unsafe "HsWin32.h"- hIWORD :: DWORD -> WORD--foreign import ccall unsafe "HsWin32.h"- castUINTPtrToPtr :: UINT_PTR -> Ptr a--foreign import ccall unsafe "HsWin32.h"- castPtrToUINTPtr :: Ptr s -> UINT_PTR--type LCID = DWORD--type LANGID = WORD-type SortID = WORD--foreign import ccall unsafe "HsWin32.h prim_MAKELCID"- mAKELCID :: LANGID -> SortID -> LCID--foreign import ccall unsafe "HsWin32.h prim_LANGIDFROMLCID"- lANGIDFROMLCID :: LCID -> LANGID--foreign import ccall unsafe "HsWin32.h prim_SORTIDFROMLCID"- sORTIDFROMLCID :: LCID -> SortID--type SubLANGID = WORD-type PrimaryLANGID = WORD--foreign import ccall unsafe "HsWin32.h prim_MAKELANGID"- mAKELANGID :: PrimaryLANGID -> SubLANGID -> LANGID--foreign import ccall unsafe "HsWin32.h prim_PRIMARYLANGID"- pRIMARYLANGID :: LANGID -> PrimaryLANGID--foreign import ccall unsafe "HsWin32.h prim_SUBLANGID"- sUBLANGID :: LANGID -> SubLANGID--------------------------------------------------------------------- End-----------------------------------------------------------------
+ System/Win32/Types.hsc view
@@ -0,0 +1,578 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Types+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Types+ ( module System.Win32.Types+ , nullPtr+ ) where++import Control.Concurrent.MVar (readMVar)+import Control.Exception (bracket, throwIO)+import Data.Bits (shiftL, shiftR, (.|.), (.&.))+import Data.Char (isSpace)+import Data.Int (Int32, Int64, Int16)+import Data.Maybe (fromMaybe)+import Data.Typeable (cast)+import Data.Word (Word8, Word16, Word32, Word64)+import Foreign.C.Error (Errno(..), errnoToIOError)+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__(..))+import Numeric (showHex)+import qualified System.IO as IO ()+import System.IO.Error (ioeSetErrorString)+import System.IO.Unsafe (unsafePerformIO)++#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Bits (finiteBitSize)+#else+import Data.Bits (Bits, bitSize)++finiteBitSize :: (Bits a) => a -> Int+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 <fcntl.h>+#include <windows.h>+##include "windows_cconv.h"++----------------------------------------------------------------+-- Platform specific definitions+--+-- Most typedefs and prototypes in Win32 are expressed in terms+-- of these types. Try to follow suit - it'll make it easier to+-- get things working on Win64 (or whatever they call it on Alphas).+----------------------------------------------------------------++type BOOL = Bool+type BYTE = Word8+type UCHAR = CUChar+type USHORT = Word16+type UINT = Word32+type INT = Int32+type WORD = Word16+type DWORD = Word32+type LONG = Int32+type FLOAT = Float+type LARGE_INTEGER = Int64++type DWORD32 = Word32+type DWORD64 = Word64+type INT32 = Int32+type INT64 = Int64+type LONG32 = Int32+type LONG64 = Int64+type UINT32 = Word32+type UINT64 = Word64+type ULONG32 = Word32+type ULONG64 = Word64+type SHORT = Int16++type INT_PTR = Ptr CInt+type ULONG = Word32+type UINT_PTR = Word+type LONG_PTR = CIntPtr+type ULONG_PTR = CUIntPtr+type DWORD_PTR = ULONG_PTR+#ifdef _WIN64+type HALF_PTR = Ptr INT32+#else+type HALF_PTR = Ptr SHORT+#endif++-- Not really a basic type, but used in many places+type DDWORD = Word64++----------------------------------------------------------------++type MbString = Maybe String+type MbINT = Maybe INT++type ATOM = WORD+type WPARAM = UINT_PTR+type LPARAM = LONG_PTR+type LRESULT = LONG_PTR+type SIZE_T = ULONG_PTR++type MbATOM = Maybe ATOM++type HRESULT = LONG++----------------------------------------------------------------+-- Pointers+----------------------------------------------------------------++type Addr = Ptr ()++type LPVOID = Ptr ()+type LPBOOL = Ptr BOOL+type LPBYTE = Ptr BYTE+type PUCHAR = Ptr UCHAR+type LPDWORD = Ptr DWORD+type LPSTR = Ptr CChar+type LPCSTR = LPSTR+type LPWSTR = Ptr CWchar+type LPCWSTR = LPWSTR+type LPTSTR = Ptr TCHAR+type LPCTSTR = LPTSTR+type LPCTSTR_ = LPCTSTR++-- Optional things with defaults++maybePtr :: Maybe (Ptr a) -> Ptr a+maybePtr = fromMaybe nullPtr++ptrToMaybe :: Ptr a -> Maybe (Ptr a)+ptrToMaybe p = if p == nullPtr then Nothing else Just p++maybeNum :: Num a => Maybe a -> a+maybeNum = fromMaybe 0++numToMaybe :: (Eq a, Num a) => a -> Maybe a+numToMaybe n = if n == 0 then Nothing else Just n++type MbLPVOID = Maybe LPVOID+type MbLPCSTR = Maybe LPCSTR+type MbLPCTSTR = Maybe LPCTSTR++----------------------------------------------------------------+-- Chars and strings+----------------------------------------------------------------++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+newTString :: String -> IO LPCTSTR++-- UTF-16 version:+type TCHAR = CWchar+withTString = withCWString+withFilePath path = useAsCWStringSafe path+withTStringLen = withCWStringLen+peekTString = peekCWString+peekTStringLen = peekCWStringLen+newTString = newCWString++{- ANSI version:+type TCHAR = CChar+withTString = withCString+withTStringLen = withCStringLen+peekTString = peekCString+peekTStringLen = peekCStringLen+newTString = newCString+-}++-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are+-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660+useAsCWStringSafe :: FilePath -> (CWString -> IO a) -> IO a+useAsCWStringSafe path f =+ if '\NUL' `elem` path+ then ioError err+ else withCWString path f+ where+ err =+ IOError+ { ioe_handle = Nothing+ , ioe_type = InvalidArgument+ , ioe_location = "useAsCWStringSafe"+ , ioe_description = "Windows filepaths must not contain internal NUL codepoints."+ , ioe_errno = Nothing+ , ioe_filename = Just path+ }+++----------------------------------------------------------------+-- Handles+----------------------------------------------------------------++type HANDLE = Ptr ()+type ForeignHANDLE = ForeignPtr ()++newForeignHANDLE :: HANDLE -> IO ForeignHANDLE+newForeignHANDLE = newForeignPtr deleteObjectFinaliser++handleToWord :: HANDLE -> UINT_PTR+handleToWord = castPtrToUINTPtr++type HKEY = ForeignHANDLE+type PKEY = HANDLE++nullHANDLE :: HANDLE+nullHANDLE = nullPtr++type MbHANDLE = Maybe HANDLE++nullHINSTANCE :: HINSTANCE+nullHINSTANCE = nullPtr++type HINSTANCE = Ptr ()+type MbHINSTANCE = Maybe HINSTANCE++type HMODULE = Ptr ()+type MbHMODULE = Maybe HMODULE++nullFinalHANDLE :: ForeignPtr a+nullFinalHANDLE = unsafePerformIO (newForeignPtr_ nullPtr)++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++-- | Create a Haskell 'Handle' from a Windows 'HANDLE'.+--+-- Beware that this function allocates a new file descriptor. A consequence of+-- this is that calling 'hANDLEToHandle' on the standard Windows handles will+-- not give you 'IO.stdin', 'IO.stdout', or 'IO.stderr'. For example, if you+-- run this code:+--+-- @+-- import Graphics.Win32.Misc+-- stdoutHANDLE <- getStdHandle sTD_OUTPUT_HANDLE+-- stdout2 <- 'hANDLEToHandle' stdoutHANDLE+-- @+--+-- 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 = 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++-- | Extract a Windows 'HANDLE' from a Haskell 'Handle' and perform+-- an action on it.++-- Originally authored by Max Bolingbroke in the ansi-terminal library+withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a+##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+ -- 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+ 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+ Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))+ $ readMVar write_handle_mvar++ -- 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++withStablePtr :: a -> (StablePtr a -> IO b) -> IO b+withStablePtr value = bracket (newStablePtr value) freeStablePtr++----------------------------------------------------------------+-- Errors+----------------------------------------------------------------++type ErrCode = DWORD++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++eRROR_INSUFFICIENT_BUFFER :: ErrCode+eRROR_INSUFFICIENT_BUFFER = #const ERROR_INSUFFICIENT_BUFFER++eRROR_MOD_NOT_FOUND :: ErrCode+eRROR_MOD_NOT_FOUND = #const ERROR_MOD_NOT_FOUND++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+ 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 <- if c_msg == nullPtr+ then return $ "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+++foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c+ c_maperrno_func :: ErrCode -> IO Errno++----------------------------------------------------------------+-- Misc helpers+----------------------------------------------------------------++ddwordToDwords :: DDWORD -> (DWORD,DWORD)+ddwordToDwords n =+ (fromIntegral (n `shiftR` finiteBitSize (undefined :: DWORD))+ ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))++dwordsToDdword:: (DWORD,DWORD) -> DDWORD+dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi)++-- 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 String+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++----------------------------------------------------------------+-- Primitives+----------------------------------------------------------------++{-# CFILES cbits/HsWin32.c #-}+foreign import ccall "HsWin32.h &DeleteObjectFinaliser"+ deleteObjectFinaliser :: FunPtr (Ptr a -> IO ())++foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"+ localFree :: Ptr a -> IO (Ptr a)++foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"+ getLastError :: IO ErrCode++foreign import WINDOWS_CCONV unsafe "windows.h SetLastError"+ setLastError :: ErrCode -> IO ()++{-# CFILES cbits/errors.c #-}++foreign import ccall unsafe "errors.h"+ getErrorMessage :: DWORD -> IO LPWSTR++{-# CFILES cbits/HsWin32.c #-}++foreign import ccall unsafe "HsWin32.h"+ lOWORD :: DWORD -> WORD++foreign import ccall unsafe "HsWin32.h"+ hIWORD :: DWORD -> WORD++foreign import ccall unsafe "HsWin32.h"+ castUINTPtrToPtr :: UINT_PTR -> Ptr a++foreign import ccall unsafe "HsWin32.h"+ castPtrToUINTPtr :: Ptr s -> UINT_PTR++type LCID = DWORD++type LANGID = WORD+type SortID = WORD++foreign import ccall unsafe "HsWin32.h prim_MAKELCID"+ mAKELCID :: LANGID -> SortID -> LCID++foreign import ccall unsafe "HsWin32.h prim_LANGIDFROMLCID"+ lANGIDFROMLCID :: LCID -> LANGID++foreign import ccall unsafe "HsWin32.h prim_SORTIDFROMLCID"+ sORTIDFROMLCID :: LCID -> SortID++type SubLANGID = WORD+type PrimaryLANGID = WORD++foreign import ccall unsafe "HsWin32.h prim_MAKELANGID"+ mAKELANGID :: PrimaryLANGID -> SubLANGID -> LANGID++foreign import ccall unsafe "HsWin32.h prim_PRIMARYLANGID"+ pRIMARYLANGID :: LANGID -> PrimaryLANGID++foreign import ccall unsafe "HsWin32.h prim_SUBLANGID"+ sUBLANGID :: LANGID -> SubLANGID++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ System/Win32/Utils.hs view
@@ -0,0 +1,410 @@+{- | + 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.Utils + ( 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 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.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. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String +try = System.Win32.Types.try +{-# INLINE try #-} + +tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String +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 + +try' :: Storable a => String -> (Ptr a -> PDWORD -> IO BOOL) -> DWORD -> IO [a] +try' loc f n = + with n $ \n' -> do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + flg <- f lptstr n' + unless flg $ do + err_code <- getLastError + unless (err_code == eRROR_INSUFFICIENT_BUFFER) + $ failWith loc err_code + r <- peek n' + 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 = + if p == nullPtr + then return Nothing + else Just `fmap` peek p + +-- | See also: 'Foreign.Marshal.Utils.maybeWith' function. +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
+ System/Win32/WindowsString/Console.hsc view
@@ -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 <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32 Console API (WindowsString variant)+--+-----------------------------------------------------------------------------++module System.Win32.WindowsString.Console (+ -- * Console mode+ getConsoleMode,+ setConsoleMode,+ eNABLE_ECHO_INPUT,+ eNABLE_EXTENDED_FLAGS,+ eNABLE_INSERT_MODE,+ eNABLE_LINE_INPUT,+ eNABLE_MOUSE_INPUT,+ eNABLE_PROCESSED_INPUT,+ eNABLE_QUICK_EDIT_MODE,+ eNABLE_WINDOW_INPUT,+ eNABLE_VIRTUAL_TERMINAL_INPUT,+ eNABLE_PROCESSED_OUTPUT,+ eNABLE_WRAP_AT_EOL_OUTPUT,+ eNABLE_VIRTUAL_TERMINAL_PROCESSING,+ dISABLE_NEWLINE_AUTO_RETURN,+ eNABLE_LVB_GRID_WORLDWIDE,+ -- * Console code pages+ getConsoleCP,+ setConsoleCP,+ getConsoleOutputCP,+ setConsoleOutputCP,+ -- * Ctrl events+ CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT,+ generateConsoleCtrlEvent,+ -- * Command line+ commandLineToArgv,+ getCommandLineW,+ getArgs,+ -- * Screen buffer+ CONSOLE_SCREEN_BUFFER_INFO(..),+ CONSOLE_SCREEN_BUFFER_INFOEX(..),+ COORD(..),+ SMALL_RECT(..),+ COLORREF,+ getConsoleScreenBufferInfo,+ getCurrentConsoleScreenBufferInfo,+ getConsoleScreenBufferInfoEx,+ getCurrentConsoleScreenBufferInfoEx,++ -- * Env+ getEnv,+ getEnvironment+ ) where++#include <windows.h>+#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:+-- <https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getcommandlinew>+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)+
+ System/Win32/WindowsString/DLL.hsc view
@@ -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 <ei@vuokko.info> +-- 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 +
+ System/Win32/WindowsString/DebugApi.hsc view
@@ -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 <ei@vuokko.info> +-- 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 +
+ System/Win32/WindowsString/File.hsc view
@@ -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 <ei@vuokko.info> +-- 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 <windows.h> +#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 +----------------------------------------------------------------
+ System/Win32/WindowsString/FileMapping.hsc view
@@ -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 <ei@vuokko.info> +-- 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 +
+ System/Win32/WindowsString/HardLink.hs view
@@ -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
+ System/Win32/WindowsString/Info.hsc view
@@ -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 <ei@vuokko.info> +-- 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 <windows.h> +#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 +----------------------------------------------------------------
+ System/Win32/WindowsString/Path.hsc view
@@ -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 <tamar@zhox.com> +-- 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 <windows.h> + +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 +
+ System/Win32/WindowsString/Shell.hsc view
@@ -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 <ei@vuokko.info>+-- 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 <windows.h>+#include <shlobj.h>++----------------------------------------------------------------+-- 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
+ System/Win32/WindowsString/String.hs view
@@ -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
+ System/Win32/WindowsString/SymbolicLink.hsc view
@@ -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 + \<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.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) +
+ System/Win32/WindowsString/Time.hsc view
@@ -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 <ei@vuokko.info> +-- 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 <windows.h> +#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')
+ System/Win32/WindowsString/Types.hsc view
@@ -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 <ei@vuokko.info> +-- 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 <fcntl.h> +#include <windows.h> +#include <wchar.h> +##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
+ System/Win32/WindowsString/Utils.hs view
@@ -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
+ System/Win32/Word.hs view
@@ -0,0 +1,23 @@+{- | + Module : System.Win32.Word + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Windows' unsigned integer types and pointer type. +-} +module System.Win32.Word + ( WORD, DWORD, PDWORD, LPDWORD + , DWORDLONG, DDWORD + , DWORD32, DWORD64, DWORD_PTR + ) where +import Data.Word ( Word64 ) +import Foreign.Ptr ( Ptr ) +import System.Win32.Types ( WORD, DWORD, LPDWORD, DDWORD, + DWORD32, DWORD64, DWORD_PTR ) + +type PDWORD = Ptr DWORD +type DWORDLONG = Word64
Win32.cabal view
@@ -1,25 +1,59 @@-name: Win32-version: 2.3.1.1-license: BSD3-license-file: LICENSE-author: Alastair Reid-copyright: Alastair Reid, 1999-2003-maintainer: Haskell Libraries <libraries@haskell.org>+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 <libraries@haskell.org> bug-reports: https://github.com/haskell/win32/issues homepage: https://github.com/haskell/win32-category: System, Graphics-synopsis: A binding to part of the Win32 library-description: A binding to part of the Win32 library.+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: >=1.6 extra-source-files:- include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h- include/Win32Aux.h include/win32debug.h include/windows_cconv.h+ 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- build-depends: base >= 4.5 && < 5, bytestring- ghc-options: -Wall -fno-warn-name-shadowing- cc-options: -fno-strict-aliasing+ default-language: Haskell2010+ default-extensions: ForeignFunctionInterface, CPP+ if impl(ghc >= 7.1)+ default-extensions: NondecreasingIndentation++ if !os(windows)+ -- This package requires Windows to build+ build-depends: unbuildable<0+ buildable: False++ 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 exposed-modules: Graphics.Win32.GDI Graphics.Win32.GDI.Bitmap@@ -43,13 +77,27 @@ Graphics.Win32.Misc Graphics.Win32.Resource Graphics.Win32.Window+ Graphics.Win32.LayeredWindow+ Graphics.Win32.GDI.AlphaBlend+ Graphics.Win32.Window.AnimateWindow+ Graphics.Win32.Window.HotKey+ Graphics.Win32.Window.IMM+ Graphics.Win32.Window.ForegroundWindow+ Graphics.Win32.Window.PostMessage++ Media.Win32+ 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+ System.Win32.MinTTY System.Win32.NLS System.Win32.Process System.Win32.Registry@@ -57,16 +105,63 @@ System.Win32.Time System.Win32.Console System.Win32.Security+ System.Win32.Semaphore System.Win32.Types System.Win32.Shell- extensions: ForeignFunctionInterface, CPP- if impl(ghc >= 7.1)- extensions: NondecreasingIndentation+ System.Win32.Automation+ System.Win32.Automation.Input+ System.Win32.Automation.Input.Key+ System.Win32.Automation.Input.Mouse+ System.Win32.Console.CtrlHandler+ System.Win32.Console.HWND+ System.Win32.Console.Title+ System.Win32.Encoding+ System.Win32.Exception.Unsupported+ System.Win32.HardLink+ System.Win32.Info.Computer+ System.Win32.Info.Version+ System.Win32.String+ System.Win32.SymbolicLink+ System.Win32.Thread+ 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"- include-dirs: include- includes: "HsWin32.h", "HsGDI.h", "WndProc.h"- install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h"+ "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32"+ ghc-options: -Wall+ include-dirs: include+ 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@@ -75,7 +170,9 @@ cbits/dumpBMP.c cbits/ellipse.c cbits/errors.c+ cbits/alphablend.c+ cc-options: -Wall source-repository head type: git- location: git://github.com/haskell/win32+ location: https://github.com/haskell/win32
+ cbits/alphablend.c view
@@ -0,0 +1,15 @@+#include <alphablend.h>++BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest+ , HDC hdcSrc, int nXOriginSrc, int nYOriginSrc, int nWidthSrc, int nHeightSrc+ , PBLENDFUNCTION pblendFunction)+{+ BLENDFUNCTION blendFunction;+ blendFunction.BlendOp = pblendFunction->BlendOp;+ blendFunction.BlendFlags = pblendFunction->BlendFlags;+ blendFunction.SourceConstantAlpha = pblendFunction->SourceConstantAlpha;+ blendFunction.AlphaFormat = pblendFunction->AlphaFormat;+ return AlphaBlend ( hdcDest, nXOriginDest, nYOriginDest, nWidthDest, hHeightDest+ , hdcSrc, nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc+ , blendFunction);+}
cbits/dumpBMP.c view
@@ -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;
+ changelog.md view
@@ -0,0 +1,246 @@+# Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32)++## 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++* Add `getConsoleMode` and `setConsoleMode` (See #137)++## 2.8.4.0 *Oct 2019*++* Added function `getWindowText`+* Added function `getWindowTextLength`++## 2.8.3.0 *Feb 2019*++* Add `Module32FirstW` and `Module32NextW` (See #121)+* Add `Virtual[Alloc/Free]Ex` (See #124)++## 2.8.2.0 *Dec 2018*++* Drop use of NegativeLiterals (See #118)++## 2.8.1.0 *Nov 2018*++* Fix broken links (See #116)+* Remove unused CPP Lower bounds (See #114)+* GHC 8.8 release++## 2.8.0.0 *May 2018*++* Deprecated `regQueryValueKey`. (See #105, #108)+* Updated `regQueryValue` signature (See #108)+* Add `regQueryDefaultValue` (See #108)+* Add `regGetValue` and `RegTypeRestriction` (See #109)+* Remove `sYNCHRONIZE` from System.Win32.Process, use System.Win32.File instead. (See #110)++## 2.7.1.0 *April 2018*++* Fixed `MOUSEINPUT` storable instance. (See #106)++## 2.7.0.0 *March 2018*++* Fixed `DWORD_PTR` type (See #99)+* Add `lockFile` and `unlockFile` (See #103)++## 2.6.2.0 *December 2017*++* Add `setFilePointerEx` (See #94)+* Add `getConsoleScreenBufferInfo` and `getCurrentConsoleScreenBufferInfo` (See #95)++## 2.6.1.0 *November 2017*++* Add `terminateProcessById` (See #91)++## 2.6.0.0 *September 2017*++* Make cabal error out on compilation on non-Windows OSes. (See #80)+* Update cabal format to 1.10 and set language+ default to Haskell2010. (See #81)+* Use `Maybe` in wrappers for functions with nullable pointer parameters (See #83)+* Improve cross compilation support. (See #87)++## 2.5.4.1 *April 2017*++* Fixed GetWindowLong on 32-bit Windows++## 2.5.3.0 *March 2017*++* Fix buffer overflow in `regSetValue`. (See #39)+* Added `getPixel`. (See #37)+* Drop dependency on `ntdll` because of incorrect import library on x86. (See #79)++## 2.5.2.0 *March 2017*++* Fix constant underflows with (-1) and unsigned numbers.+* Add `commandLineToArgv`++## 2.5.1.0 *Feb 2017*++* Add `withHandleToHANDLE` (originally found in the `ansi-terminal` library)+* fixed `PokeTZI` test++## 2.5.0.0 *Jan 2017*++* `failWith` (and the API calls that use it) now throw `IOError`s with proper+ `IOErrorType`s.+* Add function `findWindowByName`+* Fix a bug in the implementation of `poke` for `TIME_ZONE_INFORMATION` which+ would cause it to be marshalled incorrectly.+* Add `System.Win32.MinTTY` module for detecting the presence of MinTTY.+* Add `ULONG` type to `System.Win32.Types`.+* Add function `failIfNeg` to `System.Win32.Types`, which fails if a negative+ number is returned. This simulates the behavior of the `NT_SUCCESS` macro.+* Merged package Win32-extras (See #16)+* `Graphics.Win32.Misc.messageBox` safely imported now https://github.com/haskell/win32/pull/5+* Fixed various alignment calls that were incorrect. These would result in an incorrect alignment+ being returned on certain platforms. (See #66)++## 2.4.0.0 *Nov 2016*++* Add `windows_cconv.h` to the `install-includes` field of `Win32.cabal`,+ allowing packages that transitively depend on `Win32` to use the+ `WINDOWS_CCONV` CPP macro (which expands to `stdcall` or `ccall`+ appropriately depending on the system architecture)+* Added function `getLongPathName`+* Added function `getShortPathName`+* Added function `getUserName`+* Added file attribute `fILE_ATTRIBUTE_REPARSE_POINT`+* Added more [`File Access Rights` constants](https://msdn.microsoft.com/en-us/library/windows/desktop/gg258116%28v=vs.85%29.aspx)+* Added function `getCurrentProcessId`+* Added function `filepathRelativePathTo`+* Added function `pathRelativePathTo`+* Corrected 64 bit types (See #53)++## 2.3.1.1 *May 2016*++* Release for GHC 8.0.1
+ include/alignment.h view
@@ -0,0 +1,3 @@+#if __GLASGOW_HASKELL__ < 711 +#define hsc_alignment(t ) hsc_printf ( "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__)); +#endif
+ include/alphablend.h view
@@ -0,0 +1,10 @@+#ifndef _ALPHABLEND_H+#define _ALPHABLEND_H++#include <windows.h>++BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest+ , HDC hdcSrc, int nXOriginSrc, int nYOriginSrc, int nWidthSrc, int nHeightSrc+ , PBLENDFUNCTION pblendFunction);++#endif /* _ALPHABLEND_H */
+ include/namedpipeapi_compat.h view
@@ -0,0 +1,16 @@+/* The version of wincon.h provided by the version of MSYS2 included with x86+ * versions of GHC before GHC 7.10 excludes certain components introduced with+ * Windows Vista.+ */++#ifndef NAMEDPIPEAPI_COMPAT_H+#define NAMEDPIPEAPI_COMPAT_H++#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708+#+#else++#define PIPE_ACCEPT_REMOTE_CLIENTS 0x0+#define PIPE_REJECT_REMOTE_CLIENTS 0x8+#endif /* GHC version check */+#endif /* NAMEDPIPEAPI_COMPAT_H */
+ include/tlhelp32_compat.h view
@@ -0,0 +1,26 @@+#ifndef TLHELP32_COMPAT_H+#define TLHELP32_COMPAT_H+ /*+ * 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__ >= 710+#else+// Declarations from tlhelp32.h that Win32 requires+#include <windows.h>++// 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 */
+ include/wincon_compat.h view
@@ -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 */
include/windows_cconv.h view
@@ -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
+ include/winnls_compat.h view
@@ -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 */
+ include/winnt_compat.h view
@@ -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 */
+ include/winreg_compat.h view
@@ -0,0 +1,32 @@+#ifndef WINREG_COMPAT_H+#define WINREG_COMPAT_H++#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708+#+#else+#define RRF_RT_REG_NONE 0x00000001+#define RRF_RT_REG_SZ 0x00000002+#define RRF_RT_REG_EXPAND_SZ 0x00000004+#define RRF_RT_REG_BINARY 0x00000008+#define RRF_RT_REG_DWORD 0x00000010+#define RRF_RT_REG_MULTI_SZ 0x00000020+#define RRF_RT_REG_QWORD 0x00000040++#define RRF_RT_DWORD (RRF_RT_REG_BINARY | RRF_RT_REG_DWORD)+#define RRF_RT_QWORD (RRF_RT_REG_BINARY | RRF_RT_REG_QWORD)+#define RRF_RT_ANY 0x0000ffff++#define RRF_NOEXPAND 0x10000000+#define RRF_ZEROONFAILURE 0x20000000++#endif++#ifndef RRF_SUBKEY_WOW6464KEY+#define RRF_SUBKEY_WOW6464KEY 0x00010000+#endif++#ifndef RRF_SUBKEY_WOW6432KEY+#define RRF_SUBKEY_WOW6432KEY 0x00020000+#endif++#endif /* WINREG_COMPAT_H */
+ include/winternl_compat.h view
@@ -0,0 +1,39 @@+#ifndef WINTERNL_COMPAT_H+#define WINTERNL_COMPAT_H++/*+ * winternl.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 defined(x86_64_HOST_ARCH) || \+ __GLASGOW_HASKELL__ >= 711 || \+ (__GLASGOW_HASKELL__ == 710 && \+ defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \+ __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2)+# include <winternl.h>+#else+// Some declarations from winternl.h that we need in Win32+# include <windows.h>++typedef enum _OBJECT_INFORMATION_CLASS {+ ObjectBasicInformation,+ ObjectNameInformation,+ ObjectTypeInformation,+ ObjectAllInformation,+ ObjectDataInformation+} OBJECT_INFORMATION_CLASS, *POBJECT_INFORMATION_CLASS;++typedef LONG NTSTATUS, *PNTSTATUS;++typedef struct _UNICODE_STRING {+ USHORT Length;+ USHORT MaximumLength;+ PWSTR Buffer;+} UNICODE_STRING, *PUNICODE_STRING;++typedef struct _OBJECT_NAME_INFORMATION {+ UNICODE_STRING Name;+} OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION;+#endif++#endif /* WINTERNL_COMPAT_H */
+ include/winuser_compat.h view
@@ -0,0 +1,113 @@+#ifndef WINUSER_COMPAT_H+#define WINUSER_COMPAT_H++/*+ * winuser.h is missing some includes in MinGW, which was shipped with the 32-bit+ * Windows version of GHC prior to the 7.10.3 release.+ */+#if defined(x86_64_HOST_ARCH) || \+ __GLASGOW_HASKELL__ >= 711 || \+ (__GLASGOW_HASKELL__ == 710 && \+ defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \+ __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2)+#else+// Some declarations from winuser.h that we need in Win32+# include <windows.h>++#define VK_XBUTTON1 0x05+#define VK_XBUTTON2 0x06++#define VK_BROWSER_BACK 0xA6+#define VK_BROWSER_FORWARD 0xA7+#define VK_BROWSER_REFRESH 0xA8+#define VK_BROWSER_STOP 0xA9+#define VK_BROWSER_SEARCH 0xAA+#define VK_BROWSER_FAVORITES 0xAB+#define VK_BROWSER_HOME 0xAC+#define VK_VOLUME_MUTE 0xAD+#define VK_VOLUME_DOWN 0xAE+#define VK_VOLUME_UP 0xAF+#define VK_MEDIA_NEXT_TRACK 0xB0+#define VK_MEDIA_PREV_TRACK 0xB1+#define VK_MEDIA_STOP 0xB2+#define VK_MEDIA_PLAY_PAUSE 0xB3+#define VK_LAUNCH_MAIL 0xB4+#define VK_LAUNCH_MEDIA_SELECT 0xB5+#define VK_LAUNCH_APP1 0xB6+#define VK_LAUNCH_APP2 0xB7++#define VK_OEM_PLUS 0xBB+#define VK_OEM_COMMA 0xBC+#define VK_OEM_MINUS 0xBD+#define VK_OEM_PERIOD 0xBE+#define VK_OEM_102 0xE2++#define VK_PACKET 0xE7++#define LWA_COLORKEY 0x00000001+#define LWA_ALPHA 0x00000002++#define ULW_COLORKEY 0x00000001+#define ULW_ALPHA 0x00000002+#define ULW_OPAQUE 0x00000004+#define ULW_EX_NORESIZE 0x00000008++#define AW_HOR_POSITIVE 0x00000001+#define AW_HOR_NEGATIVE 0x00000002+#define AW_VER_POSITIVE 0x00000004+#define AW_VER_NEGATIVE 0x00000008+#define AW_CENTER 0x00000010+#define AW_HIDE 0x00010000+#define AW_ACTIVATE 0x00020000+#define AW_SLIDE 0x00040000+#define AW_BLEND 0x00080000++#define INPUT_MOUSE 0+#define INPUT_KEYBOARD 1+#define INPUT_HARDWARE 2++#define KEYEVENTF_UNICODE 0x0004+#define KEYEVENTF_SCANCODE 0x0008++#define MOUSEEVENTF_XDOWN 0x0080+#define MOUSEEVENTF_XUP 0x0100++#define XBUTTON1 0x0001+#define XBUTTON2 0x0002++#if __GLASGOW_HASKELL__ < 710+typedef struct tagMOUSEINPUT {+ LONG dx;+ LONG dy;+ DWORD mouseData;+ DWORD dwFlags;+ DWORD time;+ ULONG_PTR dwExtraInfo;+} MOUSEINPUT, *PMOUSEINPUT, *LPMOUSEINPUT;++typedef struct tagKEYBDINPUT {+ WORD wVk;+ WORD wScan;+ DWORD dwFlags;+ DWORD time;+ ULONG_PTR dwExtraInfo;+} KEYBDINPUT, *PKEYBDINPUT, *LPKEYBDINPUT;++typedef struct tagHARDWAREINPUT {+ DWORD uMsg;+ WORD wParamL;+ WORD wParamH;+} HARDWAREINPUT, *PHARDWAREINPUT, *LPHARDWAREINPUT;++typedef struct tagINPUT {+ DWORD type;+ union {+ MOUSEINPUT mi;+ KEYBDINPUT ki;+ HARDWAREINPUT hi;+ } DUMMYUNIONNAME;+} INPUT, *PINPUT, *LPINPUT;+#endif++#endif /* GHC Version check */+#endif /* WINUSER_COMPAT_H */