diff options
author | Egor Tensin <Egor.Tensin@gmail.com> | 2016-07-12 00:29:40 +0300 |
---|---|---|
committer | Egor Tensin <Egor.Tensin@gmail.com> | 2016-07-12 00:29:40 +0300 |
commit | 7b4f37ffad0098a829f8b1c9cab26d51cd732bbc (patch) | |
tree | 4a3eb18e9e73fa570c043dc543e19b78d277c6bd | |
parent | rename modules + fix compiler warnings (diff) | |
download | windows-env-7b4f37ffad0098a829f8b1c9cab26d51cd732bbc.tar.gz windows-env-7b4f37ffad0098a829f8b1c9cab26d51cd732bbc.zip |
code style
Diffstat (limited to '')
-rw-r--r-- | apps/AddPath.hs | 85 | ||||
-rw-r--r-- | apps/FixNtSymbolPath.hs | 50 | ||||
-rw-r--r-- | apps/ListPath.hs | 66 | ||||
-rw-r--r-- | apps/RemovePath.hs | 92 | ||||
-rw-r--r-- | apps/SetEnv.hs | 65 | ||||
-rw-r--r-- | apps/UnsetEnv.hs | 63 | ||||
-rw-r--r-- | src/Environment.hs | 61 | ||||
-rw-r--r-- | src/Registry.hs | 133 | ||||
-rw-r--r-- | src/Utils.hs | 24 |
9 files changed, 327 insertions, 312 deletions
diff --git a/apps/AddPath.hs b/apps/AddPath.hs index 558c23c..e3f8ec3 100644 --- a/apps/AddPath.hs +++ b/apps/AddPath.hs @@ -4,73 +4,76 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where -import Control.Monad ( mapM_, when ) +import Control.Monad (mapM_, when) import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - addPath args options - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + addPath args options + (_, _, errorMessages) -> exitWithUsageErrors errorMessages addPath :: [String] -> Options -> IO () addPath paths options = do - missingPaths <- dropIncludedPaths paths - when (not $ null missingPaths) $ do - oldPath <- Environment.queryFromRegistry (env options) (name options) - Environment.saveToRegistryWithPrompt (env options) (name options) $ Environment.joinPaths $ missingPaths ++ [oldPath] - where - dropIncludedPaths paths = do - currentPath <- Environment.getEnv $ name options - return $ filter (flip notElem $ Environment.splitPaths currentPath) paths + missingPaths <- dropIncludedPaths paths + when (not $ null missingPaths) $ do + oldPath <- Environment.queryFromRegistry (env options) (name options) + Environment.saveToRegistryWithPrompt (env options) (name options) $ Environment.joinPaths $ missingPaths ++ [oldPath] + where + dropIncludedPaths paths = do + currentPath <- Environment.getEnv $ name options + return $ filter (flip notElem $ Environment.splitPaths currentPath) paths -data Options = Options { name :: String - , env :: Environment.RegistryBasedEnvironment } - deriving (Eq, Show) +data Options = Options + { name :: String + , env :: Environment.RegistryBasedEnvironment + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { name = "PATH" - , env = Environment.CurrentUserEnvironment } +defaultOptions = Options + { name = "PATH" + , env = Environment.CurrentUserEnvironment + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader :: IO String + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] [PATH...]\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)", - Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "add the path for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)" + , Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "add the path for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/FixNtSymbolPath.hs b/apps/FixNtSymbolPath.hs index 9a02cf9..c75291e 100644 --- a/apps/FixNtSymbolPath.hs +++ b/apps/FixNtSymbolPath.hs @@ -4,46 +4,44 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where -import Control.Monad ( unless ) -import System.Directory ( createDirectoryIfMissing, getCurrentDirectory ) -import System.FilePath ( combine ) +import Control.Monad (unless) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath (combine) import qualified Environment getRemoteSymbolsDirectoryPath :: IO String getRemoteSymbolsDirectoryPath = do - localPath <- getLocalPath - createDirectoryIfMissing True localPath - return $ "SRV*" ++ localPath ++ "*" ++ remotePath - where - getLocalPath :: IO String - getLocalPath = do + localPath <- getLocalPath + createDirectoryIfMissing True localPath + return $ "SRV*" ++ localPath ++ "*" ++ remotePath + where + getLocalPath = do cwd <- getCurrentDirectory return $ combine cwd "symbols" - remotePath :: String - remotePath = "http://msdl.microsoft.com/download/symbols" + remotePath = "http://msdl.microsoft.com/download/symbols" getPdbsDirectoryPath :: IO String getPdbsDirectoryPath = do - cwd <- getCurrentDirectory - let path = combine cwd "pdbs" - createDirectoryIfMissing True path - return path + cwd <- getCurrentDirectory + let path = combine cwd "pdbs" + createDirectoryIfMissing True path + return path fixNtSymbolPath :: IO () fixNtSymbolPath = do - let env = Environment.CurrentUserEnvironment - val <- Environment.queryFromRegistry env ntSymbolPath - let presentPaths = Environment.splitPaths val - remoteSymbolsPath <- getRemoteSymbolsDirectoryPath - pdbsPath <- getPdbsDirectoryPath - let requiredPaths = [pdbsPath, remoteSymbolsPath] - let missingPaths = filter (`notElem` presentPaths) requiredPaths - unless (null missingPaths) $ do - let newval = Environment.joinPaths $ presentPaths ++ missingPaths - Environment.saveToRegistry env ntSymbolPath newval + let env = Environment.CurrentUserEnvironment + val <- Environment.queryFromRegistry env ntSymbolPath + let presentPaths = Environment.splitPaths val + remoteSymbolsPath <- getRemoteSymbolsDirectoryPath + pdbsPath <- getPdbsDirectoryPath + let requiredPaths = [pdbsPath, remoteSymbolsPath] + let missingPaths = filter (`notElem` presentPaths) requiredPaths + unless (null missingPaths) $ do + let newval = Environment.joinPaths $ presentPaths ++ missingPaths + Environment.saveToRegistry env ntSymbolPath newval where ntSymbolPath = "_NT_SYMBOL_PATH" diff --git a/apps/ListPath.hs b/apps/ListPath.hs index 75f1b27..b964998 100644 --- a/apps/ListPath.hs +++ b/apps/ListPath.hs @@ -4,33 +4,33 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where import System.Console.GetOpt -import System.Directory ( doesDirectoryExist ) -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Directory (doesDirectoryExist) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - case args of - [] -> listPath options - _ -> invalidNumberOfArguments - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + case args of + [] -> listPath options + _ -> invalidNumberOfArguments + (_, _, errorMessages) -> exitWithUsageErrors errorMessages listPath :: Options -> IO () listPath options = do - val <- Environment.getEnv $ name options - mapM_ printPath $ Environment.splitPaths val - where - printPath p = do + val <- Environment.getEnv $ name options + mapM_ printPath $ Environment.splitPaths val + where + printPath p = do exists <- doesDirectoryExist p putStrLn $ (if exists then "+" else "-") ++ " " ++ p @@ -41,32 +41,32 @@ defaultOptions = Options { name = "PATH" } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader :: IO String + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...]\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs index 3071708..2f73e21 100644 --- a/apps/RemovePath.hs +++ b/apps/RemovePath.hs @@ -4,77 +4,79 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where -import Control.Monad ( when ) +import Control.Monad (when) import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - removePath args options - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + removePath args options + (_, _, errorMessages) -> exitWithUsageErrors errorMessages removePath :: [String] -> Options -> IO () removePath paths options = do - let varName = name options - userVal <- Environment.queryFromRegistry Environment.CurrentUserEnvironment varName - let userValParts = Environment.splitPaths userVal - let newUserValParts = filter (`notElem` paths) userValParts - when (length userValParts /= length newUserValParts) $ do - Environment.saveToRegistryWithPrompt Environment.CurrentUserEnvironment varName $ Environment.joinPaths newUserValParts - when (global options) $ do - globalVal <- Environment.queryFromRegistry Environment.AllUsersEnvironment varName - let globalValParts = Environment.splitPaths globalVal - let newGlobalValParts = filter (`notElem` paths) globalValParts - when (length globalValParts /= length newGlobalValParts) $ do - Environment.saveToRegistryWithPrompt Environment.AllUsersEnvironment varName $ Environment.joinPaths newGlobalValParts + let varName = name options + userVal <- Environment.queryFromRegistry Environment.CurrentUserEnvironment varName + let userValParts = Environment.splitPaths userVal + let newUserValParts = filter (`notElem` paths) userValParts + when (length userValParts /= length newUserValParts) $ do + Environment.saveToRegistryWithPrompt Environment.CurrentUserEnvironment varName $ Environment.joinPaths newUserValParts + when (global options) $ do + globalVal <- Environment.queryFromRegistry Environment.AllUsersEnvironment varName + let globalValParts = Environment.splitPaths globalVal + let newGlobalValParts = filter (`notElem` paths) globalValParts + when (length globalValParts /= length newGlobalValParts) $ do + Environment.saveToRegistryWithPrompt Environment.AllUsersEnvironment varName $ Environment.joinPaths newGlobalValParts -data Options = Options { name :: String - , global :: Bool } - deriving (Eq, Show) +data Options = Options + { name :: String + , global :: Bool + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { name = "PATH" - , global = False } +defaultOptions = Options + { name = "PATH" + , global = False + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] [PATH...]\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)", - Option "g" ["global"] (NoArg $ \opts -> return opts { global = True }) "remove the path for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)" + , Option "g" ["global"] (NoArg $ \opts -> return opts { global = True }) "remove the path for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs index fda9726..f27be4e 100644 --- a/apps/SetEnv.hs +++ b/apps/SetEnv.hs @@ -4,63 +4,66 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - case args of - [name, value] -> setEnv name value options - _ -> invalidNumberOfArguments - (_, _, errorMessages) -> - exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + case args of + [name, value] -> setEnv name value options + _ -> invalidNumberOfArguments + (_, _, errorMessages) -> + exitWithUsageErrors errorMessages setEnv :: String -> String -> Options -> IO () setEnv name value options = Environment.saveToRegistryWithPrompt (env options) name value -data Options = Options { env :: Environment.RegistryBasedEnvironment } deriving (Eq, Show) +data Options = Options + { env :: Environment.RegistryBasedEnvironment + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { env = Environment.CurrentUserEnvironment } +defaultOptions = Options + { env = Environment.CurrentUserEnvironment + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME VALUE\nOptions:" exitWithHelpMessage :: Options -> IO a exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "save under the registry key for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "save under the registry key for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs index 254f383..32626f3 100644 --- a/apps/UnsetEnv.hs +++ b/apps/UnsetEnv.hs @@ -4,62 +4,65 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - case args of - [name] -> unsetEnv name options - _ -> invalidNumberOfArguments - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + case args of + [name] -> unsetEnv name options + _ -> invalidNumberOfArguments + (_, _, errorMessages) -> exitWithUsageErrors errorMessages unsetEnv :: String -> Options -> IO () unsetEnv name options = Environment.wipeFromRegistryWithPrompt (env options) name -data Options = Options { env :: Environment.RegistryBasedEnvironment } deriving (Eq, Show) +data Options = Options + { env :: Environment.RegistryBasedEnvironment + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { env = Environment.CurrentUserEnvironment } +defaultOptions = Options + { env = Environment.CurrentUserEnvironment + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "delete from the registry key for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "delete from the registry key for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/src/Environment.hs b/src/Environment.hs index 0690278..2b53258 100644 --- a/src/Environment.hs +++ b/src/Environment.hs @@ -4,29 +4,32 @@ - See LICENSE.txt for details. -} -module Environment ( saveToRegistry - , saveToRegistryWithPrompt - , queryFromRegistry - , wipeFromRegistry - , wipeFromRegistryWithPrompt - , getEnv - , splitPaths - , joinPaths - , RegistryBasedEnvironment(..) ) where - -import Control.Monad ( liftM, when ) -import Data.List ( intercalate ) -import Data.List.Split ( splitOn ) -import Data.Maybe ( fromMaybe ) -import qualified System.Environment ( lookupEnv ) -import System.IO.Error ( catchIOError, isDoesNotExistError ) +module Environment + ( saveToRegistry + , saveToRegistryWithPrompt + , queryFromRegistry + , wipeFromRegistry + , wipeFromRegistryWithPrompt + , getEnv + , splitPaths + , joinPaths + , RegistryBasedEnvironment(..) + ) where + +import Control.Monad (liftM, when) +import Data.List (intercalate) +import Data.List.Split (splitOn) +import Data.Maybe (fromMaybe) +import qualified System.Environment (lookupEnv) +import System.IO.Error (catchIOError, isDoesNotExistError) import qualified Registry -import qualified Utils ( promptToContinue ) +import qualified Utils (promptToContinue) -data RegistryBasedEnvironment = CurrentUserEnvironment - | AllUsersEnvironment - deriving (Eq, Show) +data RegistryBasedEnvironment + = CurrentUserEnvironment + | AllUsersEnvironment + deriving (Eq, Show) registrySubKeyPath :: RegistryBasedEnvironment -> String registrySubKeyPath CurrentUserEnvironment = "Environment" @@ -45,12 +48,12 @@ saveToRegistry env = Registry.setString (registryKey env) (registrySubKeyPath en saveToRegistryWithPrompt :: RegistryBasedEnvironment -> String -> String -> IO () saveToRegistryWithPrompt env name value = do - putStrLn $ "Saving variable '" ++ name ++ "' to '" ++ registryKeyPath env ++ "'..." - oldValue <- queryFromRegistry env name - putStrLn $ "\tOld value: " ++ oldValue - putStrLn $ "\tNew value: " ++ value - agreed <- Utils.promptToContinue - when agreed $ saveToRegistry env name value + putStrLn $ "Saving variable '" ++ name ++ "' to '" ++ registryKeyPath env ++ "'..." + oldValue <- queryFromRegistry env name + putStrLn $ "\tOld value: " ++ oldValue + putStrLn $ "\tNew value: " ++ value + agreed <- Utils.promptToContinue + when agreed $ saveToRegistry env name value queryFromRegistry :: RegistryBasedEnvironment -> String -> IO String queryFromRegistry env name = catchIOError (Registry.getString (registryKey env) (registrySubKeyPath env) name) emptyIfDoesNotExist @@ -66,9 +69,9 @@ wipeFromRegistry env name = catchIOError (Registry.delValue (registryKey env) (r wipeFromRegistryWithPrompt :: RegistryBasedEnvironment -> String -> IO () wipeFromRegistryWithPrompt env name = do - putStrLn $ "Deleting variable '" ++ name ++ "' from '" ++ registryKeyPath env ++ "'..." - agreed <- Utils.promptToContinue - when agreed $ wipeFromRegistry env name + putStrLn $ "Deleting variable '" ++ name ++ "' from '" ++ registryKeyPath env ++ "'..." + agreed <- Utils.promptToContinue + when agreed $ wipeFromRegistry env name getEnv :: String -> IO String getEnv = liftM (fromMaybe "") . System.Environment.lookupEnv diff --git a/src/Registry.hs b/src/Registry.hs index d6c3f26..a38ef00 100644 --- a/src/Registry.hs +++ b/src/Registry.hs @@ -4,21 +4,24 @@ - See LICENSE.txt for details. -} -module Registry ( delValue - , getString - , hkcu - , hklm - , setString - , KeyHandle ) where +module Registry + ( KeyHandle + , delValue + , getString + , setString + , hkcu + , hklm + ) where + +import Control.Exception (bracket) +import Data.Maybe (fromMaybe) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Ptr (castPtr, plusPtr) +import Foreign.Storable (peek, poke, sizeOf) +import Graphics.Win32.Window (sendMessage) +import System.IO.Error (mkIOError, doesNotExistErrorType) -import Control.Exception ( bracket ) -import Data.Maybe ( fromMaybe ) -import Foreign.ForeignPtr ( withForeignPtr ) -import Foreign.Marshal.Alloc ( alloca, allocaBytes ) -import Foreign.Ptr ( castPtr, plusPtr ) -import Foreign.Storable ( peek, poke, sizeOf ) -import Graphics.Win32.Window ( sendMessage ) -import System.IO.Error ( mkIOError, doesNotExistErrorType ) import System.Win32.Types import System.Win32.Registry @@ -26,69 +29,69 @@ newtype KeyHandle = KeyHandle HKEY getType :: HKEY -> String -> String -> IO (Maybe RegValueType) getType key subKeyPath valueName = - 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 - case ret of - 0x0 -> do - type_ <- peek p_type - return $ Just type_ - 0x2 -> return Nothing - _ -> failWith "RegQueryValueEx" ret + 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 + case ret of + 0x0 -> do + type_ <- peek p_type + return $ Just type_ + 0x2 -> return Nothing + _ -> failWith "RegQueryValueEx" ret 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 - ret <- c_RegQueryValueEx p_key p_valueName nullPtr nullPtr nullPtr dataSizePtr - case ret of - 0x0 -> do - dataSize <- peek dataSizePtr - let newDataSize = dataSize + fromIntegral (sizeOf (undefined :: TCHAR)) - poke dataSizePtr newDataSize - allocaBytes (fromIntegral newDataSize) $ \dataPtr -> do - poke (castPtr $ plusPtr dataPtr $ fromIntegral dataSize) '\0' - failUnlessSuccess "RegQueryValueEx" $ - c_RegQueryValueEx p_key p_valueName nullPtr nullPtr dataPtr dataSizePtr - peekTString $ castPtr dataPtr - 0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName) - _ -> failWith "RegQueryValueEx" ret + bracket (regOpenKey hKey subKeyPath) regCloseKey $ \hSubKey -> + withForeignPtr hSubKey $ \p_key -> + withTString valueName $ \p_valueName -> + alloca $ \dataSizePtr -> do + poke dataSizePtr 0 + ret <- c_RegQueryValueEx p_key p_valueName nullPtr nullPtr nullPtr dataSizePtr + case ret of + 0x0 -> do + dataSize <- peek dataSizePtr + let newDataSize = dataSize + fromIntegral (sizeOf (undefined :: TCHAR)) + poke dataSizePtr newDataSize + allocaBytes (fromIntegral newDataSize) $ \dataPtr -> do + poke (castPtr $ plusPtr dataPtr $ fromIntegral dataSize) '\0' + failUnlessSuccess "RegQueryValueEx" $ + c_RegQueryValueEx p_key p_valueName nullPtr nullPtr dataPtr dataSizePtr + peekTString $ castPtr dataPtr + 0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName) + _ -> failWith "RegQueryValueEx" ret 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 hKey subKeyPath valueName - regSetValueEx subKey valueName (fromMaybe rEG_SZ type_) p_valueValue $ (length valueValue + 1) * sizeOf (undefined :: TCHAR) - notifyEnvironmentUpdate + bracket (regOpenKey hKey subKeyPath) regCloseKey $ \subKey -> + withTString valueValue $ \p_valueValue -> do + type_ <- getType hKey subKeyPath valueName + regSetValueEx subKey valueName (fromMaybe rEG_SZ type_) p_valueValue $ (length valueValue + 1) * sizeOf (undefined :: TCHAR) + notifyEnvironmentUpdate notifyEnvironmentUpdate :: IO () notifyEnvironmentUpdate = - withTString "Environment" $ \p_lparam -> do - let wparam = 0 - let lparam = fromIntegral $ castPtrToUINTPtr p_lparam - let hwnd = castUINTPtrToPtr 0xffff - _ <- sendMessage hwnd wM_SETTINGCHANGE wparam lparam - return () - where - wM_SETTINGCHANGE = 0x1A + withTString "Environment" $ \p_lparam -> do + let wparam = 0 + let lparam = fromIntegral $ castPtrToUINTPtr p_lparam + let hwnd = castUINTPtrToPtr 0xffff + _ <- sendMessage hwnd wM_SETTINGCHANGE wparam lparam + return () + where + wM_SETTINGCHANGE = 0x1A 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 - notifyEnvironmentUpdate - case ret of - 0x0 -> return () - 0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName) - _ -> failWith "RegDeleteValue" ret + bracket (regOpenKey hKey subKeyPath) regCloseKey $ \subKey -> + withForeignPtr subKey $ \subKeyPtr -> + withTString valueName $ \p_valueName -> do + ret <- c_RegDeleteValue subKeyPtr p_valueName + notifyEnvironmentUpdate + case ret of + 0x0 -> return () + 0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName) + _ -> failWith "RegDeleteValue" ret hkcu :: KeyHandle hkcu = KeyHandle hKEY_CURRENT_USER diff --git a/src/Utils.hs b/src/Utils.hs index 21ee67b..ec15405 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -6,24 +6,24 @@ module Utils where -import Control.Monad ( liftM ) -import Data.Char ( toLower ) -import System.IO ( hFlush, stdout ) +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 + 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 + 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"] |