From d53c986113cef78e2b504ecd5a4bba60999a55e1 Mon Sep 17 00:00:00 2001 From: Egor Tensin Date: Mon, 11 Jul 2016 18:55:26 +0300 Subject: become a proper stack project --- .gitignore | 1 + AddPath.hs | 76 ----------------------------------------- EnvUtils.hs | 81 ------------------------------------------- FixNtSymbolPath.hs | 51 --------------------------- ListPath.hs | 72 -------------------------------------- RegUtils.hs | 91 ------------------------------------------------- RemovePath.hs | 80 ------------------------------------------- SetEnv.hs | 66 ----------------------------------- Setup.hs | 2 ++ UnsetEnv.hs | 65 ----------------------------------- Utils.hs | 32 ----------------- apps/AddPath.hs | 76 +++++++++++++++++++++++++++++++++++++++++ apps/FixNtSymbolPath.hs | 51 +++++++++++++++++++++++++++ apps/ListPath.hs | 72 ++++++++++++++++++++++++++++++++++++++ apps/RemovePath.hs | 80 +++++++++++++++++++++++++++++++++++++++++++ apps/SetEnv.hs | 66 +++++++++++++++++++++++++++++++++++ apps/UnsetEnv.hs | 65 +++++++++++++++++++++++++++++++++++ src/EnvUtils.hs | 81 +++++++++++++++++++++++++++++++++++++++++++ src/RegUtils.hs | 91 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Utils.hs | 32 +++++++++++++++++ stack.yaml | 66 +++++++++++++++++++++++++++++++++++ wintmp.cabal | 72 ++++++++++++++++++++++++++++++++++++++ 22 files changed, 755 insertions(+), 614 deletions(-) create mode 100644 .gitignore delete mode 100644 AddPath.hs delete mode 100644 EnvUtils.hs delete mode 100644 FixNtSymbolPath.hs delete mode 100644 ListPath.hs delete mode 100644 RegUtils.hs delete mode 100644 RemovePath.hs delete mode 100644 SetEnv.hs create mode 100644 Setup.hs delete mode 100644 UnsetEnv.hs delete mode 100644 Utils.hs create mode 100644 apps/AddPath.hs create mode 100644 apps/FixNtSymbolPath.hs create mode 100644 apps/ListPath.hs create mode 100644 apps/RemovePath.hs create mode 100644 apps/SetEnv.hs create mode 100644 apps/UnsetEnv.hs create mode 100644 src/EnvUtils.hs create mode 100644 src/RegUtils.hs create mode 100644 src/Utils.hs create mode 100644 stack.yaml create mode 100644 wintmp.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6fabf46 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/.stack-work/ diff --git a/AddPath.hs b/AddPath.hs deleted file mode 100644 index e17adc9..0000000 --- a/AddPath.hs +++ /dev/null @@ -1,76 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Main ( main ) where - -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 qualified EnvUtils - -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 - -addPath :: [String] -> Options -> IO () -addPath paths options = do - missingPaths <- dropIncludedPaths paths - when (not $ null missingPaths) $ do - oldPath <- EnvUtils.queryFromRegistry (env options) (name options) - EnvUtils.saveToRegistryWithPrompt (env options) (name options) $ EnvUtils.joinPaths $ missingPaths ++ [oldPath] - where - dropIncludedPaths paths = do - currentPath <- EnvUtils.getEnv $ name options - return $ filter (flip notElem $ EnvUtils.splitPaths currentPath) paths - -data Options = Options { name :: String - , env :: EnvUtils.RegistryBasedEnvironment } - deriving (Eq, Show) - -defaultOptions :: Options -defaultOptions = Options { name = "PATH" - , env = EnvUtils.CurrentUserEnvironment } - -buildHelpMessage :: IO String -buildHelpMessage = 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 - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - 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 = EnvUtils.AllUsersEnvironment }) "add the path for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] diff --git a/EnvUtils.hs b/EnvUtils.hs deleted file mode 100644 index 7e9bc96..0000000 --- a/EnvUtils.hs +++ /dev/null @@ -1,81 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module EnvUtils ( saveToRegistry - , saveToRegistryWithPrompt - , queryFromRegistry - , wipeFromRegistry - , wipeFromRegistryWithPrompt - , getEnv - , splitPaths - , joinPaths - , RegistryBasedEnvironment ( CurrentUserEnvironment, AllUsersEnvironment ) ) 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 RegUtils -import qualified Utils ( promptToContinue ) - -data RegistryBasedEnvironment = CurrentUserEnvironment - | AllUsersEnvironment - deriving (Eq, Show) - -registrySubKeyPath :: RegistryBasedEnvironment -> String -registrySubKeyPath CurrentUserEnvironment = "Environment" -registrySubKeyPath AllUsersEnvironment = "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" - -registryKey CurrentUserEnvironment = RegUtils.hkcu -registryKey AllUsersEnvironment = RegUtils.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) - -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 - -queryFromRegistry :: RegistryBasedEnvironment -> String -> IO String -queryFromRegistry env name = catchIOError (RegUtils.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 - where - ignoreIfDoesNotExist :: IOError -> IO () - ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e - -wipeFromRegistryWithPrompt :: RegistryBasedEnvironment -> String -> IO () -wipeFromRegistryWithPrompt env name = do - 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 - -pathSep = ";" - -splitPaths :: String -> [String] -splitPaths = filter (not . null) . splitOn pathSep - -joinPaths :: [String] -> String -joinPaths = intercalate pathSep . filter (not . null) diff --git a/FixNtSymbolPath.hs b/FixNtSymbolPath.hs deleted file mode 100644 index 404dc77..0000000 --- a/FixNtSymbolPath.hs +++ /dev/null @@ -1,51 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Main ( main ) where - -import Control.Monad ( unless ) -import System.Directory ( createDirectoryIfMissing, getCurrentDirectory ) -import System.FilePath ( combine ) - -import qualified EnvUtils - -getRemoteSymbolsDirectoryPath :: IO String -getRemoteSymbolsDirectoryPath = do - localPath <- getLocalPath - createDirectoryIfMissing True localPath - return $ "SRV*" ++ localPath ++ "*" ++ remotePath - where - getLocalPath :: IO String - getLocalPath = do - cwd <- getCurrentDirectory - return $ combine cwd "symbols" - remotePath :: String - remotePath = "http://msdl.microsoft.com/download/symbols" - -getPdbsDirectoryPath :: IO String -getPdbsDirectoryPath = do - cwd <- getCurrentDirectory - let path = combine cwd "pdbs" - createDirectoryIfMissing True path - return path - -fixNtSymbolPath :: IO () -fixNtSymbolPath = do - let env = EnvUtils.CurrentUserEnvironment - val <- EnvUtils.queryFromRegistry env ntSymbolPath - let presentPaths = EnvUtils.splitPaths val - remoteSymbolsPath <- getRemoteSymbolsDirectoryPath - pdbsPath <- getPdbsDirectoryPath - let requiredPaths = [pdbsPath, remoteSymbolsPath] - let missingPaths = filter (`notElem` presentPaths) requiredPaths - unless (null missingPaths) $ do - let newval = EnvUtils.joinPaths $ presentPaths ++ missingPaths - EnvUtils.saveToRegistry env ntSymbolPath newval - where - ntSymbolPath = "_NT_SYMBOL_PATH" - -main :: IO () -main = fixNtSymbolPath diff --git a/ListPath.hs b/ListPath.hs deleted file mode 100644 index ca72e87..0000000 --- a/ListPath.hs +++ /dev/null @@ -1,72 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -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 qualified EnvUtils - -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 - -listPath :: Options -> IO () -listPath options = do - val <- EnvUtils.getEnv $ name options - mapM_ printPath $ EnvUtils.splitPaths val - where - printPath p = do - exists <- doesDirectoryExist p - putStrLn $ (if exists then "+" else "-") ++ " " ++ p - -data Options = Options { name :: String } deriving (Eq, Show) - -defaultOptions :: Options -defaultOptions = Options { name = "PATH" } - -buildHelpMessage :: IO String -buildHelpMessage = 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 - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - 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" - ] diff --git a/RegUtils.hs b/RegUtils.hs deleted file mode 100644 index eccb6ad..0000000 --- a/RegUtils.hs +++ /dev/null @@ -1,91 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module RegUtils ( delValue - , getString - , hkcu - , hklm - , setString ) 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 System.Win32.Types -import System.Win32.Registry - -getType :: HKEY -> String -> String -> IO (Maybe RegValueType) -getType key subKeyPath valueName = - bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> - withForeignPtr key $ \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 :: HKEY -> String -> String -> IO String -getString key subKeyPath valueName = - bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> - withForeignPtr key $ \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 :: HKEY -> String -> String -> String -> IO () -setString key subKeyPath valueName valueValue = - bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey -> - withTString valueValue $ \p_valueValue -> do - type_ <- getType key 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 - -delValue :: HKEY -> String -> String -> IO () -delValue key subKeyPath valueName = - bracket (regOpenKey key 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 = hKEY_CURRENT_USER -hklm = hKEY_LOCAL_MACHINE diff --git a/RemovePath.hs b/RemovePath.hs deleted file mode 100644 index 2e8fd01..0000000 --- a/RemovePath.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Main ( main ) where - -import Control.Monad ( when ) -import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) - -import qualified EnvUtils - -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 - -removePath :: [String] -> Options -> IO () -removePath paths options = do - let varName = name options - userVal <- EnvUtils.queryFromRegistry EnvUtils.CurrentUserEnvironment varName - let userValParts = EnvUtils.splitPaths userVal - let newUserValParts = filter (`notElem` paths) userValParts - when (length userValParts /= length newUserValParts) $ do - EnvUtils.saveToRegistryWithPrompt EnvUtils.CurrentUserEnvironment varName $ EnvUtils.joinPaths newUserValParts - when (global options) $ do - globalVal <- EnvUtils.queryFromRegistry EnvUtils.AllUsersEnvironment varName - let globalValParts = EnvUtils.splitPaths globalVal - let newGlobalValParts = filter (`notElem` paths) globalValParts - when (length globalValParts /= length newGlobalValParts) $ do - EnvUtils.saveToRegistryWithPrompt EnvUtils.AllUsersEnvironment varName $ EnvUtils.joinPaths newGlobalValParts - -data Options = Options { name :: String - , global :: Bool } - deriving (Eq, Show) - -defaultOptions :: Options -defaultOptions = Options { name = "PATH" - , global = False } - -buildHelpMessage :: IO String -buildHelpMessage = 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 - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - 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" - ] diff --git a/SetEnv.hs b/SetEnv.hs deleted file mode 100644 index 30f5b1e..0000000 --- a/SetEnv.hs +++ /dev/null @@ -1,66 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Main ( main ) where - -import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) - -import qualified EnvUtils - -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 - -setEnv :: String -> String -> Options -> IO () -setEnv name value options = EnvUtils.saveToRegistryWithPrompt (env options) name value - -data Options = Options { env :: EnvUtils.RegistryBasedEnvironment } deriving (Eq, Show) - -defaultOptions :: Options -defaultOptions = Options { env = EnvUtils.CurrentUserEnvironment } - -buildHelpMessage :: IO String -buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do - progName <- getProgName - return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME VALUE\nOptions:" - -exitWithHelpMessage :: Options -> IO a -exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - 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 = EnvUtils.AllUsersEnvironment }) "save under the registry key for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UnsetEnv.hs b/UnsetEnv.hs deleted file mode 100644 index cd43696..0000000 --- a/UnsetEnv.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Main ( main ) where - -import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) - -import qualified EnvUtils - -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 - -unsetEnv :: String -> Options -> IO () -unsetEnv name options = EnvUtils.wipeFromRegistryWithPrompt (env options) name - -data Options = Options { env :: EnvUtils.RegistryBasedEnvironment } deriving (Eq, Show) - -defaultOptions :: Options -defaultOptions = Options { env = EnvUtils.CurrentUserEnvironment } - -buildHelpMessage :: IO String -buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do - progName <- getProgName - return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME\nOptions:" - -exitWithHelpMessage :: a -> IO b -exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - 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 = EnvUtils.AllUsersEnvironment }) "delete from the registry key for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 index 21ee67b..0000000 --- a/Utils.hs +++ /dev/null @@ -1,32 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - 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/apps/AddPath.hs b/apps/AddPath.hs new file mode 100644 index 0000000..e17adc9 --- /dev/null +++ b/apps/AddPath.hs @@ -0,0 +1,76 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Main ( main ) where + +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 qualified EnvUtils + +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 + +addPath :: [String] -> Options -> IO () +addPath paths options = do + missingPaths <- dropIncludedPaths paths + when (not $ null missingPaths) $ do + oldPath <- EnvUtils.queryFromRegistry (env options) (name options) + EnvUtils.saveToRegistryWithPrompt (env options) (name options) $ EnvUtils.joinPaths $ missingPaths ++ [oldPath] + where + dropIncludedPaths paths = do + currentPath <- EnvUtils.getEnv $ name options + return $ filter (flip notElem $ EnvUtils.splitPaths currentPath) paths + +data Options = Options { name :: String + , env :: EnvUtils.RegistryBasedEnvironment } + deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Options { name = "PATH" + , env = EnvUtils.CurrentUserEnvironment } + +buildHelpMessage :: IO String +buildHelpMessage = 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 + +exitWithUsageErrors :: [String] -> IO a +exitWithUsageErrors errorMessages = do + 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 = EnvUtils.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 new file mode 100644 index 0000000..404dc77 --- /dev/null +++ b/apps/FixNtSymbolPath.hs @@ -0,0 +1,51 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Main ( main ) where + +import Control.Monad ( unless ) +import System.Directory ( createDirectoryIfMissing, getCurrentDirectory ) +import System.FilePath ( combine ) + +import qualified EnvUtils + +getRemoteSymbolsDirectoryPath :: IO String +getRemoteSymbolsDirectoryPath = do + localPath <- getLocalPath + createDirectoryIfMissing True localPath + return $ "SRV*" ++ localPath ++ "*" ++ remotePath + where + getLocalPath :: IO String + getLocalPath = do + cwd <- getCurrentDirectory + return $ combine cwd "symbols" + remotePath :: String + remotePath = "http://msdl.microsoft.com/download/symbols" + +getPdbsDirectoryPath :: IO String +getPdbsDirectoryPath = do + cwd <- getCurrentDirectory + let path = combine cwd "pdbs" + createDirectoryIfMissing True path + return path + +fixNtSymbolPath :: IO () +fixNtSymbolPath = do + let env = EnvUtils.CurrentUserEnvironment + val <- EnvUtils.queryFromRegistry env ntSymbolPath + let presentPaths = EnvUtils.splitPaths val + remoteSymbolsPath <- getRemoteSymbolsDirectoryPath + pdbsPath <- getPdbsDirectoryPath + let requiredPaths = [pdbsPath, remoteSymbolsPath] + let missingPaths = filter (`notElem` presentPaths) requiredPaths + unless (null missingPaths) $ do + let newval = EnvUtils.joinPaths $ presentPaths ++ missingPaths + EnvUtils.saveToRegistry env ntSymbolPath newval + where + ntSymbolPath = "_NT_SYMBOL_PATH" + +main :: IO () +main = fixNtSymbolPath diff --git a/apps/ListPath.hs b/apps/ListPath.hs new file mode 100644 index 0000000..ca72e87 --- /dev/null +++ b/apps/ListPath.hs @@ -0,0 +1,72 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +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 qualified EnvUtils + +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 + +listPath :: Options -> IO () +listPath options = do + val <- EnvUtils.getEnv $ name options + mapM_ printPath $ EnvUtils.splitPaths val + where + printPath p = do + exists <- doesDirectoryExist p + putStrLn $ (if exists then "+" else "-") ++ " " ++ p + +data Options = Options { name :: String } deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Options { name = "PATH" } + +buildHelpMessage :: IO String +buildHelpMessage = 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 + +exitWithUsageErrors :: [String] -> IO a +exitWithUsageErrors errorMessages = do + 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" + ] diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs new file mode 100644 index 0000000..2e8fd01 --- /dev/null +++ b/apps/RemovePath.hs @@ -0,0 +1,80 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Main ( main ) where + +import Control.Monad ( when ) +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure, exitSuccess ) +import System.IO ( hPutStr, stderr ) + +import qualified EnvUtils + +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 + +removePath :: [String] -> Options -> IO () +removePath paths options = do + let varName = name options + userVal <- EnvUtils.queryFromRegistry EnvUtils.CurrentUserEnvironment varName + let userValParts = EnvUtils.splitPaths userVal + let newUserValParts = filter (`notElem` paths) userValParts + when (length userValParts /= length newUserValParts) $ do + EnvUtils.saveToRegistryWithPrompt EnvUtils.CurrentUserEnvironment varName $ EnvUtils.joinPaths newUserValParts + when (global options) $ do + globalVal <- EnvUtils.queryFromRegistry EnvUtils.AllUsersEnvironment varName + let globalValParts = EnvUtils.splitPaths globalVal + let newGlobalValParts = filter (`notElem` paths) globalValParts + when (length globalValParts /= length newGlobalValParts) $ do + EnvUtils.saveToRegistryWithPrompt EnvUtils.AllUsersEnvironment varName $ EnvUtils.joinPaths newGlobalValParts + +data Options = Options { name :: String + , global :: Bool } + deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Options { name = "PATH" + , global = False } + +buildHelpMessage :: IO String +buildHelpMessage = 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 + +exitWithUsageErrors :: [String] -> IO a +exitWithUsageErrors errorMessages = do + 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" + ] diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs new file mode 100644 index 0000000..30f5b1e --- /dev/null +++ b/apps/SetEnv.hs @@ -0,0 +1,66 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Main ( main ) where + +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure, exitSuccess ) +import System.IO ( hPutStr, stderr ) + +import qualified EnvUtils + +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 + +setEnv :: String -> String -> Options -> IO () +setEnv name value options = EnvUtils.saveToRegistryWithPrompt (env options) name value + +data Options = Options { env :: EnvUtils.RegistryBasedEnvironment } deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Options { env = EnvUtils.CurrentUserEnvironment } + +buildHelpMessage :: IO String +buildHelpMessage = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader :: IO String + buildHeader = do + progName <- getProgName + return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME VALUE\nOptions:" + +exitWithHelpMessage :: Options -> IO a +exitWithHelpMessage _ = do + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess + +exitWithUsageErrors :: [String] -> IO a +exitWithUsageErrors errorMessages = do + 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 = EnvUtils.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 new file mode 100644 index 0000000..cd43696 --- /dev/null +++ b/apps/UnsetEnv.hs @@ -0,0 +1,65 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Main ( main ) where + +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure, exitSuccess ) +import System.IO ( hPutStr, stderr ) + +import qualified EnvUtils + +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 + +unsetEnv :: String -> Options -> IO () +unsetEnv name options = EnvUtils.wipeFromRegistryWithPrompt (env options) name + +data Options = Options { env :: EnvUtils.RegistryBasedEnvironment } deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Options { env = EnvUtils.CurrentUserEnvironment } + +buildHelpMessage :: IO String +buildHelpMessage = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader :: IO String + buildHeader = do + progName <- getProgName + return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME\nOptions:" + +exitWithHelpMessage :: a -> IO b +exitWithHelpMessage _ = do + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess + +exitWithUsageErrors :: [String] -> IO a +exitWithUsageErrors errorMessages = do + 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 = EnvUtils.AllUsersEnvironment }) "delete from the registry key for all users", + Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/src/EnvUtils.hs b/src/EnvUtils.hs new file mode 100644 index 0000000..7e9bc96 --- /dev/null +++ b/src/EnvUtils.hs @@ -0,0 +1,81 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module EnvUtils ( saveToRegistry + , saveToRegistryWithPrompt + , queryFromRegistry + , wipeFromRegistry + , wipeFromRegistryWithPrompt + , getEnv + , splitPaths + , joinPaths + , RegistryBasedEnvironment ( CurrentUserEnvironment, AllUsersEnvironment ) ) 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 RegUtils +import qualified Utils ( promptToContinue ) + +data RegistryBasedEnvironment = CurrentUserEnvironment + | AllUsersEnvironment + deriving (Eq, Show) + +registrySubKeyPath :: RegistryBasedEnvironment -> String +registrySubKeyPath CurrentUserEnvironment = "Environment" +registrySubKeyPath AllUsersEnvironment = "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" + +registryKey CurrentUserEnvironment = RegUtils.hkcu +registryKey AllUsersEnvironment = RegUtils.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) + +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 + +queryFromRegistry :: RegistryBasedEnvironment -> String -> IO String +queryFromRegistry env name = catchIOError (RegUtils.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 + where + ignoreIfDoesNotExist :: IOError -> IO () + ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e + +wipeFromRegistryWithPrompt :: RegistryBasedEnvironment -> String -> IO () +wipeFromRegistryWithPrompt env name = do + 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 + +pathSep = ";" + +splitPaths :: String -> [String] +splitPaths = filter (not . null) . splitOn pathSep + +joinPaths :: [String] -> String +joinPaths = intercalate pathSep . filter (not . null) diff --git a/src/RegUtils.hs b/src/RegUtils.hs new file mode 100644 index 0000000..eccb6ad --- /dev/null +++ b/src/RegUtils.hs @@ -0,0 +1,91 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module RegUtils ( delValue + , getString + , hkcu + , hklm + , setString ) 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 System.Win32.Types +import System.Win32.Registry + +getType :: HKEY -> String -> String -> IO (Maybe RegValueType) +getType key subKeyPath valueName = + bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> + withForeignPtr key $ \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 :: HKEY -> String -> String -> IO String +getString key subKeyPath valueName = + bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> + withForeignPtr key $ \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 :: HKEY -> String -> String -> String -> IO () +setString key subKeyPath valueName valueValue = + bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey -> + withTString valueValue $ \p_valueValue -> do + type_ <- getType key 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 + +delValue :: HKEY -> String -> String -> IO () +delValue key subKeyPath valueName = + bracket (regOpenKey key 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 = hKEY_CURRENT_USER +hklm = hKEY_LOCAL_MACHINE diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..21ee67b --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,32 @@ +{- + - Copyright 2015 Egor Tensin + - 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/stack.yaml b/stack.yaml new file mode 100644 index 0000000..c2691e2 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-6.7 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/wintmp.cabal b/wintmp.cabal new file mode 100644 index 0000000..cbb4b2c --- /dev/null +++ b/wintmp.cabal @@ -0,0 +1,72 @@ +name: wintmp +version: 0.1.0.0 +synopsis: Windows "tmp" directory +description: Please see README.md +homepage: https://github.com/egor-tensin/wintmp +license: MIT +license-file: LICENSE.txt +author: Egor Tensin +maintainer: Egor.Tensin@gmail.com +copyright: (c) 2015 Egor Tensin +category: System +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: EnvUtils, RegUtils, Utils + build-depends: base, split, Win32 + default-language: Haskell2010 + +executable add_path + hs-source-dirs: apps + main-is: AddPath.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , wintmp + default-language: Haskell2010 + +executable fix_nt_symbol_path + hs-source-dirs: apps + main-is: FixNtSymbolPath.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base, directory, filepath + , wintmp + default-language: Haskell2010 + +executable list_path + hs-source-dirs: apps + main-is: ListPath.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base, directory + , wintmp + default-language: Haskell2010 + +executable remove_path + hs-source-dirs: apps + main-is: RemovePath.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , wintmp + default-language: Haskell2010 + +executable set_env + hs-source-dirs: apps + main-is: SetEnv.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , wintmp + default-language: Haskell2010 + +executable unset_env + hs-source-dirs: apps + main-is: UnsetEnv.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , wintmp + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/egor-tensin/wintmp -- cgit v1.2.3