diff --git a/System/Win32/WindowsString/DLL.hsc b/System/Win32/WindowsString/DLL.hsc new file mode 100644 index 0000000..cf126e5 --- /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 index 0000000..e0e7f55 --- /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 index 0000000..857f203 --- /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 index 0000000..a3c8569 --- /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 index 0000000..be6c7c1 --- /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 index 0000000..aacf074 --- /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 index 0000000..86740ec --- /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 index 0000000..d82aa4b --- /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 index 0000000..1c7c72c --- /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 index 0000000..abc16f5 --- /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 index 0000000..0fedc5f --- /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 index 0000000..affdfa9 --- /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 index 0000000..dbb4399 --- /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 index a88fbe0..1d5fad0 100644 --- a/Win32.cabal +++ b/Win32.cabal @@ -28,7 +28,8 @@ Library build-depends: unbuildable<0 buildable: False - build-depends: base >= 4.5 && < 5, filepath + build-depends: base >= 4.5 && < 5 + , filepath >= 1.4.99.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 @@ -103,6 +104,20 @@ Library System.Win32.Utils System.Win32.Word + 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 diff --git a/changelog.md b/changelog.md index 53eb6aa..5e3f849 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,7 @@ ## 2.13.2.1 July 2022 +* Add AFPP support (see #198) * Add function `createIcon` (see #194) * Add `WindowMessage` value `wM_SETICON` (see #194) * Add `WPARAM` values `iCON_SMALL`, `iCON_BIG` (see #194)