From 427ae9ad54492954578cafbfcd2d815a084e0986 Mon Sep 17 00:00:00 2001 From: Egor Tensin Date: Mon, 18 Jul 2016 00:17:44 +0300 Subject: put modules to 'Windows' --- src/Windows/Environment.hs | 88 +++++++++++++++++++++++++++ src/Windows/Registry.hs | 145 +++++++++++++++++++++++++++++++++++++++++++++ src/Windows/Utils.hs | 28 +++++++++ 3 files changed, 261 insertions(+) create mode 100644 src/Windows/Environment.hs create mode 100644 src/Windows/Registry.hs create mode 100644 src/Windows/Utils.hs (limited to 'src/Windows') diff --git a/src/Windows/Environment.hs b/src/Windows/Environment.hs new file mode 100644 index 0000000..2bea481 --- /dev/null +++ b/src/Windows/Environment.hs @@ -0,0 +1,88 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Windows.Environment + ( Profile(..) + , profileKeyPath + + , VarName + , VarValue + , query + , engrave + , wipe + + , pathJoin + , pathSplit + ) where + +import Data.List (intercalate) +import Data.List.Split (splitOn) +import System.IO.Error (catchIOError, isDoesNotExistError) + +import qualified Windows.Registry as Registry +import Windows.Utils (notifyEnvironmentUpdate) + +data Profile = CurrentUser + | AllUsers + deriving (Eq, Show) + +profileRootKey :: Profile -> Registry.RootKey +profileRootKey CurrentUser = Registry.CurrentUser +profileRootKey AllUsers = Registry.LocalMachine + +profileRootKeyPath :: Profile -> Registry.KeyPath +profileRootKeyPath = Registry.rootKeyPath . profileRootKey + +profileSubKeyPath :: Profile -> Registry.KeyPath +profileSubKeyPath CurrentUser = + Registry.keyPathFromString "Environment" +profileSubKeyPath AllUsers = + Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" + +profileKeyPath :: Profile -> Registry.KeyPath +profileKeyPath profile = Registry.keyPathJoin + [ profileRootKeyPath profile + , profileSubKeyPath profile + ] + +openRootProfileKey :: Profile -> Registry.KeyHandle +openRootProfileKey = Registry.openRootKey . profileRootKey + +openProfileKey :: Profile -> IO Registry.KeyHandle +openProfileKey profile = Registry.openSubKey (openRootProfileKey profile) (profileSubKeyPath profile) + +type VarName = Registry.ValueName +type VarValue = Registry.ValueData + +query :: Profile -> VarName -> IO (Maybe VarValue) +query profile name = do + keyHandle <- openProfileKey profile + catchIOError (Registry.getString keyHandle name >>= return . Just) emptyIfDoesNotExist + where + emptyIfDoesNotExist e = if isDoesNotExistError e then return Nothing else ioError e + +engrave :: Profile -> VarName -> VarValue -> IO () +engrave profile name value = do + keyHandle <- openProfileKey profile + Registry.setString keyHandle name value + notifyEnvironmentUpdate + +wipe :: Profile -> VarName -> IO () +wipe profile name = do + keyHandle <- openProfileKey profile + catchIOError (Registry.delValue keyHandle name) ignoreIfDoesNotExist + notifyEnvironmentUpdate + where + ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e + +pathSep :: VarValue +pathSep = ";" + +pathSplit :: VarValue -> [VarValue] +pathSplit = filter (not . null) . splitOn pathSep + +pathJoin :: [VarValue] -> VarValue +pathJoin = intercalate pathSep . filter (not . null) diff --git a/src/Windows/Registry.hs b/src/Windows/Registry.hs new file mode 100644 index 0000000..528027f --- /dev/null +++ b/src/Windows/Registry.hs @@ -0,0 +1,145 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Windows.Registry + ( KeyPath + , keyPathFromString + , keyPathJoin + , keyPathSplit + + , KeyHandle + , openSubKey + + , RootKey(..) + , rootKeyPath + , openRootKey + + , ValueName + , delValue + + , ValueData + , getString + , setString + ) where + +import Data.List (intercalate) +import Data.List.Split (splitOn) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Ptr (castPtr, plusPtr) +import Foreign.Storable (peek, poke, sizeOf) +import System.IO.Error (catchIOError, doesNotExistErrorType, mkIOError, isDoesNotExistError) + +import qualified System.Win32.Registry as WinAPI +import qualified System.Win32.Types as WinAPI + +type KeyName = String +type KeyPath = KeyName + +keyPathSep :: KeyPath +keyPathSep = "\\" + +keyPathFromString :: String -> KeyPath +keyPathFromString = keyPathJoin . keyPathSplit + +keyPathSplit :: KeyPath -> [KeyName] +keyPathSplit = filter (not . null) . splitOn keyPathSep + +keyPathJoin :: [KeyName] -> KeyPath +keyPathJoin = intercalate keyPathSep . filter (not . null) + +type KeyHandle = WinAPI.HKEY + +openSubKey :: KeyHandle -> KeyPath -> IO KeyHandle +openSubKey = WinAPI.regOpenKey + +data RootKey = CurrentUser + | LocalMachine + deriving (Eq, Show) + +rootKeyPath :: RootKey -> KeyName +rootKeyPath CurrentUser = "HKCU" +rootKeyPath LocalMachine = "HKLM" + +openRootKey :: RootKey -> KeyHandle +openRootKey CurrentUser = WinAPI.hKEY_CURRENT_USER +openRootKey LocalMachine = WinAPI.hKEY_LOCAL_MACHINE + +type ValueName = String + +raiseDoesNotExistError :: String -> IO a +raiseDoesNotExistError functionName = + ioError $ mkIOError doesNotExistErrorType functionName Nothing Nothing + +raiseUnknownError :: String -> WinAPI.ErrCode -> IO a +raiseUnknownError functionName exitCode = WinAPI.failWith functionName exitCode + +exitCodeSuccess :: WinAPI.ErrCode +exitCodeSuccess = 0 + +exitCodeFileNotFound :: WinAPI.ErrCode +exitCodeFileNotFound = 0x2 + +raiseError :: String -> WinAPI.ErrCode -> IO a +raiseError functionName ret + | ret == exitCodeFileNotFound = raiseDoesNotExistError functionName + | otherwise = raiseUnknownError functionName ret + +delValue :: KeyHandle -> ValueName -> IO () +delValue keyHandle valueName = + withForeignPtr keyHandle $ \keyPtr -> + WinAPI.withTString valueName $ \valueNamePtr -> do + ret <- WinAPI.c_RegDeleteValue keyPtr valueNamePtr + if ret == exitCodeSuccess + then return () + else raiseError "RegDeleteValue" ret + +type ValueType = WinAPI.RegValueType + +getType :: KeyHandle -> ValueName -> IO ValueType +getType keyHandle valueName = + withForeignPtr keyHandle $ \keyPtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \typePtr -> do + ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr typePtr WinAPI.nullPtr WinAPI.nullPtr + if ret == exitCodeSuccess + then peek typePtr + else raiseError "RegQueryValueEx" ret + +type ValueData = String + +getString :: KeyHandle -> ValueName -> IO ValueData +getString keyHandle valueName = + withForeignPtr keyHandle $ \keyPtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \dataSizePtr -> do + poke dataSizePtr 0 + ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr WinAPI.nullPtr dataSizePtr + if ret /= exitCodeSuccess + then raiseError "RegQueryValueEx" ret + else getStringTerminated keyPtr valueNamePtr dataSizePtr + where + getStringTerminated keyPtr valueNamePtr dataSizePtr = do + dataSize <- peek dataSizePtr + let newDataSize = dataSize + fromIntegral (sizeOf (undefined :: WinAPI.TCHAR)) + poke dataSizePtr newDataSize + allocaBytes (fromIntegral newDataSize) $ \dataPtr -> do + poke (castPtr $ plusPtr dataPtr $ fromIntegral dataSize) '\0' + ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr dataPtr dataSizePtr + if ret == exitCodeSuccess + then WinAPI.peekTString $ castPtr dataPtr + else raiseError "RegQueryValueEx" ret + +setString :: KeyHandle -> ValueName -> ValueData -> IO () +setString key name value = + WinAPI.withTString value $ \valuePtr -> do + type_ <- catchIOError (getType key name) stringTypeByDefault + WinAPI.regSetValueEx key name type_ valuePtr valueSize + where + stringTypeByDefault e = if isDoesNotExistError e + then return WinAPI.rEG_SZ + else ioError e + valueSize = (length value + 1) * sizeOf (undefined :: WinAPI.TCHAR) diff --git a/src/Windows/Utils.hs b/src/Windows/Utils.hs new file mode 100644 index 0000000..aad241f --- /dev/null +++ b/src/Windows/Utils.hs @@ -0,0 +1,28 @@ +{- + - Copyright 2016 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Windows.Utils + ( notifyEnvironmentUpdate + ) where + +import qualified Graphics.Win32.GDI.Types as WinAPI +import qualified Graphics.Win32.Message as WinAPI +import qualified System.Win32.Types as WinAPI + +foreign import ccall "SendNotifyMessageW" + c_SendNotifyMessage :: WinAPI.HWND -> WinAPI.WindowMessage -> WinAPI.WPARAM -> WinAPI.LPARAM -> IO WinAPI.LRESULT + +notifyEnvironmentUpdate :: IO () +notifyEnvironmentUpdate = + WinAPI.withTString "Environment" $ \lparamPtr -> do + let wparam = 0 + let lparam = fromIntegral $ WinAPI.castPtrToUINTPtr lparamPtr + _ <- c_SendNotifyMessage allWindows messageCode wparam lparam + return () + where + messageCode = WinAPI.wM_WININICHANGE + hWND_BROADCAST = WinAPI.castUINTPtrToPtr 0xffff + allWindows = hWND_BROADCAST -- cgit v1.2.3