diff --git a/System/Win32/Console.hsc b/System/Win32/Console.hsc --- a/System/Win32/Console.hsc +++ b/System/Win32/Console.hsc @@ -1,5 +1,5 @@ #if __GLASGOW_HASKELL__ >= 709 -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Trustworthy #-} #endif @@ -56,7 +56,11 @@ getConsoleScreenBufferInfo, getCurrentConsoleScreenBufferInfo, getConsoleScreenBufferInfoEx, - getCurrentConsoleScreenBufferInfoEx + getCurrentConsoleScreenBufferInfoEx, + + -- * Env + getEnv, + getEnvironment ) where #include @@ -64,14 +68,20 @@ ##include "windows_cconv.h" #include "wincon_compat.h" +import Data.Char (chr) import System.Win32.Types +import System.Win32.String import System.Win32.Console.Internal import Graphics.Win32.Misc import Graphics.Win32.GDI.Types (COLORREF) -import Foreign.C.String (withCWString) +import GHC.IO (bracket) +import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) +import Foreign.Ptr (plusPtr) +import Foreign.C.Types (CWchar) +import Foreign.C.String (withCWString, CWString) import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Array (peekArray, peekArray0) import Foreign.Marshal.Alloc (alloca) @@ -154,3 +164,71 @@ getCurrentConsoleScreenBufferInfoEx = do h <- failIf (== nullHANDLE) "getStdHandle" $ getStdHandle sTD_OUTPUT_HANDLE getConsoleScreenBufferInfoEx h + + +-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD +getEnv :: String -> IO (Maybe String) +getEnv name = + withCWString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- c_GetEnvironmentVariableW c_name buf c_len + case c_len' of + 0 -> do + err_code <- getLastError + if err_code == eERROR_ENVVAR_NOT_FOUND + then return Nothing + else errorWin "GetEnvironmentVariableW" + _ | c_len' > fromIntegral maxLength -> + -- shouldn't happen, because we provide maxLength + ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) + | otherwise -> do + let len' = fromIntegral c_len' + Just <$> peekTStringLen (buf, len') + where + -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew + -- max characters (wide chars): 32767 + -- => bytes = 32767 * 2 = 65534 + -- +1 byte for NUL (although not needed I think) + maxLength :: Int + maxLength = 65535 + + +getEnvironment :: IO [(String, String)] +getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do + strs <- builder lpwstr + return (divvy <$> strs) + where + divvy :: String -> (String, String) + divvy str = + case break (=='=') str of + (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment) + (name,_:value) -> (name,value) + + builder :: LPWSTR -> IO [String] + builder ptr = go 0 + where + go :: Int -> IO [String] + go off = do + (str, l) <- peekCWStringOff ptr off + if l == 0 + then pure [] + else (str:) <$> go (((l + 1) * 2) + off) + + +peekCWStringOff :: CWString -> Int -> IO (String, Int) +peekCWStringOff cp off = do + cs <- peekArray0 wNUL (cp `plusPtr` off) + return (cWcharsToChars cs, length cs) + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> [Char] +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = [] + diff --git a/System/Win32/Console/Internal.hsc b/System/Win32/Console/Internal.hsc --- a/System/Win32/Console/Internal.hsc +++ b/System/Win32/Console/Internal.hsc @@ -66,6 +66,15 @@ foreign import WINDOWS_CCONV unsafe "processenv.h GetCommandLineW" getCommandLineW :: IO LPWSTR +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentVariableW" + c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentStringsW" + c_GetEnvironmentStringsW :: IO LPWSTR + +foreign import WINDOWS_CCONV unsafe "processenv.h FreeEnvironmentStringsW" + c_FreeEnvironmentStrings :: LPWSTR -> IO Bool + data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO { dwSize :: COORD , dwCursorPosition :: COORD diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -189,6 +189,7 @@ , createDirectoryEx , removeDirectory , getBinaryType + , getTempFileName -- * HANDLE operations , createFile @@ -245,6 +246,7 @@ import Foreign hiding (void) import Control.Monad import Control.Concurrent +import Data.Maybe (fromMaybe) ##include "windows_cconv.h" @@ -344,6 +346,22 @@ failIfFalse_ (unwords ["GetBinaryType",show name]) $ c_GetBinaryType c_name p_btype peek p_btype + +-- | Get a unique temporary filename. +-- +-- Calls 'GetTempFileNameW'. +getTempFileName :: String -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long) + -> String -- ^ prefix for the temporary file name + -> Maybe UINT -- ^ if 'Nothing', a unique name is generated + -- otherwise a non-zero value is used as the unique part + -> IO (String, UINT) +getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do + uid <- withFilePath dir $ \c_dir -> + withFilePath prefix $ \ c_prefix -> do + failIfZero "getTempFileName" $ + c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf + fname <- peekTString c_buf + return (fname, uid) ---------------------------------------------------------------- -- HANDLE operations diff --git a/System/Win32/File/Internal.hsc b/System/Win32/File/Internal.hsc --- a/System/Win32/File/Internal.hsc +++ b/System/Win32/File/Internal.hsc @@ -399,6 +399,9 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetFileInformationByHandle" c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h GetTempFileNameW" + c_GetTempFileNameW :: LPCWSTR -> LPCWSTR -> UINT -> LPWSTR -> IO UINT + ---------------------------------------------------------------- -- Read/write files ---------------------------------------------------------------- diff --git a/System/Win32/Types.hsc b/System/Win32/Types.hsc --- a/System/Win32/Types.hsc +++ b/System/Win32/Types.hsc @@ -456,6 +456,8 @@ eRROR_PROC_NOT_FOUND :: ErrCode eRROR_PROC_NOT_FOUND = #const ERROR_PROC_NOT_FOUND +eERROR_ENVVAR_NOT_FOUND :: ErrCode +eERROR_ENVVAR_NOT_FOUND = #const ERROR_ENVVAR_NOT_FOUND errorWin :: String -> IO a errorWin fn_name = do diff --git a/System/Win32/WindowsString/Console.hsc b/System/Win32/WindowsString/Console.hsc --- a/System/Win32/WindowsString/Console.hsc +++ b/System/Win32/WindowsString/Console.hsc @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Win32.WindowsString.Console @@ -51,7 +53,11 @@ getConsoleScreenBufferInfo, getCurrentConsoleScreenBufferInfo, getConsoleScreenBufferInfoEx, - getCurrentConsoleScreenBufferInfoEx + getCurrentConsoleScreenBufferInfoEx, + + -- * Env + getEnv, + getEnvironment ) where #include @@ -60,15 +66,36 @@ #include "wincon_compat.h" import System.Win32.WindowsString.Types +import System.Win32.WindowsString.String (withTStringBufferLen) import System.Win32.Console.Internal -import System.Win32.Console hiding (getArgs, commandLineToArgv) +import System.Win32.Console hiding (getArgs, commandLineToArgv, getEnv, getEnvironment) import System.OsString.Windows +import System.OsString.Internal.Types +import Foreign.C.Types (CWchar) +import Foreign.C.String (CWString) +import Foreign.Ptr (plusPtr) import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Array (peekArray, peekArray0) import Foreign.Marshal.Alloc (alloca) +import GHC.IO (bracket) +import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) +import Prelude hiding (break, length, tail) +import qualified Prelude as P +#if !MIN_VERSION_filepath(1,5,0) +import Data.Coerce +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC + +tail :: WindowsString -> WindowsString +tail = coerce BC.tail + +break :: (WindowsChar -> Bool) -> WindowsString -> (WindowsString, WindowsString) +break = coerce BC.break +#endif + + -- | This function can be used to parse command line arguments and return -- the split up arguments as elements in a list. commandLineToArgv :: WindowsString -> IO [WindowsString] @@ -88,4 +115,66 @@ getArgs :: IO [WindowsString] getArgs = do getCommandLineW >>= peekTString >>= commandLineToArgv + + +-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD +getEnv :: WindowsString -> IO (Maybe WindowsString) +getEnv name = + withTString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- c_GetEnvironmentVariableW c_name buf c_len + case c_len' of + 0 -> do + err_code <- getLastError + if err_code == eERROR_ENVVAR_NOT_FOUND + then return Nothing + else errorWin "GetEnvironmentVariableW" + _ | c_len' > fromIntegral maxLength -> + -- shouldn't happen, because we provide maxLength + ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) + | otherwise -> do + let len' = fromIntegral c_len' + Just <$> peekTStringLen (buf, len') + where + -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew + -- max characters (wide chars): 32767 + -- => bytes = 32767 * 2 = 65534 + -- +1 byte for NUL (although not needed I think) + maxLength :: Int + maxLength = 65535 + + +getEnvironment :: IO [(WindowsString, WindowsString)] +getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do + strs <- builder lpwstr + return (divvy <$> strs) + where + divvy :: WindowsString -> (WindowsString, WindowsString) + divvy str = + case break (== unsafeFromChar '=') str of + (xs,ys) + | ys == mempty -> (xs,ys) -- don't barf (like Posix.getEnvironment) + (name, ys) -> let value = tail ys in (name,value) + + builder :: LPWSTR -> IO [WindowsString] + builder ptr = go 0 + where + go :: Int -> IO [WindowsString] + go off = do + (str, l) <- peekCWStringOff ptr off + if l == 0 + then pure [] + else (str:) <$> go (((l + 1) * 2) + off) + + +peekCWStringOff :: CWString -> Int -> IO (WindowsString, Int) +peekCWStringOff cp off = do + cs <- peekArray0 wNUL (cp `plusPtr` off) + return (cWcharsToChars cs, P.length cs) + +wNUL :: CWchar +wNUL = 0 + +cWcharsToChars :: [CWchar] -> WindowsString +cWcharsToChars = pack . fmap (WindowsChar . fromIntegral) diff --git a/System/Win32/WindowsString/File.hsc b/System/Win32/WindowsString/File.hsc --- a/System/Win32/WindowsString/File.hsc +++ b/System/Win32/WindowsString/File.hsc @@ -26,6 +26,7 @@ , setFileAttributes , getFileAttributes , getFileAttributesExStandard + , getTempFileName , findFirstChangeNotification , getFindDataFileName , findFirstFile @@ -52,6 +53,7 @@ , setFileAttributes , getFileAttributes , getFileAttributesExStandard + , getTempFileName , findFirstChangeNotification , getFindDataFileName , findFirstFile @@ -64,6 +66,7 @@ import System.Win32.WindowsString.Types import System.OsString.Windows import Unsafe.Coerce (unsafeCoerce) +import Data.Maybe (fromMaybe) import Foreign hiding (void) @@ -160,6 +163,23 @@ failIfFalseWithRetry_ "getFileAttributesExStandard" $ c_GetFileAttributesEx c_name (unsafeCoerce getFileExInfoStandard) res peek res + +-- | Get a unique temporary filename. +-- +-- Calls 'GetTempFileNameW'. +getTempFileName :: WindowsString -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long) + -> WindowsString -- ^ prefix for the temporary file name + -> Maybe UINT -- ^ if 'Nothing', a unique name is generated + -- otherwise a non-zero value is used as the unique part + -> IO (WindowsString, UINT) +getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do + uid <- withFilePath dir $ \c_dir -> + withFilePath prefix $ \ c_prefix -> do + failIfZero "getTempFileName" $ + c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf + fname <- peekTString c_buf + pure (fname, uid) + ---------------------------------------------------------------- diff --git a/System/Win32/WindowsString/String.hs b/System/Win32/WindowsString/String.hs --- a/System/Win32/WindowsString/String.hs +++ b/System/Win32/WindowsString/String.hs @@ -30,7 +30,7 @@ ) import System.Win32.WindowsString.Types import System.OsString.Internal.Types -#if MIN_VERSION_filepath(1, 5, 0) +#if MIN_VERSION_filepath(1,5,0) import qualified "os-string" System.OsString.Data.ByteString.Short as SBS #else import qualified "filepath" System.OsPath.Data.ByteString.Short as SBS diff --git a/System/Win32/WindowsString/Types.hsc b/System/Win32/WindowsString/Types.hsc --- a/System/Win32/WindowsString/Types.hsc +++ b/System/Win32/WindowsString/Types.hsc @@ -49,7 +49,7 @@ import System.OsPath.Windows (WindowsPath) import System.OsString.Windows (decodeWith, encodeWith) import System.OsString.Internal.Types -#if MIN_VERSION_filepath(1, 5, 0) +#if MIN_VERSION_filepath(1,5,0) import "os-string" System.OsString.Encoding.Internal (decodeWithBaseWindows) import qualified "os-string" System.OsString.Data.ByteString.Short.Word16 as SBS import "os-string" System.OsString.Data.ByteString.Short.Word16 ( diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: Win32 -version: 2.14.0.0 +version: 2.14.1.0 license: BSD3 license-file: LICENSE author: Alastair Reid, shelarcy, Tamar Christina @@ -154,7 +154,6 @@ "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32" ghc-options: -Wall include-dirs: include - includes: "alphablend.h", "diatemp.h", "dumpBMP.h", "ellipse.h", "errors.h", "HsGDI.h", "HsWin32.h", "Win32Aux.h", "win32debug.h", "windows_cconv.h", "WndProc.h", "alignment.h" install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "wincon_compat.h", "winternl_compat.h", "winuser_compat.h", "winreg_compat.h", "tlhelp32_compat.h", "winnls_compat.h", "winnt_compat.h", "namedpipeapi_compat.h" c-sources: cbits/HsGDI.c diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) +## 2.14.1.0 November 2024 + +* Add getTempFileName +* Add WindowsString variant for getEnv etc +* Implement getEnv and getEnvironment + ## 2.14.0.0 January 2023 * Add support for named pipes [#220](https://github.com/haskell/win32/pull/220)