diff --git a/System/Win32/DLL.hsc b/System/Win32/DLL.hsc --- a/System/Win32/DLL.hsc +++ b/System/Win32/DLL.hsc @@ -31,76 +31,49 @@ , lOAD_WITH_ALTERED_SEARCH_PATH ) where +import System.Win32.DLL.Internal import System.Win32.Types import Foreign import Foreign.C import Data.Maybe (fromMaybe) -##include "windows_cconv.h" - -#include - disableThreadLibraryCalls :: HMODULE -> IO () disableThreadLibraryCalls hmod = failIfFalse_ "DisableThreadLibraryCalls" $ c_DisableThreadLibraryCalls hmod -foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls" - c_DisableThreadLibraryCalls :: HMODULE -> IO Bool freeLibrary :: HMODULE -> IO () freeLibrary hmod = failIfFalse_ "FreeLibrary" $ c_FreeLibrary hmod -foreign import WINDOWS_CCONV unsafe "windows.h FreeLibrary" - c_FreeLibrary :: HMODULE -> IO Bool 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 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 name h flags = withTString name $ \ c_name -> failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags -foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryExW" - c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE setDllDirectory :: Maybe String -> IO () setDllDirectory name = maybeWith withTString name $ \ c_name -> failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" name]) $ c_SetDllDirectory c_name -foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW" - c_SetDllDirectory :: LPTSTR -> IO BOOL diff --git a/System/Win32/DLL/Internal.hsc b/System/Win32/DLL/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DLL/Internal.hsc @@ -0,0 +1,57 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.DLL.Internal +-- Copyright : (c) Alastair Reid, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.DLL.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +#include + +foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls" + c_DisableThreadLibraryCalls :: HMODULE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h FreeLibrary" + c_FreeLibrary :: HMODULE -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleHandleW" + c_GetModuleHandle :: LPCTSTR -> IO HMODULE + +foreign import WINDOWS_CCONV unsafe "windows.h GetProcAddress" + c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr + +foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryW" + c_LoadLibrary :: LPCTSTR -> IO HINSTANCE + +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 HINSTANCE + +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 @@ -70,31 +70,20 @@ , 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 @@ -416,48 +405,3 @@ outputDebugString :: String -> IO () outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s --------------------------------------------------------------------------- --- Raw imports - -foreign import WINDOWS_CCONV "windows.h SuspendThread" - c_SuspendThread :: THANDLE -> IO DWORD - -foreign import WINDOWS_CCONV "windows.h ResumeThread" - c_ResumeThread :: THANDLE -> IO DWORD - -foreign import WINDOWS_CCONV "windows.h WaitForDebugEvent" - c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h ContinueDebugEvent" - c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h DebugActiveProcess" - c_DebugActiveProcess :: DWORD -> IO Bool - --- Windows XP --- foreign import WINDOWS_CCONV "windows.h DebugActiveProcessStop" --- c_DebugActiveProcessStop :: DWORD -> IO Bool - -foreign import WINDOWS_CCONV "windows.h ReadProcessMemory" c_ReadProcessMemory :: - PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h WriteProcessMemory" c_WriteProcessMemory :: - PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h GetThreadContext" - c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL - -foreign import WINDOWS_CCONV "windows.h SetThreadContext" - c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL - ---foreign import WINDOWS_CCONV "windows.h GetThreadId" --- c_GetThreadId :: THANDLE -> IO TID - -foreign import WINDOWS_CCONV "windows.h OutputDebugStringW" - c_OutputDebugString :: LPTSTR -> IO () - -foreign import WINDOWS_CCONV "windows.h IsDebuggerPresent" - isDebuggerPresent :: IO BOOL - -foreign import WINDOWS_CCONV "windows.h DebugBreak" - debugBreak :: IO () diff --git a/System/Win32/DebugApi/Internal.hsc b/System/Win32/DebugApi/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DebugApi/Internal.hsc @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.WindowsString.DebugApi.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for using Windows DebugApi. +-- +----------------------------------------------------------------------------- + +module System.Win32.DebugApi.Internal where + +import Data.Word ( Word8, Word32 ) +import Foreign ( Ptr ) +import System.Win32.Types ( BOOL, DWORD, HANDLE, LPTSTR ) + +##include "windows_cconv.h" +#include "windows.h" + +type PID = DWORD +type TID = DWORD +type DebugEventId = (PID, TID) +type ForeignAddress = Word32 + +type PHANDLE = Ptr () +type THANDLE = Ptr () + +type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress) -- handle to thread, thread local, thread start +type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress) +type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address + +-------------------------------------------------------------------------- +-- Raw imports + +foreign import WINDOWS_CCONV "windows.h SuspendThread" + c_SuspendThread :: THANDLE -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h ResumeThread" + c_ResumeThread :: THANDLE -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h WaitForDebugEvent" + c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h ContinueDebugEvent" + c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h DebugActiveProcess" + c_DebugActiveProcess :: DWORD -> IO Bool + +-- Windows XP +-- foreign import WINDOWS_CCONV "windows.h DebugActiveProcessStop" +-- c_DebugActiveProcessStop :: DWORD -> IO Bool + +foreign import WINDOWS_CCONV "windows.h ReadProcessMemory" c_ReadProcessMemory :: + PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h WriteProcessMemory" c_WriteProcessMemory :: + PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetThreadContext" + c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetThreadContext" + c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL + +--foreign import WINDOWS_CCONV "windows.h GetThreadId" +-- c_GetThreadId :: THANDLE -> IO TID + +foreign import WINDOWS_CCONV "windows.h OutputDebugStringW" + c_OutputDebugString :: LPTSTR -> IO () + +foreign import WINDOWS_CCONV "windows.h IsDebuggerPresent" + isDebuggerPresent :: IO BOOL + +foreign import WINDOWS_CCONV "windows.h DebugBreak" + debugBreak :: IO () diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -238,8 +238,8 @@ , unlockFile ) where +import System.Win32.File.Internal import System.Win32.Types -import System.Win32.Time import Foreign hiding (void) import Control.Monad @@ -251,313 +251,6 @@ #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 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 ---------------------------------------------------------------- @@ -596,8 +289,6 @@ withTString 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 = @@ -605,8 +296,6 @@ withTString 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 = @@ -614,8 +303,6 @@ withTString dest $ \ c_dest -> failIfFalseWithRetry_ (unwords ["MoveFile",show src,show dest]) $ c_MoveFile c_src c_dest -foreign import WINDOWS_CCONV unsafe "windows.h MoveFileW" - c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool moveFileEx :: String -> Maybe String -> MoveFileFlag -> IO () moveFileEx src dest flags = @@ -623,24 +310,18 @@ maybeWith withTString 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 -> 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 -> 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 = @@ -648,16 +329,12 @@ withTString 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 -> 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 = @@ -666,8 +343,6 @@ 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 ---------------------------------------------------------------- -- HANDLE operations @@ -678,46 +353,32 @@ withTString 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) -foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" - c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE closeHandle :: HANDLE -> IO () closeHandle h = failIfFalse_ "CloseHandle" $ c_CloseHandle h -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 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 -> 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 -> 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 @@ -725,51 +386,16 @@ 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 ---------------------------------------------------------------- -- Read/write files ---------------------------------------------------------------- --- No support for this yet -data OVERLAPPED - = OVERLAPPED { ovl_internal :: ULONG_PTR - , ovl_internalHigh :: ULONG_PTR - , ovl_offset :: DWORD - , ovl_offsetHigh :: DWORD - , ovl_hEvent :: HANDLE - } deriving (Show) - -instance Storable OVERLAPPED where - sizeOf = const (#size OVERLAPPED) - alignment _ = #alignment OVERLAPPED - poke buf ad = do - (#poke OVERLAPPED, Internal ) buf (ovl_internal ad) - (#poke OVERLAPPED, InternalHigh) buf (ovl_internalHigh ad) - (#poke OVERLAPPED, Offset ) buf (ovl_offset ad) - (#poke OVERLAPPED, OffsetHigh ) buf (ovl_offsetHigh ad) - (#poke OVERLAPPED, hEvent ) buf (ovl_hEvent ad) - - peek buf = do - intnl <- (#peek OVERLAPPED, Internal ) buf - intnl_high <- (#peek OVERLAPPED, InternalHigh) buf - off <- (#peek OVERLAPPED, Offset ) buf - off_high <- (#peek OVERLAPPED, OffsetHigh ) buf - hevnt <- (#peek OVERLAPPED, hEvent ) buf - return $ OVERLAPPED intnl intnl_high off off_high hevnt - -type LPOVERLAPPED = Ptr OVERLAPPED - -type MbLPOVERLAPPED = Maybe LPOVERLAPPED - --Sigh - I give up & prefix win32_ to the next two to avoid -- senseless Prelude name clashes. --sof. @@ -778,24 +404,18 @@ alloca $ \ p_n -> do failIfFalse_ "ReadFile" $ c_ReadFile h buf n p_n (maybePtr mb_over) peek p_n -foreign import WINDOWS_CCONV unsafe "windows.h ReadFile" - c_ReadFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool win32_WriteFile :: HANDLE -> Ptr a -> DWORD -> Maybe LPOVERLAPPED -> IO DWORD win32_WriteFile h buf n mb_over = alloca $ \ p_n -> do failIfFalse_ "WriteFile" $ c_WriteFile h buf n p_n (maybePtr mb_over) peek p_n -foreign import WINDOWS_CCONV unsafe "windows.h WriteFile" - c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool setFilePointerEx :: HANDLE -> LARGE_INTEGER -> FilePtrDirection -> IO LARGE_INTEGER setFilePointerEx h dist dir = alloca $ \p_pos -> do failIfFalse_ "SetFilePointerEx" $ c_SetFilePointerEx h dist p_pos dir peek p_pos -foreign import WINDOWS_CCONV unsafe "windows.h SetFilePointerEx" - c_SetFilePointerEx :: HANDLE -> LARGE_INTEGER -> Ptr LARGE_INTEGER -> FilePtrDirection -> IO Bool ---------------------------------------------------------------- -- File Notifications @@ -809,29 +429,19 @@ withTString 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 -> @@ -845,8 +455,6 @@ 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 @@ -859,13 +467,9 @@ if err_code == (# const ERROR_NO_MORE_FILES ) then return False else failWith "findNextFile" err_code -foreign import WINDOWS_CCONV unsafe "windows.h FindNextFileW" - c_FindNextFile :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL findClose :: HANDLE -> IO () findClose h = failIfFalse_ "findClose" $ c_FindClose h -foreign import WINDOWS_CCONV unsafe "windows.h FindClose" - c_FindClose :: HANDLE -> IO BOOL ---------------------------------------------------------------- -- DOS Device flags @@ -876,33 +480,12 @@ maybeWith withTString path $ \ c_path -> withTString 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 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 - ----------------------------------------------------------------- - 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 @@ -920,16 +503,12 @@ nfree <- peek p_nfree nclusters <- peek p_nclusters return (sectors, bytes, nfree, nclusters) -foreign import WINDOWS_CCONV unsafe "windows.h GetDiskFreeSpaceW" - c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool setVolumeLabel :: Maybe String -> Maybe String -> IO () setVolumeLabel path name = maybeWith withTString path $ \ c_path -> maybeWith withTString name $ \ c_name -> failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name -foreign import WINDOWS_CCONV unsafe "windows.h SetVolumeLabelW" - c_SetVolumeLabel :: LPCTSTR -> LPCTSTR -> IO Bool ---------------------------------------------------------------- -- File locks @@ -951,10 +530,6 @@ ovlp = OVERLAPPED 0 0 o_low o_hi nullPtr with ovlp $ \ptr -> c_LockFileEx hwnd mode 0 s_low s_hi ptr -foreign import WINDOWS_CCONV unsafe "LockFileEx" - c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED - -> IO BOOL - -- | Unlocks a given range in a file handle, To unlock an entire file -- use 0xFFFFFFFFFFFFFFFF for size and 0 for offset. unlockFile :: HANDLE -- ^ CreateFile handle @@ -969,9 +544,6 @@ o_hi = fromIntegral (f_offset `shiftR` 32) ovlp = OVERLAPPED 0 0 o_low o_hi nullPtr with ovlp $ \ptr -> c_UnlockFileEx hwnd 0 s_low s_hi ptr - -foreign import WINDOWS_CCONV unsafe "UnlockFileEx" - c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL ---------------------------------------------------------------- -- End diff --git a/System/Win32/File/Internal.hsc b/System/Win32/File/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/File/Internal.hsc @@ -0,0 +1,529 @@ +#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" + +#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 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 + +---------------------------------------------------------------- +-- 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 + +---------------------------------------------------------------- +-- 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 @@ -44,7 +44,9 @@ , unmapViewOfFile ) where -import System.Win32.Types ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR, withTString + +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 @@ -52,9 +54,8 @@ import System.Win32.Info import Control.Exception ( mask_, bracket ) -import Foreign ( Ptr, nullPtr, plusPtr, maybeWith, FunPtr +import Foreign ( Ptr, nullPtr, plusPtr, maybeWith , ForeignPtr, newForeignPtr ) -import Foreign.C.Types (CUIntPtr(..)) ##include "windows_cconv.h" @@ -81,8 +82,6 @@ newForeignPtr c_UnmapViewOfFileFinaliser ptr return (fp, fromIntegral $ bhfiSize fi) -data MappedObject = MappedObject HANDLE HANDLE FileMapAccess - -- | Opens an existing file and creates mapping object to it. withMappedFile :: FilePath -- ^ Path @@ -128,24 +127,6 @@ (act . flip plusPtr (fromIntegral offset)) --------------------------------------------------------------------------- --- Enums ---------------------------------------------------------------------------- -type ProtectSectionFlags = DWORD -#{enum ProtectSectionFlags, - , sEC_COMMIT = SEC_COMMIT - , sEC_IMAGE = SEC_IMAGE - , sEC_NOCACHE = SEC_NOCACHE - , sEC_RESERVE = SEC_RESERVE - } -type FileMapAccess = DWORD -#{enum FileMapAccess, - , fILE_MAP_ALL_ACCESS = FILE_MAP_ALL_ACCESS - , fILE_MAP_COPY = FILE_MAP_COPY - , fILE_MAP_READ = FILE_MAP_READ - , fILE_MAP_WRITE = FILE_MAP_WRITE - } - ---------------------------------------------------------------------------- -- API in Haskell --------------------------------------------------------------------------- createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> IO HANDLE @@ -175,21 +156,3 @@ unmapViewOfFile :: Ptr a -> IO () unmapViewOfFile v = c_UnmapViewOfFile v >> return () ---------------------------------------------------------------------------- --- Imports ---------------------------------------------------------------------------- -foreign import WINDOWS_CCONV "windows.h OpenFileMappingW" - c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE - -foreign import WINDOWS_CCONV "windows.h CreateFileMappingW" - c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE - -foreign import WINDOWS_CCONV "windows.h MapViewOfFileEx" - c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b) - -foreign import WINDOWS_CCONV "windows.h UnmapViewOfFile" - c_UnmapViewOfFile :: Ptr a -> IO BOOL - -{-# CFILES cbits/HsWin32.c #-} -foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser" - c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ()) diff --git a/System/Win32/FileMapping/Internal.hsc b/System/Win32/FileMapping/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/FileMapping/Internal.hsc @@ -0,0 +1,72 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.FileMapping.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 mapped files. +-- +----------------------------------------------------------------------------- +module System.Win32.FileMapping.Internal where + +import System.Win32.Types ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR ) + +import Foreign ( Ptr, FunPtr ) +import Foreign.C.Types (CUIntPtr(..)) + +##include "windows_cconv.h" + +#include "windows.h" + +--------------------------------------------------------------------------- +-- Derived functions +--------------------------------------------------------------------------- + +data MappedObject = MappedObject HANDLE HANDLE FileMapAccess + + +--------------------------------------------------------------------------- +-- Enums +--------------------------------------------------------------------------- +type ProtectSectionFlags = DWORD +#{enum ProtectSectionFlags, + , sEC_COMMIT = SEC_COMMIT + , sEC_IMAGE = SEC_IMAGE + , sEC_NOCACHE = SEC_NOCACHE + , sEC_RESERVE = SEC_RESERVE + } +type FileMapAccess = DWORD +#{enum FileMapAccess, + , fILE_MAP_ALL_ACCESS = FILE_MAP_ALL_ACCESS + , fILE_MAP_COPY = FILE_MAP_COPY + , fILE_MAP_READ = FILE_MAP_READ + , fILE_MAP_WRITE = FILE_MAP_WRITE + } + +--------------------------------------------------------------------------- +-- Imports +--------------------------------------------------------------------------- +foreign import WINDOWS_CCONV "windows.h OpenFileMappingW" + c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h CreateFileMappingW" + c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE + +foreign import WINDOWS_CCONV "windows.h MapViewOfFileEx" + c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b) + +foreign import WINDOWS_CCONV "windows.h UnmapViewOfFile" + c_UnmapViewOfFile :: Ptr a -> IO BOOL + +{-# CFILES cbits/HsWin32.c #-} +foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser" + c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ()) diff --git a/System/Win32/HardLink.hs b/System/Win32/HardLink.hs --- a/System/Win32/HardLink.hs +++ b/System/Win32/HardLink.hs @@ -21,9 +21,10 @@ , createHardLink' ) where -import System.Win32.File ( LPSECURITY_ATTRIBUTES, failIfFalseWithRetry_ ) -import System.Win32.String ( LPCTSTR, withTString ) -import System.Win32.Types ( BOOL, nullPtr ) +import System.Win32.HardLink.Internal +import System.Win32.File ( failIfFalseWithRetry_ ) +import System.Win32.String ( withTString ) +import System.Win32.Types ( nullPtr ) #include "windows_cconv.h" @@ -44,11 +45,6 @@ failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $ c_CreateHardLink c_link c_target nullPtr -foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW" - c_CreateHardLink :: LPCTSTR -- ^ Hard link name - -> LPCTSTR -- ^ Target file path - -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/. - -> IO BOOL {- -- We plan to check file system type internally. diff --git a/System/Win32/HardLink/Internal.hs b/System/Win32/HardLink/Internal.hs new file mode 100644 --- /dev/null +++ b/System/Win32/HardLink/Internal.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.HardLink.Internal + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling hard link using Win32 API. [NTFS only] + + Note: You should worry about file system type when use this module's function in your application: + + * NTFS only supprts this functionality. + + * ReFS doesn't support hard link currently. +-} +module System.Win32.HardLink.Internal where + +import System.Win32.File ( LPSECURITY_ATTRIBUTES ) +import System.Win32.String ( LPCTSTR ) +import System.Win32.Types ( BOOL ) + +#include "windows_cconv.h" + +foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW" + c_CreateHardLink :: LPCTSTR -- ^ Hard link name + -> LPCTSTR -- ^ Target file path + -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/. + -> IO BOOL diff --git a/System/Win32/Info.hsc b/System/Win32/Info.hsc --- a/System/Win32/Info.hsc +++ b/System/Win32/Info.hsc @@ -129,14 +129,14 @@ , getUserName ) where +import System.Win32.Info.Internal import Control.Exception (catch) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with, maybeWith) import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Ptr (nullPtr) import Foreign.Storable (Storable(..)) import System.IO.Error (isDoesNotExistError) -import System.Win32.Types (DWORD, LPDWORD, LPCTSTR, LPTSTR, LPVOID, UINT, WORD) import System.Win32.Types (failIfFalse_, peekTStringLen, withTString, try) #if !MIN_VERSION_base(4,6,0) @@ -175,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 ---------------------------------------------------------------- @@ -256,204 +221,15 @@ then return Nothing else ioError e -foreign import WINDOWS_CCONV unsafe "GetWindowsDirectoryW" - c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetSystemDirectoryW" - c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetCurrentDirectoryW" - c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetTempPathW" - c_getTempPath :: DWORD -> LPTSTR -> IO UINT - -foreign import WINDOWS_CCONV unsafe "GetFullPathNameW" - c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "GetLongPathNameW" - c_GetLongPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "GetShortPathNameW" - c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "SearchPathW" - c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR - -> IO DWORD - ---------------------------------------------------------------- -- System Info (Info about processor and memory subsystem) ---------------------------------------------------------------- -data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64 - deriving (Show,Eq) - -instance Storable ProcessorArchitecture where - sizeOf _ = sizeOf (undefined::WORD) - alignment _ = alignment (undefined::WORD) - poke buf pa = pokeByteOff buf 0 $ case pa of - PaUnknown w -> w - PaIntel -> #const PROCESSOR_ARCHITECTURE_INTEL - PaMips -> #const PROCESSOR_ARCHITECTURE_MIPS - PaAlpha -> #const PROCESSOR_ARCHITECTURE_ALPHA - PaPpc -> #const PROCESSOR_ARCHITECTURE_PPC - PaIa64 -> #const PROCESSOR_ARCHITECTURE_IA64 -#ifndef __WINE_WINDOWS_H - PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 -#endif - PaAmd64 -> #const PROCESSOR_ARCHITECTURE_AMD64 - peek buf = do - v <- (peekByteOff buf 0:: IO WORD) - return $ case v of - (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel - (#const PROCESSOR_ARCHITECTURE_MIPS) -> PaMips - (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha - (#const PROCESSOR_ARCHITECTURE_PPC) -> PaPpc - (#const PROCESSOR_ARCHITECTURE_IA64) -> PaIa64 -#ifndef __WINE_WINDOWS_H - (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64 -#endif - (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64 - w -> PaUnknown w - -data SYSTEM_INFO = SYSTEM_INFO - { siProcessorArchitecture :: ProcessorArchitecture - , siPageSize :: DWORD - , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID - , siActiveProcessorMask :: DWORD - , siNumberOfProcessors :: DWORD - , siProcessorType :: DWORD - , siAllocationGranularity :: DWORD - , siProcessorLevel :: WORD - , siProcessorRevision :: WORD - } deriving (Show) - -instance Storable SYSTEM_INFO where - sizeOf = const #size SYSTEM_INFO - alignment _ = #alignment SYSTEM_INFO - poke buf si = do - (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si) - (#poke SYSTEM_INFO, dwPageSize) buf (siPageSize si) - (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si) - (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si) - (#poke SYSTEM_INFO, dwActiveProcessorMask) buf (siActiveProcessorMask si) - (#poke SYSTEM_INFO, dwNumberOfProcessors) buf (siNumberOfProcessors si) - (#poke SYSTEM_INFO, dwProcessorType) buf (siProcessorType si) - (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si) - (#poke SYSTEM_INFO, wProcessorLevel) buf (siProcessorLevel si) - (#poke SYSTEM_INFO, wProcessorRevision) buf (siProcessorRevision si) - - peek buf = do - processorArchitecture <- - (#peek SYSTEM_INFO, wProcessorArchitecture) buf - pageSize <- (#peek SYSTEM_INFO, dwPageSize) buf - minimumApplicationAddress <- - (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf - maximumApplicationAddress <- - (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf - activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf - numberOfProcessors <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf - processorType <- (#peek SYSTEM_INFO, dwProcessorType) buf - allocationGranularity <- - (#peek SYSTEM_INFO, dwAllocationGranularity) buf - processorLevel <- (#peek SYSTEM_INFO, wProcessorLevel) buf - processorRevision <- (#peek SYSTEM_INFO, wProcessorRevision) buf - return $ SYSTEM_INFO { - siProcessorArchitecture = processorArchitecture, - siPageSize = pageSize, - siMinimumApplicationAddress = minimumApplicationAddress, - siMaximumApplicationAddress = maximumApplicationAddress, - siActiveProcessorMask = activeProcessorMask, - siNumberOfProcessors = numberOfProcessors, - siProcessorType = processorType, - siAllocationGranularity = allocationGranularity, - siProcessorLevel = processorLevel, - siProcessorRevision = processorRevision - } - -foreign import WINDOWS_CCONV unsafe "windows.h GetSystemInfo" - c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO () - getSystemInfo :: IO SYSTEM_INFO getSystemInfo = alloca $ \ret -> do c_GetSystemInfo ret peek ret ----------------------------------------------------------------- --- System metrics ----------------------------------------------------------------- - -type SMSetting = UINT - -#{enum SMSetting, - , sM_ARRANGE = SM_ARRANGE - , sM_CLEANBOOT = SM_CLEANBOOT - , sM_CMETRICS = SM_CMETRICS - , sM_CMOUSEBUTTONS = SM_CMOUSEBUTTONS - , sM_CXBORDER = SM_CXBORDER - , sM_CYBORDER = SM_CYBORDER - , sM_CXCURSOR = SM_CXCURSOR - , sM_CYCURSOR = SM_CYCURSOR - , sM_CXDLGFRAME = SM_CXDLGFRAME - , sM_CYDLGFRAME = SM_CYDLGFRAME - , sM_CXDOUBLECLK = SM_CXDOUBLECLK - , sM_CYDOUBLECLK = SM_CYDOUBLECLK - , sM_CXDRAG = SM_CXDRAG - , sM_CYDRAG = SM_CYDRAG - , sM_CXEDGE = SM_CXEDGE - , sM_CYEDGE = SM_CYEDGE - , sM_CXFRAME = SM_CXFRAME - , sM_CYFRAME = SM_CYFRAME - , sM_CXFULLSCREEN = SM_CXFULLSCREEN - , sM_CYFULLSCREEN = SM_CYFULLSCREEN - , sM_CXHSCROLL = SM_CXHSCROLL - , sM_CYVSCROLL = SM_CYVSCROLL - , sM_CXICON = SM_CXICON - , sM_CYICON = SM_CYICON - , sM_CXICONSPACING = SM_CXICONSPACING - , sM_CYICONSPACING = SM_CYICONSPACING - , sM_CXMAXIMIZED = SM_CXMAXIMIZED - , sM_CYMAXIMIZED = SM_CYMAXIMIZED - , sM_CXMENUCHECK = SM_CXMENUCHECK - , sM_CYMENUCHECK = SM_CYMENUCHECK - , sM_CXMENUSIZE = SM_CXMENUSIZE - , sM_CYMENUSIZE = SM_CYMENUSIZE - , sM_CXMIN = SM_CXMIN - , sM_CYMIN = SM_CYMIN - , sM_CXMINIMIZED = SM_CXMINIMIZED - , sM_CYMINIMIZED = SM_CYMINIMIZED - , sM_CXMINTRACK = SM_CXMINTRACK - , sM_CYMINTRACK = SM_CYMINTRACK - , sM_CXSCREEN = SM_CXSCREEN - , sM_CYSCREEN = SM_CYSCREEN - , sM_CXSIZE = SM_CXSIZE - , sM_CYSIZE = SM_CYSIZE - , sM_CXSIZEFRAME = SM_CXSIZEFRAME - , sM_CYSIZEFRAME = SM_CYSIZEFRAME - , sM_CXSMICON = SM_CXSMICON - , sM_CYSMICON = SM_CYSMICON - , sM_CXSMSIZE = SM_CXSMSIZE - , sM_CYSMSIZE = SM_CYSMSIZE - , sM_CXVSCROLL = SM_CXVSCROLL - , sM_CYHSCROLL = SM_CYHSCROLL - , sM_CYVTHUMB = SM_CYVTHUMB - , sM_CYCAPTION = SM_CYCAPTION - , sM_CYKANJIWINDOW = SM_CYKANJIWINDOW - , sM_CYMENU = SM_CYMENU - , sM_CYSMCAPTION = SM_CYSMCAPTION - , sM_DBCSENABLED = SM_DBCSENABLED - , sM_DEBUG = SM_DEBUG - , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT - , sM_MIDEASTENABLED = SM_MIDEASTENABLED - , sM_MOUSEPRESENT = SM_MOUSEPRESENT - , sM_NETWORK = SM_NETWORK - , sM_PENWINDOWS = SM_PENWINDOWS - , sM_SECURE = SM_SECURE - , sM_SHOWSOUNDS = SM_SHOWSOUNDS - , sM_SLOWMACHINE = SM_SLOWMACHINE - , sM_SWAPBUTTON = SM_SWAPBUTTON - } - -- %fun GetSystemMetrics :: SMSetting -> IO Int ---------------------------------------------------------------- @@ -468,9 +244,6 @@ ---------------------------------------------------------------- -- %fun GetUserName :: IO String - -foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW" - c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool getUserName :: IO String getUserName = diff --git a/System/Win32/Info/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/Path.hsc b/System/Win32/Path.hsc --- a/System/Win32/Path.hsc +++ b/System/Win32/Path.hsc @@ -22,6 +22,7 @@ , pathRelativePathTo ) where +import System.Win32.Path.Internal import System.Win32.Types import System.Win32.File @@ -53,5 +54,3 @@ _ <- localFree p_AbsPath return path -foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW" - c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT diff --git a/System/Win32/Path/Internal.hsc b/System/Win32/Path/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Path/Internal.hsc @@ -0,0 +1,29 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Path.Internal +-- Copyright : (c) Tamar Christina, 1997-2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Tamar Christina +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module System.Win32.Path.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +#include + +foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW" + c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT diff --git a/System/Win32/Shell.hsc b/System/Win32/Shell.hsc --- a/System/Win32/Shell.hsc +++ b/System/Win32/Shell.hsc @@ -32,13 +32,13 @@ sHGFP_TYPE_DEFAULT ) where +import System.Win32.Shell.Internal import System.Win32.Types import Graphics.Win32.GDI.Types (HWND) import Foreign import Foreign.C import Control.Monad -import System.IO.Error ##include "windows_cconv.h" @@ -79,11 +79,3 @@ r <- c_SHGetFolderPath hwnd csidl hdl flags pstr when (r < 0) $ raiseUnsupported "sHGetFolderPath" peekTString pstr - -raiseUnsupported :: String -> IO () -raiseUnsupported loc = - ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation") - -foreign import WINDOWS_CCONV unsafe "SHGetFolderPathW" - c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR - -> IO HRESULT diff --git a/System/Win32/Shell/Internal.hsc b/System/Win32/Shell/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Shell/Internal.hsc @@ -0,0 +1,50 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Shell.Internal +-- Copyright : (c) The University of Glasgow 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Win32 stuff from shell32.dll +-- +----------------------------------------------------------------------------- + +module System.Win32.Shell.Internal ( + c_SHGetFolderPath + , raiseUnsupported + ) where + +import System.Win32.Types +import Graphics.Win32.GDI.Types (HWND) + +import Foreign.C +import System.IO.Error + +##include "windows_cconv.h" + +-- for SHGetFolderPath stuff +#define _WIN32_IE 0x500 +#include +#include + +---------------------------------------------------------------- +-- SHGetFolderPath +-- +-- XXX: this is deprecated in Vista and later +---------------------------------------------------------------- + +raiseUnsupported :: String -> IO () +raiseUnsupported loc = + ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation") + +foreign import WINDOWS_CCONV unsafe "SHGetFolderPathW" + c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR + -> IO HRESULT diff --git a/System/Win32/SymbolicLink.hsc b/System/Win32/SymbolicLink.hsc --- a/System/Win32/SymbolicLink.hsc +++ b/System/Win32/SymbolicLink.hsc @@ -35,20 +35,14 @@ , createSymbolicLinkDirectory ) where +import System.Win32.SymbolicLink.Internal import Data.Bits ((.|.)) import System.Win32.Types import System.Win32.File ( failIfFalseWithRetry_ ) ##include "windows_cconv.h" -type SymbolicLinkFlags = DWORD -#{enum SymbolicLinkFlags, - , sYMBOLIC_LINK_FLAG_FILE = 0x0 - , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 - , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2 -} - -- | createSymbolicLink* functions don't check that file is exist or not. -- -- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix, @@ -97,5 +91,3 @@ failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $ c_CreateSymbolicLink c_link c_target flag -foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW" - c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL diff --git a/System/Win32/SymbolicLink/Internal.hsc b/System/Win32/SymbolicLink/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/SymbolicLink/Internal.hsc @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.SymbolicLink.Internal + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) +-} +module System.Win32.SymbolicLink.Internal where + +import System.Win32.Types + +##include "windows_cconv.h" + +type SymbolicLinkFlags = DWORD + +#{enum SymbolicLinkFlags, + , sYMBOLIC_LINK_FLAG_FILE = 0x0 + , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 + , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2 +} + +foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW" + c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL diff --git a/System/Win32/Time.hsc b/System/Win32/Time.hsc --- a/System/Win32/Time.hsc +++ b/System/Win32/Time.hsc @@ -52,21 +52,19 @@ , getTimeFormat ) where +import System.Win32.Time.Internal import System.Win32.String ( peekTStringLen, withTString ) -import System.Win32.Types ( BOOL, DDWORD, DWORD, HANDLE, LARGE_INTEGER, LCID - , LONG, LPCTSTR, LPCWSTR, LPTSTR, LPWSTR, UINT, WORD - , dwordsToDdword, ddwordToDwords, failIf +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" @@ -74,145 +72,30 @@ #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 () getSystemTime :: IO SYSTEMTIME getSystemTime = alloca $ \res -> do c_GetSystemTime res peek res -foreign import WINDOWS_CCONV "windows.h SetSystemTime" - c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL setSystemTime :: SYSTEMTIME -> IO () setSystemTime st = with st $ \c_st -> failIf_ not "setSystemTime: SetSystemTime" $ c_SetSystemTime c_st -foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime" - c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () getSystemTimeAsFileTime :: IO FILETIME getSystemTimeAsFileTime = alloca $ \ret -> do c_GetSystemTimeAsFileTime ret peek ret -foreign import WINDOWS_CCONV "windows.h GetLocalTime" - c_GetLocalTime :: Ptr SYSTEMTIME -> IO () getLocalTime :: IO SYSTEMTIME getLocalTime = alloca $ \res -> do c_GetLocalTime res peek res -foreign import WINDOWS_CCONV "windows.h SetLocalTime" - c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL setLocalTime :: SYSTEMTIME -> IO () setLocalTime st = with st $ \c_st -> failIf_ not "setLocalTime: SetLocalTime" $ c_SetLocalTime c_st -foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment" - c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL getSystemTimeAdjustment :: IO (Maybe (Int, Int)) getSystemTimeAdjustment = alloca $ \ta -> alloca $ \ti -> alloca $ \enabled -> do failIf_ not "getSystemTimeAdjustment: GetSystemTimeAdjustment" $ @@ -225,10 +108,6 @@ return $ Just (fromIntegral ta', fromIntegral ti') else return Nothing -foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD - -foreign import WINDOWS_CCONV unsafe "windows.h GetLastInputInfo" - c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool getLastInputInfo :: IO DWORD getLastInputInfo = with (LASTINPUTINFO 0) $ \lii_p -> do @@ -242,8 +121,6 @@ now <- getTickCount return $ fromIntegral $ now - lii -foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment" - c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL setSystemTimeAdjustment :: Maybe Int -> IO () setSystemTimeAdjustment ta = failIf_ not "setSystemTimeAjustment: SetSystemTimeAdjustment" $ @@ -253,8 +130,6 @@ Nothing -> (0,True) Just x -> (fromIntegral x,False) -foreign import WINDOWS_CCONV "windows.h GetTimeZoneInformation" - c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD getTimeZoneInformation :: IO (TimeZoneId, TIME_ZONE_INFORMATION) getTimeZoneInformation = alloca $ \tzi -> do tz <- failIf (==(#const TIME_ZONE_ID_INVALID)) "getTimeZoneInformation: GetTimeZoneInformation" $ @@ -266,24 +141,18 @@ (#const TIME_ZONE_ID_DAYLIGHT) -> TzIdDaylight _ -> TzIdUnknown -- to remove warning -foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime" - c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL systemTimeToFileTime :: SYSTEMTIME -> IO FILETIME systemTimeToFileTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "systemTimeToFileTime: SystemTimeToFileTime" $ c_SystemTimeToFileTime c_s ret peek ret -foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime" - c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL fileTimeToSystemTime :: FILETIME -> IO SYSTEMTIME fileTimeToSystemTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "fileTimeToSystemTime: FileTimeToSystemTime" $ c_FileTimeToSystemTime c_s ret peek ret -foreign import WINDOWS_CCONV "windows.h GetFileTime" - c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL getFileTime :: HANDLE -> IO (FILETIME,FILETIME,FILETIME) getFileTime h = alloca $ \crt -> alloca $ \acc -> alloca $ \wrt -> do failIf_ not "getFileTime: GetFileTime" $ c_GetFileTime h crt acc wrt @@ -292,8 +161,6 @@ invalidFileTime :: FILETIME invalidFileTime = FILETIME 0 -foreign import WINDOWS_CCONV "windows.h SetFileTime" - c_SetFileTime :: HANDLE -> Ptr FILETIME -> 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 $ @@ -305,16 +172,12 @@ withTime Nothing k = k nullPtr withTime (Just t) k = with t k -foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime" - c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL fileTimeToLocalFileTime :: FILETIME -> IO FILETIME fileTimeToLocalFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "fileTimeToLocalFileTime: FileTimeToLocalFileTime" $ c_FileTimeToLocalFileTime c_ft res peek res -foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime" - c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL localFileTimeToFileTime :: FILETIME -> IO FILETIME localFileTimeToFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "localFileTimeToFileTime: LocalFileTimeToFileTime" @@ -350,31 +213,18 @@ 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 - } getTimeFormatEx :: Maybe String -> GetTimeFormatFlags @@ -387,17 +237,7 @@ maybeWith withTString fmt $ \c_fmt -> do let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt trySized "GetTimeFormatEx" c_func -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 getTimeFormat :: LCID -> GetTimeFormatFlags -> Maybe SYSTEMTIME -> Maybe String -> IO String getTimeFormat locale flags st fmt = maybeWith with st $ \c_st -> diff --git a/System/Win32/Time/Internal.hsc b/System/Win32/Time/Internal.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Time/Internal.hsc @@ -0,0 +1,245 @@ +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Time.Internal +-- Copyright : (c) Esa Ilari Vuokko, 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Time API. +-- +----------------------------------------------------------------------------- +module System.Win32.Time.Internal where + +import System.Win32.Types ( BOOL, DDWORD, DWORD, HANDLE, LARGE_INTEGER, LCID + , LONG, LPCTSTR, LPCWSTR, LPTSTR, LPWSTR, UINT, WORD + , dwordsToDdword, ddwordToDwords + ) +import Control.Monad ( when ) +import Data.Word ( Word8 ) +import Foreign ( Storable(sizeOf, alignment, peekByteOff, peek, + pokeByteOff, poke) + , Ptr, castPtr, plusPtr, advancePtr + , copyArray ) +import Foreign.C ( CInt(..), CWchar(..) + , peekCWString, withCWStringLen ) + +##include "windows_cconv.h" +#include +#include "alignment.h" +#include "winnls_compat.h" + +---------------------------------------------------------------- +-- data types +---------------------------------------------------------------- + +newtype FILETIME = FILETIME DDWORD deriving (Show, Eq, Ord) + +data SYSTEMTIME = SYSTEMTIME { + wYear, wMonth, wDayOfWeek, wDay, wHour, wMinute, wSecond, wMilliseconds :: WORD } + deriving (Show, Eq, Ord) + +data TIME_ZONE_INFORMATION = TIME_ZONE_INFORMATION + { tziBias :: LONG + , tziStandardName :: String + , tziStandardDate :: SYSTEMTIME + , tziStandardBias :: LONG + , tziDaylightName :: String + , tziDaylightDate :: SYSTEMTIME + , tziDaylightBias :: LONG + } deriving (Show,Eq,Ord) + +data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight + deriving (Show, Eq, Ord) + +data LASTINPUTINFO = LASTINPUTINFO DWORD deriving (Show) + +---------------------------------------------------------------- +-- Instances +---------------------------------------------------------------- + +instance Storable FILETIME where + sizeOf = const (#size FILETIME) + alignment _ = #alignment FILETIME + poke buf (FILETIME n) = do + (#poke FILETIME, dwLowDateTime) buf low + (#poke FILETIME, dwHighDateTime) buf hi + where (hi,low) = ddwordToDwords n + peek buf = do + low <- (#peek FILETIME, dwLowDateTime) buf + hi <- (#peek FILETIME, dwHighDateTime) buf + return $ FILETIME $ dwordsToDdword (hi,low) + +instance Storable SYSTEMTIME where + sizeOf _ = #size SYSTEMTIME + alignment _ = #alignment SYSTEMTIME + poke buf st = do + (#poke SYSTEMTIME, wYear) buf (wYear st) + (#poke SYSTEMTIME, wMonth) buf (wMonth st) + (#poke SYSTEMTIME, wDayOfWeek) buf (wDayOfWeek st) + (#poke SYSTEMTIME, wDay) buf (wDay st) + (#poke SYSTEMTIME, wHour) buf (wHour st) + (#poke SYSTEMTIME, wMinute) buf (wMinute st) + (#poke SYSTEMTIME, wSecond) buf (wSecond st) + (#poke SYSTEMTIME, wMilliseconds) buf (wMilliseconds st) + peek buf = do + year <- (#peek SYSTEMTIME, wYear) buf + month <- (#peek SYSTEMTIME, wMonth) buf + dow <- (#peek SYSTEMTIME, wDayOfWeek) buf + day <- (#peek SYSTEMTIME, wDay) buf + hour <- (#peek SYSTEMTIME, wHour) buf + mins <- (#peek SYSTEMTIME, wMinute) buf + sec <- (#peek SYSTEMTIME, wSecond) buf + ms <- (#peek SYSTEMTIME, wMilliseconds) buf + return $ SYSTEMTIME year month dow day hour mins sec ms + +instance Storable TIME_ZONE_INFORMATION where + sizeOf _ = (#size TIME_ZONE_INFORMATION) + alignment _ = #alignment TIME_ZONE_INFORMATION + poke buf tzi = do + (#poke TIME_ZONE_INFORMATION, Bias) buf (tziBias tzi) + (#poke TIME_ZONE_INFORMATION, StandardDate) buf (tziStandardDate tzi) + (#poke TIME_ZONE_INFORMATION, StandardBias) buf (tziStandardBias tzi) + (#poke TIME_ZONE_INFORMATION, DaylightDate) buf (tziDaylightDate tzi) + (#poke TIME_ZONE_INFORMATION, DaylightBias) buf (tziDaylightBias tzi) + write buf (#offset TIME_ZONE_INFORMATION, StandardName) (tziStandardName tzi) + write buf (#offset TIME_ZONE_INFORMATION, DaylightName) (tziDaylightName tzi) + where + write buf_ offset str = withCWStringLen str $ \(c_str,len) -> do + when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string." + let len' = len * sizeOf (undefined :: CWchar) + start = (advancePtr (castPtr buf_) offset) + end = advancePtr start len' + copyArray start (castPtr c_str :: Ptr Word8) len' + poke (castPtr end) (0 :: CWchar) + + peek buf = do + bias <- (#peek TIME_ZONE_INFORMATION, Bias) buf + sdat <- (#peek TIME_ZONE_INFORMATION, StandardDate) buf + sbia <- (#peek TIME_ZONE_INFORMATION, StandardBias) buf + ddat <- (#peek TIME_ZONE_INFORMATION, DaylightDate) buf + dbia <- (#peek TIME_ZONE_INFORMATION, DaylightBias) buf + snam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, StandardName)) + dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName)) + return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia + +instance Storable LASTINPUTINFO where + sizeOf = const (#size LASTINPUTINFO) + alignment = sizeOf + poke buf (LASTINPUTINFO t) = do + (#poke LASTINPUTINFO, cbSize) buf ((#size LASTINPUTINFO) :: UINT) + (#poke LASTINPUTINFO, dwTime) buf t + peek buf = do + t <- (#peek LASTINPUTINFO, dwTime) buf + return $ LASTINPUTINFO t + +foreign import WINDOWS_CCONV "windows.h GetSystemTime" + c_GetSystemTime :: Ptr SYSTEMTIME -> IO () + +foreign import WINDOWS_CCONV "windows.h SetSystemTime" + c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime" + c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () + +foreign import WINDOWS_CCONV "windows.h GetLocalTime" + c_GetLocalTime :: Ptr SYSTEMTIME -> IO () + +foreign import WINDOWS_CCONV "windows.h SetLocalTime" + c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment" + c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD + +foreign import WINDOWS_CCONV unsafe "windows.h GetLastInputInfo" + c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool + +foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment" + c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetTimeZoneInformation" + c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime" + c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime" + c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetFileTime" + c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h SetFileTime" + c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime" + c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime" + c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL + +{- +-- Windows XP SP1 +foreign import WINDOWS_CCONV "windows.h GetSystemTimes" + c_GetSystemTimes :: Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL +getSystemTimes :: IO (FILETIME,FILETIME,FILETIME) +getSystemTimes = alloca $ \idle -> alloca $ \kernel -> alloca $ \user -> do + failIf not "getSystemTimes: GetSystemTimes" $ c_GetSystemTimes idle kernel user + liftM3 (,,) (peek idle) (peek kernel) (peek user) +-} + +{- +-- Windows XP +foreign import WINDOWS_CCONV "windows.h SystemTimeToTzSpecificLocalTime" + c_SystemTimeToTzSpecificLocalTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL +systemTimeToTzSpecificLocalTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME +systemTimeToTzSpecificLocalTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do + failIf not "systemTimeToTzSpecificLocalTime: SystemTimeToTzSpecificLocalTime" $ + c_SystemTimeToTzSpecificLocalTime tzi st res + peek res + +foreign import WINDOWS_CCONV "windows.h TzSpecificLocalTimeToSystemTime" + c_TzSpecificLocalTimeToSystemTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL +tzSpecificLocalTimeToSystemTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME +tzSpecificLocalTimeToSystemTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do + failIf not "tzSpecificLocalTimeToSystemTime: TzSpecificLocalTimeToSystemTime" $ + c_TzSpecificLocalTimeToSystemTime tzi st res + peek res +-} + +foreign import WINDOWS_CCONV "windows.h QueryPerformanceFrequency" + c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h QueryPerformanceCounter" + c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL + +type GetTimeFormatFlags = DWORD +#{enum GetTimeFormatFlags, + , lOCALE_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE + , lOCALE_USE_CP_ACP = LOCALE_USE_CP_ACP + , tIME_NOMINUTESORSECONDS = TIME_NOMINUTESORSECONDS + , tIME_NOSECONDS = TIME_NOSECONDS + , tIME_NOTIMEMARKER = TIME_NOTIMEMARKER + , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT + } + +foreign import WINDOWS_CCONV "windows.h GetTimeFormatEx" + c_GetTimeFormatEx :: LPCWSTR + -> GetTimeFormatFlags + -> Ptr SYSTEMTIME + -> LPCWSTR + -> LPWSTR + -> CInt + -> IO CInt + +foreign import WINDOWS_CCONV "windows.h GetTimeFormatW" + c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt diff --git a/System/Win32/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 HINSTANCE +loadLibrary name = + withTString name $ \ c_name -> + failIfNull "LoadLibrary" $ c_LoadLibrary c_name + +loadLibraryEx :: WindowsString -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE +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,238 @@ +----------------------------------------------------------------------------- +-- | +-- 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 + , findFirstChangeNotification + , getFindDataFileName + , findFirstFile + , defineDosDevice + , getDiskFreeSpace + , setVolumeLabel + , getFileExInfoStandard + , getFileExMaxInfoLevel + , 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 + , findFirstChangeNotification + , getFindDataFileName + , findFirstFile + , defineDosDevice + , getDiskFreeSpace + , setVolumeLabel + , getFileExInfoStandard + , getFileExMaxInfoLevel + ) +import System.Win32.WindowsString.Types +import System.OsString.Windows +import Unsafe.Coerce (unsafeCoerce) + +import Foreign hiding (void) + +##include "windows_cconv.h" + +#include +#include "alignment.h" + +deleteFile :: WindowsString -> IO () +deleteFile name = + withTString name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $ + c_DeleteFile c_name + +copyFile :: WindowsString -> WindowsString -> Bool -> IO () +copyFile src dest over = + withTString src $ \ c_src -> + withTString dest $ \ c_dest -> + failIfFalseWithRetry_ (unwords ["CopyFile",show src,show dest]) $ + c_CopyFile c_src c_dest over + +moveFile :: WindowsString -> WindowsString -> IO () +moveFile src dest = + withTString src $ \ c_src -> + withTString 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 = + withTString src $ \ c_src -> + maybeWith withTString dest $ \ c_dest -> + failIfFalseWithRetry_ (unwords ["MoveFileEx",show src,show dest]) $ + c_MoveFileEx c_src c_dest flags + +setCurrentDirectory :: WindowsString -> IO () +setCurrentDirectory name = + withTString name $ \ c_name -> + failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $ + c_SetCurrentDirectory c_name + +createDirectory :: WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO () +createDirectory name mb_attr = + withTString 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 = + withTString template $ \ c_template -> + withTString name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["CreateDirectoryEx",show template,show name]) $ + c_CreateDirectoryEx c_template c_name (maybePtr mb_attr) + +removeDirectory :: WindowsString -> IO () +removeDirectory name = + withTString name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $ + c_RemoveDirectory c_name + +getBinaryType :: WindowsString -> IO BinaryType +getBinaryType name = + withTString 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 = + withTString 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 = + withTString name $ \ c_name -> + failIfFalseWithRetry_ (unwords ["SetFileAttributes",show name]) + $ c_SetFileAttributes c_name attr + +getFileAttributes :: WindowsString -> IO FileAttributeOrFlag +getFileAttributes name = + withTString 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 + withTString name $ \ c_name -> + failIfFalseWithRetry_ "getFileAttributesExStandard" $ + c_GetFileAttributesEx c_name (unsafeCoerce getFileExInfoStandard) res + peek res + + +---------------------------------------------------------------- +-- 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 = + withTString 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 <- withTString 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 withTString path $ \ c_path -> + withTString 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 withTString 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 withTString path $ \ c_path -> + maybeWith withTString 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,67 @@ +{- | + 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 +import qualified System.OsPath.Data.ByteString.Short as SBS +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,166 @@ +{-# 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.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 + ) + +import System.OsString.Windows +import System.OsString.Internal.Types +import System.OsPath.Data.ByteString.Short.Word16 ( + 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 GHC.Ptr (castPtr) + +#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 "windows_cconv.h" + + +---------------------------------------------------------------- +-- Chars and strings +---------------------------------------------------------------- + +withTString :: WindowsString -> (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)) +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 + +---------------------------------------------------------------- +-- Errors +---------------------------------------------------------------- + +failIf :: (a -> Bool) -> String -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +failIf_ :: (a -> Bool) -> String -> IO a -> IO () +failIf_ p wh act = do + v <- act + if p v then errorWin wh else return () + +failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a +failIfNeg = failIf (< 0) + +failIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +failIfNull = failIf (== nullPtr) + +failIfZero :: (Eq a, Num a) => String -> IO a -> IO a +failIfZero = failIf (== 0) + +failIfFalse_ :: String -> IO Bool -> IO () +failIfFalse_ = failIf_ not + +failUnlessSuccess :: String -> IO ErrCode -> IO () +failUnlessSuccess fn_name act = do + r <- act + if r == 0 then return () else failWith fn_name r + +failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool +failUnlessSuccessOr val fn_name act = do + r <- act + if r == 0 then return False + else if r == val then return True + else failWith fn_name r + + +errorWin :: String -> IO a +errorWin fn_name = do + err_code <- getLastError + failWith fn_name err_code + +failWith :: String -> ErrCode -> IO a +failWith fn_name err_code = do + c_msg <- getErrorMessage err_code + + msg <- either (fail . show) pure . decodeWith (mkUTF16le TransliterateCodingFailure) =<< if c_msg == nullPtr + then either (fail . show) pure . encodeWith (mkUTF16le TransliterateCodingFailure) $ "Error 0x" ++ Numeric.showHex err_code "" + else do msg <- peekTString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + -- turn GetLastError() into errno, which errnoToIOError knows how to convert + -- to an IOException we can throw. + errno <- c_maperrno_func err_code + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + ioerror = errnoToIOError fn_name errno Nothing Nothing + `ioeSetErrorString` msg' + throwIO ioerror + + +-- Support for API calls that are passed a fixed-size buffer and tell +-- you via the return value if the buffer was too small. In that +-- case, we double the buffer size and try again. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +try loc f n = do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + r <- failIfZero loc $ f lptstr n + if (r > n) then return (Left r) else do + str <- peekTStringLen (lptstr, fromIntegral r) + return (Right str) + case e of + Left n' -> try loc f n' + Right str -> return str diff --git a/System/Win32/WindowsString/Utils.hs b/System/Win32/WindowsString/Utils.hs new file mode 100644 --- /dev/null +++ b/System/Win32/WindowsString/Utils.hs @@ -0,0 +1,63 @@ +{- | + Module : System.Win32.Utils + Copyright : 2009 Balazs Komuves, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Utilities for calling Win32 API +-} +module System.Win32.WindowsString.Utils + ( module System.Win32.WindowsString.Utils + , module System.Win32.Utils + ) where + +import Foreign.C.Types ( CInt ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Ptr ( nullPtr ) + +import System.Win32.Utils hiding + ( try + , tryWithoutNull + , trySized + ) +import System.Win32.WindowsString.String ( LPTSTR, peekTString, peekTStringLen + , withTStringBufferLen ) +import System.Win32.WindowsString.Types ( UINT + , failIfZero + ) +import qualified System.Win32.WindowsString.Types ( try ) +import System.OsString.Windows + + +-- | Support for API calls that are passed a fixed-size buffer and tell +-- you via the return value if the buffer was too small. In that +-- case, we extend the buffer size and try again. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +try = System.Win32.WindowsString.Types.try +{-# INLINE try #-} + +tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString +tryWithoutNull loc f n = do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + r <- failIfZero loc $ f lptstr n + if r > n then return (Left r) else do + str <- peekTString lptstr + return (Right str) + case e of + Left r' -> tryWithoutNull loc f r' + Right str -> return str + +-- | Support for API calls that return the required size, in characters +-- including a null character, of the buffer when passed a buffer size of zero. +trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO WindowsString +trySized wh f = do + c_len <- failIfZero wh $ f nullPtr 0 + let len = fromIntegral c_len + withTStringBufferLen len $ \(buf', len') -> do + let c_len' = fromIntegral len' + c_len'' <- failIfZero wh $ f buf' c_len' + let len'' = fromIntegral c_len'' + peekTStringLen (buf', len'' - 1) -- Drop final null character diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,5 +1,5 @@ name: Win32 -version: 2.13.2.1 +version: 2.13.3.0 license: BSD3 license-file: LICENSE author: Alastair Reid, shelarcy, Tamar Christina @@ -28,7 +28,12 @@ build-depends: unbuildable<0 buildable: False - build-depends: base >= 4.5 && < 5, filepath + build-depends: base >= 4.5 && < 5 + + -- AFPP support + if impl(ghc >= 8.0) + build-depends: filepath >= 1.4.100.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 @@ -102,6 +107,35 @@ System.Win32.Thread System.Win32.Utils System.Win32.Word + + -- AFPP support + if impl(ghc >= 8.0) + exposed-modules: + 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.DebugApi.Internal + System.Win32.DLL.Internal + System.Win32.File.Internal + System.Win32.FileMapping.Internal + System.Win32.HardLink.Internal + System.Win32.Info.Internal + System.Win32.Path.Internal + System.Win32.Shell.Internal + System.Win32.SymbolicLink.Internal + System.Win32.Time.Internal extra-libraries: "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,9 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) +## 2.13.3.0 July 2022 + +* Add AFPP support (see #198) + ## 2.13.2.1 July 2022 * Add function `createIcon` (see #194)