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/Environment.hs | 88 --------------------------- src/Registry.hs | 145 --------------------------------------------- src/Windows/Environment.hs | 88 +++++++++++++++++++++++++++ src/Windows/Registry.hs | 145 +++++++++++++++++++++++++++++++++++++++++++++ src/Windows/Utils.hs | 28 +++++++++ src/WindowsUtils.hs | 28 --------- 6 files changed, 261 insertions(+), 261 deletions(-) delete mode 100644 src/Environment.hs delete mode 100644 src/Registry.hs create mode 100644 src/Windows/Environment.hs create mode 100644 src/Windows/Registry.hs create mode 100644 src/Windows/Utils.hs delete mode 100644 src/WindowsUtils.hs (limited to 'src') diff --git a/src/Environment.hs b/src/Environment.hs deleted file mode 100644 index f370de4..0000000 --- a/src/Environment.hs +++ /dev/null @@ -1,88 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module 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 Registry -import WindowsUtils (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/Registry.hs b/src/Registry.hs deleted file mode 100644 index 48d69f0..0000000 --- a/src/Registry.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module 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/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 diff --git a/src/WindowsUtils.hs b/src/WindowsUtils.hs deleted file mode 100644 index 6fa1f0e..0000000 --- a/src/WindowsUtils.hs +++ /dev/null @@ -1,28 +0,0 @@ -{- - - Copyright 2016 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module WindowsUtils - ( 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