aboutsummaryrefslogtreecommitdiffstatshomepage
path: root/src
diff options
context:
space:
mode:
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 17:40:16 +0000