diff options
Diffstat (limited to '')
| -rw-r--r-- | src/Environment.hs | 122 | ||||
| -rw-r--r-- | src/Registry.hs | 2 | ||||
| -rw-r--r-- | src/Utils.hs | 32 | ||||
| -rw-r--r-- | src/WindowsUtils.hs | 28 |
4 files changed, 74 insertions, 110 deletions
diff --git a/src/Environment.hs b/src/Environment.hs index 68a3917..f370de4 100644 --- a/src/Environment.hs +++ b/src/Environment.hs @@ -5,116 +5,84 @@ -} module Environment - ( RegistryLocation(..) + ( Profile(..) + , profileKeyPath + + , VarName + , VarValue , query , engrave - , engravePrompt , wipe - , wipePrompt , pathJoin , pathSplit ) where -import Control.Monad (when) import Data.List (intercalate) import Data.List.Split (splitOn) -import Data.Maybe (fromJust, isJust) import System.IO.Error (catchIOError, isDoesNotExistError) -import qualified Graphics.Win32.GDI.Types as WinAPI -import qualified Graphics.Win32.Message as WinAPI -import qualified System.Win32.Types as WinAPI - import qualified Registry -import qualified Utils (promptToContinue) +import WindowsUtils (notifyEnvironmentUpdate) -data RegistryLocation - = CurrentUser - | AllUsers - deriving (Eq, Show) +data Profile = CurrentUser + | AllUsers + deriving (Eq, Show) -subKeyPath :: RegistryLocation -> Registry.KeyPath -subKeyPath CurrentUser = - Registry.keyPathFromString "Environment" -subKeyPath AllUsers = - Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" +profileRootKey :: Profile -> Registry.RootKey +profileRootKey CurrentUser = Registry.CurrentUser +profileRootKey AllUsers = Registry.LocalMachine -rootKey :: RegistryLocation -> Registry.RootKey -rootKey CurrentUser = Registry.CurrentUser -rootKey AllUsers = Registry.LocalMachine +profileRootKeyPath :: Profile -> Registry.KeyPath +profileRootKeyPath = Registry.rootKeyPath . profileRootKey -openRootKey :: RegistryLocation -> Registry.KeyHandle -openRootKey = Registry.openRootKey . rootKey +profileSubKeyPath :: Profile -> Registry.KeyPath +profileSubKeyPath CurrentUser = + Registry.keyPathFromString "Environment" +profileSubKeyPath AllUsers = + Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" -openRegistryKey :: RegistryLocation -> IO Registry.KeyHandle -openRegistryKey env = Registry.openSubKey (openRootKey env) (subKeyPath env) +profileKeyPath :: Profile -> Registry.KeyPath +profileKeyPath profile = Registry.keyPathJoin + [ profileRootKeyPath profile + , profileSubKeyPath profile + ] -registryKeyPath :: RegistryLocation -> Registry.KeyPath -registryKeyPath env = Registry.keyPathJoin [Registry.rootKeyPath $ rootKey env, subKeyPath env] +openRootProfileKey :: Profile -> Registry.KeyHandle +openRootProfileKey = Registry.openRootKey . profileRootKey -foreign import ccall "SendNotifyMessageW" - c_SendNotifyMessage :: WinAPI.HWND -> WinAPI.WindowMessage -> WinAPI.WPARAM -> WinAPI.LPARAM -> IO WinAPI.LRESULT +openProfileKey :: Profile -> IO Registry.KeyHandle +openProfileKey profile = Registry.openSubKey (openRootProfileKey profile) (profileSubKeyPath profile) -notifyEnvUpdate :: IO () -notifyEnvUpdate = - 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 +type VarName = Registry.ValueName +type VarValue = Registry.ValueData -query :: RegistryLocation -> Registry.ValueName -> IO (Maybe Registry.ValueData) -query env name = do - keyHandle <- openRegistryKey env +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 :: RegistryLocation -> Registry.ValueName -> Registry.ValueData -> IO () -engrave env name value = do - keyHandle <- openRegistryKey env +engrave :: Profile -> VarName -> VarValue -> IO () +engrave profile name value = do + keyHandle <- openProfileKey profile Registry.setString keyHandle name value - notifyEnvUpdate - -engravePrompt :: RegistryLocation -> Registry.ValueName -> Registry.ValueData -> IO Bool -engravePrompt env name value = do - putStrLn $ "Saving variable '" ++ name ++ "' to '" ++ registryKeyPath env ++ "'..." - oldValue <- query env name - if (isJust oldValue) - then do - putStrLn $ "\tOld value: " ++ fromJust oldValue - putStrLn $ "\tNew value: " ++ value - else do - putStrLn $ "\tValue: " ++ value - agreed <- Utils.promptToContinue - when agreed $ engrave env name value - return agreed - -wipe :: RegistryLocation -> Registry.ValueName -> IO () -wipe env name = do - keyHandle <- openRegistryKey env + notifyEnvironmentUpdate + +wipe :: Profile -> VarName -> IO () +wipe profile name = do + keyHandle <- openProfileKey profile catchIOError (Registry.delValue keyHandle name) ignoreIfDoesNotExist - notifyEnvUpdate + notifyEnvironmentUpdate where ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e -wipePrompt :: RegistryLocation -> Registry.ValueName -> IO Bool -wipePrompt env name = do - putStrLn $ "Deleting variable '" ++ name ++ "' from '" ++ registryKeyPath env ++ "'..." - agreed <- Utils.promptToContinue - when agreed $ wipe env name - return agreed - -pathSep :: String +pathSep :: VarValue pathSep = ";" -pathSplit :: String -> [String] +pathSplit :: VarValue -> [VarValue] pathSplit = filter (not . null) . splitOn pathSep -pathJoin :: [String] -> String +pathJoin :: [VarValue] -> VarValue pathJoin = intercalate pathSep . filter (not . null) diff --git a/src/Registry.hs b/src/Registry.hs index 4a7c593..48d69f0 100644 --- a/src/Registry.hs +++ b/src/Registry.hs @@ -14,8 +14,8 @@ module Registry , openSubKey , RootKey(..) - , openRootKey , rootKeyPath + , openRootKey , ValueName , delValue diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 index 143696b..0000000 --- a/src/Utils.hs +++ /dev/null @@ -1,32 +0,0 @@ -{- - - Copyright 2015 Egor Tensin <Egor.Tensin@gmail.com> - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Utils where - -import Control.Monad (liftM) -import Data.Char (toLower) -import System.IO (hFlush, stdout) - -prompt :: String -> IO String -prompt banner = do - putStr banner - hFlush stdout - getLine - -promptYesNo :: String -> IO Bool -promptYesNo banner = do - response <- liftM (map toLower) $ prompt banner - if response `elem` yeses - then return True - else if response `elem` noes - then return False - else promptToContinue - where - yeses = ["y", "yes"] - noes = ["n", "no"] - -promptToContinue :: IO Bool -promptToContinue = promptYesNo "Continue? (y/n) " diff --git a/src/WindowsUtils.hs b/src/WindowsUtils.hs new file mode 100644 index 0000000..6fa1f0e --- /dev/null +++ b/src/WindowsUtils.hs @@ -0,0 +1,28 @@ +{- + - Copyright 2016 Egor Tensin <Egor.Tensin@gmail.com> + - 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 |