diff --git a/Graphics/Win32.hs b/Graphics/Win32.hs --- a/Graphics/Win32.hs +++ b/Graphics/Win32.hs @@ -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 diff --git a/Graphics/Win32/Control.hsc b/Graphics/Win32/Control.hsc --- a/Graphics/Win32/Control.hsc +++ b/Graphics/Win32/Control.hsc @@ -1,6 +1,4 @@ -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.Control diff --git a/Graphics/Win32/Dialogue.hsc b/Graphics/Win32/Dialogue.hsc --- a/Graphics/Win32/Dialogue.hsc +++ b/Graphics/Win32/Dialogue.hsc @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/GDI.hs b/Graphics/Win32/GDI.hs --- a/Graphics/Win32/GDI.hs +++ b/Graphics/Win32/GDI.hs @@ -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 ( diff --git a/Graphics/Win32/GDI/AlphaBlend.hsc b/Graphics/Win32/GDI/AlphaBlend.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/AlphaBlend.hsc @@ -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 +#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' diff --git a/Graphics/Win32/GDI/Bitmap.hsc b/Graphics/Win32/GDI/Bitmap.hsc --- a/Graphics/Win32/GDI/Bitmap.hsc +++ b/Graphics/Win32/GDI/Bitmap.hsc @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Brush.hsc b/Graphics/Win32/GDI/Brush.hsc --- a/Graphics/Win32/GDI/Brush.hsc +++ b/Graphics/Win32/GDI/Brush.hsc @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Clip.hsc b/Graphics/Win32/GDI/Clip.hsc --- a/Graphics/Win32/GDI/Clip.hsc +++ b/Graphics/Win32/GDI/Clip.hsc @@ -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 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 diff --git a/Graphics/Win32/GDI/Font.hsc b/Graphics/Win32/GDI/Font.hsc --- a/Graphics/Win32/GDI/Font.hsc +++ b/Graphics/Win32/GDI/Font.hsc @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Graphics2D.hs b/Graphics/Win32/GDI/Graphics2D.hs --- a/Graphics/Win32/GDI/Graphics2D.hs +++ b/Graphics/Win32/GDI/Graphics2D.hs @@ -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 () diff --git a/Graphics/Win32/GDI/HDC.hs b/Graphics/Win32/GDI/HDC.hs --- a/Graphics/Win32/GDI/HDC.hs +++ b/Graphics/Win32/GDI/HDC.hs @@ -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 = diff --git a/Graphics/Win32/GDI/Palette.hsc b/Graphics/Win32/GDI/Palette.hsc --- a/Graphics/Win32/GDI/Palette.hsc +++ b/Graphics/Win32/GDI/Palette.hsc @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Path.hs b/Graphics/Win32/GDI/Path.hs --- a/Graphics/Win32/GDI/Path.hs +++ b/Graphics/Win32/GDI/Path.hs @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Pen.hsc b/Graphics/Win32/GDI/Pen.hsc --- a/Graphics/Win32/GDI/Pen.hsc +++ b/Graphics/Win32/GDI/Pen.hsc @@ -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 diff --git a/Graphics/Win32/GDI/Region.hs b/Graphics/Win32/GDI/Region.hs --- a/Graphics/Win32/GDI/Region.hs +++ b/Graphics/Win32/GDI/Region.hs @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Types.hsc b/Graphics/Win32/GDI/Types.hsc --- a/Graphics/Win32/GDI/Types.hsc +++ b/Graphics/Win32/GDI/Types.hsc @@ -1,6 +1,4 @@ -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.GDI.Types diff --git a/Graphics/Win32/Icon.hs b/Graphics/Win32/Icon.hs --- a/Graphics/Win32/Icon.hs +++ b/Graphics/Win32/Icon.hs @@ -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 = diff --git a/Graphics/Win32/Key.hsc b/Graphics/Win32/Key.hsc --- a/Graphics/Win32/Key.hsc +++ b/Graphics/Win32/Key.hsc @@ -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 @@ -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 +#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 + } diff --git a/Graphics/Win32/LayeredWindow.hsc b/Graphics/Win32/LayeredWindow.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/LayeredWindow.hsc @@ -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 +##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 + } + diff --git a/Graphics/Win32/Menu.hsc b/Graphics/Win32/Menu.hsc --- a/Graphics/Win32/Menu.hsc +++ b/Graphics/Win32/Menu.hsc @@ -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 diff --git a/Graphics/Win32/Message.hsc b/Graphics/Win32/Message.hsc --- a/Graphics/Win32/Message.hsc +++ b/Graphics/Win32/Message.hsc @@ -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 } ---------------------------------------------------------------- diff --git a/Graphics/Win32/Misc.hsc b/Graphics/Win32/Misc.hsc --- a/Graphics/Win32/Misc.hsc +++ b/Graphics/Win32/Misc.hsc @@ -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 diff --git a/Graphics/Win32/Resource.hsc b/Graphics/Win32/Resource.hsc --- a/Graphics/Win32/Resource.hsc +++ b/Graphics/Win32/Resource.hsc @@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 +#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/Graphics/Win32/Window.hsc b/Graphics/Win32/Window.hsc --- a/Graphics/Win32/Window.hsc +++ b/Graphics/Win32/Window.hsc @@ -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 diff --git a/Graphics/Win32/Window/AnimateWindow.hsc b/Graphics/Win32/Window/AnimateWindow.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/AnimateWindow.hsc @@ -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 +##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 diff --git a/Graphics/Win32/Window/ForegroundWindow.hs b/Graphics/Win32/Window/ForegroundWindow.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/ForegroundWindow.hs @@ -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: , +-- . +---------------------------------------------------------------- +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 diff --git a/Graphics/Win32/Window/HotKey.hsc b/Graphics/Win32/Window/HotKey.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/HotKey.hsc @@ -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 +##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 diff --git a/Graphics/Win32/Window/IMM.hsc b/Graphics/Win32/Window/IMM.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/IMM.hsc @@ -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 +##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 diff --git a/Graphics/Win32/Window/PostMessage.hsc b/Graphics/Win32/Window/PostMessage.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/PostMessage.hsc @@ -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 +##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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Media/Win32.hs b/Media/Win32.hs new file mode 100644 --- /dev/null +++ b/Media/Win32.hs @@ -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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMainWithHooks autoconfUserHooks diff --git a/System/Win32.hs b/System/Win32.hs --- a/System/Win32.hs +++ b/System/Win32.hs @@ -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 diff --git a/System/Win32/Automation.hs b/System/Win32/Automation.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Automation.hs @@ -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 diff --git a/System/Win32/Automation/Input.hsc b/System/Win32/Automation/Input.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Automation/Input.hsc @@ -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 +#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 diff --git a/System/Win32/Automation/Input/Key.hsc b/System/Win32/Automation/Input/Key.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Automation/Input/Key.hsc @@ -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 +#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 + } diff --git a/System/Win32/Automation/Input/Mouse.hsc b/System/Win32/Automation/Input/Mouse.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Automation/Input/Mouse.hsc @@ -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 +#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 +-} diff --git a/System/Win32/Console.hsc b/System/Win32/Console.hsc --- a/System/Win32/Console.hsc +++ b/System/Win32/Console.hsc @@ -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 +#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: +-- +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 diff --git a/System/Win32/Console/CtrlHandler.hs b/System/Win32/Console/CtrlHandler.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Console/CtrlHandler.hs @@ -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 diff --git a/System/Win32/Console/HWND.hs b/System/Win32/Console/HWND.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Console/HWND.hs @@ -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: +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 diff --git a/System/Win32/Console/Internal.hsc b/System/Win32/Console/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Console/Internal.hsc @@ -0,0 +1,336 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Console.Internal +-- Copyright : (c) University of Glasgow 2023 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Internals for Console modules. +-- +----------------------------------------------------------------------------- + +module System.Win32.Console.Internal where + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "wincon_compat.h" + +import System.Win32.Types +import Graphics.Win32.GDI.Types (COLORREF) + +import Foreign.C.Types (CInt(..), CWchar) +import Foreign.C.String (CWString) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, pokeArray) + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" + c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" + c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP" + getConsoleCP :: IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCP" + setConsoleCP :: UINT -> IO () + +foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleOutputCP" + getConsoleOutputCP :: IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleOutputCP" + setConsoleOutputCP :: UINT -> IO () + +type CtrlEvent = DWORD +#{enum CtrlEvent, + , cTRL_C_EVENT = 0 + , cTRL_BREAK_EVENT = 1 + } + +foreign import WINDOWS_CCONV safe "windows.h GenerateConsoleCtrlEvent" + c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "Shellapi.h CommandLineToArgvW" + c_CommandLineToArgvW :: CWString -> Ptr CInt -> IO (Ptr CWString) + +foreign import WINDOWS_CCONV unsafe "processenv.h GetCommandLineW" + getCommandLineW :: IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentVariableW" + c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentStringsW" + c_GetEnvironmentStringsW :: IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "processenv.h FreeEnvironmentStringsW" + c_FreeEnvironmentStrings :: LPWSTR -> IO Bool + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO + { dwSize :: COORD + , dwCursorPosition :: COORD + , wAttributes :: WORD + , srWindow :: SMALL_RECT + , dwMaximumWindowSize :: COORD + } deriving (Show, Eq) + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFO} + alignment _ = #alignment CONSOLE_SCREEN_BUFFER_INFO + peek buf = do + dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf + dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf + wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf + srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf + dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf + return $ CONSOLE_SCREEN_BUFFER_INFO dwSize' dwCursorPosition' wAttributes' srWindow' dwMaximumWindowSize' + poke buf info = do + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf (dwSize info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf (dwCursorPosition info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf (wAttributes info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf (srWindow info) + (#poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf (dwMaximumWindowSize info) + +data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX + { dwSizeEx :: COORD + , dwCursorPositionEx :: COORD + , wAttributesEx :: WORD + , srWindowEx :: SMALL_RECT + , dwMaximumWindowSizeEx :: COORD + , wPopupAttributes :: WORD + , bFullscreenSupported :: BOOL + , colorTable :: [COLORREF] + -- ^ Only the first 16 'COLORREF' values passed to the Windows Console + -- API. If fewer than 16 values, the remainder are padded with @0@ when + -- passed to the API. + } deriving (Show, Eq) + +instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where + sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFOEX} + alignment = const #{alignment CONSOLE_SCREEN_BUFFER_INFOEX} + peek buf = do + dwSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf + dwCursorPosition' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf + wAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf + srWindow' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf + dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf + wPopupAttributes' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf + bFullscreenSupported' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf + colorTable' <- peekArray 16 ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) + return $ CONSOLE_SCREEN_BUFFER_INFOEX dwSize' dwCursorPosition' + wAttributes' srWindow' dwMaximumWindowSize' wPopupAttributes' + bFullscreenSupported' colorTable' + poke buf info = do + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, cbSize) buf cbSize + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf (dwSizeEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf (dwCursorPositionEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf (wAttributesEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf (srWindowEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf (dwMaximumWindowSizeEx info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf (wPopupAttributes info) + (#poke CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf (bFullscreenSupported info) + pokeArray ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) colorTable' + where + cbSize :: ULONG + cbSize = #{size CONSOLE_SCREEN_BUFFER_INFOEX} + colorTable' = take 16 $ colorTable info ++ repeat 0 + +data COORD = COORD + { xPos :: SHORT + , yPos :: SHORT + } deriving (Show, Eq) + +instance Storable COORD where + sizeOf = const #{size COORD} + alignment _ = #alignment COORD + peek buf = do + x' <- (#peek COORD, X) buf + y' <- (#peek COORD, Y) buf + return $ COORD x' y' + poke buf coord = do + (#poke COORD, X) buf (xPos coord) + (#poke COORD, Y) buf (yPos coord) + +data SMALL_RECT = SMALL_RECT + { leftPos :: SHORT + , topPos :: SHORT + , rightPos :: SHORT + , bottomPos :: SHORT + } deriving (Show, Eq) + +instance Storable SMALL_RECT where + sizeOf _ = #{size SMALL_RECT} + alignment _ = #alignment SMALL_RECT + peek buf = do + left' <- (#peek SMALL_RECT, Left) buf + top' <- (#peek SMALL_RECT, Top) buf + right' <- (#peek SMALL_RECT, Right) buf + bottom' <- (#peek SMALL_RECT, Bottom) buf + return $ SMALL_RECT left' top' right' bottom' + poke buf small_rect = do + (#poke SMALL_RECT, Left) buf (leftPos small_rect) + (#poke SMALL_RECT, Top) buf (topPos small_rect) + (#poke SMALL_RECT, Right) buf (rightPos small_rect) + (#poke SMALL_RECT, Bottom) buf (bottomPos small_rect) + +foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo" + c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL + +foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfoEx" + c_GetConsoleScreenBufferInfoEx :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFOEX -> IO BOOL + +-- | This type represents a keyboard input event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/key-event-record-str +data KEY_EVENT_RECORD = KEY_EVENT_RECORD + { keyDown :: BOOL + , repeatCount :: WORD + , virtualKeyCode :: WORD + , virtualScanCode :: WORD + , uChar :: CWchar + , controlKeyStateK :: DWORD + } deriving (Eq, Show) + +-- | This type represents a mouse event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/mouse-event-record-str +data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD + { mousePosition :: COORD + , buttonState :: DWORD + , controlKeyStateM :: DWORD + , eventFlags :: DWORD + } deriving (Eq, Show) + +-- | This type represents a window size change event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/window-buffer-size-record-str +newtype WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD + { windowSize :: COORD + } deriving (Eq, Show) + +-- | This type represents a window menu event. (Current ignored by VTY). The structure +-- is documented here: https://learn.microsoft.com/en-us/windows/console/menu-event-record-str +newtype MENU_EVENT_RECORD = MENU_EVENT_RECORD + { commandId :: UINT + } deriving (Eq, Show) + +-- | This type represents a window focus change event. The structure is documented here: +-- https://learn.microsoft.com/en-us/windows/console/focus-event-record-str +newtype FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD + { setFocus :: BOOL + } deriving (Eq, Show) + +-- | Description of a Windows console input event. Documented here: +-- https://learn.microsoft.com/en-us/windows/console/input-record-str +data INPUT_RECORD = + KeyEvent KEY_EVENT_RECORD + | MouseEvent MOUSE_EVENT_RECORD + | WindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD + | MenuEvent MENU_EVENT_RECORD + | FocusEvent FOCUS_EVENT_RECORD + deriving (Eq, Show) + +instance Storable KEY_EVENT_RECORD where + sizeOf = const #{size KEY_EVENT_RECORD} + alignment _ = #alignment KEY_EVENT_RECORD + poke buf input = do + (#poke KEY_EVENT_RECORD, bKeyDown) buf (keyDown input) + (#poke KEY_EVENT_RECORD, wRepeatCount) buf (repeatCount input) + (#poke KEY_EVENT_RECORD, wVirtualKeyCode) buf (virtualKeyCode input) + (#poke KEY_EVENT_RECORD, wVirtualScanCode) buf (virtualScanCode input) + (#poke KEY_EVENT_RECORD, uChar) buf (uChar input) + (#poke KEY_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateK input) + peek buf = do + keyDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) buf + repeatCount' <- (#peek KEY_EVENT_RECORD, wRepeatCount) buf + virtualKeyCode' <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) buf + virtualScanCode' <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) buf + uChar' <- (#peek KEY_EVENT_RECORD, uChar) buf + controlKeyStateK' <- (#peek KEY_EVENT_RECORD, dwControlKeyState) buf + return $ KEY_EVENT_RECORD keyDown' repeatCount' virtualKeyCode' virtualScanCode' uChar' controlKeyStateK' + +instance Storable MOUSE_EVENT_RECORD where + sizeOf = const #{size MOUSE_EVENT_RECORD} + alignment _ = #alignment MOUSE_EVENT_RECORD + poke buf input = do + (#poke MOUSE_EVENT_RECORD, dwMousePosition) buf (mousePosition input) + (#poke MOUSE_EVENT_RECORD, dwButtonState) buf (buttonState input) + (#poke MOUSE_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateM input) + (#poke MOUSE_EVENT_RECORD, dwEventFlags) buf (eventFlags input) + peek buf = do + mousePosition' <- (#peek MOUSE_EVENT_RECORD, dwMousePosition) buf + buttonState' <- (#peek MOUSE_EVENT_RECORD, dwButtonState) buf + controlKeyStateM' <- (#peek MOUSE_EVENT_RECORD, dwControlKeyState) buf + eventFlags' <- (#peek MOUSE_EVENT_RECORD, dwEventFlags) buf + return $ MOUSE_EVENT_RECORD mousePosition' buttonState' controlKeyStateM' eventFlags' + +instance Storable WINDOW_BUFFER_SIZE_RECORD where + sizeOf = const #{size WINDOW_BUFFER_SIZE_RECORD} + alignment _ = #alignment WINDOW_BUFFER_SIZE_RECORD + poke buf input = do + (#poke WINDOW_BUFFER_SIZE_RECORD, dwSize) buf (windowSize input) + peek buf = do + size' <- (#peek WINDOW_BUFFER_SIZE_RECORD, dwSize) buf + return $ WINDOW_BUFFER_SIZE_RECORD size' + +instance Storable MENU_EVENT_RECORD where + sizeOf = const #{size MENU_EVENT_RECORD} + alignment _ = #alignment MENU_EVENT_RECORD + poke buf input = do + (#poke MENU_EVENT_RECORD, dwCommandId) buf (commandId input) + peek buf = do + commandId' <- (#peek MENU_EVENT_RECORD, dwCommandId) buf + return $ MENU_EVENT_RECORD commandId' + +instance Storable FOCUS_EVENT_RECORD where + sizeOf = const #{size FOCUS_EVENT_RECORD} + alignment _ = #alignment FOCUS_EVENT_RECORD + poke buf input = do + (#poke FOCUS_EVENT_RECORD, bSetFocus) buf (setFocus input) + peek buf = do + setFocus' <- (#peek FOCUS_EVENT_RECORD, bSetFocus) buf + return $ FOCUS_EVENT_RECORD setFocus' + +instance Storable INPUT_RECORD where + sizeOf = const #{size INPUT_RECORD} + alignment _ = #alignment INPUT_RECORD + + poke buf (KeyEvent key) = do + (#poke INPUT_RECORD, EventType) buf (#{const KEY_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf key + poke buf (MouseEvent mouse) = do + (#poke INPUT_RECORD, EventType) buf (#{const MOUSE_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf mouse + poke buf (WindowBufferSizeEvent window) = do + (#poke INPUT_RECORD, EventType) buf (#{const WINDOW_BUFFER_SIZE_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf window + poke buf (MenuEvent menu) = do + (#poke INPUT_RECORD, EventType) buf (#{const MENU_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf menu + poke buf (FocusEvent focus) = do + (#poke INPUT_RECORD, EventType) buf (#{const FOCUS_EVENT} :: WORD) + (#poke INPUT_RECORD, Event) buf focus + + peek buf = do + event <- (#peek INPUT_RECORD, EventType) buf :: IO WORD + case event of + #{const KEY_EVENT} -> + KeyEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const MOUSE_EVENT} -> + MouseEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const WINDOW_BUFFER_SIZE_EVENT} -> + WindowBufferSizeEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const MENU_EVENT} -> + MenuEvent `fmap` (#peek INPUT_RECORD, Event) buf + #{const FOCUS_EVENT} -> + FocusEvent `fmap` (#peek INPUT_RECORD, Event) buf + _ -> error $ "Unknown input event type " ++ show event + +foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" + c_ReadConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL diff --git a/System/Win32/Console/Title.hsc b/System/Win32/Console/Title.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Console/Title.hsc @@ -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 +##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 + diff --git a/System/Win32/DLL.hsc b/System/Win32/DLL.hsc --- a/System/Win32/DLL.hsc +++ b/System/Win32/DLL.hsc @@ -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 +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 + diff --git a/System/Win32/DLL/Internal.hsc b/System/Win32/DLL/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DLL/Internal.hsc @@ -0,0 +1,57 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.DLL.Internal +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.DLL.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +#include + +foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls" + c_DisableThreadLibraryCalls :: HMODULE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h FreeLibrary" + c_FreeLibrary :: HMODULE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleHandleW" + c_GetModuleHandle :: LPCTSTR -> IO HMODULE + +foreign import WINDOWS_CCONV unsafe "windows.h GetProcAddress" + c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr + +foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryW" + c_LoadLibrary :: LPCTSTR -> IO HMODULE + +type LoadLibraryFlags = DWORD + +#{enum LoadLibraryFlags, + , lOAD_LIBRARY_AS_DATAFILE = LOAD_LIBRARY_AS_DATAFILE + , lOAD_WITH_ALTERED_SEARCH_PATH = LOAD_WITH_ALTERED_SEARCH_PATH + } + +foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryExW" + c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HMODULE + +foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW" + c_SetDllDirectory :: LPTSTR -> IO BOOL diff --git a/System/Win32/DebugApi.hsc b/System/Win32/DebugApi.hsc --- a/System/Win32/DebugApi.hsc +++ b/System/Win32/DebugApi.hsc @@ -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 () diff --git a/System/Win32/DebugApi/Internal.hsc b/System/Win32/DebugApi/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DebugApi/Internal.hsc @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.DebugApi.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for using Windows DebugApi. +-- +----------------------------------------------------------------------------- + +module System.Win32.DebugApi.Internal where + +import Data.Word ( Word8, Word32 ) +import Foreign ( Ptr ) +import System.Win32.Types ( BOOL, DWORD, HANDLE, LPTSTR ) + +##include "windows_cconv.h" +#include "windows.h" + +type PID = DWORD +type TID = DWORD +type DebugEventId = (PID, TID) +type ForeignAddress = Word32 + +type PHANDLE = Ptr () +type THANDLE = Ptr () + +type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress) -- handle to thread, thread local, thread start +type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress) +type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address + +-------------------------------------------------------------------------- +-- Raw imports + +foreign import WINDOWS_CCONV "windows.h SuspendThread" + c_SuspendThread :: THANDLE -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h ResumeThread" + c_ResumeThread :: THANDLE -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForDebugEvent" + c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h ContinueDebugEvent" + c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h DebugActiveProcess" + c_DebugActiveProcess :: DWORD -> IO Bool + +-- Windows XP +-- foreign import WINDOWS_CCONV "windows.h DebugActiveProcessStop" +-- c_DebugActiveProcessStop :: DWORD -> IO Bool + +foreign import WINDOWS_CCONV "windows.h ReadProcessMemory" c_ReadProcessMemory :: + PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h WriteProcessMemory" c_WriteProcessMemory :: + PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetThreadContext" + c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetThreadContext" + c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL + +--foreign import WINDOWS_CCONV "windows.h GetThreadId" +-- c_GetThreadId :: THANDLE -> IO TID + +foreign import WINDOWS_CCONV "windows.h OutputDebugStringW" + c_OutputDebugString :: LPTSTR -> IO () + +foreign import WINDOWS_CCONV "windows.h IsDebuggerPresent" + isDebuggerPresent :: IO BOOL + +foreign import WINDOWS_CCONV "windows.h DebugBreak" + debugBreak :: IO () diff --git a/System/Win32/Encoding.hs b/System/Win32/Encoding.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Encoding.hs @@ -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 #-} diff --git a/System/Win32/Event.hsc b/System/Win32/Event.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Event.hsc @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Event +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 event system between +-- processes. +-- +----------------------------------------------------------------------------- +module System.Win32.Event + ( -- * Duplicate options + DuplicateOption + , dUPLICATE_CLOSE_SOURCE + , dUPLICATE_SAME_ACCESS + -- * Access modes + , AccessMode + , eVENT_ALL_ACCESS + , eVENT_MODIFY_STATE + -- * Wait results + , WaitResult + , wAIT_ABANDONED + , wAIT_IO_COMPLETION + , wAIT_OBJECT_0 + , wAIT_TIMEOUT + , wAIT_FAILED + -- * Managing events + , openEvent + , createEvent + , duplicateHandle + , setEvent + , resetEvent + , pulseEvent + -- * Signalling objects + , signalObjectAndWait + -- * Waiting on objects + , waitForSingleObject + , waitForSingleObjectEx + , waitForMultipleObjects + , waitForMultipleObjectsEx + ) where + +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( withArrayLen ) +import Foreign.Marshal.Utils ( maybeWith, with ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.Storable ( Storable(..) ) +import Graphics.Win32.Misc ( MilliSeconds ) +import System.Win32.File ( AccessMode, LPSECURITY_ATTRIBUTES, SECURITY_ATTRIBUTES ) +import System.Win32.Types ( LPCTSTR, HANDLE, BOOL, withTString, failIf, failIfFalse_ ) +import System.Win32.Word ( DWORD ) + +##include "windows_cconv.h" + +#include "windows.h" +#include "winuser_compat.h" +#include "alignment.h" + +--------------------------------------------------------------------------- +-- Enums +--------------------------------------------------------------------------- +type DuplicateOption = DWORD +#{enum DuplicateOption, + , dUPLICATE_CLOSE_SOURCE = DUPLICATE_CLOSE_SOURCE + , dUPLICATE_SAME_ACCESS = DUPLICATE_SAME_ACCESS + } + +#{enum AccessMode, + , eVENT_ALL_ACCESS = EVENT_ALL_ACCESS + , eVENT_MODIFY_STATE = EVENT_MODIFY_STATE + } + +type WaitResult = DWORD +#{enum WaitResult, + , wAIT_ABANDONED = WAIT_ABANDONED + , wAIT_IO_COMPLETION = WAIT_IO_COMPLETION + , wAIT_OBJECT_0 = WAIT_OBJECT_0 + , wAIT_TIMEOUT = WAIT_TIMEOUT + , wAIT_FAILED = WAIT_FAILED + } + +--------------------------------------------------------------------------- +-- API in Haskell +--------------------------------------------------------------------------- +openEvent :: AccessMode -> Bool -> String -> IO HANDLE +openEvent amode inherit name = withTString name $ \c_name -> + failIf (==nullPtr) "openEvent: OpenEvent" $ c_OpenEvent (fromIntegral amode) inherit c_name + +createEvent :: Maybe SECURITY_ATTRIBUTES -> Bool -> Bool -> String -> IO HANDLE +createEvent msecurity manual initial name = withTString name $ \c_name -> + maybeWith with msecurity $ \c_sec -> + failIf (==nullPtr) "createEvent: CreateEvent" $ c_CreateEvent c_sec manual initial c_name + +duplicateHandle :: HANDLE -> HANDLE -> HANDLE -> AccessMode -> Bool -> DuplicateOption -> IO HANDLE +duplicateHandle srcProccess srcHandler targetProcess access inherit opts = alloca $ \res -> do + failIfFalse_ "duplicateHandle: DuplicateHandle" $ c_DuplicateHandle srcProccess srcHandler targetProcess res (fromIntegral access) inherit opts + peek res + +setEvent :: HANDLE -> IO () +setEvent event = failIfFalse_ "setEvent: SetEvent" $ c_SetEvent event + +resetEvent :: HANDLE -> IO () +resetEvent event = failIfFalse_ "resetEvent: ResetEvent" $ c_ResetEvent event + +pulseEvent :: HANDLE -> IO () +pulseEvent event = failIfFalse_ "pulseEvent: PulseEvent" $ c_PulseEvent event + +signalObjectAndWait :: HANDLE -> HANDLE -> MilliSeconds -> Bool -> IO WaitResult +signalObjectAndWait toSignal toWaitOn millis alterable = c_SignalObjectAndWait toSignal toWaitOn millis alterable + +waitForSingleObject :: HANDLE -> MilliSeconds -> IO WaitResult +waitForSingleObject toWaitOn millis = c_WaitForSingleObject toWaitOn millis + +waitForSingleObjectEx :: HANDLE -> MilliSeconds -> Bool -> IO WaitResult +waitForSingleObjectEx toWaitOn millis alterable = c_WaitForSingleObjectEx toWaitOn millis alterable + +waitForMultipleObjects :: [HANDLE] -> Bool -> MilliSeconds -> IO WaitResult +waitForMultipleObjects hs waitAll millis = withArrayLen hs $ \n hsp -> + c_WaitForMultipleObjects (fromIntegral n) hsp waitAll millis + +waitForMultipleObjectsEx :: [HANDLE] -> Bool -> MilliSeconds -> Bool -> IO WaitResult +waitForMultipleObjectsEx hs waitAll millis alterable = withArrayLen hs $ \n hsp -> + c_WaitForMultipleObjectsEx (fromIntegral n) hsp waitAll millis alterable + +--------------------------------------------------------------------------- +-- Imports +--------------------------------------------------------------------------- +foreign import WINDOWS_CCONV "windows.h OpenEventW" + c_OpenEvent :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h CreateEventW" + c_CreateEvent :: LPSECURITY_ATTRIBUTES -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h DuplicateHandle" + c_DuplicateHandle :: HANDLE -> HANDLE -> HANDLE -> Ptr HANDLE -> DWORD -> BOOL -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetEvent" + c_SetEvent :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV "windows.h ResetEvent" + c_ResetEvent :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV "windows.h PulseEvent" + c_PulseEvent :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV "windows.h SignalObjectAndWait" + c_SignalObjectAndWait :: HANDLE -> HANDLE -> DWORD -> BOOL -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" + c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForSingleObjectEx" + c_WaitForSingleObjectEx :: HANDLE -> DWORD -> BOOL -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForMultipleObjects" + c_WaitForMultipleObjects :: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForMultipleObjectsEx" + c_WaitForMultipleObjectsEx :: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> BOOL -> IO DWORD diff --git a/System/Win32/Exception/Unsupported.hs b/System/Win32/Exception/Unsupported.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Exception/Unsupported.hs @@ -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 + diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -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 - ----------------------------------------------------------------- --- 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 +#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 diff --git a/System/Win32/File/Internal.hsc b/System/Win32/File/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/File/Internal.hsc @@ -0,0 +1,548 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.File.Internal +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.File.Internal where + +import System.Win32.Types +import System.Win32.Time + +import Foreign hiding (void) + +##include "windows_cconv.h" + +-- For REPLACEFILE_IGNORE_ACL_ERRORS +#define _WIN32_WINNT 0x0600 + +#include +#include "alignment.h" + +---------------------------------------------------------------- +-- Enumeration types +---------------------------------------------------------------- + +type AccessMode = UINT + +gENERIC_NONE :: AccessMode +gENERIC_NONE = 0 + +#{enum AccessMode, + , gENERIC_READ = GENERIC_READ + , gENERIC_WRITE = GENERIC_WRITE + , gENERIC_EXECUTE = GENERIC_EXECUTE + , gENERIC_ALL = GENERIC_ALL + , dELETE = DELETE + , rEAD_CONTROL = READ_CONTROL + , wRITE_DAC = WRITE_DAC + , wRITE_OWNER = WRITE_OWNER + , sYNCHRONIZE = SYNCHRONIZE + , sTANDARD_RIGHTS_REQUIRED = STANDARD_RIGHTS_REQUIRED + , sTANDARD_RIGHTS_READ = STANDARD_RIGHTS_READ + , sTANDARD_RIGHTS_WRITE = STANDARD_RIGHTS_WRITE + , sTANDARD_RIGHTS_EXECUTE = STANDARD_RIGHTS_EXECUTE + , sTANDARD_RIGHTS_ALL = STANDARD_RIGHTS_ALL + , sPECIFIC_RIGHTS_ALL = SPECIFIC_RIGHTS_ALL + , aCCESS_SYSTEM_SECURITY = ACCESS_SYSTEM_SECURITY + , mAXIMUM_ALLOWED = MAXIMUM_ALLOWED + , fILE_ADD_FILE = FILE_ADD_FILE + , fILE_ADD_SUBDIRECTORY = FILE_ADD_SUBDIRECTORY + , fILE_ALL_ACCESS = FILE_ALL_ACCESS + , fILE_APPEND_DATA = FILE_APPEND_DATA + , fILE_CREATE_PIPE_INSTANCE = FILE_CREATE_PIPE_INSTANCE + , fILE_DELETE_CHILD = FILE_DELETE_CHILD + , fILE_EXECUTE = FILE_EXECUTE + , fILE_LIST_DIRECTORY = FILE_LIST_DIRECTORY + , fILE_READ_ATTRIBUTES = FILE_READ_ATTRIBUTES + , fILE_READ_DATA = FILE_READ_DATA + , fILE_READ_EA = FILE_READ_EA + , fILE_TRAVERSE = FILE_TRAVERSE + , fILE_WRITE_ATTRIBUTES = FILE_WRITE_ATTRIBUTES + , fILE_WRITE_DATA = FILE_WRITE_DATA + , fILE_WRITE_EA = FILE_WRITE_EA + } + +---------------------------------------------------------------- + +type ShareMode = UINT + +fILE_SHARE_NONE :: ShareMode +fILE_SHARE_NONE = 0 + +#{enum ShareMode, + , fILE_SHARE_READ = FILE_SHARE_READ + , fILE_SHARE_WRITE = FILE_SHARE_WRITE + , fILE_SHARE_DELETE = FILE_SHARE_DELETE + } + +---------------------------------------------------------------- + +type CreateMode = UINT + +#{enum CreateMode, + , cREATE_NEW = CREATE_NEW + , cREATE_ALWAYS = CREATE_ALWAYS + , oPEN_EXISTING = OPEN_EXISTING + , oPEN_ALWAYS = OPEN_ALWAYS + , tRUNCATE_EXISTING = TRUNCATE_EXISTING + } + +---------------------------------------------------------------- + +type FileAttributeOrFlag = UINT + +#{enum FileAttributeOrFlag, + , fILE_ATTRIBUTE_READONLY = FILE_ATTRIBUTE_READONLY + , fILE_ATTRIBUTE_HIDDEN = FILE_ATTRIBUTE_HIDDEN + , fILE_ATTRIBUTE_SYSTEM = FILE_ATTRIBUTE_SYSTEM + , fILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY + , fILE_ATTRIBUTE_ARCHIVE = FILE_ATTRIBUTE_ARCHIVE + , fILE_ATTRIBUTE_NORMAL = FILE_ATTRIBUTE_NORMAL + , fILE_ATTRIBUTE_TEMPORARY = FILE_ATTRIBUTE_TEMPORARY + , fILE_ATTRIBUTE_COMPRESSED = FILE_ATTRIBUTE_COMPRESSED + , fILE_ATTRIBUTE_REPARSE_POINT = FILE_ATTRIBUTE_REPARSE_POINT + , fILE_FLAG_WRITE_THROUGH = FILE_FLAG_WRITE_THROUGH + , fILE_FLAG_OVERLAPPED = FILE_FLAG_OVERLAPPED + , fILE_FLAG_NO_BUFFERING = FILE_FLAG_NO_BUFFERING + , fILE_FLAG_RANDOM_ACCESS = FILE_FLAG_RANDOM_ACCESS + , fILE_FLAG_SEQUENTIAL_SCAN = FILE_FLAG_SEQUENTIAL_SCAN + , fILE_FLAG_DELETE_ON_CLOSE = FILE_FLAG_DELETE_ON_CLOSE + , fILE_FLAG_BACKUP_SEMANTICS = FILE_FLAG_BACKUP_SEMANTICS + , fILE_FLAG_POSIX_SEMANTICS = FILE_FLAG_POSIX_SEMANTICS + } +#ifndef __WINE_WINDOWS_H +#{enum FileAttributeOrFlag, + , sECURITY_ANONYMOUS = SECURITY_ANONYMOUS + , sECURITY_IDENTIFICATION = SECURITY_IDENTIFICATION + , sECURITY_IMPERSONATION = SECURITY_IMPERSONATION + , sECURITY_DELEGATION = SECURITY_DELEGATION + , sECURITY_CONTEXT_TRACKING = SECURITY_CONTEXT_TRACKING + , sECURITY_EFFECTIVE_ONLY = SECURITY_EFFECTIVE_ONLY + , sECURITY_SQOS_PRESENT = SECURITY_SQOS_PRESENT + , sECURITY_VALID_SQOS_FLAGS = SECURITY_VALID_SQOS_FLAGS + } +#endif + +---------------------------------------------------------------- + +type MoveFileFlag = DWORD + +#{enum MoveFileFlag, + , mOVEFILE_REPLACE_EXISTING = MOVEFILE_REPLACE_EXISTING + , mOVEFILE_COPY_ALLOWED = MOVEFILE_COPY_ALLOWED + , mOVEFILE_DELAY_UNTIL_REBOOT = MOVEFILE_DELAY_UNTIL_REBOOT + } + +---------------------------------------------------------------- + +type FilePtrDirection = DWORD + +#{enum FilePtrDirection, + , fILE_BEGIN = FILE_BEGIN + , fILE_CURRENT = FILE_CURRENT + , fILE_END = FILE_END + } + +---------------------------------------------------------------- + +type DriveType = UINT + +#{enum DriveType, + , dRIVE_UNKNOWN = DRIVE_UNKNOWN + , dRIVE_NO_ROOT_DIR = DRIVE_NO_ROOT_DIR + , dRIVE_REMOVABLE = DRIVE_REMOVABLE + , dRIVE_FIXED = DRIVE_FIXED + , dRIVE_REMOTE = DRIVE_REMOTE + , dRIVE_CDROM = DRIVE_CDROM + , dRIVE_RAMDISK = DRIVE_RAMDISK + } + +---------------------------------------------------------------- + +type DefineDosDeviceFlags = DWORD + +#{enum DefineDosDeviceFlags, + , dDD_RAW_TARGET_PATH = DDD_RAW_TARGET_PATH + , dDD_REMOVE_DEFINITION = DDD_REMOVE_DEFINITION + , dDD_EXACT_MATCH_ON_REMOVE = DDD_EXACT_MATCH_ON_REMOVE + } + +---------------------------------------------------------------- + +type BinaryType = DWORD + +#{enum BinaryType, + , sCS_32BIT_BINARY = SCS_32BIT_BINARY + , sCS_DOS_BINARY = SCS_DOS_BINARY + , sCS_WOW_BINARY = SCS_WOW_BINARY + , sCS_PIF_BINARY = SCS_PIF_BINARY + , sCS_POSIX_BINARY = SCS_POSIX_BINARY + , sCS_OS216_BINARY = SCS_OS216_BINARY + } + +---------------------------------------------------------------- + +type ReplaceType = DWORD + +#{enum ReplaceType, + , rEPLACEFILE_WRITE_THROUGH = REPLACEFILE_WRITE_THROUGH + , rEPLACEFILE_IGNORE_MERGE_ERRORS = REPLACEFILE_IGNORE_MERGE_ERRORS + , rEPLACEFILE_IGNORE_ACL_ERRORS = REPLACEFILE_IGNORE_ACL_ERRORS + } + +---------------------------------------------------------------- + +type FileNotificationFlag = DWORD + +#{enum FileNotificationFlag, + , fILE_NOTIFY_CHANGE_FILE_NAME = FILE_NOTIFY_CHANGE_FILE_NAME + , fILE_NOTIFY_CHANGE_DIR_NAME = FILE_NOTIFY_CHANGE_DIR_NAME + , fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES + , fILE_NOTIFY_CHANGE_SIZE = FILE_NOTIFY_CHANGE_SIZE + , fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE + , fILE_NOTIFY_CHANGE_SECURITY = FILE_NOTIFY_CHANGE_SECURITY + } + +---------------------------------------------------------------- + +type FileType = DWORD + +#{enum FileType, + , fILE_TYPE_UNKNOWN = FILE_TYPE_UNKNOWN + , fILE_TYPE_DISK = FILE_TYPE_DISK + , fILE_TYPE_CHAR = FILE_TYPE_CHAR + , fILE_TYPE_PIPE = FILE_TYPE_PIPE + , fILE_TYPE_REMOTE = FILE_TYPE_REMOTE + } + +---------------------------------------------------------------- + +type LockMode = DWORD + +#{enum LockMode, + , lOCKFILE_EXCLUSIVE_LOCK = LOCKFILE_EXCLUSIVE_LOCK + , lOCKFILE_FAIL_IMMEDIATELY = LOCKFILE_FAIL_IMMEDIATELY + } + +---------------------------------------------------------------- + +newtype GET_FILEEX_INFO_LEVELS = GET_FILEEX_INFO_LEVELS (#type GET_FILEEX_INFO_LEVELS) + deriving (Eq, Ord) + +#{enum GET_FILEEX_INFO_LEVELS, GET_FILEEX_INFO_LEVELS + , getFileExInfoStandard = GetFileExInfoStandard + , getFileExMaxInfoLevel = GetFileExMaxInfoLevel + } + +---------------------------------------------------------------- + +data SECURITY_ATTRIBUTES = SECURITY_ATTRIBUTES + { nLength :: !DWORD + , lpSecurityDescriptor :: !LPVOID + , bInheritHandle :: !BOOL + } deriving Show + +type PSECURITY_ATTRIBUTES = Ptr SECURITY_ATTRIBUTES +type LPSECURITY_ATTRIBUTES = Ptr SECURITY_ATTRIBUTES +type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES + +instance Storable SECURITY_ATTRIBUTES where + sizeOf = const #{size SECURITY_ATTRIBUTES} + alignment _ = #alignment SECURITY_ATTRIBUTES + poke buf input = do + (#poke SECURITY_ATTRIBUTES, nLength) buf (nLength input) + (#poke SECURITY_ATTRIBUTES, lpSecurityDescriptor) buf (lpSecurityDescriptor input) + (#poke SECURITY_ATTRIBUTES, bInheritHandle) buf (bInheritHandle input) + peek buf = do + nLength' <- (#peek SECURITY_ATTRIBUTES, nLength) buf + lpSecurityDescriptor' <- (#peek SECURITY_ATTRIBUTES, lpSecurityDescriptor) buf + bInheritHandle' <- (#peek SECURITY_ATTRIBUTES, bInheritHandle) buf + return $ SECURITY_ATTRIBUTES nLength' lpSecurityDescriptor' bInheritHandle' + +---------------------------------------------------------------- +-- Other types +---------------------------------------------------------------- + +data BY_HANDLE_FILE_INFORMATION = BY_HANDLE_FILE_INFORMATION + { bhfiFileAttributes :: FileAttributeOrFlag + , bhfiCreationTime, bhfiLastAccessTime, bhfiLastWriteTime :: FILETIME + , bhfiVolumeSerialNumber :: DWORD + , bhfiSize :: DDWORD + , bhfiNumberOfLinks :: DWORD + , bhfiFileIndex :: DDWORD + } deriving (Show) + +instance Storable BY_HANDLE_FILE_INFORMATION where + sizeOf = const (#size BY_HANDLE_FILE_INFORMATION) + alignment _ = #alignment BY_HANDLE_FILE_INFORMATION + poke buf bhi = do + (#poke BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf (bhfiFileAttributes bhi) + (#poke BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf (bhfiCreationTime bhi) + (#poke BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf (bhfiLastAccessTime bhi) + (#poke BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf (bhfiLastWriteTime bhi) + (#poke BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf (bhfiVolumeSerialNumber bhi) + (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf sizeHi + (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf sizeLow + (#poke BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf (bhfiNumberOfLinks bhi) + (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf idxHi + (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf idxLow + where + (sizeHi,sizeLow) = ddwordToDwords $ bhfiSize bhi + (idxHi,idxLow) = ddwordToDwords $ bhfiFileIndex bhi + + peek buf = do + attr <- (#peek BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf + ctim <- (#peek BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf + lati <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf + lwti <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf + vser <- (#peek BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf + fshi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf + fslo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf + link <- (#peek BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf + idhi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf + idlo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf + return $ BY_HANDLE_FILE_INFORMATION attr ctim lati lwti vser + (dwordsToDdword (fshi,fslo)) link (dwordsToDdword (idhi,idlo)) + +---------------------------------------------------------------- + +data WIN32_FILE_ATTRIBUTE_DATA = WIN32_FILE_ATTRIBUTE_DATA + { fadFileAttributes :: DWORD + , fadCreationTime , fadLastAccessTime , fadLastWriteTime :: FILETIME + , fadFileSize :: DDWORD + } deriving (Show) + +instance Storable WIN32_FILE_ATTRIBUTE_DATA where + sizeOf = const (#size WIN32_FILE_ATTRIBUTE_DATA) + alignment _ = #alignment WIN32_FILE_ATTRIBUTE_DATA + poke buf ad = do + (#poke WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf (fadFileAttributes ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime) buf (fadCreationTime ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf (fadLastAccessTime ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime) buf (fadLastWriteTime ad) + (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh) buf sizeHi + (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow) buf sizeLo + where + (sizeHi,sizeLo) = ddwordToDwords $ fadFileSize ad + + peek buf = do + attr <- (#peek WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf + ctim <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime) buf + lati <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf + lwti <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime) buf + fshi <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh) buf + fslo <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow) buf + return $ WIN32_FILE_ATTRIBUTE_DATA attr ctim lati lwti + (dwordsToDdword (fshi,fslo)) + +---------------------------------------------------------------- +-- File operations +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h DeleteFileW" + c_DeleteFile :: LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CopyFileW" + c_CopyFile :: LPCTSTR -> LPCTSTR -> Bool -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h MoveFileW" + c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h MoveFileExW" + c_MoveFileEx :: LPCTSTR -> LPCTSTR -> MoveFileFlag -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetCurrentDirectoryW" + c_SetCurrentDirectory :: LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryW" + c_CreateDirectory :: LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryExW" + c_CreateDirectoryEx :: LPCTSTR -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h RemoveDirectoryW" + c_RemoveDirectory :: LPCTSTR -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetBinaryTypeW" + c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h ReplaceFileW" + c_ReplaceFile :: LPCWSTR -> LPCWSTR -> LPCWSTR -> DWORD -> LPVOID -> LPVOID -> IO Bool + +---------------------------------------------------------------- +-- HANDLE operations +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" + c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE + +foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle" + c_CloseHandle :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileType" + getFileType :: HANDLE -> IO FileType +--Apparently no error code + +foreign import WINDOWS_CCONV unsafe "windows.h FlushFileBuffers" + c_FlushFileBuffers :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetEndOfFile" + c_SetEndOfFile :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetFileAttributesW" + c_SetFileAttributes :: LPCTSTR -> FileAttributeOrFlag -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesW" + c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesExW" + c_GetFileAttributesEx :: LPCTSTR -> GET_FILEEX_INFO_LEVELS -> Ptr a -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetFileInformationByHandle" + c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetTempFileNameW" + c_GetTempFileNameW :: LPCWSTR -> LPCWSTR -> UINT -> LPWSTR -> IO UINT + +---------------------------------------------------------------- +-- Read/write files +---------------------------------------------------------------- + +-- No support for this yet +data OVERLAPPED + = OVERLAPPED { ovl_internal :: ULONG_PTR + , ovl_internalHigh :: ULONG_PTR + , ovl_offset :: DWORD + , ovl_offsetHigh :: DWORD + , ovl_hEvent :: HANDLE + } deriving (Show) + +instance Storable OVERLAPPED where + sizeOf = const (#size OVERLAPPED) + alignment _ = #alignment OVERLAPPED + poke buf ad = do + (#poke OVERLAPPED, Internal ) buf (ovl_internal ad) + (#poke OVERLAPPED, InternalHigh) buf (ovl_internalHigh ad) + (#poke OVERLAPPED, Offset ) buf (ovl_offset ad) + (#poke OVERLAPPED, OffsetHigh ) buf (ovl_offsetHigh ad) + (#poke OVERLAPPED, hEvent ) buf (ovl_hEvent ad) + + peek buf = do + intnl <- (#peek OVERLAPPED, Internal ) buf + intnl_high <- (#peek OVERLAPPED, InternalHigh) buf + off <- (#peek OVERLAPPED, Offset ) buf + off_high <- (#peek OVERLAPPED, OffsetHigh ) buf + hevnt <- (#peek OVERLAPPED, hEvent ) buf + return $ OVERLAPPED intnl intnl_high off off_high hevnt + +type LPOVERLAPPED = Ptr OVERLAPPED + +type MbLPOVERLAPPED = Maybe LPOVERLAPPED + +foreign import WINDOWS_CCONV unsafe "windows.h ReadFile" + c_ReadFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h WriteFile" + c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetFilePointerEx" + c_SetFilePointerEx :: HANDLE -> LARGE_INTEGER -> Ptr LARGE_INTEGER -> FilePtrDirection -> IO Bool + +---------------------------------------------------------------- +-- File Notifications +-- +-- Use these to initialise, "increment" and close a HANDLE you can wait +-- on. +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h FindFirstChangeNotificationW" + c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE + +foreign import WINDOWS_CCONV unsafe "windows.h FindNextChangeNotification" + c_FindNextChangeNotification :: HANDLE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h FindCloseChangeNotification" + c_FindCloseChangeNotification :: HANDLE -> IO Bool + +---------------------------------------------------------------- +-- Directories +---------------------------------------------------------------- + +type WIN32_FIND_DATA = () + +newtype FindData = FindData (ForeignPtr WIN32_FIND_DATA) + +foreign import WINDOWS_CCONV unsafe "windows.h FindFirstFileW" + c_FindFirstFile :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE + +foreign import WINDOWS_CCONV unsafe "windows.h FindNextFileW" + c_FindNextFile :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h FindClose" + c_FindClose :: HANDLE -> IO BOOL + +---------------------------------------------------------------- +-- DOS Device flags +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h DefineDosDeviceW" + c_DefineDosDevice :: DefineDosDeviceFlags -> LPCTSTR -> LPCTSTR -> IO Bool + +---------------------------------------------------------------- + +-- These functions are very unusual in the Win32 API: +-- They don't return error codes + +foreign import WINDOWS_CCONV unsafe "windows.h AreFileApisANSI" + areFileApisANSI :: IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToOEM" + setFileApisToOEM :: IO () + +foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToANSI" + setFileApisToANSI :: IO () + +foreign import WINDOWS_CCONV unsafe "windows.h SetHandleCount" + setHandleCount :: UINT -> IO UINT + +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h GetLogicalDrives" + c_GetLogicalDrives :: IO DWORD + +-- %fun GetDriveType :: Maybe String -> IO DriveType + +foreign import WINDOWS_CCONV unsafe "windows.h GetDiskFreeSpaceW" + c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h SetVolumeLabelW" + c_SetVolumeLabel :: LPCTSTR -> LPCTSTR -> IO Bool + +---------------------------------------------------------------- +-- File locks +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "LockFileEx" + c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED + -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "UnlockFileEx" + c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/FileMapping.hsc b/System/Win32/FileMapping.hsc --- a/System/Win32/FileMapping.hsc +++ b/System/Win32/FileMapping.hsc @@ -1,4 +1,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 ()) diff --git a/System/Win32/FileMapping/Internal.hsc b/System/Win32/FileMapping/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/FileMapping/Internal.hsc @@ -0,0 +1,72 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.FileMapping.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 mapped files. +-- +----------------------------------------------------------------------------- +module System.Win32.FileMapping.Internal where + +import System.Win32.Types ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR ) + +import Foreign ( Ptr, FunPtr ) +import Foreign.C.Types (CUIntPtr(..)) + +##include "windows_cconv.h" + +#include "windows.h" + +--------------------------------------------------------------------------- +-- Derived functions +--------------------------------------------------------------------------- + +data MappedObject = MappedObject HANDLE HANDLE FileMapAccess + + +--------------------------------------------------------------------------- +-- Enums +--------------------------------------------------------------------------- +type ProtectSectionFlags = DWORD +#{enum ProtectSectionFlags, + , sEC_COMMIT = SEC_COMMIT + , sEC_IMAGE = SEC_IMAGE + , sEC_NOCACHE = SEC_NOCACHE + , sEC_RESERVE = SEC_RESERVE + } +type FileMapAccess = DWORD +#{enum FileMapAccess, + , fILE_MAP_ALL_ACCESS = FILE_MAP_ALL_ACCESS + , fILE_MAP_COPY = FILE_MAP_COPY + , fILE_MAP_READ = FILE_MAP_READ + , fILE_MAP_WRITE = FILE_MAP_WRITE + } + +--------------------------------------------------------------------------- +-- Imports +--------------------------------------------------------------------------- +foreign import WINDOWS_CCONV "windows.h OpenFileMappingW" + c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h CreateFileMappingW" + c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h MapViewOfFileEx" + c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b) + +foreign import WINDOWS_CCONV "windows.h UnmapViewOfFile" + c_UnmapViewOfFile :: Ptr a -> IO BOOL + +{-# CFILES cbits/HsWin32.c #-} +foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser" + c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ()) diff --git a/System/Win32/HardLink.hs b/System/Win32/HardLink.hs new file mode 100644 --- /dev/null +++ b/System/Win32/HardLink.hs @@ -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 +-} diff --git a/System/Win32/HardLink/Internal.hs b/System/Win32/HardLink/Internal.hs new file mode 100644 --- /dev/null +++ b/System/Win32/HardLink/Internal.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.HardLink.Internal + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling hard link using Win32 API. [NTFS only] + + Note: You should worry about file system type when use this module's function in your application: + + * NTFS only supprts this functionality. + + * ReFS doesn't support hard link currently. +-} +module System.Win32.HardLink.Internal where + +import System.Win32.File ( LPSECURITY_ATTRIBUTES ) +import System.Win32.String ( LPCTSTR ) +import System.Win32.Types ( BOOL ) + +#include "windows_cconv.h" + +foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW" + c_CreateHardLink :: LPCTSTR -- ^ Hard link name + -> LPCTSTR -- ^ Target file path + -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/. + -> IO BOOL diff --git a/System/Win32/Info.hsc b/System/Win32/Info.hsc --- a/System/Win32/Info.hsc +++ b/System/Win32/Info.hsc @@ -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 +#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 diff --git a/System/Win32/Info/Computer.hsc b/System/Win32/Info/Computer.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Info/Computer.hsc @@ -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 +#include +#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: , +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 +-} diff --git a/System/Win32/Info/Internal.hsc b/System/Win32/Info/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Info/Internal.hsc @@ -0,0 +1,313 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Info.Internal +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.Info.Internal where + +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import System.Win32.Types (DWORD, LPDWORD, LPCTSTR, LPTSTR, LPVOID, UINT, WORD) + +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif + +##include "windows_cconv.h" + +#include +#include "alignment.h" + +---------------------------------------------------------------- +-- Environment Strings +---------------------------------------------------------------- + +-- %fun ExpandEnvironmentStrings :: String -> IO String + +---------------------------------------------------------------- +-- Computer Name +---------------------------------------------------------------- + +-- %fun GetComputerName :: IO String +-- %fun SetComputerName :: String -> IO () +-- %end free(arg1) + +---------------------------------------------------------------- +-- Hardware Profiles +---------------------------------------------------------------- + +-- %fun GetCurrentHwProfile :: IO HW_PROFILE_INFO + +---------------------------------------------------------------- +-- Keyboard Type +---------------------------------------------------------------- + +-- %fun GetKeyboardType :: KeyboardTypeKind -> IO KeyboardType + +---------------------------------------------------------------- +-- System Color +---------------------------------------------------------------- + +type SystemColor = UINT + +-- ToDo: This list is out of date. + +#{enum SystemColor, + , cOLOR_SCROLLBAR = COLOR_SCROLLBAR + , cOLOR_BACKGROUND = COLOR_BACKGROUND + , cOLOR_ACTIVECAPTION = COLOR_ACTIVECAPTION + , cOLOR_INACTIVECAPTION = COLOR_INACTIVECAPTION + , cOLOR_MENU = COLOR_MENU + , cOLOR_WINDOW = COLOR_WINDOW + , cOLOR_WINDOWFRAME = COLOR_WINDOWFRAME + , cOLOR_MENUTEXT = COLOR_MENUTEXT + , cOLOR_WINDOWTEXT = COLOR_WINDOWTEXT + , cOLOR_CAPTIONTEXT = COLOR_CAPTIONTEXT + , cOLOR_ACTIVEBORDER = COLOR_ACTIVEBORDER + , cOLOR_INACTIVEBORDER = COLOR_INACTIVEBORDER + , cOLOR_APPWORKSPACE = COLOR_APPWORKSPACE + , cOLOR_HIGHLIGHT = COLOR_HIGHLIGHT + , cOLOR_HIGHLIGHTTEXT = COLOR_HIGHLIGHTTEXT + , cOLOR_BTNFACE = COLOR_BTNFACE + , cOLOR_BTNSHADOW = COLOR_BTNSHADOW + , cOLOR_GRAYTEXT = COLOR_GRAYTEXT + , cOLOR_BTNTEXT = COLOR_BTNTEXT + , cOLOR_INACTIVECAPTIONTEXT = COLOR_INACTIVECAPTIONTEXT + , cOLOR_BTNHIGHLIGHT = COLOR_BTNHIGHLIGHT + } + +-- %fun GetSysColor :: SystemColor -> IO COLORREF +-- %fun SetSysColors :: [(SystemColor,COLORREF)] -> IO () + +---------------------------------------------------------------- +-- Standard Directories +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "GetWindowsDirectoryW" + c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetSystemDirectoryW" + c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetCurrentDirectoryW" + c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetTempPathW" + c_getTempPath :: DWORD -> LPTSTR -> IO UINT + +foreign import WINDOWS_CCONV unsafe "GetFullPathNameW" + c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "GetLongPathNameW" + c_GetLongPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "GetShortPathNameW" + c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "SearchPathW" + c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR + -> IO DWORD + +---------------------------------------------------------------- +-- System Info (Info about processor and memory subsystem) +---------------------------------------------------------------- + +data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64 + deriving (Show,Eq) + +instance Storable ProcessorArchitecture where + sizeOf _ = sizeOf (undefined::WORD) + alignment _ = alignment (undefined::WORD) + poke buf pa = pokeByteOff buf 0 $ case pa of + PaUnknown w -> w + PaIntel -> #const PROCESSOR_ARCHITECTURE_INTEL + PaMips -> #const PROCESSOR_ARCHITECTURE_MIPS + PaAlpha -> #const PROCESSOR_ARCHITECTURE_ALPHA + PaPpc -> #const PROCESSOR_ARCHITECTURE_PPC + PaIa64 -> #const PROCESSOR_ARCHITECTURE_IA64 +#ifndef __WINE_WINDOWS_H + PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 +#endif + PaAmd64 -> #const PROCESSOR_ARCHITECTURE_AMD64 + peek buf = do + v <- (peekByteOff buf 0:: IO WORD) + return $ case v of + (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel + (#const PROCESSOR_ARCHITECTURE_MIPS) -> PaMips + (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha + (#const PROCESSOR_ARCHITECTURE_PPC) -> PaPpc + (#const PROCESSOR_ARCHITECTURE_IA64) -> PaIa64 +#ifndef __WINE_WINDOWS_H + (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64 +#endif + (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64 + w -> PaUnknown w + +data SYSTEM_INFO = SYSTEM_INFO + { siProcessorArchitecture :: ProcessorArchitecture + , siPageSize :: DWORD + , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID + , siActiveProcessorMask :: DWORD + , siNumberOfProcessors :: DWORD + , siProcessorType :: DWORD + , siAllocationGranularity :: DWORD + , siProcessorLevel :: WORD + , siProcessorRevision :: WORD + } deriving (Show) + +instance Storable SYSTEM_INFO where + sizeOf = const #size SYSTEM_INFO + alignment _ = #alignment SYSTEM_INFO + poke buf si = do + (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si) + (#poke SYSTEM_INFO, dwPageSize) buf (siPageSize si) + (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si) + (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si) + (#poke SYSTEM_INFO, dwActiveProcessorMask) buf (siActiveProcessorMask si) + (#poke SYSTEM_INFO, dwNumberOfProcessors) buf (siNumberOfProcessors si) + (#poke SYSTEM_INFO, dwProcessorType) buf (siProcessorType si) + (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si) + (#poke SYSTEM_INFO, wProcessorLevel) buf (siProcessorLevel si) + (#poke SYSTEM_INFO, wProcessorRevision) buf (siProcessorRevision si) + + peek buf = do + processorArchitecture <- + (#peek SYSTEM_INFO, wProcessorArchitecture) buf + pageSize <- (#peek SYSTEM_INFO, dwPageSize) buf + minimumApplicationAddress <- + (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf + maximumApplicationAddress <- + (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf + activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf + numberOfProcessors <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf + processorType <- (#peek SYSTEM_INFO, dwProcessorType) buf + allocationGranularity <- + (#peek SYSTEM_INFO, dwAllocationGranularity) buf + processorLevel <- (#peek SYSTEM_INFO, wProcessorLevel) buf + processorRevision <- (#peek SYSTEM_INFO, wProcessorRevision) buf + return $ SYSTEM_INFO { + siProcessorArchitecture = processorArchitecture, + siPageSize = pageSize, + siMinimumApplicationAddress = minimumApplicationAddress, + siMaximumApplicationAddress = maximumApplicationAddress, + siActiveProcessorMask = activeProcessorMask, + siNumberOfProcessors = numberOfProcessors, + siProcessorType = processorType, + siAllocationGranularity = allocationGranularity, + siProcessorLevel = processorLevel, + siProcessorRevision = processorRevision + } + +foreign import WINDOWS_CCONV unsafe "windows.h GetSystemInfo" + c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO () + +---------------------------------------------------------------- +-- System metrics +---------------------------------------------------------------- + +type SMSetting = UINT + +#{enum SMSetting, + , sM_ARRANGE = SM_ARRANGE + , sM_CLEANBOOT = SM_CLEANBOOT + , sM_CMETRICS = SM_CMETRICS + , sM_CMOUSEBUTTONS = SM_CMOUSEBUTTONS + , sM_CXBORDER = SM_CXBORDER + , sM_CYBORDER = SM_CYBORDER + , sM_CXCURSOR = SM_CXCURSOR + , sM_CYCURSOR = SM_CYCURSOR + , sM_CXDLGFRAME = SM_CXDLGFRAME + , sM_CYDLGFRAME = SM_CYDLGFRAME + , sM_CXDOUBLECLK = SM_CXDOUBLECLK + , sM_CYDOUBLECLK = SM_CYDOUBLECLK + , sM_CXDRAG = SM_CXDRAG + , sM_CYDRAG = SM_CYDRAG + , sM_CXEDGE = SM_CXEDGE + , sM_CYEDGE = SM_CYEDGE + , sM_CXFRAME = SM_CXFRAME + , sM_CYFRAME = SM_CYFRAME + , sM_CXFULLSCREEN = SM_CXFULLSCREEN + , sM_CYFULLSCREEN = SM_CYFULLSCREEN + , sM_CXHSCROLL = SM_CXHSCROLL + , sM_CYVSCROLL = SM_CYVSCROLL + , sM_CXICON = SM_CXICON + , sM_CYICON = SM_CYICON + , sM_CXICONSPACING = SM_CXICONSPACING + , sM_CYICONSPACING = SM_CYICONSPACING + , sM_CXMAXIMIZED = SM_CXMAXIMIZED + , sM_CYMAXIMIZED = SM_CYMAXIMIZED + , sM_CXMENUCHECK = SM_CXMENUCHECK + , sM_CYMENUCHECK = SM_CYMENUCHECK + , sM_CXMENUSIZE = SM_CXMENUSIZE + , sM_CYMENUSIZE = SM_CYMENUSIZE + , sM_CXMIN = SM_CXMIN + , sM_CYMIN = SM_CYMIN + , sM_CXMINIMIZED = SM_CXMINIMIZED + , sM_CYMINIMIZED = SM_CYMINIMIZED + , sM_CXMINTRACK = SM_CXMINTRACK + , sM_CYMINTRACK = SM_CYMINTRACK + , sM_CXSCREEN = SM_CXSCREEN + , sM_CYSCREEN = SM_CYSCREEN + , sM_CXSIZE = SM_CXSIZE + , sM_CYSIZE = SM_CYSIZE + , sM_CXSIZEFRAME = SM_CXSIZEFRAME + , sM_CYSIZEFRAME = SM_CYSIZEFRAME + , sM_CXSMICON = SM_CXSMICON + , sM_CYSMICON = SM_CYSMICON + , sM_CXSMSIZE = SM_CXSMSIZE + , sM_CYSMSIZE = SM_CYSMSIZE + , sM_CXVSCROLL = SM_CXVSCROLL + , sM_CYHSCROLL = SM_CYHSCROLL + , sM_CYVTHUMB = SM_CYVTHUMB + , sM_CYCAPTION = SM_CYCAPTION + , sM_CYKANJIWINDOW = SM_CYKANJIWINDOW + , sM_CYMENU = SM_CYMENU + , sM_CYSMCAPTION = SM_CYSMCAPTION + , sM_DBCSENABLED = SM_DBCSENABLED + , sM_DEBUG = SM_DEBUG + , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT + , sM_MIDEASTENABLED = SM_MIDEASTENABLED + , sM_MOUSEPRESENT = SM_MOUSEPRESENT + , sM_NETWORK = SM_NETWORK + , sM_PENWINDOWS = SM_PENWINDOWS + , sM_SECURE = SM_SECURE + , sM_SHOWSOUNDS = SM_SHOWSOUNDS + , sM_SLOWMACHINE = SM_SLOWMACHINE + , sM_SWAPBUTTON = SM_SWAPBUTTON + } + +-- %fun GetSystemMetrics :: SMSetting -> IO Int + +---------------------------------------------------------------- +-- Thread Desktops +---------------------------------------------------------------- + +-- %fun GetThreadDesktop :: ThreadId -> IO HDESK +-- %fun SetThreadDesktop :: ThreadId -> HDESK -> IO () + +---------------------------------------------------------------- +-- User name +---------------------------------------------------------------- + +-- %fun GetUserName :: IO String + +foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW" + c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/Info/Version.hsc b/System/Win32/Info/Version.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Info/Version.hsc @@ -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 +#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 +-} diff --git a/System/Win32/Mem.hsc b/System/Win32/Mem.hsc --- a/System/Win32/Mem.hsc +++ b/System/Win32/Mem.hsc @@ -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 +#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 = diff --git a/System/Win32/MinTTY.hsc b/System/Win32/MinTTY.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/MinTTY.hsc @@ -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 +-- 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 +#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) diff --git a/System/Win32/NLS.hsc b/System/Win32/NLS.hsc --- a/System/Win32/NLS.hsc +++ b/System/Win32/NLS.hsc @@ -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 +#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 diff --git a/System/Win32/NamedPipes.hsc b/System/Win32/NamedPipes.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/NamedPipes.hsc @@ -0,0 +1,276 @@ +#include +#include + +#include "namedpipeapi_compat.h" + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} + +-- | For full details on the Windows named pipes API see +-- +-- +module System.Win32.NamedPipes ( + + -- * Named pipe server APIs + createNamedPipe, + pIPE_UNLIMITED_INSTANCES, + + -- ** Parameter types + LPSECURITY_ATTRIBUTES, + OpenMode, + pIPE_ACCESS_DUPLEX, + pIPE_ACCESS_INBOUND, + pIPE_ACCESS_OUTBOUND, + fILE_FLAG_OVERLAPPED, + PipeMode, + pIPE_TYPE_BYTE, + pIPE_TYPE_MESSAGE, + pIPE_READMODE_BYTE, + pIPE_READMODE_MESSAGE, + pIPE_WAIT, + pIPE_NOWAIT, + pIPE_ACCEPT_REMOTE_CLIENTS, + pIPE_REJECT_REMOTE_CLIENTS, + + -- * Named pipe client APIs + -- ** connect to a named pipe + connect, + + -- ** waiting for named pipe instances + waitNamedPipe, + + TimeOut, + nMPWAIT_USE_DEFAULT_WAIT, + nMPWAIT_WAIT_FOREVER, + ) where + + +import Control.Exception +import Control.Monad (when) +import Foreign.C.String (withCString) + +import System.Win32.Types hiding (try) +import System.Win32.File + +-- | The named pipe open mode. +-- +-- This must specify one of: +-- +-- * 'pIPE_ACCESS_DUPLEX' +-- * 'pIPE_ACCESS_INBOUND' +-- * 'pIPE_ACCESS_OUTBOUND' +-- +-- It may also specify: +-- +-- * 'fILE_FLAG_WRITE_THROUGH' +-- * 'fILE_FLAG_OVERLAPPED' +-- +-- It may also specify any combination of: +-- +-- * 'wRITE_DAC' +-- * 'wRITE_OWNER' +-- * 'aCCESS_SYSTEM_SECURITY' +-- +type OpenMode = UINT + +#{enum OpenMode, + , pIPE_ACCESS_DUPLEX = PIPE_ACCESS_DUPLEX + , pIPE_ACCESS_INBOUND = PIPE_ACCESS_INBOUND + , pIPE_ACCESS_OUTBOUND = PIPE_ACCESS_OUTBOUND + } + +-- | The pipe mode. +-- +-- One of the following type modes can be specified. The same type mode must be +-- specified for each instance of the pipe. +-- +-- * 'pIPE_TYPE_BYTE' +-- * 'pIPE_TYPE_MESSAGE' +-- +-- One of the following read modes can be specified. Different instances of the +-- same pipe can specify different read modes. +-- +-- * 'pIPE_READMODE_BYTE' +-- * 'pIPE_READMODE_MESSAGE' +-- +-- One of the following wait modes can be specified. Different instances of the +-- same pipe can specify different wait modes. +-- +-- * 'pIPE_WAIT' +-- * 'pIPE_NOWAIT' +-- +-- One of the following remote-client modes can be specified. Different +-- instances of the same pipe can specify different remote-client modes. +-- +-- * 'pIPE_ACCEPT_REMOTE_CLIENT' +-- * 'pIPE_REJECT_REMOTE_CLIENT' +-- +type PipeMode = UINT + +#{enum PipeMode, + , pIPE_TYPE_BYTE = PIPE_TYPE_BYTE + , pIPE_TYPE_MESSAGE = PIPE_TYPE_MESSAGE + , pIPE_READMODE_BYTE = PIPE_READMODE_BYTE + , pIPE_READMODE_MESSAGE = PIPE_READMODE_MESSAGE + , pIPE_WAIT = PIPE_WAIT + , pIPE_NOWAIT = PIPE_NOWAIT + , pIPE_ACCEPT_REMOTE_CLIENTS = PIPE_ACCEPT_REMOTE_CLIENTS + , pIPE_REJECT_REMOTE_CLIENTS = PIPE_REJECT_REMOTE_CLIENTS + } + +-- | If the 'createNamedPipe' @nMaxInstances@ parameter is +-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created +-- is limited only by the availability of system resources. +pIPE_UNLIMITED_INSTANCES :: DWORD +pIPE_UNLIMITED_INSTANCES = #const PIPE_UNLIMITED_INSTANCES + +-- | Creates an instance of a named pipe and returns a handle for subsequent +-- pipe operations. A named pipe server process uses this function either to +-- create the first instance of a specific named pipe and establish its basic +-- attributes or to create a new instance of an existing named pipe. +-- +-- For full details see +-- +-- +-- To create a named pipe which can be associate with IO completion port on +-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument, +-- e.g. +-- +-- > Win32.createNamedPipe pipeName +-- > (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED) +-- > (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE) +-- > pIPE_UNLIMITED_INSTANCES +-- > 512 +-- > 512 +-- > 0 +-- > NothinROR +-- +-- +createNamedPipe :: String -- ^ A unique pipe name of the form @\\\\.\\pipe\\{pipename}@ + -- The `pipename` part of the name can include any + -- character other than a backslash, including + -- numbers and special characters. The entire pipe + -- name string can be up to 256 characters long. + -- Pipe names are not case sensitive. + -> OpenMode + -> PipeMode + -> DWORD -- ^ nMaxInstances + -> DWORD -- ^ nOutBufferSize + -> DWORD -- ^ nInBufferSize + -> DWORD -- ^ nDefaultTimeOut + -> Maybe LPSECURITY_ATTRIBUTES + -> IO HANDLE +createNamedPipe name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut mb_attr = + withTString name $ \ c_name -> + failIf (==iNVALID_HANDLE_VALUE) ("CreateNamedPipe ('" ++ name ++ "')") $ + c_CreateNamedPipe c_name openMode pipeMode + nMaxInstances nOutBufferSize nInBufferSize + nDefaultTimeOut (maybePtr mb_attr) + +foreign import ccall unsafe "windows.h CreateNamedPipeW" + c_CreateNamedPipe :: LPCTSTR + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> DWORD + -> LPSECURITY_ATTRIBUTES + -> IO HANDLE + + +-- | Timeout in milliseconds. +-- +-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to +-- 'createNamedPipe' should be used. +-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named +-- pipe instance is available. +-- +type TimeOut = DWORD +#{enum TimeOut, + , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT + , nMPWAIT_WAIT_FOREVER = NMPWAIT_WAIT_FOREVER + } + + +-- | Wait until a named pipe instance is available. If there is no instance at +-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e. +-- @invalid argument (The semaphore timeout period has expired)@ +-- +-- It returns 'True' if there is an available instance, subsequent 'createFile' +-- might still fail, if another thread will take turn and connect before, or if +-- the other end shuts down the name pipe. +-- +-- It returns 'False' if timeout fired. +-- +waitNamedPipe :: String -- ^ pipe name + -> TimeOut -- ^ nTimeOut + -> IO Bool +waitNamedPipe name timeout = + withCString name $ \ c_name -> do + r <- c_WaitNamedPipe c_name timeout + e <- getLastError + if | r -> pure r + | e == eRROR_SEM_TIMEOUT -> pure False + | otherwise -> failWith "waitNamedPipe" e + + +-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import. +foreign import ccall safe "windows.h WaitNamedPipeA" + c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName + -> DWORD -- nTimeOut + -> IO BOOL + +-- | A reliable connect call, as designed in +-- +-- +-- The arguments are passed directly to 'createFile'. +-- +-- Note we pick the more familiar posix naming convention, do not confuse this +-- function with 'connectNamedPipe' (which corresponds to posix 'accept') +-- +connect :: String -- ^ file name + -> AccessMode -- ^ dwDesiredAccess + -> ShareMode -- ^ dwSharedMode + -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes + -> CreateMode -- ^ dwCreationDisposition + -> FileAttributeOrFlag -- ^ dwFlagsAndAttributes + -> Maybe HANDLE -- ^ hTemplateFile + -> IO HANDLE +connect fileName dwDesiredAccess dwSharedMode lpSecurityAttributes dwCreationDisposition dwFlagsAndAttributes hTemplateFile = connectLoop + where + connectLoop = do + -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is + -- caused by `ERROR_SHARING_VIOLATION`. + mh <- try $ + createFile fileName + dwDesiredAccess + dwSharedMode + lpSecurityAttributes + dwCreationDisposition + dwFlagsAndAttributes + hTemplateFile + case mh :: Either IOException HANDLE of + Left e -> do + errorCode <- getLastError + when (errorCode /= eRROR_PIPE_BUSY) + $ throwIO e + -- all pipe instance were busy, wait 20s and retry; we ignore the + -- result + _ <- waitNamedPipe fileName 5000 + connectLoop + + Right h -> pure h + + +-- | [ERROR_PIPE_BUSY](https://docs.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-#ERROR_PIPE_BUSY): +-- all pipe instances are busy. +-- +eRROR_PIPE_BUSY :: ErrCode +eRROR_PIPE_BUSY = #const ERROR_PIPE_BUSY + +eRROR_SEM_TIMEOUT :: ErrCode +eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT diff --git a/System/Win32/Path.hsc b/System/Win32/Path.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Path.hsc @@ -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 +-- 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 + +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 + diff --git a/System/Win32/Path/Internal.hsc b/System/Win32/Path/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Path/Internal.hsc @@ -0,0 +1,29 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Path.Internal +-- Copyright : (c) Tamar Christina, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Tamar Christina +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.Path.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +#include + +foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW" + c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT diff --git a/System/Win32/Process.hsc b/System/Win32/Process.hsc --- a/System/Win32/Process.hsc +++ b/System/Win32/Process.hsc @@ -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 #include +#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) diff --git a/System/Win32/Registry.hsc b/System/Win32/Registry.hsc --- a/System/Win32/Registry.hsc +++ b/System/Win32/Registry.hsc @@ -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 +#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 diff --git a/System/Win32/Security.hsc b/System/Win32/Security.hsc --- a/System/Win32/Security.hsc +++ b/System/Win32/Security.hsc @@ -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 diff --git a/System/Win32/Semaphore.hsc b/System/Win32/Semaphore.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Semaphore.hsc @@ -0,0 +1,146 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Semaphore +-- Copyright : (c) Sam Derbyshire, 2022 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Sam Derbyshire +-- Stability : provisional +-- Portability : portable +-- +-- Windows Semaphore objects and operations +-- +----------------------------------------------------------------------------- + +module System.Win32.Semaphore + ( -- * Semaphores + Semaphore(..) + + -- * Access modes + , AccessMode + , sEMAPHORE_ALL_ACCESS + , sEMAPHORE_MODIFY_STATE + + -- * Managing semaphores + , createSemaphore + , openSemaphore + , releaseSemaphore + ) where + +import System.Win32.File +import System.Win32.Types + +import Data.Maybe (fromMaybe) +import Foreign hiding (void) +import Foreign.C (withCAString) + +##include "windows_cconv.h" + +#include + +---------------------------------------------------------------- +-- Semaphore access modes +---------------------------------------------------------------- + +#{enum AccessMode, + , sEMAPHORE_ALL_ACCESS = SEMAPHORE_ALL_ACCESS + , sEMAPHORE_MODIFY_STATE = SEMAPHORE_MODIFY_STATE + } + +---------------------------------------------------------------- +-- Semaphores +---------------------------------------------------------------- + +-- | A Windows semaphore. +-- +-- To obtain a 'Semaphore', use 'createSemaphore' to create a new one, +-- or 'openSemaphore' to open an existing one. +-- +-- To wait on a semaphore, use 'System.Win32.Event.waitForSingleObject'. +-- +-- To release resources on a semaphore, use 'releaseSemaphore'. +-- +-- To free a semaphore, use 'System.Win32.File.closeHandle'. +-- The semaphore object is destroyed when its last handle has been closed. +-- Closing the handle does not affect the semaphore count; therefore, be sure to call +-- 'releaseSemaphore' before closing the handle or before the process terminates. +-- Otherwise, pending wait operations will either time out or continue indefinitely, +-- depending on whether a time-out value has been specified. +newtype Semaphore = Semaphore { semaphoreHandle :: HANDLE } + +-- | Open a 'Semaphore' with the given name, or create a new semaphore +-- if no such semaphore exists, with initial count @i@ and maximum count @m@. +-- +-- The counts must satisfy @i >= 0@, @m > 0@ and @i <= m@. +-- +-- The returned 'Bool' is 'True' if the function found an existing semaphore +-- with the given name, in which case a handle to that semaphore is returned +-- and the counts are ignored. +-- +-- Use 'openSemaphore' if you don't want to create a new semaphore. +createSemaphore :: Maybe SECURITY_ATTRIBUTES + -> LONG -- ^ initial count @i@ with @0 <= i <= m@ + -> LONG -- ^ maximum count @m > 0@ + -> Maybe String -- ^ (optional) semaphore name + -- (case-sensitive, limited to MAX_PATH characters) + -> IO (Semaphore, Bool) +createSemaphore mb_sec initial_count max_count mb_name = + maybeWith with mb_sec $ \ c_sec -> do + maybeWith withCAString mb_name $ \ c_name -> do + handle <- c_CreateSemaphore c_sec initial_count max_count c_name + err_code <- getLastError + already_exists <- + case err_code of + (# const ERROR_INVALID_HANDLE) -> + errorWin $ "createSemaphore: semaphore name '" + ++ fromMaybe "" mb_name + ++ "' matches non-semaphore" + (# const ERROR_ALREADY_EXISTS) -> + return True + _ -> + return False + if handle == nullPtr + then errorWin "createSemaphore" + else return (Semaphore handle, already_exists) + +foreign import WINDOWS_CCONV unsafe "windows.h CreateSemaphoreA" + c_CreateSemaphore :: LPSECURITY_ATTRIBUTES -> LONG -> LONG -> LPCSTR -> IO HANDLE + +-- | Open an existing 'Semaphore'. +openSemaphore :: AccessMode -- ^ desired access mode + -> Bool -- ^ should child processes inherit the handle? + -> String -- ^ name of the semaphore to open (case-sensitive) + -> IO Semaphore +openSemaphore amode inherit name = + withTString name $ \c_name -> do + handle <- failIfNull ("openSemaphore: '" ++ name ++ "'") $ + c_OpenSemaphore (fromIntegral amode) inherit c_name + return (Semaphore handle) + +foreign import WINDOWS_CCONV unsafe "windows.h OpenSemaphoreW" + c_OpenSemaphore :: DWORD -> BOOL -> LPCWSTR -> IO HANDLE + +-- | Increase the count of the 'Semaphore' by the specified amount. +-- +-- Returns the count of the semaphore before the increase. +-- +-- Throws an error if the count would exceeded the maximum count +-- of the semaphore. +releaseSemaphore :: Semaphore -> LONG -> IO LONG +releaseSemaphore (Semaphore handle) count = + with 0 $ \ ptr_prevCount -> do + failIfFalse_ "releaseSemaphore" $ c_ReleaseSemaphore handle count ptr_prevCount + peek ptr_prevCount + +foreign import WINDOWS_CCONV unsafe "windows.h ReleaseSemaphore" + c_ReleaseSemaphore :: HANDLE -> LONG -> Ptr LONG -> IO BOOL + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/Shell.hsc b/System/Win32/Shell.hsc --- a/System/Win32/Shell.hsc +++ b/System/Win32/Shell.hsc @@ -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 diff --git a/System/Win32/Shell/Internal.hsc b/System/Win32/Shell/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Shell/Internal.hsc @@ -0,0 +1,50 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Shell.Internal +-- Copyright : (c) The University of Glasgow 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Win32 stuff from shell32.dll +-- +----------------------------------------------------------------------------- + +module System.Win32.Shell.Internal ( + c_SHGetFolderPath + , raiseUnsupported + ) where + +import System.Win32.Types +import Graphics.Win32.GDI.Types (HWND) + +import Foreign.C +import System.IO.Error + +##include "windows_cconv.h" + +-- for SHGetFolderPath stuff +#define _WIN32_IE 0x500 +#include +#include + +---------------------------------------------------------------- +-- SHGetFolderPath +-- +-- XXX: this is deprecated in Vista and later +---------------------------------------------------------------- + +raiseUnsupported :: String -> IO () +raiseUnsupported loc = + ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation") + +foreign import WINDOWS_CCONV unsafe "SHGetFolderPathW" + c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR + -> IO HRESULT diff --git a/System/Win32/SimpleMAPI.hsc b/System/Win32/SimpleMAPI.hsc --- a/System/Win32/SimpleMAPI.hsc +++ b/System/Win32/SimpleMAPI.hsc @@ -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 diff --git a/System/Win32/String.hs b/System/Win32/String.hs new file mode 100644 --- /dev/null +++ b/System/Win32/String.hs @@ -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 + diff --git a/System/Win32/SymbolicLink.hsc b/System/Win32/SymbolicLink.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/SymbolicLink.hsc @@ -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 + \. + + 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 + diff --git a/System/Win32/SymbolicLink/Internal.hsc b/System/Win32/SymbolicLink/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/SymbolicLink/Internal.hsc @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.SymbolicLink.Internal + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) +-} +module System.Win32.SymbolicLink.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +type SymbolicLinkFlags = DWORD + +#{enum SymbolicLinkFlags, + , sYMBOLIC_LINK_FLAG_FILE = 0x0 + , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 + , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2 +} + +foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW" + c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL diff --git a/System/Win32/Thread.hs b/System/Win32/Thread.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Thread.hs @@ -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 diff --git a/System/Win32/Time.hsc b/System/Win32/Time.hsc --- a/System/Win32/Time.hsc +++ b/System/Win32/Time.hsc @@ -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 +#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') diff --git a/System/Win32/Time/Internal.hsc b/System/Win32/Time/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Time/Internal.hsc @@ -0,0 +1,245 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Time.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Time API. +-- +----------------------------------------------------------------------------- +module System.Win32.Time.Internal where + +import System.Win32.Types ( BOOL, DDWORD, DWORD, HANDLE, LARGE_INTEGER, LCID + , LONG, LPCTSTR, LPCWSTR, LPTSTR, LPWSTR, UINT, WORD + , dwordsToDdword, ddwordToDwords + ) +import Control.Monad ( when ) +import Data.Word ( Word8 ) +import Foreign ( Storable(sizeOf, alignment, peekByteOff, peek, + pokeByteOff, poke) + , Ptr, castPtr, plusPtr, advancePtr + , copyArray ) +import Foreign.C ( CInt(..), CWchar(..) + , peekCWString, withCWStringLen ) + +##include "windows_cconv.h" +#include +#include "alignment.h" +#include "winnls_compat.h" + +---------------------------------------------------------------- +-- data types +---------------------------------------------------------------- + +newtype FILETIME = FILETIME DDWORD deriving (Show, Eq, Ord) + +data SYSTEMTIME = SYSTEMTIME { + wYear, wMonth, wDayOfWeek, wDay, wHour, wMinute, wSecond, wMilliseconds :: WORD } + deriving (Show, Eq, Ord) + +data TIME_ZONE_INFORMATION = TIME_ZONE_INFORMATION + { tziBias :: LONG + , tziStandardName :: String + , tziStandardDate :: SYSTEMTIME + , tziStandardBias :: LONG + , tziDaylightName :: String + , tziDaylightDate :: SYSTEMTIME + , tziDaylightBias :: LONG + } deriving (Show,Eq,Ord) + +data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight + deriving (Show, Eq, Ord) + +data LASTINPUTINFO = LASTINPUTINFO DWORD deriving (Show) + +---------------------------------------------------------------- +-- Instances +---------------------------------------------------------------- + +instance Storable FILETIME where + sizeOf = const (#size FILETIME) + alignment _ = #alignment FILETIME + poke buf (FILETIME n) = do + (#poke FILETIME, dwLowDateTime) buf low + (#poke FILETIME, dwHighDateTime) buf hi + where (hi,low) = ddwordToDwords n + peek buf = do + low <- (#peek FILETIME, dwLowDateTime) buf + hi <- (#peek FILETIME, dwHighDateTime) buf + return $ FILETIME $ dwordsToDdword (hi,low) + +instance Storable SYSTEMTIME where + sizeOf _ = #size SYSTEMTIME + alignment _ = #alignment SYSTEMTIME + poke buf st = do + (#poke SYSTEMTIME, wYear) buf (wYear st) + (#poke SYSTEMTIME, wMonth) buf (wMonth st) + (#poke SYSTEMTIME, wDayOfWeek) buf (wDayOfWeek st) + (#poke SYSTEMTIME, wDay) buf (wDay st) + (#poke SYSTEMTIME, wHour) buf (wHour st) + (#poke SYSTEMTIME, wMinute) buf (wMinute st) + (#poke SYSTEMTIME, wSecond) buf (wSecond st) + (#poke SYSTEMTIME, wMilliseconds) buf (wMilliseconds st) + peek buf = do + year <- (#peek SYSTEMTIME, wYear) buf + month <- (#peek SYSTEMTIME, wMonth) buf + dow <- (#peek SYSTEMTIME, wDayOfWeek) buf + day <- (#peek SYSTEMTIME, wDay) buf + hour <- (#peek SYSTEMTIME, wHour) buf + mins <- (#peek SYSTEMTIME, wMinute) buf + sec <- (#peek SYSTEMTIME, wSecond) buf + ms <- (#peek SYSTEMTIME, wMilliseconds) buf + return $ SYSTEMTIME year month dow day hour mins sec ms + +instance Storable TIME_ZONE_INFORMATION where + sizeOf _ = (#size TIME_ZONE_INFORMATION) + alignment _ = #alignment TIME_ZONE_INFORMATION + poke buf tzi = do + (#poke TIME_ZONE_INFORMATION, Bias) buf (tziBias tzi) + (#poke TIME_ZONE_INFORMATION, StandardDate) buf (tziStandardDate tzi) + (#poke TIME_ZONE_INFORMATION, StandardBias) buf (tziStandardBias tzi) + (#poke TIME_ZONE_INFORMATION, DaylightDate) buf (tziDaylightDate tzi) + (#poke TIME_ZONE_INFORMATION, DaylightBias) buf (tziDaylightBias tzi) + write buf (#offset TIME_ZONE_INFORMATION, StandardName) (tziStandardName tzi) + write buf (#offset TIME_ZONE_INFORMATION, DaylightName) (tziDaylightName tzi) + where + write buf_ offset str = withCWStringLen str $ \(c_str,len) -> do + when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string." + let len' = len * sizeOf (undefined :: CWchar) + start = (advancePtr (castPtr buf_) offset) + end = advancePtr start len' + copyArray start (castPtr c_str :: Ptr Word8) len' + poke (castPtr end) (0 :: CWchar) + + peek buf = do + bias <- (#peek TIME_ZONE_INFORMATION, Bias) buf + sdat <- (#peek TIME_ZONE_INFORMATION, StandardDate) buf + sbia <- (#peek TIME_ZONE_INFORMATION, StandardBias) buf + ddat <- (#peek TIME_ZONE_INFORMATION, DaylightDate) buf + dbia <- (#peek TIME_ZONE_INFORMATION, DaylightBias) buf + snam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, StandardName)) + dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName)) + return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia + +instance Storable LASTINPUTINFO where + sizeOf = const (#size LASTINPUTINFO) + alignment = sizeOf + poke buf (LASTINPUTINFO t) = do + (#poke LASTINPUTINFO, cbSize) buf ((#size LASTINPUTINFO) :: UINT) + (#poke LASTINPUTINFO, dwTime) buf t + peek buf = do + t <- (#peek LASTINPUTINFO, dwTime) buf + return $ LASTINPUTINFO t + +foreign import WINDOWS_CCONV "windows.h GetSystemTime" + c_GetSystemTime :: Ptr SYSTEMTIME -> IO () + +foreign import WINDOWS_CCONV "windows.h SetSystemTime" + c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime" + c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () + +foreign import WINDOWS_CCONV "windows.h GetLocalTime" + c_GetLocalTime :: Ptr SYSTEMTIME -> IO () + +foreign import WINDOWS_CCONV "windows.h SetLocalTime" + c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment" + c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD + +foreign import WINDOWS_CCONV unsafe "windows.h GetLastInputInfo" + c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool + +foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment" + c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetTimeZoneInformation" + c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime" + c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime" + c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetFileTime" + c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetFileTime" + c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime" + c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime" + c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +{- +-- Windows XP SP1 +foreign import WINDOWS_CCONV "windows.h GetSystemTimes" + c_GetSystemTimes :: Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL +getSystemTimes :: IO (FILETIME,FILETIME,FILETIME) +getSystemTimes = alloca $ \idle -> alloca $ \kernel -> alloca $ \user -> do + failIf not "getSystemTimes: GetSystemTimes" $ c_GetSystemTimes idle kernel user + liftM3 (,,) (peek idle) (peek kernel) (peek user) +-} + +{- +-- Windows XP +foreign import WINDOWS_CCONV "windows.h SystemTimeToTzSpecificLocalTime" + c_SystemTimeToTzSpecificLocalTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL +systemTimeToTzSpecificLocalTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME +systemTimeToTzSpecificLocalTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do + failIf not "systemTimeToTzSpecificLocalTime: SystemTimeToTzSpecificLocalTime" $ + c_SystemTimeToTzSpecificLocalTime tzi st res + peek res + +foreign import WINDOWS_CCONV "windows.h TzSpecificLocalTimeToSystemTime" + c_TzSpecificLocalTimeToSystemTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL +tzSpecificLocalTimeToSystemTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME +tzSpecificLocalTimeToSystemTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do + failIf not "tzSpecificLocalTimeToSystemTime: TzSpecificLocalTimeToSystemTime" $ + c_TzSpecificLocalTimeToSystemTime tzi st res + peek res +-} + +foreign import WINDOWS_CCONV "windows.h QueryPerformanceFrequency" + c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h QueryPerformanceCounter" + c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL + +type GetTimeFormatFlags = DWORD +#{enum GetTimeFormatFlags, + , lOCALE_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE + , lOCALE_USE_CP_ACP = LOCALE_USE_CP_ACP + , tIME_NOMINUTESORSECONDS = TIME_NOMINUTESORSECONDS + , tIME_NOSECONDS = TIME_NOSECONDS + , tIME_NOTIMEMARKER = TIME_NOTIMEMARKER + , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT + } + +foreign import WINDOWS_CCONV "windows.h GetTimeFormatEx" + c_GetTimeFormatEx :: LPCWSTR + -> GetTimeFormatFlags + -> Ptr SYSTEMTIME + -> LPCWSTR + -> LPWSTR + -> CInt + -> IO CInt + +foreign import WINDOWS_CCONV "windows.h GetTimeFormatW" + c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt diff --git a/System/Win32/Types.hs b/System/Win32/Types.hs deleted file mode 100644 --- a/System/Win32/Types.hs +++ /dev/null @@ -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 --- 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 ----------------------------------------------------------------- diff --git a/System/Win32/Types.hsc b/System/Win32/Types.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Types.hsc @@ -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 +-- 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 +#include +##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 +---------------------------------------------------------------- diff --git a/System/Win32/Utils.hs b/System/Win32/Utils.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Utils.hs @@ -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 diff --git a/System/Win32/WindowsString/Console.hsc b/System/Win32/WindowsString/Console.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Console.hsc @@ -0,0 +1,180 @@ +{-# LANGUAGE PackageImports #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.Console +-- Copyright : (c) University of Glasgow 2023 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Console API (WindowsString variant) +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Console ( + -- * Console mode + getConsoleMode, + setConsoleMode, + eNABLE_ECHO_INPUT, + eNABLE_EXTENDED_FLAGS, + eNABLE_INSERT_MODE, + eNABLE_LINE_INPUT, + eNABLE_MOUSE_INPUT, + eNABLE_PROCESSED_INPUT, + eNABLE_QUICK_EDIT_MODE, + eNABLE_WINDOW_INPUT, + eNABLE_VIRTUAL_TERMINAL_INPUT, + eNABLE_PROCESSED_OUTPUT, + eNABLE_WRAP_AT_EOL_OUTPUT, + eNABLE_VIRTUAL_TERMINAL_PROCESSING, + dISABLE_NEWLINE_AUTO_RETURN, + eNABLE_LVB_GRID_WORLDWIDE, + -- * Console code pages + getConsoleCP, + setConsoleCP, + getConsoleOutputCP, + setConsoleOutputCP, + -- * Ctrl events + CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT, + generateConsoleCtrlEvent, + -- * Command line + commandLineToArgv, + getCommandLineW, + getArgs, + -- * Screen buffer + CONSOLE_SCREEN_BUFFER_INFO(..), + CONSOLE_SCREEN_BUFFER_INFOEX(..), + COORD(..), + SMALL_RECT(..), + COLORREF, + getConsoleScreenBufferInfo, + getCurrentConsoleScreenBufferInfo, + getConsoleScreenBufferInfoEx, + getCurrentConsoleScreenBufferInfoEx, + + -- * Env + getEnv, + getEnvironment + ) where + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "wincon_compat.h" + +import System.Win32.WindowsString.Types +import System.Win32.WindowsString.String (withTStringBufferLen) +import System.Win32.Console.Internal +import System.Win32.Console hiding (getArgs, commandLineToArgv, getEnv, getEnvironment) +import System.OsString.Windows +import System.OsString.Internal.Types + +import Foreign.C.Types (CWchar) +import Foreign.C.String (CWString) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, peekArray0) +import Foreign.Marshal.Alloc (alloca) +import GHC.IO (bracket) +import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) + +import Prelude hiding (break, length, tail) +import qualified Prelude as P + +#if !MIN_VERSION_filepath(1,5,0) +import Data.Coerce +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC + +tail :: WindowsString -> WindowsString +tail = coerce BC.tail + +break :: (WindowsChar -> Bool) -> WindowsString -> (WindowsString, WindowsString) +break = coerce BC.break +#endif + + +-- | This function can be used to parse command line arguments and return +-- the split up arguments as elements in a list. +commandLineToArgv :: WindowsString -> IO [WindowsString] +commandLineToArgv arg + | arg == mempty = return [] + | otherwise = withTString arg $ \c_arg -> do + alloca $ \c_size -> do + res <- c_CommandLineToArgvW c_arg c_size + size <- peek c_size + args <- peekArray (fromIntegral size) res + _ <- localFree res + mapM peekTString args + +-- | Based on 'GetCommandLineW'. This behaves slightly different +-- than 'System.Environment.getArgs'. See the online documentation: +-- +getArgs :: IO [WindowsString] +getArgs = do + getCommandLineW >>= peekTString >>= commandLineToArgv + + +-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD +getEnv :: WindowsString -> IO (Maybe WindowsString) +getEnv name = + withTString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- c_GetEnvironmentVariableW c_name buf c_len + case c_len' of + 0 -> do + err_code <- getLastError + if err_code == eERROR_ENVVAR_NOT_FOUND + then return Nothing + else errorWin "GetEnvironmentVariableW" + _ | c_len' > fromIntegral maxLength -> + -- shouldn't happen, because we provide maxLength + ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) + | otherwise -> do + let len' = fromIntegral c_len' + Just <$> peekTStringLen (buf, len') + where + -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew + -- max characters (wide chars): 32767 + -- => bytes = 32767 * 2 = 65534 + -- +1 byte for NUL (although not needed I think) + maxLength :: Int + maxLength = 65535 + + +getEnvironment :: IO [(WindowsString, WindowsString)] +getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do + strs <- builder lpwstr + return (divvy <$> strs) + where + divvy :: WindowsString -> (WindowsString, WindowsString) + divvy str = + case break (== unsafeFromChar '=') str of + (xs,ys) + | ys == mempty -> (xs,ys) -- don't barf (like Posix.getEnvironment) + (name, ys) -> let value = tail ys in (name,value) + + builder :: LPWSTR -> IO [WindowsString] + builder ptr = go 0 + where + go :: Int -> IO [WindowsString] + go off = do + (str, l) <- peekCWStringOff ptr off + if l == 0 + then pure [] + else (str:) <$> go (((l + 1) * 2) + off) + + +peekCWStringOff :: CWString -> Int -> IO (WindowsString, Int) +peekCWStringOff cp off = do + cs <- peekArray0 wNUL (cp `plusPtr` off) + return (cWcharsToChars cs, P.length cs) + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> WindowsString +cWcharsToChars = pack . fmap (WindowsChar . fromIntegral) + diff --git a/System/Win32/WindowsString/DLL.hsc b/System/Win32/WindowsString/DLL.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/DLL.hsc @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.DLL +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.DLL + ( module System.Win32.WindowsString.DLL + , module System.Win32.DLL + ) where + +import System.Win32.DLL hiding + ( disableThreadLibraryCalls + , freeLibrary + , getModuleFileName + , getModuleHandle + , getProcAddress + , loadLibrary + , loadLibraryEx + , setDllDirectory + , lOAD_LIBRARY_AS_DATAFILE + , lOAD_WITH_ALTERED_SEARCH_PATH + ) +import System.Win32.DLL.Internal +import System.Win32.WindowsString.Types + +import Foreign +import Data.Maybe (fromMaybe) +import System.OsString.Windows +import GHC.IO.Encoding.UTF16 ( mkUTF16le ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) + +getModuleFileName :: HMODULE -> IO WindowsString +getModuleFileName hmod = + allocaArray 512 $ \ c_str -> do + failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512 + peekTString c_str + +getModuleHandle :: Maybe WindowsString -> IO HMODULE +getModuleHandle mb_name = + maybeWith withTString mb_name $ \ c_name -> + failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name + +loadLibrary :: WindowsString -> IO HMODULE +loadLibrary name = + withTString name $ \ c_name -> + failIfNull "LoadLibrary" $ c_LoadLibrary c_name + +loadLibraryEx :: WindowsString -> HANDLE -> LoadLibraryFlags -> IO HMODULE +loadLibraryEx name h flags = + withTString name $ \ c_name -> + failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags + +setDllDirectory :: Maybe WindowsString -> IO () +setDllDirectory name = + maybeWith withTString name $ \ c_name -> do + let nameS = name >>= either (const Nothing) Just . decodeWith (mkUTF16le TransliterateCodingFailure) + failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" nameS]) $ c_SetDllDirectory c_name + diff --git a/System/Win32/WindowsString/DebugApi.hsc b/System/Win32/WindowsString/DebugApi.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/DebugApi.hsc @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.DebugApi +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for using Windows DebugApi. +-- +----------------------------------------------------------------------------- +module System.Win32.WindowsString.DebugApi + ( module System.Win32.WindowsString.DebugApi + , module System.Win32.DebugApi + ) where + +import System.Win32.DebugApi.Internal +import System.Win32.DebugApi hiding (outputDebugString) +import System.Win32.WindowsString.Types ( withTString ) +import System.OsString.Windows + +##include "windows_cconv.h" +#include "windows.h" + + +-------------------------------------------------------------------------- +-- On process being debugged + +outputDebugString :: WindowsString -> IO () +outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s + diff --git a/System/Win32/WindowsString/File.hsc b/System/Win32/WindowsString/File.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/File.hsc @@ -0,0 +1,269 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.File +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.File + ( deleteFile + , copyFile + , moveFile + , moveFileEx + , setCurrentDirectory + , createDirectory + , createDirectoryEx + , removeDirectory + , getBinaryType + , createFile + , setFileAttributes + , getFileAttributes + , getFileAttributesExStandard + , getTempFileName + , findFirstChangeNotification + , getFindDataFileName + , findFirstFile + , defineDosDevice + , getDiskFreeSpace + , setVolumeLabel + , getFileExInfoStandard + , getFileExMaxInfoLevel + , replaceFile + , module System.Win32.File + ) where + +import System.Win32.File.Internal +import System.Win32.File hiding ( + deleteFile + , copyFile + , moveFile + , moveFileEx + , setCurrentDirectory + , createDirectory + , createDirectoryEx + , removeDirectory + , getBinaryType + , createFile + , setFileAttributes + , getFileAttributes + , getFileAttributesExStandard + , getTempFileName + , findFirstChangeNotification + , getFindDataFileName + , findFirstFile + , defineDosDevice + , getDiskFreeSpace + , setVolumeLabel + , getFileExInfoStandard + , getFileExMaxInfoLevel + , replaceFile + ) +import System.Win32.WindowsString.Types +import System.OsString.Windows +import Unsafe.Coerce (unsafeCoerce) +import Data.Maybe (fromMaybe) + +import Foreign hiding (void) + +##include "windows_cconv.h" + +#include +#include "alignment.h" + +deleteFile :: WindowsString -> IO () +deleteFile name = + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $ + c_DeleteFile c_name + +copyFile :: WindowsString -> WindowsString -> Bool -> IO () +copyFile src dest over = + withFilePath src $ \ c_src -> + withFilePath dest $ \ c_dest -> + failIfFalseWithRetry_ (unwords ["CopyFile",show src,show dest]) $ + c_CopyFile c_src c_dest over + +moveFile :: WindowsString -> WindowsString -> IO () +moveFile src dest = + withFilePath src $ \ c_src -> + withFilePath dest $ \ c_dest -> + failIfFalseWithRetry_ (unwords ["MoveFile",show src,show dest]) $ + c_MoveFile c_src c_dest + +moveFileEx :: WindowsString -> Maybe WindowsString -> MoveFileFlag -> IO () +moveFileEx src dest flags = + withFilePath src $ \ c_src -> + maybeWith withFilePath dest $ \ c_dest -> + failIfFalseWithRetry_ (unwords ["MoveFileEx",show src,show dest]) $ + c_MoveFileEx c_src c_dest flags + +setCurrentDirectory :: WindowsString -> IO () +setCurrentDirectory name = + withFilePath name $ \ c_name -> + failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $ + c_SetCurrentDirectory c_name + +createDirectory :: WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO () +createDirectory name mb_attr = + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["CreateDirectory",show name]) $ + c_CreateDirectory c_name (maybePtr mb_attr) + +createDirectoryEx :: WindowsString -> WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO () +createDirectoryEx template name mb_attr = + withFilePath template $ \ c_template -> + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["CreateDirectoryEx",show template,show name]) $ + c_CreateDirectoryEx c_template c_name (maybePtr mb_attr) + +removeDirectory :: WindowsString -> IO () +removeDirectory name = + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $ + c_RemoveDirectory c_name + +getBinaryType :: WindowsString -> IO BinaryType +getBinaryType name = + withFilePath name $ \ c_name -> + alloca $ \ p_btype -> do + failIfFalse_ (unwords ["GetBinaryType",show name]) $ + c_GetBinaryType c_name p_btype + peek p_btype + +---------------------------------------------------------------- +-- HANDLE operations +---------------------------------------------------------------- + +createFile :: WindowsString -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE +createFile name access share mb_attr mode flag mb_h = + withFilePath name $ \ c_name -> + failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ + c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) + +setFileAttributes :: WindowsString -> FileAttributeOrFlag -> IO () +setFileAttributes name attr = + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["SetFileAttributes",show name]) + $ c_SetFileAttributes c_name attr + +getFileAttributes :: WindowsString -> IO FileAttributeOrFlag +getFileAttributes name = + withFilePath name $ \ c_name -> + failIfWithRetry (== 0xFFFFFFFF) (unwords ["GetFileAttributes",show name]) $ + c_GetFileAttributes c_name + +getFileAttributesExStandard :: WindowsString -> IO WIN32_FILE_ATTRIBUTE_DATA +getFileAttributesExStandard name = alloca $ \res -> do + withFilePath name $ \ c_name -> + failIfFalseWithRetry_ "getFileAttributesExStandard" $ + c_GetFileAttributesEx c_name (unsafeCoerce getFileExInfoStandard) res + peek res + +-- | Get a unique temporary filename. +-- +-- Calls 'GetTempFileNameW'. +getTempFileName :: WindowsString -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long) + -> WindowsString -- ^ prefix for the temporary file name + -> Maybe UINT -- ^ if 'Nothing', a unique name is generated + -- otherwise a non-zero value is used as the unique part + -> IO (WindowsString, UINT) +getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do + uid <- withFilePath dir $ \c_dir -> + withFilePath prefix $ \ c_prefix -> do + failIfZero "getTempFileName" $ + c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf + fname <- peekTString c_buf + pure (fname, uid) + +replaceFile :: WindowsString -> WindowsString -> Maybe WindowsString -> DWORD -> IO () +replaceFile replacedFile replacementFile mBackupFile replaceFlags = + withFilePath replacedFile $ \ c_replacedFile -> + withFilePath replacementFile $ \ c_replacementFile -> + let getResult f = + case mBackupFile of + Nothing -> f nullPtr + Just backupFile -> withFilePath backupFile f + in getResult $ \ c_backupFile -> + failIfFalse_ "ReplaceFile" $ c_ReplaceFile c_replacedFile c_replacementFile c_backupFile replaceFlags nullPtr nullPtr + +---------------------------------------------------------------- +-- File Notifications +-- +-- Use these to initialise, "increment" and close a HANDLE you can wait +-- on. +---------------------------------------------------------------- + +findFirstChangeNotification :: WindowsString -> Bool -> FileNotificationFlag -> IO HANDLE +findFirstChangeNotification path watch flag = + withFilePath path $ \ c_path -> + failIfNull (unwords ["FindFirstChangeNotification",show path]) $ + c_FindFirstChangeNotification c_path watch flag + + +---------------------------------------------------------------- +-- Directories +---------------------------------------------------------------- + + +getFindDataFileName :: FindData -> IO WindowsString +getFindDataFileName fd = case unsafeCoerce fd of + (FindData fp) -> + withForeignPtr fp $ \p -> + peekTString ((# ptr WIN32_FIND_DATAW, cFileName ) p) + +findFirstFile :: WindowsString -> IO (HANDLE, FindData) +findFirstFile str = do + fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) ) + withForeignPtr fp_finddata $ \p_finddata -> do + handle <- withFilePath str $ \tstr -> do + failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $ + c_FindFirstFile tstr p_finddata + return (handle, unsafeCoerce (FindData fp_finddata)) + + +---------------------------------------------------------------- +-- DOS Device flags +---------------------------------------------------------------- + +defineDosDevice :: DefineDosDeviceFlags -> WindowsString -> Maybe WindowsString -> IO () +defineDosDevice flags name path = + maybeWith withFilePath path $ \ c_path -> + withFilePath name $ \ c_name -> + failIfFalse_ "DefineDosDevice" $ c_DefineDosDevice flags c_name c_path + +---------------------------------------------------------------- + + +-- %fun GetDriveType :: Maybe String -> IO DriveType + +getDiskFreeSpace :: Maybe WindowsString -> IO (DWORD,DWORD,DWORD,DWORD) +getDiskFreeSpace path = + maybeWith withFilePath path $ \ c_path -> + alloca $ \ p_sectors -> + alloca $ \ p_bytes -> + alloca $ \ p_nfree -> + alloca $ \ p_nclusters -> do + failIfFalse_ "GetDiskFreeSpace" $ + c_GetDiskFreeSpace c_path p_sectors p_bytes p_nfree p_nclusters + sectors <- peek p_sectors + bytes <- peek p_bytes + nfree <- peek p_nfree + nclusters <- peek p_nclusters + return (sectors, bytes, nfree, nclusters) + +setVolumeLabel :: Maybe WindowsString -> Maybe WindowsString -> IO () +setVolumeLabel path name = + maybeWith withFilePath path $ \ c_path -> + maybeWith withFilePath name $ \ c_name -> + failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/WindowsString/FileMapping.hsc b/System/Win32/WindowsString/FileMapping.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/FileMapping.hsc @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.FileMapping +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 mapped files. +-- +----------------------------------------------------------------------------- +module System.Win32.WindowsString.FileMapping + ( module System.Win32.WindowsString.FileMapping + , module System.Win32.FileMapping + ) where + +import System.Win32.FileMapping hiding + ( + mapFile + , withMappedFile + , createFileMapping + , openFileMapping + ) + +import System.Win32.FileMapping.Internal +import System.Win32.WindowsString.Types ( HANDLE, BOOL, withTString + , failIf, DDWORD, ddwordToDwords + , iNVALID_HANDLE_VALUE ) +import System.Win32.Mem +import System.Win32.WindowsString.File +import System.OsString.Windows +import System.OsPath.Windows + +import Control.Exception ( mask_, bracket ) +import Foreign ( nullPtr, maybeWith + , ForeignPtr, newForeignPtr ) + +##include "windows_cconv.h" + +#include "windows.h" + +--------------------------------------------------------------------------- +-- Derived functions +--------------------------------------------------------------------------- + +-- | Maps file fully and returns ForeignPtr and length of the mapped area. +-- The mapped file is opened read-only and shared reading. +mapFile :: WindowsPath -> IO (ForeignPtr a, Int) +mapFile path = do + bracket + (createFile path gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) + (closeHandle) + $ \fh -> bracket + (createFileMapping (Just fh) pAGE_READONLY 0 Nothing) + (closeHandle) + $ \fm -> do + fi <- getFileInformationByHandle fh + fp <- mask_ $ do + ptr <- mapViewOfFile fm fILE_MAP_READ 0 0 + newForeignPtr c_UnmapViewOfFileFinaliser ptr + return (fp, fromIntegral $ bhfiSize fi) + +-- | Opens an existing file and creates mapping object to it. +withMappedFile + :: WindowsPath -- ^ Path + -> Bool -- ^ Write? (False = read-only) + -> Maybe Bool -- ^ Sharing mode, no sharing, share read, share read+write + -> (Integer -> MappedObject -> IO a) -- ^ Action + -> IO a +withMappedFile path write share act = + bracket + (createFile path access share' Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) + (closeHandle) + $ \fh -> bracket + (createFileMapping (Just fh) page 0 Nothing) + (closeHandle) + $ \fm -> do + bhfi <- getFileInformationByHandle fh + act (fromIntegral $ bhfiSize bhfi) (MappedObject fh fm mapaccess) + where + access = if write then gENERIC_READ+gENERIC_WRITE else gENERIC_READ + page = if write then pAGE_READWRITE else pAGE_READONLY + mapaccess = if write then fILE_MAP_ALL_ACCESS else fILE_MAP_READ + share' = case share of + Nothing -> fILE_SHARE_NONE + Just False -> fILE_SHARE_READ + Just True -> fILE_SHARE_READ + fILE_SHARE_WRITE + +--------------------------------------------------------------------------- +-- API in Haskell +--------------------------------------------------------------------------- +createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe WindowsString -> IO HANDLE +createFileMapping mh flags mosize name = + maybeWith withTString name $ \c_name -> + failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow c_name + where + (moshi,moslow) = ddwordToDwords mosize + handle = maybe iNVALID_HANDLE_VALUE id mh + +openFileMapping :: FileMapAccess -> BOOL -> Maybe WindowsString -> IO HANDLE +openFileMapping access inherit name = + maybeWith withTString name $ \c_name -> + failIf (==nullPtr) "openFileMapping: OpenFileMapping" $ + c_OpenFileMapping access inherit c_name + diff --git a/System/Win32/WindowsString/HardLink.hs b/System/Win32/WindowsString/HardLink.hs new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/HardLink.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.HardLink + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling hard link using Win32 API. [NTFS only] + + Note: You should worry about file system type when use this module's function in your application: + + * NTFS only supprts this functionality. + + * ReFS doesn't support hard link currently. +-} +module System.Win32.WindowsString.HardLink + ( createHardLink + , createHardLink' + ) where + +import System.Win32.HardLink.Internal +import System.Win32.WindowsString.File ( failIfFalseWithRetry_ ) +import System.Win32.WindowsString.String ( withTString ) +import System.Win32.WindowsString.Types ( nullPtr ) +import System.OsPath.Windows + +#include "windows_cconv.h" + +-- | NOTE: createHardLink is /flipped arguments/ to provide compatibility for Unix. +-- +-- If you want to create hard link by Windows way, use 'createHardLink'' instead. +createHardLink :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Hard link name + -> IO () +createHardLink = flip createHardLink' + +createHardLink' :: WindowsPath -- ^ Hard link name + -> WindowsPath -- ^ Target file path + -> IO () +createHardLink' link target = + withTString target $ \c_target -> + withTString link $ \c_link -> + failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $ + c_CreateHardLink c_link c_target nullPtr diff --git a/System/Win32/WindowsString/Info.hsc b/System/Win32/WindowsString/Info.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Info.hsc @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Info +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Info + ( module System.Win32.WindowsString.Info + , module System.Win32.Info + ) where + +import System.Win32.Info.Internal +import System.Win32.Info hiding ( + getSystemDirectory + , getWindowsDirectory + , getCurrentDirectory + , getTemporaryDirectory + , getFullPathName + , getLongPathName + , getShortPathName + , searchPath + , getUserName + ) +import Control.Exception (catch) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Utils (with, maybeWith) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (nullPtr) +import Foreign.Storable (Storable(..)) +import System.IO.Error (isDoesNotExistError) +import System.Win32.WindowsString.Types (failIfFalse_, peekTStringLen, withTString, try) +import System.OsPath.Windows + +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif + +##include "windows_cconv.h" + +#include +#include "alignment.h" + +---------------------------------------------------------------- +-- Standard Directories +---------------------------------------------------------------- + +getSystemDirectory :: IO WindowsString +getSystemDirectory = try "GetSystemDirectory" c_getSystemDirectory 512 + +getWindowsDirectory :: IO WindowsString +getWindowsDirectory = try "GetWindowsDirectory" c_getWindowsDirectory 512 + +getCurrentDirectory :: IO WindowsString +getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512 + +getTemporaryDirectory :: IO WindowsString +getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 + +getFullPathName :: WindowsPath -> IO WindowsPath +getFullPathName name = do + withTString name $ \ c_name -> + try "getFullPathName" + (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512 + +getLongPathName :: WindowsPath -> IO WindowsPath +getLongPathName name = do + withTString name $ \ c_name -> + try "getLongPathName" + (c_GetLongPathName c_name) 512 + +getShortPathName :: WindowsPath -> IO WindowsPath +getShortPathName name = do + withTString name $ \ c_name -> + try "getShortPathName" + (c_GetShortPathName c_name) 512 + +searchPath :: Maybe WindowsString -> WindowsPath -> Maybe WindowsString -> IO (Maybe WindowsPath) +searchPath path filename ext = + maybe ($ nullPtr) withTString path $ \p_path -> + withTString filename $ \p_filename -> + maybeWith withTString ext $ \p_ext -> + alloca $ \ppFilePart -> (do + s <- try "searchPath" (\buf len -> c_SearchPath p_path p_filename p_ext + len buf ppFilePart) 512 + return (Just s)) + `catch` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +---------------------------------------------------------------- +-- User name +---------------------------------------------------------------- + +-- %fun GetUserName :: IO String + +getUserName :: IO WindowsString +getUserName = + allocaArray 512 $ \ c_str -> + with 512 $ \ c_len -> do + failIfFalse_ "GetUserName" $ c_GetUserName c_str c_len + len <- peek c_len + peekTStringLen (c_str, fromIntegral len - 1) + +---------------------------------------------------------------- +-- End +---------------------------------------------------------------- diff --git a/System/Win32/WindowsString/Path.hsc b/System/Win32/WindowsString/Path.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Path.hsc @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Path +-- Copyright : (c) Tamar Christina, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Tamar Christina +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Path ( + filepathRelativePathTo + , pathRelativePathTo + ) where + +import System.Win32.Path.Internal +import System.Win32.WindowsString.Types +import System.Win32.WindowsString.File +import System.OsPath.Windows + +import Foreign + +##include "windows_cconv.h" + +#include + +filepathRelativePathTo :: WindowsPath -> WindowsPath -> IO WindowsPath +filepathRelativePathTo from to = + withTString from $ \p_from -> + withTString to $ \p_to -> + allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do + _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from fILE_ATTRIBUTE_DIRECTORY + p_to fILE_ATTRIBUTE_NORMAL) + path <- peekTString p_AbsPath + _ <- localFree p_AbsPath + return path + +pathRelativePathTo :: WindowsPath -> FileAttributeOrFlag -> WindowsPath -> FileAttributeOrFlag -> IO WindowsPath +pathRelativePathTo from from_attr to to_attr = + withTString from $ \p_from -> + withTString to $ \p_to -> + allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do + _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from from_attr + p_to to_attr) + path <- peekTString p_AbsPath + _ <- localFree p_AbsPath + return path + diff --git a/System/Win32/WindowsString/Shell.hsc b/System/Win32/WindowsString/Shell.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Shell.hsc @@ -0,0 +1,59 @@ +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.Shell +-- Copyright : (c) The University of Glasgow 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Win32 stuff from shell32.dll +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Shell ( + sHGetFolderPath, + CSIDL, + cSIDL_PROFILE, + cSIDL_APPDATA, + cSIDL_WINDOWS, + cSIDL_PERSONAL, + cSIDL_LOCAL_APPDATA, + cSIDL_DESKTOPDIRECTORY, + cSIDL_PROGRAM_FILES, + SHGetFolderPathFlags, + sHGFP_TYPE_CURRENT, + sHGFP_TYPE_DEFAULT + ) where + +import System.OsString.Windows (WindowsString) +import System.Win32.Shell.Internal +import System.Win32.Shell hiding (sHGetFolderPath) +import System.Win32.WindowsString.Types +import Graphics.Win32.GDI.Types (HWND) + +import Foreign +import Control.Monad + +##include "windows_cconv.h" + +-- for SHGetFolderPath stuff +#define _WIN32_IE 0x500 +#include +#include + +---------------------------------------------------------------- +-- SHGetFolderPath +-- +-- XXX: this is deprecated in Vista and later +---------------------------------------------------------------- + + +sHGetFolderPath :: HWND -> CSIDL -> HANDLE -> SHGetFolderPathFlags -> IO WindowsString +sHGetFolderPath hwnd csidl hdl flags = + allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pstr -> do + r <- c_SHGetFolderPath hwnd csidl hdl flags pstr + when (r < 0) $ raiseUnsupported "sHGetFolderPath" + peekTString pstr diff --git a/System/Win32/WindowsString/String.hs b/System/Win32/WindowsString/String.hs new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/String.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE PackageImports #-} + +{- | + Module : System.Win32.String + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Utilities for primitive marshalling of Windows' C strings. +-} +module System.Win32.WindowsString.String + ( LPSTR, LPCSTR, LPWSTR, LPCWSTR + , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_ + , withTString, withTStringLen, peekTString, peekTStringLen + , newTString + , withTStringBuffer, withTStringBufferLen + ) where + +import System.Win32.String hiding + ( withTStringBuffer + , withTStringBufferLen + , withTString + , withTStringLen + , peekTString + , peekTStringLen + , newTString + ) +import System.Win32.WindowsString.Types +import System.OsString.Internal.Types +#if MIN_VERSION_filepath(1,5,0) +import qualified "os-string" System.OsString.Data.ByteString.Short as SBS +#else +import qualified "filepath" System.OsPath.Data.ByteString.Short as SBS +#endif +import Data.Word (Word8) + +-- | Marshal a dummy Haskell string into a NUL terminated C wide string +-- using temporary storage. +-- +-- * the Haskell string is created by length parameter. And the Haskell +-- string contains /only/ NUL characters. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withTStringBuffer :: Int -> (LPTSTR -> IO a) -> IO a +withTStringBuffer maxLength + = let dummyBuffer = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul + in withTString dummyBuffer + +-- | Marshal a dummy Haskell string into a C wide string (i.e. wide +-- character array) in temporary storage, with explicit length +-- information. +-- +-- * the Haskell string is created by length parameter. And the Haskell +-- string contains /only/ NUL characters. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withTStringBufferLen :: Int -> ((LPTSTR, Int) -> IO a) -> IO a +withTStringBufferLen maxLength + = let dummyBuffer = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul + in withTStringLen dummyBuffer + + +_nul :: Word8 +_nul = 0x00 diff --git a/System/Win32/WindowsString/SymbolicLink.hsc b/System/Win32/WindowsString/SymbolicLink.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/SymbolicLink.hsc @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.SymbolicLink + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling symbolic link using Win32 API. [Vista of later and desktop app only] + + Note: When using the createSymbolicLink* functions without the + SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE flag, you should worry about UAC + (User Account Control) when use this module's function in your application: + + * require to use 'Run As Administrator' to run your application. + + * or modify your application's manifect file to add + \. + + Starting from Windows 10 version 1703 (Creators Update), after enabling + Developer Mode, users can create symbolic links without requiring the + Administrator privilege in the current process. Supply a 'True' flag in + addition to the target and link name to enable this behavior. +-} +module System.Win32.WindowsString.SymbolicLink + ( SymbolicLinkFlags + , sYMBOLIC_LINK_FLAG_FILE + , sYMBOLIC_LINK_FLAG_DIRECTORY + , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + , createSymbolicLink + , createSymbolicLink' + , createSymbolicLinkFile + , createSymbolicLinkDirectory + ) where + +import System.Win32.SymbolicLink.Internal +import Data.Bits ((.|.)) +import System.Win32.WindowsString.Types +import System.Win32.WindowsString.File ( failIfFalseWithRetry_ ) +import System.OsPath.Windows +import Unsafe.Coerce (unsafeCoerce) + +##include "windows_cconv.h" + +-- | createSymbolicLink* functions don't check that file is exist or not. +-- +-- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix, +-- except 'createSymbolicLink''. +-- +-- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead. +createSymbolicLink :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Symbolic link name + -> SymbolicLinkFlags -> IO () +createSymbolicLink = flip createSymbolicLink' + +createSymbolicLinkFile :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Symbolic link name + -> Bool -- ^ Create the symbolic link with the unprivileged mode + -> IO () +createSymbolicLinkFile target link unprivileged = + createSymbolicLink' + link + target + ( if unprivileged + then sYMBOLIC_LINK_FLAG_FILE .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + else sYMBOLIC_LINK_FLAG_FILE + ) + +createSymbolicLinkDirectory :: WindowsPath -- ^ Target file path + -> WindowsPath -- ^ Symbolic link name + -> Bool -- ^ Create the symbolic link with the unprivileged mode + -> IO () +createSymbolicLinkDirectory target link unprivileged = + createSymbolicLink' + link + target + ( if unprivileged + then + sYMBOLIC_LINK_FLAG_DIRECTORY + .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE + else sYMBOLIC_LINK_FLAG_DIRECTORY + ) + +createSymbolicLink' :: WindowsPath -- ^ Symbolic link name + -> WindowsPath -- ^ Target file path + -> SymbolicLinkFlags -> IO () +createSymbolicLink' link target flag = do + withTString link $ \c_link -> + withTString target $ \c_target -> + failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $ + c_CreateSymbolicLink c_link c_target (unsafeCoerce flag) + diff --git a/System/Win32/WindowsString/Time.hsc b/System/Win32/WindowsString/Time.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Time.hsc @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Time +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Time API. +-- +----------------------------------------------------------------------------- +module System.Win32.WindowsString.Time + ( module System.Win32.WindowsString.Time + , module System.Win32.Time + ) where + +import System.Win32.Time.Internal +import System.Win32.Time hiding (getTimeFormatEx, getTimeFormat) + +import System.Win32.WindowsString.String ( peekTStringLen, withTString ) +import System.Win32.WindowsString.Types ( LCID, failIf ) +import System.Win32.Utils ( trySized ) + +import Foreign ( Storable(sizeOf) + , nullPtr, castPtr + , with, allocaBytes ) +import Foreign.C ( CWchar(..) + , withCWString ) +import Foreign.Marshal.Utils (maybeWith) +import System.OsString.Windows + +##include "windows_cconv.h" +#include +#include "alignment.h" +#include "winnls_compat.h" + + +getTimeFormatEx :: Maybe WindowsString + -> GetTimeFormatFlags + -> Maybe SYSTEMTIME + -> Maybe WindowsString + -> IO String +getTimeFormatEx locale flags st fmt = + maybeWith withTString locale $ \c_locale -> + maybeWith with st $ \c_st -> + maybeWith withTString fmt $ \c_fmt -> do + let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt + trySized "GetTimeFormatEx" c_func + +getTimeFormat :: LCID -> GetTimeFormatFlags -> Maybe SYSTEMTIME -> Maybe String -> IO WindowsString +getTimeFormat locale flags st fmt = + maybeWith with st $ \c_st -> + maybeWith withCWString fmt $ \c_fmt -> do + size <- c_GetTimeFormat locale flags c_st c_fmt nullPtr 0 + allocaBytes ((fromIntegral size) * (sizeOf (undefined::CWchar))) $ \out -> do + size' <- failIf (==0) "getTimeFormat: GetTimeFormat" $ + c_GetTimeFormat locale flags c_st c_fmt (castPtr out) size + peekTStringLen (out,fromIntegral size') diff --git a/System/Win32/WindowsString/Types.hsc b/System/Win32/WindowsString/Types.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Types.hsc @@ -0,0 +1,214 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Types +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.WindowsString.Types + ( module System.Win32.WindowsString.Types + , module System.Win32.Types + ) where + +import System.Win32.Types hiding ( + withTString + , withTStringLen + , peekTString + , peekTStringLen + , newTString + , failIf + , failIf_ + , failIfNeg + , failIfNull + , failIfZero + , failIfFalse_ + , failUnlessSuccess + , failUnlessSuccessOr + , errorWin + , failWith + , try + , withFilePath + , useAsCWStringSafe + ) + +import Foreign.C.Types (CUIntPtr(..)) +import Foreign.C.String (CWString) +import qualified System.OsPath.Windows as WS +import System.OsPath.Windows (WindowsPath) +import System.OsString.Windows (decodeWith, encodeWith) +import System.OsString.Internal.Types +#if MIN_VERSION_filepath(1,5,0) +import "os-string" System.OsString.Encoding.Internal (decodeWithBaseWindows) +import qualified "os-string" System.OsString.Data.ByteString.Short.Word16 as SBS +import "os-string" System.OsString.Data.ByteString.Short.Word16 ( +#else +import "filepath" System.OsPath.Encoding.Internal (decodeWithBaseWindows) +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as SBS +import "filepath" System.OsPath.Data.ByteString.Short.Word16 ( +#endif + packCWString, + packCWStringLen, + useAsCWString, + useAsCWStringLen, + newCWString + ) +import Data.Bifunctor (first) +import Data.Char (isSpace) +import Numeric (showHex) +import qualified System.IO as IO () +import System.IO.Error (ioeSetErrorString) +import Foreign (allocaArray) +import Foreign.Ptr ( Ptr ) +import Foreign.C.Error ( errnoToIOError ) +import Control.Exception ( throwIO ) +import qualified Control.Exception as EX +import GHC.Ptr (castPtr) +import GHC.IO.Exception + +#if !MIN_VERSION_base(4,8,0) +import Data.Word (Word) +#endif + +import GHC.IO.Encoding.UTF16 ( mkUTF16le ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) + +#include +#include +#include +##include "windows_cconv.h" + + +---------------------------------------------------------------- +-- Chars and strings +---------------------------------------------------------------- + +withTString :: WindowsString -> (LPTSTR -> IO a) -> IO a +withFilePath :: WindowsPath -> (LPTSTR -> IO a) -> IO a +withTStringLen :: WindowsString -> ((LPTSTR, Int) -> IO a) -> IO a +peekTString :: LPCTSTR -> IO WindowsString +peekTStringLen :: (LPCTSTR, Int) -> IO WindowsString +newTString :: WindowsString -> IO LPCTSTR + +-- UTF-16 version: +-- the casts are from 'Ptr Word16' to 'Ptr CWchar', which is safe +withTString (WindowsString str) f = useAsCWString str (\ptr -> f (castPtr ptr)) +withFilePath path = useAsCWStringSafe path +withTStringLen (WindowsString str) f = useAsCWStringLen str (\(ptr, len) -> f (castPtr ptr, len)) +peekTString = fmap WindowsString . packCWString . castPtr +peekTStringLen = fmap WindowsString . packCWStringLen . first castPtr +newTString (WindowsString str) = fmap castPtr $ newCWString str + +foreign import ccall unsafe "wchar.h wcslen" c_wcslen + :: CWString -> IO SIZE_T + +-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are +-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660 +useAsCWStringSafe :: WindowsPath -> (CWString -> IO a) -> IO a +useAsCWStringSafe wp@(WS path) f = useAsCWString path $ \(castPtr -> ptr) -> do + let len = SBS.numWord16 path + clen <- c_wcslen ptr + if clen == fromIntegral len + then f ptr + else do + path' <- either (const (_toStr wp)) id <$> (EX.try @IOException) (decodeWithBaseWindows path) + ioError (err path') + where + _toStr = fmap WS.toChar . WS.unpack + err path' = + IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "useAsCWStringSafe" + , ioe_description = "Windows filepaths must not contain internal NUL codepoints." + , ioe_errno = Nothing + , ioe_filename = Just path' + } + +---------------------------------------------------------------- +-- Errors +---------------------------------------------------------------- + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +failIf_ :: (a -> Bool) -> String -> IO a -> IO () +failIf_ p wh act = do + v <- act + if p v then errorWin wh else return () + +failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a +failIfNeg = failIf (< 0) + +failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +failIfNull = failIf (== nullPtr) + +failIfZero :: (Eq a, Num a) => String -> IO a -> IO a +failIfZero = failIf (== 0) + +failIfFalse_ :: String -> IO Bool -> IO () +failIfFalse_ = failIf_ not + +failUnlessSuccess :: String -> IO ErrCode -> IO () +failUnlessSuccess fn_name act = do + r <- act + if r == 0 then return () else failWith fn_name r + +failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool +failUnlessSuccessOr val fn_name act = do + r <- act + if r == 0 then return False + else if r == val then return True + else failWith fn_name r + + +errorWin :: String -> IO a +errorWin fn_name = do + err_code <- getLastError + failWith fn_name err_code + +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = do + c_msg <- getErrorMessage err_code + + msg <- either (fail . show) pure . decodeWith (mkUTF16le TransliterateCodingFailure) =<< if c_msg == nullPtr + then either (fail . show) pure . encodeWith (mkUTF16le TransliterateCodingFailure) $ "Error 0x" ++ Numeric.showHex err_code "" + else do msg <- peekTString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + -- turn GetLastError() into errno, which errnoToIOError knows how to convert + -- to an IOException we can throw. + errno <- c_maperrno_func err_code + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + throwIO ioerror + + +-- Support for API calls that are passed a fixed-size buffer and tell +-- you via the return value if the buffer was too small. In that +-- case, we double the buffer size and try again. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +try loc f n = do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + r <- failIfZero loc $ f lptstr n + if (r > n) then return (Left r) else do + str <- peekTStringLen (lptstr, fromIntegral r) + return (Right str) + case e of + Left n' -> try loc f n' + Right str -> return str diff --git a/System/Win32/WindowsString/Utils.hs b/System/Win32/WindowsString/Utils.hs new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Utils.hs @@ -0,0 +1,63 @@ +{- | + Module : System.Win32.Utils + Copyright : 2009 Balazs Komuves, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Utilities for calling Win32 API +-} +module System.Win32.WindowsString.Utils + ( module System.Win32.WindowsString.Utils + , module System.Win32.Utils + ) where + +import Foreign.C.Types ( CInt ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Ptr ( nullPtr ) + +import System.Win32.Utils hiding + ( try + , tryWithoutNull + , trySized + ) +import System.Win32.WindowsString.String ( LPTSTR, peekTString, peekTStringLen + , withTStringBufferLen ) +import System.Win32.WindowsString.Types ( UINT + , failIfZero + ) +import qualified System.Win32.WindowsString.Types ( try ) +import System.OsString.Windows + + +-- | Support for API calls that are passed a fixed-size buffer and tell +-- you via the return value if the buffer was too small. In that +-- case, we extend the buffer size and try again. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +try = System.Win32.WindowsString.Types.try +{-# INLINE try #-} + +tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +tryWithoutNull loc f n = do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + r <- failIfZero loc $ f lptstr n + if r > n then return (Left r) else do + str <- peekTString lptstr + return (Right str) + case e of + Left r' -> tryWithoutNull loc f r' + Right str -> return str + +-- | Support for API calls that return the required size, in characters +-- including a null character, of the buffer when passed a buffer size of zero. +trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO WindowsString +trySized wh f = do + c_len <- failIfZero wh $ f nullPtr 0 + let len = fromIntegral c_len + withTStringBufferLen len $ \(buf', len') -> do + let c_len' = fromIntegral len' + c_len'' <- failIfZero wh $ f buf' c_len' + let len'' = fromIntegral c_len'' + peekTStringLen (buf', len'' - 1) -- Drop final null character diff --git a/System/Win32/Word.hs b/System/Win32/Word.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Word.hs @@ -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 diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -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 +cabal-version: 2.0 +name: Win32 +version: 2.14.2.2 +license: BSD3 +license-file: LICENSE +author: Alastair Reid, shelarcy, Tamar Christina +copyright: Alastair Reid, 1999-2003; shelarcy, 2012-2013; Tamar Christina, 2016-2020 +maintainer: Haskell Libraries bug-reports: https://github.com/haskell/win32/issues homepage: https://github.com/haskell/win32 -category: System, Graphics -synopsis: A binding to 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 diff --git a/cbits/alphablend.c b/cbits/alphablend.c new file mode 100644 --- /dev/null +++ b/cbits/alphablend.c @@ -0,0 +1,15 @@ +#include + +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); +} diff --git a/cbits/dumpBMP.c b/cbits/dumpBMP.c --- a/cbits/dumpBMP.c +++ b/cbits/dumpBMP.c @@ -64,7 +64,7 @@ // if BitCount != 0, color table will be retrieved // bmi.bmiHeader.biSize = 0x28; // GDI need this to work - bmi.bmiHeader.biBitCount = 0; // dont get the color table + bmi.bmiHeader.biBitCount = 0; // don't get the color table if ((GetDIBits(hDC, hBmp, 0, 0, (LPSTR)NULL, &bmi, DIB_RGB_COLORS)) == 0) { fprintf(stderr, "GetDIBits failed!"); return; @@ -81,7 +81,7 @@ } // - // Note: 24 bits per pixel has no color table. So, we dont have to + // Note: 24 bits per pixel has no color table. So, we don't have to // allocate memory for retrieving that. Otherwise, we do. // pbmi = &bmi; // assume no color table @@ -113,7 +113,7 @@ goto ErrExit1; } // - // Now that weve a bigger chunk of memory, lets copy the Bitmap + // Now that we've a bigger chunk of memory, lets copy the Bitmap // info header data over // pjTmp = (PBYTE)pbmi; diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 diff --git a/include/alignment.h b/include/alignment.h new file mode 100644 --- /dev/null +++ b/include/alignment.h @@ -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 diff --git a/include/alphablend.h b/include/alphablend.h new file mode 100644 --- /dev/null +++ b/include/alphablend.h @@ -0,0 +1,10 @@ +#ifndef _ALPHABLEND_H +#define _ALPHABLEND_H + +#include + +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 */ diff --git a/include/namedpipeapi_compat.h b/include/namedpipeapi_compat.h new file mode 100644 --- /dev/null +++ b/include/namedpipeapi_compat.h @@ -0,0 +1,16 @@ +/* The version of wincon.h provided by the version of MSYS2 included with x86 + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef NAMEDPIPEAPI_COMPAT_H +#define NAMEDPIPEAPI_COMPAT_H + +#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 +# +#else + +#define PIPE_ACCEPT_REMOTE_CLIENTS 0x0 +#define PIPE_REJECT_REMOTE_CLIENTS 0x8 +#endif /* GHC version check */ +#endif /* NAMEDPIPEAPI_COMPAT_H */ diff --git a/include/tlhelp32_compat.h b/include/tlhelp32_compat.h new file mode 100644 --- /dev/null +++ b/include/tlhelp32_compat.h @@ -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 + +// CreateToolhelp32Snapshot Flags +// https://docs.microsoft.com/en-us/windows/win32/api/tlhelp32/nf-tlhelp32-createtoolhelp32snapshot + +#define TH32CS_INHERIT 0x80000000 + +#define TH32CS_SNAPHEAPLIST 0x00000001 +#define TH32CS_SNAPPROCESS 0x00000002 +#define TH32CS_SNAPTHREAD 0x00000004 +#define TH32CS_SNAPMODULE 0x00000008 +#define TH32CS_SNAPMODULE32 0x00000010 + +#define TH32CS_SNAPALL (TH32CS_SNAPHEAPLIST|TH32CS_SNAPPROCESS|TH32CS_SNAPTHREAD|TH32CS_SNAPMODULE) + +#endif +#endif /* TLHELP32_COMPAT_H */ diff --git a/include/wincon_compat.h b/include/wincon_compat.h new file mode 100644 --- /dev/null +++ b/include/wincon_compat.h @@ -0,0 +1,26 @@ +/* The version of wincon.h provided by the version of MSYS2 included with x86 + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef WINCON_COMPAT_H +#define WINCON_COMPAT_H + +#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 +# +#else + +typedef struct _CONSOLE_SCREEN_BUFFER_INFOEX { + ULONG cbSize; + COORD dwSize; + COORD dwCursorPosition; + WORD wAttributes; + SMALL_RECT srWindow; + COORD dwMaximumWindowSize; + WORD wPopupAttributes; + WINBOOL bFullscreenSupported; + COLORREF ColorTable[16]; +} CONSOLE_SCREEN_BUFFER_INFOEX, *PCONSOLE_SCREEN_BUFFER_INFOEX; + +#endif /* GHC version check */ +#endif /* WINCON_COMPAT_H */ diff --git a/include/windows_cconv.h b/include/windows_cconv.h --- a/include/windows_cconv.h +++ b/include/windows_cconv.h @@ -3,7 +3,7 @@ #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) +#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch diff --git a/include/winnls_compat.h b/include/winnls_compat.h new file mode 100644 --- /dev/null +++ b/include/winnls_compat.h @@ -0,0 +1,105 @@ +/* The version of winnls.h provided by the version of MSYS2 included with + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef WINNLS_COMPAT_H +#define WINNLS_COMPAT_H + +#if __GLASGOW_HASKELL__ < 710 +// Locale information constants +#define LOCALE_IGEOID 0x0000005b +#define LOCALE_SCONSOLEFALLBACKNAME 0x0000006e +#define LOCALE_SDURATION 0x0000005d +#define LOCALE_SENGLISHCOUNTRYNAME 0x00001002 +#define LOCALE_SENGLISHLANGUAGENAME 0x00001001 +#define LOCALE_SISO3166CTRYNAME2 0x00000068 +#define LOCALE_SISO639LANGNAME2 0x00000067 +#define LOCALE_SKEYBOARDSTOINSTALL 0x0000005e +#define LOCALE_SNAME 0x0000005c +#define LOCALE_SNAN 0x00000069 +#define LOCALE_SNATIVECOUNTRYNAME 0x00000008 +#define LOCALE_SNEGINFINITY 0x0000006b +#define LOCALE_SPARENT 0x0000006d +#define LOCALE_SPOSINFINITY 0x0000006a +#define LOCALE_SSCRIPTS 0x0000006c +#define LOCALE_SSHORTESTDAYNAME1 0x00000060 +#define LOCALE_SSHORTESTDAYNAME2 0x00000061 +#define LOCALE_SSHORTESTDAYNAME3 0x00000062 +#define LOCALE_SSHORTESTDAYNAME4 0x00000063 +#define LOCALE_SSHORTESTDAYNAME5 0x00000064 +#define LOCALE_SSHORTESTDAYNAME6 0x00000065 +#define LOCALE_SSHORTESTDAYNAME7 0x00000066 +// Locale map flag constants +#define LINGUISTIC_IGNORECASE 0x00000010 +#define LINGUISTIC_IGNOREDIACRITIC 0x00000020 +#define NORM_LINGUISTIC_CASING 0x08000000 +// Locale enumeration flag constants +#define LOCALE_ALL 0 +#define LOCALE_ALTERNATE_SORTS 0x00000004 +#define LOCALE_REPLACEMENT 0x00000008 +#define LOCALE_SUPPLEMENTAL 0x00000002 +#define LOCALE_WINDOWS 0x00000001 +// Other +WINBASEAPI WINBOOL WINAPI IsValidLocaleName (LPCWSTR lpLocaleName); +#endif + +#if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH) +// Locale information constants +#define LOCALE_IDEFAULTMACCODEPAGE 0x00001011 +// Other +typedef struct _nlsversioninfoex { + DWORD dwNLSVersionInfoSize; + DWORD dwNLSVersion; + DWORD dwDefinedVersion; + DWORD dwEffectiveId; + GUID guidCustomVersion; +} NLSVERSIONINFOEX, *LPNLSVERSIONINFOEX; + +WINBASEAPI int WINAPI GetLocaleInfoEx( + LPCWSTR lpLocaleName, + LCTYPE LCType, + LPWSTR lpLCData, + int cchData +); + +WINBASEAPI WINBOOL WINAPI GetNLSVersionEx( + NLS_FUNCTION function, + LPCWSTR lpLocaleName, + LPNLSVERSIONINFOEX lpVersionInformation +); + +WINBASEAPI int WINAPI LCMapStringEx( + LPCWSTR lpLocaleName, + DWORD dwMapFlags, + LPCWSTR lpSrcStr, + int cchSrc, + LPWSTR lpDestStr, + int cchDest, + LPNLSVERSIONINFO lpVersionInformation, + LPVOID lpReserved, + LPARAM lParam +); + + +WINBASEAPI int WINAPI GetTimeFormatEx( + LPCWSTR lpLocaleName, + DWORD dwFlags, + const SYSTEMTIME *lpTime, + LPCWSTR lpFormat, + LPWSTR lpTimeStr, + int cchTime +); + +WINBASEAPI int WINAPI GetSystemDefaultLocaleName( + LPWSTR lpLocaleName, + int cchLocaleName +); + +WINBASEAPI int WINAPI GetUserDefaultLocaleName( + LPWSTR lpLocaleName, + int cchLocaleName +); +#endif + +#endif /* #ifndef WINNLS_COMPAT_H */ diff --git a/include/winnt_compat.h b/include/winnt_compat.h new file mode 100644 --- /dev/null +++ b/include/winnt_compat.h @@ -0,0 +1,13 @@ +/* The version of winnt.h provided by the version of MSYS2 included with + * versions of GHC before GHC 7.10 excludes certain components introduced with + * Windows Vista. + */ + +#ifndef WINNT_COMPAT_H +#define WINNT_COMPAT_H + +#if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH) +#define LOCALE_NAME_MAX_LENGTH 85 +#endif + +#endif /* #ifndef WINNT_COMPAT_H */ diff --git a/include/winreg_compat.h b/include/winreg_compat.h new file mode 100644 --- /dev/null +++ b/include/winreg_compat.h @@ -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 */ diff --git a/include/winternl_compat.h b/include/winternl_compat.h new file mode 100644 --- /dev/null +++ b/include/winternl_compat.h @@ -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 +#else +// Some declarations from winternl.h that we need in Win32 +# include + +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 */ diff --git a/include/winuser_compat.h b/include/winuser_compat.h new file mode 100644 --- /dev/null +++ b/include/winuser_compat.h @@ -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 + +#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 */