diff options
author | Egor Tensin <Egor.Tensin@gmail.com> | 2016-07-11 19:11:23 +0300 |
---|---|---|
committer | Egor Tensin <Egor.Tensin@gmail.com> | 2016-07-11 19:11:23 +0300 |
commit | 7b3fd9218596a2d7a14a92625a4d62c9a7b7b0f6 (patch) | |
tree | 8195393c18d0cdd3d9ebcdadb014d75285bfaf7e /src | |
parent | become a proper stack project (diff) | |
download | windows-env-7b3fd9218596a2d7a14a92625a4d62c9a7b7b0f6.tar.gz windows-env-7b3fd9218596a2d7a14a92625a4d62c9a7b7b0f6.zip |
rename modules + fix compiler warnings
Diffstat (limited to 'src')
-rw-r--r-- | src/Environment.hs (renamed from src/EnvUtils.hs) | 32 | ||||
-rw-r--r-- | src/Registry.hs (renamed from src/RegUtils.hs) | 42 |
2 files changed, 41 insertions, 33 deletions
diff --git a/src/EnvUtils.hs b/src/Environment.hs index 7e9bc96..0690278 100644 --- a/src/EnvUtils.hs +++ b/src/Environment.hs @@ -4,15 +4,15 @@ - See LICENSE.txt for details. -} -module EnvUtils ( saveToRegistry - , saveToRegistryWithPrompt - , queryFromRegistry - , wipeFromRegistry - , wipeFromRegistryWithPrompt - , getEnv - , splitPaths - , joinPaths - , RegistryBasedEnvironment ( CurrentUserEnvironment, AllUsersEnvironment ) ) where +module Environment ( saveToRegistry + , saveToRegistryWithPrompt + , queryFromRegistry + , wipeFromRegistry + , wipeFromRegistryWithPrompt + , getEnv + , splitPaths + , joinPaths + , RegistryBasedEnvironment(..) ) where import Control.Monad ( liftM, when ) import Data.List ( intercalate ) @@ -21,7 +21,7 @@ import Data.Maybe ( fromMaybe ) import qualified System.Environment ( lookupEnv ) import System.IO.Error ( catchIOError, isDoesNotExistError ) -import qualified RegUtils +import qualified Registry import qualified Utils ( promptToContinue ) data RegistryBasedEnvironment = CurrentUserEnvironment @@ -32,15 +32,16 @@ registrySubKeyPath :: RegistryBasedEnvironment -> String registrySubKeyPath CurrentUserEnvironment = "Environment" registrySubKeyPath AllUsersEnvironment = "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" -registryKey CurrentUserEnvironment = RegUtils.hkcu -registryKey AllUsersEnvironment = RegUtils.hklm +registryKey :: RegistryBasedEnvironment -> Registry.KeyHandle +registryKey CurrentUserEnvironment = Registry.hkcu +registryKey AllUsersEnvironment = Registry.hklm registryKeyPath :: RegistryBasedEnvironment -> String registryKeyPath CurrentUserEnvironment = "HKCU\\" ++ registrySubKeyPath CurrentUserEnvironment registryKeyPath AllUsersEnvironment = "HKLM\\" ++ registrySubKeyPath AllUsersEnvironment saveToRegistry :: RegistryBasedEnvironment -> String -> String -> IO () -saveToRegistry env = RegUtils.setString (registryKey env) (registrySubKeyPath env) +saveToRegistry env = Registry.setString (registryKey env) (registrySubKeyPath env) saveToRegistryWithPrompt :: RegistryBasedEnvironment -> String -> String -> IO () saveToRegistryWithPrompt env name value = do @@ -52,13 +53,13 @@ saveToRegistryWithPrompt env name value = do when agreed $ saveToRegistry env name value queryFromRegistry :: RegistryBasedEnvironment -> String -> IO String -queryFromRegistry env name = catchIOError (RegUtils.getString (registryKey env) (registrySubKeyPath env) name) emptyIfDoesNotExist +queryFromRegistry env name = catchIOError (Registry.getString (registryKey env) (registrySubKeyPath env) name) emptyIfDoesNotExist where emptyIfDoesNotExist :: IOError -> IO String emptyIfDoesNotExist e = if isDoesNotExistError e then return "" else ioError e wipeFromRegistry :: RegistryBasedEnvironment -> String -> IO () -wipeFromRegistry env name = catchIOError (RegUtils.delValue (registryKey env) (registrySubKeyPath env) name) ignoreIfDoesNotExist +wipeFromRegistry env name = catchIOError (Registry.delValue (registryKey env) (registrySubKeyPath env) name) ignoreIfDoesNotExist where ignoreIfDoesNotExist :: IOError -> IO () ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e @@ -72,6 +73,7 @@ wipeFromRegistryWithPrompt env name = do getEnv :: String -> IO String getEnv = liftM (fromMaybe "") . System.Environment.lookupEnv +pathSep :: String pathSep = ";" splitPaths :: String -> [String] diff --git a/src/RegUtils.hs b/src/Registry.hs index eccb6ad..d6c3f26 100644 --- a/src/RegUtils.hs +++ b/src/Registry.hs @@ -4,11 +4,12 @@ - See LICENSE.txt for details. -} -module RegUtils ( delValue +module Registry ( delValue , getString , hkcu , hklm - , setString ) where + , setString + , KeyHandle ) where import Control.Exception ( bracket ) import Data.Maybe ( fromMaybe ) @@ -21,10 +22,12 @@ import System.IO.Error ( mkIOError, doesNotExistErrorType ) import System.Win32.Types import System.Win32.Registry +newtype KeyHandle = KeyHandle HKEY + getType :: HKEY -> String -> String -> IO (Maybe RegValueType) getType key subKeyPath valueName = - bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> - withForeignPtr key $ \p_key -> + bracket (regOpenKey key subKeyPath) regCloseKey $ \hKey -> + withForeignPtr hKey $ \p_key -> withTString valueName $ \p_valueName -> alloca $ \p_type -> do ret <- c_RegQueryValueEx p_key p_valueName nullPtr p_type nullPtr nullPtr @@ -35,10 +38,10 @@ getType key subKeyPath valueName = 0x2 -> return Nothing _ -> failWith "RegQueryValueEx" ret -getString :: HKEY -> String -> String -> IO String -getString key subKeyPath valueName = - bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> - withForeignPtr key $ \p_key -> +getString :: KeyHandle -> String -> String -> IO String +getString (KeyHandle hKey) subKeyPath valueName = + bracket (regOpenKey hKey subKeyPath) regCloseKey $ \hSubKey -> + withForeignPtr hSubKey $ \p_key -> withTString valueName $ \p_valueName -> alloca $ \dataSizePtr -> do poke dataSizePtr 0 @@ -56,11 +59,11 @@ getString key subKeyPath valueName = 0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName) _ -> failWith "RegQueryValueEx" ret -setString :: HKEY -> String -> String -> String -> IO () -setString key subKeyPath valueName valueValue = - bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey -> +setString :: KeyHandle -> String -> String -> String -> IO () +setString (KeyHandle hKey) subKeyPath valueName valueValue = + bracket (regOpenKey hKey subKeyPath) regCloseKey $ \subKey -> withTString valueValue $ \p_valueValue -> do - type_ <- getType key subKeyPath valueName + type_ <- getType hKey subKeyPath valueName regSetValueEx subKey valueName (fromMaybe rEG_SZ type_) p_valueValue $ (length valueValue + 1) * sizeOf (undefined :: TCHAR) notifyEnvironmentUpdate @@ -70,14 +73,14 @@ notifyEnvironmentUpdate = let wparam = 0 let lparam = fromIntegral $ castPtrToUINTPtr p_lparam let hwnd = castUINTPtrToPtr 0xffff - sendMessage hwnd wM_SETTINGCHANGE wparam lparam + _ <- sendMessage hwnd wM_SETTINGCHANGE wparam lparam return () where wM_SETTINGCHANGE = 0x1A -delValue :: HKEY -> String -> String -> IO () -delValue key subKeyPath valueName = - bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey -> +delValue :: KeyHandle -> String -> String -> IO () +delValue (KeyHandle hKey) subKeyPath valueName = + bracket (regOpenKey hKey subKeyPath) regCloseKey $ \subKey -> withForeignPtr subKey $ \subKeyPtr -> withTString valueName $ \p_valueName -> do ret <- c_RegDeleteValue subKeyPtr p_valueName @@ -87,5 +90,8 @@ delValue key subKeyPath valueName = 0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName) _ -> failWith "RegDeleteValue" ret -hkcu = hKEY_CURRENT_USER -hklm = hKEY_LOCAL_MACHINE +hkcu :: KeyHandle +hkcu = KeyHandle hKEY_CURRENT_USER + +hklm :: KeyHandle +hklm = KeyHandle hKEY_LOCAL_MACHINE |