From b20d44c618f370a1998c70dd5708d9bbe4ed1c80 Mon Sep 17 00:00:00 2001 From: Egor Tensin Date: Sun, 26 Mar 2017 19:03:03 +0300 Subject: rename directories --- app/AddPath.hs | 83 ++++++++++++ app/ListPaths.hs | 84 ++++++++++++ app/RemovePath.hs | 85 ++++++++++++ app/SetEnv.hs | 72 +++++++++++ app/UnsetEnv.hs | 66 ++++++++++ app/Utils/Prompt.hs | 50 ++++++++ app/Utils/PromptMessage.hs | 39 ++++++ bin/AddPath.hs | 83 ------------ bin/ListPaths.hs | 84 ------------ bin/RemovePath.hs | 85 ------------ bin/SetEnv.hs | 72 ----------- bin/UnsetEnv.hs | 66 ---------- bin/Utils/Prompt.hs | 50 -------- bin/Utils/PromptMessage.hs | 39 ------ lib/WindowsEnv.hs | 16 --- lib/WindowsEnv/Environment.hs | 79 ------------ lib/WindowsEnv/Registry.hs | 292 ------------------------------------------ lib/WindowsEnv/Utils.hs | 30 ----- src/WindowsEnv.hs | 16 +++ src/WindowsEnv/Environment.hs | 79 ++++++++++++ src/WindowsEnv/Registry.hs | 292 ++++++++++++++++++++++++++++++++++++++++++ src/WindowsEnv/Utils.hs | 30 +++++ windows-env.cabal | 12 +- 23 files changed, 902 insertions(+), 902 deletions(-) create mode 100644 app/AddPath.hs create mode 100644 app/ListPaths.hs create mode 100644 app/RemovePath.hs create mode 100644 app/SetEnv.hs create mode 100644 app/UnsetEnv.hs create mode 100644 app/Utils/Prompt.hs create mode 100644 app/Utils/PromptMessage.hs delete mode 100644 bin/AddPath.hs delete mode 100644 bin/ListPaths.hs delete mode 100644 bin/RemovePath.hs delete mode 100644 bin/SetEnv.hs delete mode 100644 bin/UnsetEnv.hs delete mode 100644 bin/Utils/Prompt.hs delete mode 100644 bin/Utils/PromptMessage.hs delete mode 100644 lib/WindowsEnv.hs delete mode 100644 lib/WindowsEnv/Environment.hs delete mode 100644 lib/WindowsEnv/Registry.hs delete mode 100644 lib/WindowsEnv/Utils.hs create mode 100644 src/WindowsEnv.hs create mode 100644 src/WindowsEnv/Environment.hs create mode 100644 src/WindowsEnv/Registry.hs create mode 100644 src/WindowsEnv/Utils.hs diff --git a/app/AddPath.hs b/app/AddPath.hs new file mode 100644 index 0000000..683b82f --- /dev/null +++ b/app/AddPath.hs @@ -0,0 +1,83 @@ +-- | +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module Main (main) where + +import Control.Monad (void, when) +import Control.Monad.Trans.Except (catchE, runExceptT, throwE) +import Data.List (union) +import System.IO.Error (ioError, isDoesNotExistError) + +import Options.Applicative + +import qualified WindowsEnv + +import Utils.Prompt +import Utils.PromptMessage + +data Options = Options + { optName :: WindowsEnv.VarName + , optYes :: Bool + , optGlobal :: Bool + , optPaths :: [WindowsEnv.VarValue] + } deriving (Eq, Show) + +optionParser :: Parser Options +optionParser = Options + <$> optNameDesc + <*> optYesDesc + <*> optGlobalDesc + <*> optPathsDesc + where + optNameDesc = strOption + $ long "name" <> short 'n' + <> metavar "NAME" <> value "PATH" + <> help "Variable name ('PATH' by default)" + optYesDesc = switch + $ long "yes" <> short 'y' + <> help "Skip confirmation prompt" + optGlobalDesc = switch + $ long "global" <> short 'g' + <> help "Add for all users" + optPathsDesc = many $ argument str + $ metavar "PATH" + <> help "Directories to add" + +main :: IO () +main = execParser parser >>= addPath + where + parser = info (helper <*> optionParser) $ + fullDesc <> progDesc "Add directories to your PATH" + +addPath :: Options -> IO () +addPath options = runExceptT doAddPath >>= either ioError return + where + varName = optName options + pathsToAdd = optPaths options + + forAllUsers = optGlobal options + profile + | forAllUsers = WindowsEnv.AllUsers + | otherwise = WindowsEnv.CurrentUser + + skipPrompt = optYes options + + emptyIfMissing e + | isDoesNotExistError e = return "" + | otherwise = throwE e + + doAddPath = do + oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing + let oldPaths = WindowsEnv.pathSplit oldValue + let newPaths = oldPaths `union` pathsToAdd + when (length oldPaths /= length newPaths) $ do + let newValue = WindowsEnv.pathJoin newPaths + let promptAnd = if skipPrompt + then withoutPrompt + else withPrompt $ oldNewMessage profile varName oldValue newValue + let engrave = WindowsEnv.engrave profile varName newValue + void $ promptAnd engrave diff --git a/app/ListPaths.hs b/app/ListPaths.hs new file mode 100644 index 0000000..666423f --- /dev/null +++ b/app/ListPaths.hs @@ -0,0 +1,84 @@ +-- | +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module Main (main) where + +import Control.Monad (filterM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) +import Data.Maybe (fromMaybe) +import System.Directory (doesDirectoryExist) +import System.Environment (lookupEnv) +import System.IO.Error (ioError) + +import Options.Applicative + +import qualified WindowsEnv + +data WhichPaths = All | ExistingOnly | MissingOnly + deriving (Eq, Show) + +shouldListPath :: WhichPaths -> WindowsEnv.VarValue -> IO Bool +shouldListPath All = return . const True +shouldListPath ExistingOnly = doesDirectoryExist +shouldListPath MissingOnly = fmap not . doesDirectoryExist + +data Source = Environment | Registry WindowsEnv.Profile + deriving (Eq, Show) + +data Options = Options + { optName :: WindowsEnv.VarName + , optWhichPaths :: WhichPaths + , optSource :: Source + } deriving (Eq, Show) + +optionParser :: Parser Options +optionParser = Options + <$> optNameDesc + <*> optWhichPathsDesc + <*> optSourceDesc + where + optNameDesc = strOption + $ long "name" <> short 'n' + <> metavar "NAME" <> value "PATH" + <> help "Variable name ('PATH' by default)" + optWhichPathsDesc = pure All + <|> flag' ExistingOnly (long "existing" <> short 'e' + <> help "List existing paths only") + <|> flag' MissingOnly (long "missing" <> short 'm' + <> help "List missing paths only") + optSourceDesc = pure Environment + <|> flag' (Registry WindowsEnv.CurrentUser) (long "user" <> short 'u' + <> help "List current user's paths only") + <|> flag' (Registry WindowsEnv.AllUsers) (long "global" <> short 'g' + <> help "List global (all users') paths only") + +main :: IO () +main = execParser parser >>= listPaths + where + parser = info (helper <*> optionParser) $ + fullDesc <> progDesc "List directories in your PATH" + +listPaths :: Options -> IO () +listPaths options = runExceptT doListPaths >>= either ioError return + where + varName = optName options + whichPaths = optWhichPaths options + source = optSource options + + query = queryFrom source + + queryFrom Environment = lift $ fromMaybe "" <$> lookupEnv varName + queryFrom (Registry profile) = WindowsEnv.query profile varName + + filterPaths = filterM $ shouldListPath whichPaths + + doListPaths = do + paths <- WindowsEnv.pathSplit <$> query + lift $ do + pathsToPrint <- filterPaths paths + mapM_ putStrLn pathsToPrint diff --git a/app/RemovePath.hs b/app/RemovePath.hs new file mode 100644 index 0000000..6f2174b --- /dev/null +++ b/app/RemovePath.hs @@ -0,0 +1,85 @@ +-- | +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module Main (main) where + +import Control.Monad (void, when) +import Control.Monad.Trans.Except (catchE, runExceptT, throwE) +import Data.List ((\\)) +import System.IO.Error (ioError, isDoesNotExistError) + +import Options.Applicative + +import qualified WindowsEnv + +import Utils.Prompt +import Utils.PromptMessage + +data Options = Options + { optName :: WindowsEnv.VarName + , optYes :: Bool + , optGlobal :: Bool + , optPaths :: [WindowsEnv.VarValue] + } deriving (Eq, Show) + +optionParser :: Parser Options +optionParser = Options + <$> optNameDesc + <*> optYesDesc + <*> optGlobalDesc + <*> optPathsDesc + where + optNameDesc = strOption + $ long "name" <> short 'n' + <> metavar "NAME" <> value "PATH" + <> help "Variable name ('PATH' by default)" + optYesDesc = switch + $ long "yes" <> short 'y' + <> help "Skip confirmation prompt" + optGlobalDesc = switch + $ long "global" <> short 'g' + <> help "Remove for all users" + optPathsDesc = many $ argument str + $ metavar "PATH" + <> help "Directories to remove" + +main :: IO () +main = execParser parser >>= removePath + where + parser = info (helper <*> optionParser) $ + fullDesc <> progDesc "Remove directories from your PATH" + +removePath :: Options -> IO () +removePath options = runExceptT doRemovePath >>= either ioError return + where + varName = optName options + pathsToRemove = optPaths options + + forAllUsers = optGlobal options + + skipPrompt = optYes options + + emptyIfMissing e + | isDoesNotExistError e = return "" + | otherwise = throwE e + + doRemovePath = do + removePathFrom WindowsEnv.CurrentUser + when forAllUsers $ + removePathFrom WindowsEnv.AllUsers + + removePathFrom profile = do + oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing + let oldPaths = WindowsEnv.pathSplit oldValue + let newPaths = oldPaths \\ pathsToRemove + when (length oldPaths /= length newPaths) $ do + let newValue = WindowsEnv.pathJoin newPaths + let promptAnd = if skipPrompt + then withoutPrompt + else withPrompt $ oldNewMessage profile varName oldValue newValue + let engrave = WindowsEnv.engrave profile varName newValue + void $ promptAnd engrave diff --git a/app/SetEnv.hs b/app/SetEnv.hs new file mode 100644 index 0000000..5948d3e --- /dev/null +++ b/app/SetEnv.hs @@ -0,0 +1,72 @@ +-- | +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module Main (main) where + +import Control.Monad (void) +import Control.Monad.Trans.Except (runExceptT) +import System.IO.Error (ioError) + +import Options.Applicative + +import qualified WindowsEnv + +import Utils.Prompt +import Utils.PromptMessage + +data Options = Options + { optYes :: Bool + , optGlobal :: Bool + , optName :: WindowsEnv.VarName + , optValue :: WindowsEnv.VarValue + } deriving (Eq, Show) + +optionParser :: Parser Options +optionParser = Options + <$> optYesDesc + <*> optGlobalDesc + <*> optNameDesc + <*> optValueDesc + where + optYesDesc = switch + $ long "yes" <> short 'y' + <> help "Skip confirmation prompt" + optGlobalDesc = switch + $ long "global" <> short 'g' + <> help "Set for all users" + optNameDesc = argument str + $ metavar "NAME" + <> help "Variable name" + optValueDesc = argument str + $ metavar "VALUE" + <> help "Variable value" + +main :: IO () +main = execParser parser >>= setEnv + where + parser = info (helper <*> optionParser) $ + fullDesc <> progDesc "Define environment variables" + +setEnv :: Options -> IO () +setEnv options = runExceptT doSetEnv >>= either ioError return + where + varName = optName options + varValue = optValue options + + forAllUsers = optGlobal options + profile + | forAllUsers = WindowsEnv.AllUsers + | otherwise = WindowsEnv.CurrentUser + + skipPrompt = optYes options + promptAnd + | skipPrompt = withoutPrompt + | otherwise = withPrompt $ newMessage profile varName varValue + + engrave = WindowsEnv.engraveForce profile varName varValue + + doSetEnv = void $ promptAnd engrave diff --git a/app/UnsetEnv.hs b/app/UnsetEnv.hs new file mode 100644 index 0000000..98b52e3 --- /dev/null +++ b/app/UnsetEnv.hs @@ -0,0 +1,66 @@ +-- | +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module Main (main) where + +import Control.Monad (void) +import Control.Monad.Trans.Except (runExceptT) +import System.IO.Error (ioError) + +import Options.Applicative + +import qualified WindowsEnv + +import Utils.Prompt +import Utils.PromptMessage + +data Options = Options + { optYes :: Bool + , optGlobal :: Bool + , optName :: WindowsEnv.VarName + } deriving (Eq, Show) + +optionParser :: Parser Options +optionParser = Options + <$> optYesDesc + <*> optGlobalDesc + <*> optNameDesc + where + optYesDesc = switch + $ long "yes" <> short 'y' + <> help "Skip confirmation prompt" + optGlobalDesc = switch + $ long "global" <> short 'g' + <> help "Unset for all users" + optNameDesc = argument str + $ metavar "NAME" + <> help "Variable name" + +main :: IO () +main = execParser parser >>= unsetEnv + where + parser = info (helper <*> optionParser) $ + fullDesc <> progDesc "Delete environment variables" + +unsetEnv :: Options -> IO () +unsetEnv options = runExceptT doUnsetEnv >>= either ioError return + where + varName = optName options + + forAllUsers = optGlobal options + profile + | forAllUsers = WindowsEnv.AllUsers + | otherwise = WindowsEnv.CurrentUser + + skipPrompt = optYes options + promptAnd + | skipPrompt = withoutPrompt + | otherwise = withPrompt $ wipeMessage profile varName + + wipe = WindowsEnv.wipe profile varName + + doUnsetEnv = void $ promptAnd wipe diff --git a/app/Utils/Prompt.hs b/app/Utils/Prompt.hs new file mode 100644 index 0000000..51b3f0c --- /dev/null +++ b/app/Utils/Prompt.hs @@ -0,0 +1,50 @@ +-- | +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : portable + +module Utils.Prompt + ( withPrompt + , withoutPrompt + ) where + +import Control.Monad (void, when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Data.Char (toLower) +import System.IO (hFlush, stdout) + +prompt :: String -> IO String +prompt msg = do + putStr msg + hFlush stdout + getLine + +promptYesNo :: String -> IO Bool +promptYesNo msg = do + response <- map toLower <$> prompt msg + 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) " + +withPrompt :: String -> ExceptT IOError IO a -> ExceptT IOError IO Bool +withPrompt msg m = do + lift $ do + putStr msg + hFlush stdout + agreed <- lift promptToContinue + when agreed $ void m + return agreed + +withoutPrompt :: ExceptT IOError IO a -> ExceptT IOError IO Bool +withoutPrompt m = m >> return True diff --git a/app/Utils/PromptMessage.hs b/app/Utils/PromptMessage.hs new file mode 100644 index 0000000..37fc1e6 --- /dev/null +++ b/app/Utils/PromptMessage.hs @@ -0,0 +1,39 @@ +-- | +-- Copyright : (c) 2016 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module Utils.PromptMessage + ( oldNewMessage + , newMessage + , wipeMessage + ) where + +import Text.Printf (printf) + +import qualified WindowsEnv + +oldNewMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> WindowsEnv.VarValue -> String +oldNewMessage profile name oldValue newValue = + descrMsg ++ oldValueMsg ++ newValueMsg + where + profileKey = WindowsEnv.profileKeyPath profile + descrMsg = printf "Saving variable '%s' to '%s'...\n" name (show profileKey) + oldValueMsg = printf "\tOld value: %s\n" oldValue + newValueMsg = printf "\tNew value: %s\n" newValue + +newMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> String +newMessage profile name newValue = + descrMsg ++ newValueMsg + where + profileKey = WindowsEnv.profileKeyPath profile + descrMsg = printf "Saving variable '%s' to '%s'...\n" name (show profileKey) + newValueMsg = printf "\tNew value: %s\n" newValue + +wipeMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> String +wipeMessage profile name = + printf "Deleting variable '%s' from '%s'...\n" name (show profileKey) + where + profileKey = WindowsEnv.profileKeyPath profile diff --git a/bin/AddPath.hs b/bin/AddPath.hs deleted file mode 100644 index 683b82f..0000000 --- a/bin/AddPath.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only - -module Main (main) where - -import Control.Monad (void, when) -import Control.Monad.Trans.Except (catchE, runExceptT, throwE) -import Data.List (union) -import System.IO.Error (ioError, isDoesNotExistError) - -import Options.Applicative - -import qualified WindowsEnv - -import Utils.Prompt -import Utils.PromptMessage - -data Options = Options - { optName :: WindowsEnv.VarName - , optYes :: Bool - , optGlobal :: Bool - , optPaths :: [WindowsEnv.VarValue] - } deriving (Eq, Show) - -optionParser :: Parser Options -optionParser = Options - <$> optNameDesc - <*> optYesDesc - <*> optGlobalDesc - <*> optPathsDesc - where - optNameDesc = strOption - $ long "name" <> short 'n' - <> metavar "NAME" <> value "PATH" - <> help "Variable name ('PATH' by default)" - optYesDesc = switch - $ long "yes" <> short 'y' - <> help "Skip confirmation prompt" - optGlobalDesc = switch - $ long "global" <> short 'g' - <> help "Add for all users" - optPathsDesc = many $ argument str - $ metavar "PATH" - <> help "Directories to add" - -main :: IO () -main = execParser parser >>= addPath - where - parser = info (helper <*> optionParser) $ - fullDesc <> progDesc "Add directories to your PATH" - -addPath :: Options -> IO () -addPath options = runExceptT doAddPath >>= either ioError return - where - varName = optName options - pathsToAdd = optPaths options - - forAllUsers = optGlobal options - profile - | forAllUsers = WindowsEnv.AllUsers - | otherwise = WindowsEnv.CurrentUser - - skipPrompt = optYes options - - emptyIfMissing e - | isDoesNotExistError e = return "" - | otherwise = throwE e - - doAddPath = do - oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing - let oldPaths = WindowsEnv.pathSplit oldValue - let newPaths = oldPaths `union` pathsToAdd - when (length oldPaths /= length newPaths) $ do - let newValue = WindowsEnv.pathJoin newPaths - let promptAnd = if skipPrompt - then withoutPrompt - else withPrompt $ oldNewMessage profile varName oldValue newValue - let engrave = WindowsEnv.engrave profile varName newValue - void $ promptAnd engrave diff --git a/bin/ListPaths.hs b/bin/ListPaths.hs deleted file mode 100644 index 666423f..0000000 --- a/bin/ListPaths.hs +++ /dev/null @@ -1,84 +0,0 @@ --- | --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only - -module Main (main) where - -import Control.Monad (filterM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (runExceptT) -import Data.Maybe (fromMaybe) -import System.Directory (doesDirectoryExist) -import System.Environment (lookupEnv) -import System.IO.Error (ioError) - -import Options.Applicative - -import qualified WindowsEnv - -data WhichPaths = All | ExistingOnly | MissingOnly - deriving (Eq, Show) - -shouldListPath :: WhichPaths -> WindowsEnv.VarValue -> IO Bool -shouldListPath All = return . const True -shouldListPath ExistingOnly = doesDirectoryExist -shouldListPath MissingOnly = fmap not . doesDirectoryExist - -data Source = Environment | Registry WindowsEnv.Profile - deriving (Eq, Show) - -data Options = Options - { optName :: WindowsEnv.VarName - , optWhichPaths :: WhichPaths - , optSource :: Source - } deriving (Eq, Show) - -optionParser :: Parser Options -optionParser = Options - <$> optNameDesc - <*> optWhichPathsDesc - <*> optSourceDesc - where - optNameDesc = strOption - $ long "name" <> short 'n' - <> metavar "NAME" <> value "PATH" - <> help "Variable name ('PATH' by default)" - optWhichPathsDesc = pure All - <|> flag' ExistingOnly (long "existing" <> short 'e' - <> help "List existing paths only") - <|> flag' MissingOnly (long "missing" <> short 'm' - <> help "List missing paths only") - optSourceDesc = pure Environment - <|> flag' (Registry WindowsEnv.CurrentUser) (long "user" <> short 'u' - <> help "List current user's paths only") - <|> flag' (Registry WindowsEnv.AllUsers) (long "global" <> short 'g' - <> help "List global (all users') paths only") - -main :: IO () -main = execParser parser >>= listPaths - where - parser = info (helper <*> optionParser) $ - fullDesc <> progDesc "List directories in your PATH" - -listPaths :: Options -> IO () -listPaths options = runExceptT doListPaths >>= either ioError return - where - varName = optName options - whichPaths = optWhichPaths options - source = optSource options - - query = queryFrom source - - queryFrom Environment = lift $ fromMaybe "" <$> lookupEnv varName - queryFrom (Registry profile) = WindowsEnv.query profile varName - - filterPaths = filterM $ shouldListPath whichPaths - - doListPaths = do - paths <- WindowsEnv.pathSplit <$> query - lift $ do - pathsToPrint <- filterPaths paths - mapM_ putStrLn pathsToPrint diff --git a/bin/RemovePath.hs b/bin/RemovePath.hs deleted file mode 100644 index 6f2174b..0000000 --- a/bin/RemovePath.hs +++ /dev/null @@ -1,85 +0,0 @@ --- | --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only - -module Main (main) where - -import Control.Monad (void, when) -import Control.Monad.Trans.Except (catchE, runExceptT, throwE) -import Data.List ((\\)) -import System.IO.Error (ioError, isDoesNotExistError) - -import Options.Applicative - -import qualified WindowsEnv - -import Utils.Prompt -import Utils.PromptMessage - -data Options = Options - { optName :: WindowsEnv.VarName - , optYes :: Bool - , optGlobal :: Bool - , optPaths :: [WindowsEnv.VarValue] - } deriving (Eq, Show) - -optionParser :: Parser Options -optionParser = Options - <$> optNameDesc - <*> optYesDesc - <*> optGlobalDesc - <*> optPathsDesc - where - optNameDesc = strOption - $ long "name" <> short 'n' - <> metavar "NAME" <> value "PATH" - <> help "Variable name ('PATH' by default)" - optYesDesc = switch - $ long "yes" <> short 'y' - <> help "Skip confirmation prompt" - optGlobalDesc = switch - $ long "global" <> short 'g' - <> help "Remove for all users" - optPathsDesc = many $ argument str - $ metavar "PATH" - <> help "Directories to remove" - -main :: IO () -main = execParser parser >>= removePath - where - parser = info (helper <*> optionParser) $ - fullDesc <> progDesc "Remove directories from your PATH" - -removePath :: Options -> IO () -removePath options = runExceptT doRemovePath >>= either ioError return - where - varName = optName options - pathsToRemove = optPaths options - - forAllUsers = optGlobal options - - skipPrompt = optYes options - - emptyIfMissing e - | isDoesNotExistError e = return "" - | otherwise = throwE e - - doRemovePath = do - removePathFrom WindowsEnv.CurrentUser - when forAllUsers $ - removePathFrom WindowsEnv.AllUsers - - removePathFrom profile = do - oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing - let oldPaths = WindowsEnv.pathSplit oldValue - let newPaths = oldPaths \\ pathsToRemove - when (length oldPaths /= length newPaths) $ do - let newValue = WindowsEnv.pathJoin newPaths - let promptAnd = if skipPrompt - then withoutPrompt - else withPrompt $ oldNewMessage profile varName oldValue newValue - let engrave = WindowsEnv.engrave profile varName newValue - void $ promptAnd engrave diff --git a/bin/SetEnv.hs b/bin/SetEnv.hs deleted file mode 100644 index 5948d3e..0000000 --- a/bin/SetEnv.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only - -module Main (main) where - -import Control.Monad (void) -import Control.Monad.Trans.Except (runExceptT) -import System.IO.Error (ioError) - -import Options.Applicative - -import qualified WindowsEnv - -import Utils.Prompt -import Utils.PromptMessage - -data Options = Options - { optYes :: Bool - , optGlobal :: Bool - , optName :: WindowsEnv.VarName - , optValue :: WindowsEnv.VarValue - } deriving (Eq, Show) - -optionParser :: Parser Options -optionParser = Options - <$> optYesDesc - <*> optGlobalDesc - <*> optNameDesc - <*> optValueDesc - where - optYesDesc = switch - $ long "yes" <> short 'y' - <> help "Skip confirmation prompt" - optGlobalDesc = switch - $ long "global" <> short 'g' - <> help "Set for all users" - optNameDesc = argument str - $ metavar "NAME" - <> help "Variable name" - optValueDesc = argument str - $ metavar "VALUE" - <> help "Variable value" - -main :: IO () -main = execParser parser >>= setEnv - where - parser = info (helper <*> optionParser) $ - fullDesc <> progDesc "Define environment variables" - -setEnv :: Options -> IO () -setEnv options = runExceptT doSetEnv >>= either ioError return - where - varName = optName options - varValue = optValue options - - forAllUsers = optGlobal options - profile - | forAllUsers = WindowsEnv.AllUsers - | otherwise = WindowsEnv.CurrentUser - - skipPrompt = optYes options - promptAnd - | skipPrompt = withoutPrompt - | otherwise = withPrompt $ newMessage profile varName varValue - - engrave = WindowsEnv.engraveForce profile varName varValue - - doSetEnv = void $ promptAnd engrave diff --git a/bin/UnsetEnv.hs b/bin/UnsetEnv.hs deleted file mode 100644 index 98b52e3..0000000 --- a/bin/UnsetEnv.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only - -module Main (main) where - -import Control.Monad (void) -import Control.Monad.Trans.Except (runExceptT) -import System.IO.Error (ioError) - -import Options.Applicative - -import qualified WindowsEnv - -import Utils.Prompt -import Utils.PromptMessage - -data Options = Options - { optYes :: Bool - , optGlobal :: Bool - , optName :: WindowsEnv.VarName - } deriving (Eq, Show) - -optionParser :: Parser Options -optionParser = Options - <$> optYesDesc - <*> optGlobalDesc - <*> optNameDesc - where - optYesDesc = switch - $ long "yes" <> short 'y' - <> help "Skip confirmation prompt" - optGlobalDesc = switch - $ long "global" <> short 'g' - <> help "Unset for all users" - optNameDesc = argument str - $ metavar "NAME" - <> help "Variable name" - -main :: IO () -main = execParser parser >>= unsetEnv - where - parser = info (helper <*> optionParser) $ - fullDesc <> progDesc "Delete environment variables" - -unsetEnv :: Options -> IO () -unsetEnv options = runExceptT doUnsetEnv >>= either ioError return - where - varName = optName options - - forAllUsers = optGlobal options - profile - | forAllUsers = WindowsEnv.AllUsers - | otherwise = WindowsEnv.CurrentUser - - skipPrompt = optYes options - promptAnd - | skipPrompt = withoutPrompt - | otherwise = withPrompt $ wipeMessage profile varName - - wipe = WindowsEnv.wipe profile varName - - doUnsetEnv = void $ promptAnd wipe diff --git a/bin/Utils/Prompt.hs b/bin/Utils/Prompt.hs deleted file mode 100644 index 51b3f0c..0000000 --- a/bin/Utils/Prompt.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : portable - -module Utils.Prompt - ( withPrompt - , withoutPrompt - ) where - -import Control.Monad (void, when) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT) -import Data.Char (toLower) -import System.IO (hFlush, stdout) - -prompt :: String -> IO String -prompt msg = do - putStr msg - hFlush stdout - getLine - -promptYesNo :: String -> IO Bool -promptYesNo msg = do - response <- map toLower <$> prompt msg - 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) " - -withPrompt :: String -> ExceptT IOError IO a -> ExceptT IOError IO Bool -withPrompt msg m = do - lift $ do - putStr msg - hFlush stdout - agreed <- lift promptToContinue - when agreed $ void m - return agreed - -withoutPrompt :: ExceptT IOError IO a -> ExceptT IOError IO Bool -withoutPrompt m = m >> return True diff --git a/bin/Utils/PromptMessage.hs b/bin/Utils/PromptMessage.hs deleted file mode 100644 index 37fc1e6..0000000 --- a/bin/Utils/PromptMessage.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | --- Copyright : (c) 2016 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only - -module Utils.PromptMessage - ( oldNewMessage - , newMessage - , wipeMessage - ) where - -import Text.Printf (printf) - -import qualified WindowsEnv - -oldNewMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> WindowsEnv.VarValue -> String -oldNewMessage profile name oldValue newValue = - descrMsg ++ oldValueMsg ++ newValueMsg - where - profileKey = WindowsEnv.profileKeyPath profile - descrMsg = printf "Saving variable '%s' to '%s'...\n" name (show profileKey) - oldValueMsg = printf "\tOld value: %s\n" oldValue - newValueMsg = printf "\tNew value: %s\n" newValue - -newMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> String -newMessage profile name newValue = - descrMsg ++ newValueMsg - where - profileKey = WindowsEnv.profileKeyPath profile - descrMsg = printf "Saving variable '%s' to '%s'...\n" name (show profileKey) - newValueMsg = printf "\tNew value: %s\n" newValue - -wipeMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> String -wipeMessage profile name = - printf "Deleting variable '%s' from '%s'...\n" name (show profileKey) - where - profileKey = WindowsEnv.profileKeyPath profile diff --git a/lib/WindowsEnv.hs b/lib/WindowsEnv.hs deleted file mode 100644 index e306507..0000000 --- a/lib/WindowsEnv.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | --- Description : The convinience module to re-export public definitions --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only --- --- An empty module to re-export everything required by the packaged --- applications. - -module WindowsEnv ( - module WindowsEnv.Environment - ) where - -import WindowsEnv.Environment diff --git a/lib/WindowsEnv/Environment.hs b/lib/WindowsEnv/Environment.hs deleted file mode 100644 index 8bfb449..0000000 --- a/lib/WindowsEnv/Environment.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | --- Description : High-level environment variables management functions --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only --- --- High-level functions for reading and writing Windows environment variables. - -module WindowsEnv.Environment - ( Profile(..) - , profileKeyPath - - , VarName - , VarValue - , query - , engrave - , engraveForce - , wipe - - , pathJoin - , pathSplit - ) where - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT(..)) -import Data.List (intercalate) -import Data.List.Split (splitOn) - -import qualified WindowsEnv.Registry as Registry -import WindowsEnv.Utils (notifyEnvironmentUpdate) - -data Profile = CurrentUser - | AllUsers - deriving (Eq, Show) - -profileKeyPath :: Profile -> Registry.KeyPath -profileKeyPath CurrentUser = Registry.KeyPath Registry.CurrentUser ["Environment"] -profileKeyPath AllUsers = Registry.KeyPath Registry.LocalMachine - [ "SYSTEM" - , "CurrentControlSet" - , "Control" - , "Session Manager" - , "Environment" - ] - -type VarName = String -type VarValue = String - -query :: Profile -> VarName -> ExceptT IOError IO VarValue -query profile name = Registry.getExpandedString (profileKeyPath profile) name - -engrave :: Profile -> VarName -> VarValue -> ExceptT IOError IO () -engrave profile name value = do - ret <- Registry.setStringPreserveType (profileKeyPath profile) name value - lift notifyEnvironmentUpdate - return ret - -engraveForce :: Profile -> VarName -> VarValue -> ExceptT IOError IO () -engraveForce profile name value = do - ret <- Registry.setString (profileKeyPath profile) name value - lift notifyEnvironmentUpdate - return ret - -wipe :: Profile -> VarName -> ExceptT IOError IO () -wipe profile name = do - ret <- Registry.deleteValue (profileKeyPath profile) name - lift notifyEnvironmentUpdate - return ret - -pathSep :: VarValue -pathSep = ";" - -pathSplit :: VarValue -> [VarValue] -pathSplit = filter (not . null) . splitOn pathSep - -pathJoin :: [VarValue] -> VarValue -pathJoin = intercalate pathSep . filter (not . null) diff --git a/lib/WindowsEnv/Registry.hs b/lib/WindowsEnv/Registry.hs deleted file mode 100644 index da889d4..0000000 --- a/lib/WindowsEnv/Registry.hs +++ /dev/null @@ -1,292 +0,0 @@ --- | --- Description : Lower-level registry access wrappers --- Copyright : (c) 2015 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only --- --- Lower-level functions for reading and writing registry values. - -module WindowsEnv.Registry - ( IsKeyPath(..) - , RootKey(..) - , KeyPath(..) - - , ValueName - , ValueType - , ValueData - - , open - , close - - , deleteValue - - , queryValue - , queryType - - , getValue - , GetValueFlag(..) - , getType - - , getExpandedString - - , setValue - , setString - , setExpandableString - , setStringPreserveType - ) where - -import Control.Exception (bracket) -import Control.Monad.Trans.Except (ExceptT(..), catchE, throwE) -import Data.Bits ((.|.)) -import qualified Data.ByteString as B -import Data.List (intercalate) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf16LE, encodeUtf16LE) -import Data.Tuple (swap) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Marshal.Alloc (alloca, allocaBytes) -import Foreign.Marshal.Array (peekArray, pokeArray) -import Foreign.Storable (peek, poke) -import System.IO.Error (catchIOError, isDoesNotExistError) -import qualified System.Win32.Types as WinAPI -import qualified System.Win32.Registry as WinAPI - -type Handle = WinAPI.HKEY - -class IsKeyPath a where - openUnsafe :: a -> IO Handle - -close :: Handle -> IO () -close = WinAPI.regCloseKey - -open :: IsKeyPath a => a -> IO (Either IOError Handle) -open keyPath = catchIOError doOpen wrapError - where - doOpen = Right <$> openUnsafe keyPath - wrapError = return . Left - -withHandle :: IsKeyPath a => a -> (Handle -> IO b) -> ExceptT IOError IO b -withHandle keyPath f = ExceptT $ catchIOError doStuff wrapError - where - doStuff = Right <$> bracket (openUnsafe keyPath) close f - wrapError = return . Left - -data RootKey = CurrentUser - | LocalMachine - deriving (Eq) - -instance IsKeyPath RootKey where - openUnsafe CurrentUser = return WinAPI.hKEY_CURRENT_USER - openUnsafe LocalMachine = return WinAPI.hKEY_LOCAL_MACHINE - -instance Show RootKey where - show CurrentUser = "HKCU" - show LocalMachine = "HKLM" - -data KeyPath = KeyPath RootKey [String] - -pathSep :: String -pathSep = "\\" - -instance IsKeyPath KeyPath where - openUnsafe (KeyPath root path) = do - rootHandle <- openUnsafe root - WinAPI.regOpenKey rootHandle $ intercalate pathSep path - -instance Show KeyPath where - show (KeyPath root path) = intercalate pathSep $ show root : path - -type ValueName = String - -data ValueType = TypeNone - | TypeBinary - | TypeDWord - | TypeDWordBE - | TypeQWord - | TypeString - | TypeMultiString - | TypeExpandableString - | TypeLink - deriving (Eq, Show) - -instance Enum ValueType where - fromEnum = fromJust . flip lookup valueTypeTable - toEnum = fromJust . flip lookup (map swap valueTypeTable) - -valueTypeTable :: [(ValueType, Int)] -valueTypeTable = - [ (TypeNone, 0) - , (TypeBinary, 3) - , (TypeDWord, 4) - , (TypeDWordBE, 5) - , (TypeQWord, 11) - , (TypeString, 1) - , (TypeMultiString, 7) - , (TypeExpandableString, 2) - , (TypeLink, 6) - ] - -type ValueData = (ValueType, B.ByteString) - -encodeString :: String -> B.ByteString -encodeString str = encodeUtf16LE addLastZero - where - addLastZero - | T.null text = text - | T.last text == '\0' = text - | otherwise = T.snoc text '\0' - text = T.pack str - -decodeString :: ValueData -> String -decodeString (_, bytes) = T.unpack dropLastZero - where - dropLastZero - | T.null text = text - | otherwise = T.takeWhile (/= '\0') text - text = decodeUtf16LE bytes - -foreign import ccall unsafe "Windows.h RegQueryValueExW" - c_RegQueryValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPDWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode - -foreign import ccall unsafe "Windows.h RegSetValueExW" - c_RegSetValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.DWORD -> WinAPI.DWORD -> WinAPI.LPBYTE -> WinAPI.DWORD -> IO WinAPI.ErrCode - -foreign import ccall unsafe "Windows.h RegGetValueW" - c_RegGetValue :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPCTSTR -> WinAPI.DWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode - -queryValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueData -queryValue keyPath valueName = - withHandle keyPath $ \keyHandle -> - withForeignPtr keyHandle $ \keyHandlePtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - alloca $ \valueSizePtr -> do - poke valueSizePtr 0 - WinAPI.failUnlessSuccess "RegQueryValueExW" $ - c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr WinAPI.nullPtr valueSizePtr - valueSize <- fromIntegral <$> peek valueSizePtr - alloca $ \valueTypePtr -> - allocaBytes valueSize $ \bufferPtr -> do - WinAPI.failUnlessSuccess "RegQueryValueExW" $ - c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr valueTypePtr bufferPtr valueSizePtr - buffer <- B.pack <$> peekArray valueSize bufferPtr - valueType <- toEnum . fromIntegral <$> peek valueTypePtr - return (valueType, buffer) - -queryType :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueType -queryType keyPath valueName = - withHandle keyPath $ \keyHandle -> - withForeignPtr keyHandle $ \keyHandlePtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - alloca $ \valueTypePtr -> do - WinAPI.failUnlessSuccess "RegQueryValueExW" $ - c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr valueTypePtr WinAPI.nullPtr WinAPI.nullPtr - toEnum . fromIntegral <$> peek valueTypePtr - -data GetValueFlag = RestrictAny - | RestrictNone - | RestrictBinary - | RestrictDWord - | RestrictQWord - | RestrictString - | RestrictMultiString - | RestrictExpandableString - | DoNotExpand - deriving (Eq, Show) - -instance Enum GetValueFlag where - fromEnum = fromJust . flip lookup getValueFlagsTable - toEnum = fromJust . flip lookup (map swap getValueFlagsTable) - -getValueFlagsTable :: [(GetValueFlag, Int)] -getValueFlagsTable = - [ (RestrictAny, 0x0000ffff) - , (RestrictNone, 0x00000001) - , (RestrictBinary, 0x00000008) - , (RestrictDWord, 0x00000010) - , (RestrictQWord, 0x00000040) - , (RestrictString, 0x00000002) - , (RestrictMultiString, 0x00000020) - , (RestrictExpandableString, 0x00000004) - , (DoNotExpand, 0x10000000) - ] - -getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueData -getValue keyPath valueName flags = - withHandle keyPath $ \keyHandle -> - withForeignPtr keyHandle $ \keyHandlePtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - alloca $ \valueSizePtr -> do - poke valueSizePtr 0 - WinAPI.failUnlessSuccess "RegGetValueW" $ - c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags WinAPI.nullPtr WinAPI.nullPtr valueSizePtr - bufferCapacity <- fromIntegral <$> peek valueSizePtr - alloca $ \valueTypePtr -> - allocaBytes bufferCapacity $ \bufferPtr -> do - WinAPI.failUnlessSuccess "RegGetValueW" $ - c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags valueTypePtr bufferPtr valueSizePtr - bufferSize <- fromIntegral <$> peek valueSizePtr - buffer <- B.pack <$> peekArray bufferSize bufferPtr - valueType <- toEnum . fromIntegral <$> peek valueTypePtr - return (valueType, buffer) - where - rawFlags = fromIntegral $ foldr ((.|.) . fromEnum) 0 flags - -getType :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueType -getType keyPath valueName flags = - withHandle keyPath $ \keyHandle -> - withForeignPtr keyHandle $ \keyHandlePtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - alloca $ \valueTypePtr -> do - WinAPI.failUnlessSuccess "RegGetValueW" $ - c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags valueTypePtr WinAPI.nullPtr WinAPI.nullPtr - toEnum . fromIntegral <$> peek valueTypePtr - where - rawFlags = fromIntegral $ foldr ((.|.) . fromEnum) 0 (DoNotExpand : flags) - -getExpandedString :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String -getExpandedString keyPath valueName = do - valueData <- getValue keyPath valueName [RestrictString] - return $ decodeString valueData - -setValue :: IsKeyPath a => a -> ValueName -> ValueData -> ExceptT IOError IO () -setValue keyPath valueName (valueType, valueData) = - withHandle keyPath $ \keyHandle -> - withForeignPtr keyHandle $ \keyHandlePtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - allocaBytes bufferSize $ \bufferPtr -> do - pokeArray bufferPtr buffer - WinAPI.failUnlessSuccess "RegSetValueExW" $ - c_RegSetValueEx keyHandlePtr valueNamePtr 0 rawValueType bufferPtr (fromIntegral bufferSize) - where - rawValueType = fromIntegral $ fromEnum valueType - buffer = B.unpack valueData - bufferSize = B.length valueData - -setString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () -setString keyPath valueName valueData = - setValue keyPath valueName (TypeString, encodeString valueData) - -setExpandableString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () -setExpandableString keyPath valueName valueData = - setValue keyPath valueName (TypeExpandableString, encodeString valueData) - -setStringPreserveType :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () -setStringPreserveType keyPath valueName valueData = do - valueType <- getType keyPath valueName flags `catchE` stringByDefault - setValue keyPath valueName (valueType, encodeString valueData) - where - flags = [RestrictString, RestrictExpandableString] - stringByDefault e - | isDoesNotExistError e = return TypeString - | otherwise = throwE e - -deleteValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO () -deleteValue keyPath valueName = - withHandle keyPath $ \keyHandle -> - withForeignPtr keyHandle $ \keyHandlePtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - WinAPI.failUnlessSuccess "RegDeleteValueW" $ - WinAPI.c_RegDeleteValue keyHandlePtr valueNamePtr diff --git a/lib/WindowsEnv/Utils.hs b/lib/WindowsEnv/Utils.hs deleted file mode 100644 index c852229..0000000 --- a/lib/WindowsEnv/Utils.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | --- Copyright : (c) 2016 Egor Tensin --- License : MIT --- Maintainer : Egor.Tensin@gmail.com --- Stability : experimental --- Portability : Windows-only - -module WindowsEnv.Utils - ( notifyEnvironmentUpdate - ) where - -import Foreign.C.Types (CIntPtr(..)) -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 "Windows.h 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 diff --git a/src/WindowsEnv.hs b/src/WindowsEnv.hs new file mode 100644 index 0000000..e306507 --- /dev/null +++ b/src/WindowsEnv.hs @@ -0,0 +1,16 @@ +-- | +-- Description : The convinience module to re-export public definitions +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only +-- +-- An empty module to re-export everything required by the packaged +-- applications. + +module WindowsEnv ( + module WindowsEnv.Environment + ) where + +import WindowsEnv.Environment diff --git a/src/WindowsEnv/Environment.hs b/src/WindowsEnv/Environment.hs new file mode 100644 index 0000000..8bfb449 --- /dev/null +++ b/src/WindowsEnv/Environment.hs @@ -0,0 +1,79 @@ +-- | +-- Description : High-level environment variables management functions +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only +-- +-- High-level functions for reading and writing Windows environment variables. + +module WindowsEnv.Environment + ( Profile(..) + , profileKeyPath + + , VarName + , VarValue + , query + , engrave + , engraveForce + , wipe + + , pathJoin + , pathSplit + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT(..)) +import Data.List (intercalate) +import Data.List.Split (splitOn) + +import qualified WindowsEnv.Registry as Registry +import WindowsEnv.Utils (notifyEnvironmentUpdate) + +data Profile = CurrentUser + | AllUsers + deriving (Eq, Show) + +profileKeyPath :: Profile -> Registry.KeyPath +profileKeyPath CurrentUser = Registry.KeyPath Registry.CurrentUser ["Environment"] +profileKeyPath AllUsers = Registry.KeyPath Registry.LocalMachine + [ "SYSTEM" + , "CurrentControlSet" + , "Control" + , "Session Manager" + , "Environment" + ] + +type VarName = String +type VarValue = String + +query :: Profile -> VarName -> ExceptT IOError IO VarValue +query profile name = Registry.getExpandedString (profileKeyPath profile) name + +engrave :: Profile -> VarName -> VarValue -> ExceptT IOError IO () +engrave profile name value = do + ret <- Registry.setStringPreserveType (profileKeyPath profile) name value + lift notifyEnvironmentUpdate + return ret + +engraveForce :: Profile -> VarName -> VarValue -> ExceptT IOError IO () +engraveForce profile name value = do + ret <- Registry.setString (profileKeyPath profile) name value + lift notifyEnvironmentUpdate + return ret + +wipe :: Profile -> VarName -> ExceptT IOError IO () +wipe profile name = do + ret <- Registry.deleteValue (profileKeyPath profile) name + lift notifyEnvironmentUpdate + return ret + +pathSep :: VarValue +pathSep = ";" + +pathSplit :: VarValue -> [VarValue] +pathSplit = filter (not . null) . splitOn pathSep + +pathJoin :: [VarValue] -> VarValue +pathJoin = intercalate pathSep . filter (not . null) diff --git a/src/WindowsEnv/Registry.hs b/src/WindowsEnv/Registry.hs new file mode 100644 index 0000000..da889d4 --- /dev/null +++ b/src/WindowsEnv/Registry.hs @@ -0,0 +1,292 @@ +-- | +-- Description : Lower-level registry access wrappers +-- Copyright : (c) 2015 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only +-- +-- Lower-level functions for reading and writing registry values. + +module WindowsEnv.Registry + ( IsKeyPath(..) + , RootKey(..) + , KeyPath(..) + + , ValueName + , ValueType + , ValueData + + , open + , close + + , deleteValue + + , queryValue + , queryType + + , getValue + , GetValueFlag(..) + , getType + + , getExpandedString + + , setValue + , setString + , setExpandableString + , setStringPreserveType + ) where + +import Control.Exception (bracket) +import Control.Monad.Trans.Except (ExceptT(..), catchE, throwE) +import Data.Bits ((.|.)) +import qualified Data.ByteString as B +import Data.List (intercalate) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf16LE, encodeUtf16LE) +import Data.Tuple (swap) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Array (peekArray, pokeArray) +import Foreign.Storable (peek, poke) +import System.IO.Error (catchIOError, isDoesNotExistError) +import qualified System.Win32.Types as WinAPI +import qualified System.Win32.Registry as WinAPI + +type Handle = WinAPI.HKEY + +class IsKeyPath a where + openUnsafe :: a -> IO Handle + +close :: Handle -> IO () +close = WinAPI.regCloseKey + +open :: IsKeyPath a => a -> IO (Either IOError Handle) +open keyPath = catchIOError doOpen wrapError + where + doOpen = Right <$> openUnsafe keyPath + wrapError = return . Left + +withHandle :: IsKeyPath a => a -> (Handle -> IO b) -> ExceptT IOError IO b +withHandle keyPath f = ExceptT $ catchIOError doStuff wrapError + where + doStuff = Right <$> bracket (openUnsafe keyPath) close f + wrapError = return . Left + +data RootKey = CurrentUser + | LocalMachine + deriving (Eq) + +instance IsKeyPath RootKey where + openUnsafe CurrentUser = return WinAPI.hKEY_CURRENT_USER + openUnsafe LocalMachine = return WinAPI.hKEY_LOCAL_MACHINE + +instance Show RootKey where + show CurrentUser = "HKCU" + show LocalMachine = "HKLM" + +data KeyPath = KeyPath RootKey [String] + +pathSep :: String +pathSep = "\\" + +instance IsKeyPath KeyPath where + openUnsafe (KeyPath root path) = do + rootHandle <- openUnsafe root + WinAPI.regOpenKey rootHandle $ intercalate pathSep path + +instance Show KeyPath where + show (KeyPath root path) = intercalate pathSep $ show root : path + +type ValueName = String + +data ValueType = TypeNone + | TypeBinary + | TypeDWord + | TypeDWordBE + | TypeQWord + | TypeString + | TypeMultiString + | TypeExpandableString + | TypeLink + deriving (Eq, Show) + +instance Enum ValueType where + fromEnum = fromJust . flip lookup valueTypeTable + toEnum = fromJust . flip lookup (map swap valueTypeTable) + +valueTypeTable :: [(ValueType, Int)] +valueTypeTable = + [ (TypeNone, 0) + , (TypeBinary, 3) + , (TypeDWord, 4) + , (TypeDWordBE, 5) + , (TypeQWord, 11) + , (TypeString, 1) + , (TypeMultiString, 7) + , (TypeExpandableString, 2) + , (TypeLink, 6) + ] + +type ValueData = (ValueType, B.ByteString) + +encodeString :: String -> B.ByteString +encodeString str = encodeUtf16LE addLastZero + where + addLastZero + | T.null text = text + | T.last text == '\0' = text + | otherwise = T.snoc text '\0' + text = T.pack str + +decodeString :: ValueData -> String +decodeString (_, bytes) = T.unpack dropLastZero + where + dropLastZero + | T.null text = text + | otherwise = T.takeWhile (/= '\0') text + text = decodeUtf16LE bytes + +foreign import ccall unsafe "Windows.h RegQueryValueExW" + c_RegQueryValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPDWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode + +foreign import ccall unsafe "Windows.h RegSetValueExW" + c_RegSetValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.DWORD -> WinAPI.DWORD -> WinAPI.LPBYTE -> WinAPI.DWORD -> IO WinAPI.ErrCode + +foreign import ccall unsafe "Windows.h RegGetValueW" + c_RegGetValue :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPCTSTR -> WinAPI.DWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode + +queryValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueData +queryValue keyPath valueName = + withHandle keyPath $ \keyHandle -> + withForeignPtr keyHandle $ \keyHandlePtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \valueSizePtr -> do + poke valueSizePtr 0 + WinAPI.failUnlessSuccess "RegQueryValueExW" $ + c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr WinAPI.nullPtr valueSizePtr + valueSize <- fromIntegral <$> peek valueSizePtr + alloca $ \valueTypePtr -> + allocaBytes valueSize $ \bufferPtr -> do + WinAPI.failUnlessSuccess "RegQueryValueExW" $ + c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr valueTypePtr bufferPtr valueSizePtr + buffer <- B.pack <$> peekArray valueSize bufferPtr + valueType <- toEnum . fromIntegral <$> peek valueTypePtr + return (valueType, buffer) + +queryType :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueType +queryType keyPath valueName = + withHandle keyPath $ \keyHandle -> + withForeignPtr keyHandle $ \keyHandlePtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \valueTypePtr -> do + WinAPI.failUnlessSuccess "RegQueryValueExW" $ + c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr valueTypePtr WinAPI.nullPtr WinAPI.nullPtr + toEnum . fromIntegral <$> peek valueTypePtr + +data GetValueFlag = RestrictAny + | RestrictNone + | RestrictBinary + | RestrictDWord + | RestrictQWord + | RestrictString + | RestrictMultiString + | RestrictExpandableString + | DoNotExpand + deriving (Eq, Show) + +instance Enum GetValueFlag where + fromEnum = fromJust . flip lookup getValueFlagsTable + toEnum = fromJust . flip lookup (map swap getValueFlagsTable) + +getValueFlagsTable :: [(GetValueFlag, Int)] +getValueFlagsTable = + [ (RestrictAny, 0x0000ffff) + , (RestrictNone, 0x00000001) + , (RestrictBinary, 0x00000008) + , (RestrictDWord, 0x00000010) + , (RestrictQWord, 0x00000040) + , (RestrictString, 0x00000002) + , (RestrictMultiString, 0x00000020) + , (RestrictExpandableString, 0x00000004) + , (DoNotExpand, 0x10000000) + ] + +getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueData +getValue keyPath valueName flags = + withHandle keyPath $ \keyHandle -> + withForeignPtr keyHandle $ \keyHandlePtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \valueSizePtr -> do + poke valueSizePtr 0 + WinAPI.failUnlessSuccess "RegGetValueW" $ + c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags WinAPI.nullPtr WinAPI.nullPtr valueSizePtr + bufferCapacity <- fromIntegral <$> peek valueSizePtr + alloca $ \valueTypePtr -> + allocaBytes bufferCapacity $ \bufferPtr -> do + WinAPI.failUnlessSuccess "RegGetValueW" $ + c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags valueTypePtr bufferPtr valueSizePtr + bufferSize <- fromIntegral <$> peek valueSizePtr + buffer <- B.pack <$> peekArray bufferSize bufferPtr + valueType <- toEnum . fromIntegral <$> peek valueTypePtr + return (valueType, buffer) + where + rawFlags = fromIntegral $ foldr ((.|.) . fromEnum) 0 flags + +getType :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueType +getType keyPath valueName flags = + withHandle keyPath $ \keyHandle -> + withForeignPtr keyHandle $ \keyHandlePtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \valueTypePtr -> do + WinAPI.failUnlessSuccess "RegGetValueW" $ + c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags valueTypePtr WinAPI.nullPtr WinAPI.nullPtr + toEnum . fromIntegral <$> peek valueTypePtr + where + rawFlags = fromIntegral $ foldr ((.|.) . fromEnum) 0 (DoNotExpand : flags) + +getExpandedString :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String +getExpandedString keyPath valueName = do + valueData <- getValue keyPath valueName [RestrictString] + return $ decodeString valueData + +setValue :: IsKeyPath a => a -> ValueName -> ValueData -> ExceptT IOError IO () +setValue keyPath valueName (valueType, valueData) = + withHandle keyPath $ \keyHandle -> + withForeignPtr keyHandle $ \keyHandlePtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + allocaBytes bufferSize $ \bufferPtr -> do + pokeArray bufferPtr buffer + WinAPI.failUnlessSuccess "RegSetValueExW" $ + c_RegSetValueEx keyHandlePtr valueNamePtr 0 rawValueType bufferPtr (fromIntegral bufferSize) + where + rawValueType = fromIntegral $ fromEnum valueType + buffer = B.unpack valueData + bufferSize = B.length valueData + +setString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () +setString keyPath valueName valueData = + setValue keyPath valueName (TypeString, encodeString valueData) + +setExpandableString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () +setExpandableString keyPath valueName valueData = + setValue keyPath valueName (TypeExpandableString, encodeString valueData) + +setStringPreserveType :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () +setStringPreserveType keyPath valueName valueData = do + valueType <- getType keyPath valueName flags `catchE` stringByDefault + setValue keyPath valueName (valueType, encodeString valueData) + where + flags = [RestrictString, RestrictExpandableString] + stringByDefault e + | isDoesNotExistError e = return TypeString + | otherwise = throwE e + +deleteValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO () +deleteValue keyPath valueName = + withHandle keyPath $ \keyHandle -> + withForeignPtr keyHandle $ \keyHandlePtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + WinAPI.failUnlessSuccess "RegDeleteValueW" $ + WinAPI.c_RegDeleteValue keyHandlePtr valueNamePtr diff --git a/src/WindowsEnv/Utils.hs b/src/WindowsEnv/Utils.hs new file mode 100644 index 0000000..c852229 --- /dev/null +++ b/src/WindowsEnv/Utils.hs @@ -0,0 +1,30 @@ +-- | +-- Copyright : (c) 2016 Egor Tensin +-- License : MIT +-- Maintainer : Egor.Tensin@gmail.com +-- Stability : experimental +-- Portability : Windows-only + +module WindowsEnv.Utils + ( notifyEnvironmentUpdate + ) where + +import Foreign.C.Types (CIntPtr(..)) +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 "Windows.h 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 diff --git a/windows-env.cabal b/windows-env.cabal index 876cb5a..abea108 100644 --- a/windows-env.cabal +++ b/windows-env.cabal @@ -21,7 +21,7 @@ extra-source-files: README.md cabal-version: >=1.10 library - hs-source-dirs: lib + hs-source-dirs: src exposed-modules: WindowsEnv, WindowsEnv.Environment other-modules: WindowsEnv.Registry, WindowsEnv.Utils ghc-options: -Wall -Werror @@ -34,7 +34,7 @@ library default-language: Haskell2010 executable addpath - hs-source-dirs: bin + hs-source-dirs: app main-is: AddPath.hs other-modules: Utils.Prompt, Utils.PromptMessage ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N @@ -45,7 +45,7 @@ executable addpath default-language: Haskell2010 executable paths - hs-source-dirs: bin + hs-source-dirs: app main-is: ListPaths.hs other-modules: Utils.Prompt, Utils.PromptMessage ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N @@ -56,7 +56,7 @@ executable paths default-language: Haskell2010 executable delpath - hs-source-dirs: bin + hs-source-dirs: app main-is: RemovePath.hs other-modules: Utils.Prompt, Utils.PromptMessage ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N @@ -67,7 +67,7 @@ executable delpath default-language: Haskell2010 executable setenv - hs-source-dirs: bin + hs-source-dirs: app main-is: SetEnv.hs other-modules: Utils.Prompt, Utils.PromptMessage ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N @@ -78,7 +78,7 @@ executable setenv default-language: Haskell2010 executable delenv - hs-source-dirs: bin + hs-source-dirs: app main-is: UnsetEnv.hs other-modules: Utils.Prompt, Utils.PromptMessage ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N -- cgit v1.2.3