aboutsummaryrefslogtreecommitdiffstatshomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--apps/AddPath.hs24
-rw-r--r--apps/FixNtSymbolPath.hs17
-rw-r--r--apps/ListPath.hs2
-rw-r--r--apps/RemovePath.hs21
-rw-r--r--apps/SetEnv.hs20
-rw-r--r--apps/UnsetEnv.hs18
-rw-r--r--apps/Utils.hs66
-rw-r--r--src/Environment.hs122
-rw-r--r--src/Registry.hs2
-rw-r--r--src/Utils.hs32
-rw-r--r--src/WindowsUtils.hs28
-rw-r--r--windows-env.cabal2
12 files changed, 201 insertions, 153 deletions
diff --git a/apps/AddPath.hs b/apps/AddPath.hs
index 9c6c245..6103d1d 100644
--- a/apps/AddPath.hs
+++ b/apps/AddPath.hs
@@ -6,19 +6,22 @@
module Main (main) where
-import Control.Monad (when)
+import Control.Monad (void, when)
import Data.List (union)
import Data.Maybe (fromMaybe)
+import Text.Printf (printf)
import Options.Applicative
import qualified Environment
+import qualified Utils
+
data Options = Options
- { optName :: String
+ { optName :: Environment.VarName
, optYes :: Bool
, optGlobal :: Bool
- , optPaths :: [String]
+ , optPaths :: [Environment.VarValue]
} deriving (Eq, Show)
options :: Parser Options
@@ -49,24 +52,23 @@ main = execParser parser >>= addPath
addPath :: Options -> IO ()
addPath options = do
- oldValue <- query
+ oldValue <- Environment.query profile varName
let oldPaths = Environment.pathSplit $ fromMaybe "" oldValue
let newPaths = union oldPaths pathsToAdd
when (length oldPaths /= length newPaths) $ do
let newValue = Environment.pathJoin newPaths
- engrave newValue
+ let promptBanner = Utils.engraveBanner profile varName oldValue newValue
+ void $ prompt promptBanner $ Environment.engrave profile varName newValue
where
varName = optName options
pathsToAdd = optPaths options
forAllUsers = optGlobal options
- env = if forAllUsers
+ profile = if forAllUsers
then Environment.AllUsers
else Environment.CurrentUser
- query = Environment.query env varName
-
skipPrompt = optYes options
- engrave value = if skipPrompt
- then Environment.engrave env varName value
- else Environment.engravePrompt env varName value >> return ()
+ prompt = if skipPrompt
+ then const Utils.withoutPrompt
+ else Utils.withPrompt
diff --git a/apps/FixNtSymbolPath.hs b/apps/FixNtSymbolPath.hs
index 14d0861..3788381 100644
--- a/apps/FixNtSymbolPath.hs
+++ b/apps/FixNtSymbolPath.hs
@@ -16,6 +16,8 @@ import Options.Applicative
import qualified Environment
+import qualified Utils
+
data Options = Options
{ optYes :: Bool
, optGlobal :: Bool
@@ -64,30 +66,29 @@ getLocalDirs = do
fixNtSymbolPath :: Options -> IO ()
fixNtSymbolPath options = do
- oldValue <- query
+ oldValue <- Environment.query profile varName
let oldPaths = Environment.pathSplit $ fromMaybe "" oldValue
localDirs <- getLocalDirs
let remoteDirs = toRemoteDirs localDirs
let newPaths = union oldPaths $ dirPaths remoteDirs
when (length oldPaths /= length newPaths) $ do
let newValue = Environment.pathJoin newPaths
- confirmed <- engrave newValue
+ let promptBanner = Utils.engraveBanner profile varName oldValue newValue
+ confirmed <- prompt promptBanner $ Environment.engrave profile varName newValue
when confirmed $
createDirs localDirs
where
varName = "_NT_SYMBOL_PATH"
forAllUsers = optGlobal options
- env = if forAllUsers
+ profile = if forAllUsers
then Environment.AllUsers
else Environment.CurrentUser
- query = Environment.query env varName
-
skipPrompt = optYes options
- engrave value = if skipPrompt
- then Environment.engrave env varName value >> return True
- else Environment.engravePrompt env varName value
+ prompt = if skipPrompt
+ then const Utils.withoutPrompt
+ else Utils.withPrompt
main :: IO ()
main = execParser parser >>= fixNtSymbolPath
diff --git a/apps/ListPath.hs b/apps/ListPath.hs
index e0cbefe..ace3ede 100644
--- a/apps/ListPath.hs
+++ b/apps/ListPath.hs
@@ -16,7 +16,7 @@ import Options.Applicative
import qualified Environment
data Options = Options
- { optName :: String
+ { optName :: Environment.VarName
} deriving (Eq, Show)
options :: Parser Options
diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs
index 21b4ac6..a594ecd 100644
--- a/apps/RemovePath.hs
+++ b/apps/RemovePath.hs
@@ -6,7 +6,7 @@
module Main (main) where
-import Control.Monad (when)
+import Control.Monad (void, when)
import Data.List ((\\))
import Data.Maybe (fromJust, isJust)
@@ -14,11 +14,13 @@ import Options.Applicative
import qualified Environment
+import qualified Utils
+
data Options = Options
- { optName :: String
+ { optName :: Environment.VarName
, optYes :: Bool
, optGlobal :: Bool
- , optPaths :: [String]
+ , optPaths :: [Environment.VarValue]
} deriving (Eq, Show)
options = Options
@@ -57,16 +59,17 @@ removePath options = do
forAllUsers = optGlobal options
- removePathFrom env = do
- oldValue <- Environment.query env varName
+ removePathFrom profile = do
+ oldValue <- Environment.query profile varName
when (isJust oldValue) $ do
let oldPaths = Environment.pathSplit $ fromJust oldValue
let newPaths = oldPaths \\ pathsToRemove
when (length oldPaths /= length newPaths) $ do
let newValue = Environment.pathJoin newPaths
- engrave env newValue
+ let promptBanner = Utils.engraveBanner profile varName oldValue newValue
+ void $ prompt promptBanner $ Environment.engrave profile varName newValue
skipPrompt = optYes options
- engrave env value = if skipPrompt
- then Environment.engrave env varName value
- else Environment.engravePrompt env varName value >> return ()
+ prompt = if skipPrompt
+ then const Utils.withoutPrompt
+ else Utils.withPrompt
diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs
index 3b88e7c..0b95176 100644
--- a/apps/SetEnv.hs
+++ b/apps/SetEnv.hs
@@ -6,15 +6,19 @@
module Main (main) where
+import Control.Monad (void)
+
import Options.Applicative hiding (value)
import qualified Environment
+import qualified Utils
+
data Options = Options
{ optYes :: Bool
, optGlobal :: Bool
- , optName :: String
- , optValue :: String
+ , optName :: Environment.VarName
+ , optValue :: Environment.VarValue
} deriving (Eq, Show)
options :: Parser Options
@@ -44,17 +48,19 @@ main = execParser parser >>= setEnv
fullDesc <> progDesc "Set environment variable"
setEnv :: Options -> IO ()
-setEnv options = engrave varValue
+setEnv options = void $ prompt confirmationBanner $ Environment.engrave profile varName varValue
where
+ confirmationBanner = Utils.engraveBanner profile varName Nothing varValue
+
varName = optName options
varValue = optValue options
forAllUsers = optGlobal options
- env = if forAllUsers
+ profile = if forAllUsers
then Environment.AllUsers
else Environment.CurrentUser
skipPrompt = optYes options
- engrave value = if skipPrompt
- then Environment.engrave env varName value
- else Environment.engravePrompt env varName value >> return ()
+ prompt = if skipPrompt
+ then const Utils.withoutPrompt
+ else Utils.withPrompt
diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs
index e4cbeac..b0ed96a 100644
--- a/apps/UnsetEnv.hs
+++ b/apps/UnsetEnv.hs
@@ -6,14 +6,18 @@
module Main (main) where
+import Control.Monad (void)
+
import Options.Applicative
import qualified Environment
+import qualified Utils
+
data Options = Options
{ optYes :: Bool
, optGlobal :: Bool
- , optName :: String
+ , optName :: Environment.VarName
} deriving (Eq, Show)
options :: Parser Options
@@ -39,16 +43,18 @@ main = execParser parser >>= unsetEnv
fullDesc <> progDesc "Unset environment variable"
unsetEnv :: Options -> IO ()
-unsetEnv options = wipe
+unsetEnv options = void $ prompt confirmationBanner $ Environment.wipe profile varName
where
+ confirmationBanner = Utils.wipeBanner profile varName
+
varName = optName options
forAllUsers = optGlobal options
- env = if forAllUsers
+ profile = if forAllUsers
then Environment.AllUsers
else Environment.CurrentUser
skipPrompt = optYes options
- wipe = if skipPrompt
- then Environment.wipe env varName
- else Environment.wipePrompt env varName >> return ()
+ prompt = if skipPrompt
+ then const Utils.withoutPrompt
+ else Utils.withPrompt
diff --git a/apps/Utils.hs b/apps/Utils.hs
new file mode 100644
index 0000000..28309d4
--- /dev/null
+++ b/apps/Utils.hs
@@ -0,0 +1,66 @@
+{-
+ - Copyright 2015 Egor Tensin <Egor.Tensin@gmail.com>
+ - This file is licensed under the terms of the MIT License.
+ - See LICENSE.txt for details.
+-}
+
+module Utils
+ ( withPrompt
+ , withoutPrompt
+
+ , engraveBanner
+ , wipeBanner
+ ) where
+
+import Control.Monad (liftM, void, when)
+import Data.Maybe (fromJust, isJust)
+import Data.Char (toLower)
+import System.IO (hFlush, stdout)
+import Text.Printf (printf)
+
+import Environment (Profile, profileKeyPath, VarName, VarValue)
+
+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) "
+
+withPrompt :: String -> IO a -> IO Bool
+withPrompt banner m = do
+ putStr banner
+ hFlush stdout
+ agreed <- promptToContinue
+ when agreed $ void m
+ return agreed
+
+withoutPrompt :: IO a -> IO Bool
+withoutPrompt m = m >> return True
+
+engraveBanner :: Profile -> VarName -> Maybe VarValue -> VarValue -> String
+engraveBanner profile name oldValue newValue =
+ header ++ values
+ where
+ header = printf "Saving variable '%s' to '%s'...\n" name (profileKeyPath profile)
+ values = if isJust oldValue
+ then printf "\tOld value: %s\n\tNew value: %s\n" (fromJust oldValue) newValue
+ else printf "\tValue: %s\n" newValue
+
+wipeBanner :: Profile -> VarName -> String
+wipeBanner profile name =
+ printf "Deleting variable '%s' from '%s'...\n" name (profileKeyPath profile)
diff --git a/src/Environment.hs b/src/Environment.hs
index 68a3917..f370de4 100644
--- a/src/Environment.hs
+++ b/src/Environment.hs
@@ -5,116 +5,84 @@
-}
module Environment
- ( RegistryLocation(..)
+ ( Profile(..)
+ , profileKeyPath
+
+ , VarName
+ , VarValue
, query
, engrave
- , engravePrompt
, wipe
- , wipePrompt
, pathJoin
, pathSplit
) where
-import Control.Monad (when)
import Data.List (intercalate)
import Data.List.Split (splitOn)
-import Data.Maybe (fromJust, isJust)
import System.IO.Error (catchIOError, isDoesNotExistError)
-import qualified Graphics.Win32.GDI.Types as WinAPI
-import qualified Graphics.Win32.Message as WinAPI
-import qualified System.Win32.Types as WinAPI
-
import qualified Registry
-import qualified Utils (promptToContinue)
+import WindowsUtils (notifyEnvironmentUpdate)
-data RegistryLocation
- = CurrentUser
- | AllUsers
- deriving (Eq, Show)
+data Profile = CurrentUser
+ | AllUsers
+ deriving (Eq, Show)
-subKeyPath :: RegistryLocation -> Registry.KeyPath
-subKeyPath CurrentUser =
- Registry.keyPathFromString "Environment"
-subKeyPath AllUsers =
- Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment"
+profileRootKey :: Profile -> Registry.RootKey
+profileRootKey CurrentUser = Registry.CurrentUser
+profileRootKey AllUsers = Registry.LocalMachine
-rootKey :: RegistryLocation -> Registry.RootKey
-rootKey CurrentUser = Registry.CurrentUser
-rootKey AllUsers = Registry.LocalMachine
+profileRootKeyPath :: Profile -> Registry.KeyPath
+profileRootKeyPath = Registry.rootKeyPath . profileRootKey
-openRootKey :: RegistryLocation -> Registry.KeyHandle
-openRootKey = Registry.openRootKey . rootKey
+profileSubKeyPath :: Profile -> Registry.KeyPath
+profileSubKeyPath CurrentUser =
+ Registry.keyPathFromString "Environment"
+profileSubKeyPath AllUsers =
+ Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment"
-openRegistryKey :: RegistryLocation -> IO Registry.KeyHandle
-openRegistryKey env = Registry.openSubKey (openRootKey env) (subKeyPath env)
+profileKeyPath :: Profile -> Registry.KeyPath
+profileKeyPath profile = Registry.keyPathJoin
+ [ profileRootKeyPath profile
+ , profileSubKeyPath profile
+ ]
-registryKeyPath :: RegistryLocation -> Registry.KeyPath
-registryKeyPath env = Registry.keyPathJoin [Registry.rootKeyPath $ rootKey env, subKeyPath env]
+openRootProfileKey :: Profile -> Registry.KeyHandle
+openRootProfileKey = Registry.openRootKey . profileRootKey
-foreign import ccall "SendNotifyMessageW"
- c_SendNotifyMessage :: WinAPI.HWND -> WinAPI.WindowMessage -> WinAPI.WPARAM -> WinAPI.LPARAM -> IO WinAPI.LRESULT
+openProfileKey :: Profile -> IO Registry.KeyHandle
+openProfileKey profile = Registry.openSubKey (openRootProfileKey profile) (profileSubKeyPath profile)
-notifyEnvUpdate :: IO ()
-notifyEnvUpdate =
- WinAPI.withTString "Environment" $ \lparamPtr -> do
- let wparam = 0
- let lparam = fromIntegral $ WinAPI.castPtrToUINTPtr lparamPtr
- _ <- c_SendNotifyMessage allWindows messageCode wparam lparam
- return ()
- where
- messageCode = WinAPI.wM_WININICHANGE
- hWND_BROADCAST = WinAPI.castUINTPtrToPtr 0xffff
- allWindows = hWND_BROADCAST
+type VarName = Registry.ValueName
+type VarValue = Registry.ValueData
-query :: RegistryLocation -> Registry.ValueName -> IO (Maybe Registry.ValueData)
-query env name = do
- keyHandle <- openRegistryKey env
+query :: Profile -> VarName -> IO (Maybe VarValue)
+query profile name = do
+ keyHandle <- openProfileKey profile
catchIOError (Registry.getString keyHandle name >>= return . Just) emptyIfDoesNotExist
where
emptyIfDoesNotExist e = if isDoesNotExistError e then return Nothing else ioError e
-engrave :: RegistryLocation -> Registry.ValueName -> Registry.ValueData -> IO ()
-engrave env name value = do
- keyHandle <- openRegistryKey env
+engrave :: Profile -> VarName -> VarValue -> IO ()
+engrave profile name value = do
+ keyHandle <- openProfileKey profile
Registry.setString keyHandle name value
- notifyEnvUpdate
-
-engravePrompt :: RegistryLocation -> Registry.ValueName -> Registry.ValueData -> IO Bool
-engravePrompt env name value = do
- putStrLn $ "Saving variable '" ++ name ++ "' to '" ++ registryKeyPath env ++ "'..."
- oldValue <- query env name
- if (isJust oldValue)
- then do
- putStrLn $ "\tOld value: " ++ fromJust oldValue
- putStrLn $ "\tNew value: " ++ value
- else do
- putStrLn $ "\tValue: " ++ value
- agreed <- Utils.promptToContinue
- when agreed $ engrave env name value
- return agreed
-
-wipe :: RegistryLocation -> Registry.ValueName -> IO ()
-wipe env name = do
- keyHandle <- openRegistryKey env
+ notifyEnvironmentUpdate
+
+wipe :: Profile -> VarName -> IO ()
+wipe profile name = do
+ keyHandle <- openProfileKey profile
catchIOError (Registry.delValue keyHandle name) ignoreIfDoesNotExist
- notifyEnvUpdate
+ notifyEnvironmentUpdate
where
ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e
-wipePrompt :: RegistryLocation -> Registry.ValueName -> IO Bool
-wipePrompt env name = do
- putStrLn $ "Deleting variable '" ++ name ++ "' from '" ++ registryKeyPath env ++ "'..."
- agreed <- Utils.promptToContinue
- when agreed $ wipe env name
- return agreed
-
-pathSep :: String
+pathSep :: VarValue
pathSep = ";"
-pathSplit :: String -> [String]
+pathSplit :: VarValue -> [VarValue]
pathSplit = filter (not . null) . splitOn pathSep
-pathJoin :: [String] -> String
+pathJoin :: [VarValue] -> VarValue
pathJoin = intercalate pathSep . filter (not . null)
diff --git a/src/Registry.hs b/src/Registry.hs
index 4a7c593..48d69f0 100644
--- a/src/Registry.hs
+++ b/src/Registry.hs
@@ -14,8 +14,8 @@ module Registry
, openSubKey
, RootKey(..)
- , openRootKey
, rootKeyPath
+ , openRootKey
, ValueName
, delValue
diff --git a/src/Utils.hs b/src/Utils.hs
deleted file mode 100644
index 143696b..0000000
--- a/src/Utils.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-
- - Copyright 2015 Egor Tensin <Egor.Tensin@gmail.com>
- - This file is licensed under the terms of the MIT License.
- - See LICENSE.txt for details.
--}
-
-module Utils where
-
-import Control.Monad (liftM)
-import Data.Char (toLower)
-import System.IO (hFlush, stdout)
-
-prompt :: String -> IO String
-prompt banner = do
- putStr banner
- hFlush stdout
- getLine
-
-promptYesNo :: String -> IO Bool
-promptYesNo banner = do
- response <- liftM (map toLower) $ prompt banner
- if response `elem` yeses
- then return True
- else if response `elem` noes
- then return False
- else promptToContinue
- where
- yeses = ["y", "yes"]
- noes = ["n", "no"]
-
-promptToContinue :: IO Bool
-promptToContinue = promptYesNo "Continue? (y/n) "
diff --git a/src/WindowsUtils.hs b/src/WindowsUtils.hs
new file mode 100644
index 0000000..6fa1f0e
--- /dev/null
+++ b/src/WindowsUtils.hs
@@ -0,0 +1,28 @@
+{-
+ - Copyright 2016 Egor Tensin <Egor.Tensin@gmail.com>
+ - This file is licensed under the terms of the MIT License.
+ - See LICENSE.txt for details.
+-}
+
+module WindowsUtils
+ ( notifyEnvironmentUpdate
+ ) where
+
+import qualified Graphics.Win32.GDI.Types as WinAPI
+import qualified Graphics.Win32.Message as WinAPI
+import qualified System.Win32.Types as WinAPI
+
+foreign import ccall "SendNotifyMessageW"
+ c_SendNotifyMessage :: WinAPI.HWND -> WinAPI.WindowMessage -> WinAPI.WPARAM -> WinAPI.LPARAM -> IO WinAPI.LRESULT
+
+notifyEnvironmentUpdate :: IO ()
+notifyEnvironmentUpdate =
+ WinAPI.withTString "Environment" $ \lparamPtr -> do
+ let wparam = 0
+ let lparam = fromIntegral $ WinAPI.castPtrToUINTPtr lparamPtr
+ _ <- c_SendNotifyMessage allWindows messageCode wparam lparam
+ return ()
+ where
+ messageCode = WinAPI.wM_WININICHANGE
+ hWND_BROADCAST = WinAPI.castUINTPtrToPtr 0xffff
+ allWindows = hWND_BROADCAST
diff --git a/windows-env.cabal b/windows-env.cabal
index 4293db6..aa0190e 100644
--- a/windows-env.cabal
+++ b/windows-env.cabal
@@ -15,7 +15,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
- exposed-modules: Environment, Registry, Utils
+ exposed-modules: Environment, Registry, WindowsUtils
ghc-options: -Wall -Werror
build-depends: base, split, Win32
default-language: Haskell2010
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-02 12:16:35 +0000