aboutsummaryrefslogtreecommitdiffstatshomepage
diff options
context:
space:
mode:
-rw-r--r--app/AddPath.hs39
-rw-r--r--app/ListPaths.hs4
-rw-r--r--app/RemovePath.hs16
-rw-r--r--app/SetEnv.hs4
-rw-r--r--app/Utils/PromptMessage.hs4
-rw-r--r--src/WindowsEnv/Environment.hs55
-rw-r--r--src/WindowsEnv/Registry.hs71
7 files changed, 102 insertions, 91 deletions
diff --git a/app/AddPath.hs b/app/AddPath.hs
index fc8d5de..1993b4a 100644
--- a/app/AddPath.hs
+++ b/app/AddPath.hs
@@ -20,11 +20,11 @@ import Utils.Prompt
import Utils.PromptMessage
data Options = Options
- { optName :: WindowsEnv.VarName
+ { optName :: WindowsEnv.VarName
, optYes :: Bool
, optGlobal :: Bool
, optPrepend :: Bool
- , optPaths :: [WindowsEnv.VarValue]
+ , optPaths :: [String]
} deriving (Eq, Show)
optionParser :: Parser Options
@@ -62,7 +62,7 @@ addPath :: Options -> IO ()
addPath options = runExceptT doAddPath >>= either ioError return
where
varName = optName options
- pathsToAdd = optPaths options
+ pathsToAdd = nub $ optPaths options
forAllUsers = optGlobal options
profile
@@ -72,22 +72,31 @@ addPath options = runExceptT doAddPath >>= either ioError return
skipPrompt = optYes options
prepend = optPrepend options
- append xs ys
- | prepend = ys ++ xs
- | otherwise = xs ++ ys
+ mergePaths old new
+ | prepend = new ++ old
+ | otherwise = old ++ new
emptyIfMissing e
- | isDoesNotExistError e = return ""
+ | isDoesNotExistError e = defaultValue
| otherwise = throwE e
+ defaultValue = do
+ expandedPaths <- mapM WindowsEnv.expand pathsToAdd
+ if pathsToAdd == expandedPaths
+ then return $ WindowsEnv.VarValue False ""
+ else return $ WindowsEnv.VarValue True ""
+
doAddPath = do
oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing
- let oldPaths = WindowsEnv.pathSplit oldValue
- let newPaths = (nub pathsToAdd) \\ oldPaths
+ let oldPaths = WindowsEnv.pathSplit $ show oldValue
+ let newPaths = pathsToAdd \\ oldPaths
unless (null newPaths) $ do
- let newValue = WindowsEnv.pathJoin $ append oldPaths newPaths
- let promptAnd = if skipPrompt
- then withoutPrompt
- else withPrompt $ oldNewMessage profile varName oldValue newValue
- let engrave = WindowsEnv.engrave profile varName newValue
- void $ promptAnd engrave
+ let newValue = WindowsEnv.VarValue (WindowsEnv.varValueExpandable oldValue) $ WindowsEnv.pathJoin (mergePaths oldPaths newPaths)
+ promptAndEngrave oldValue newValue
+
+ promptAndEngrave oldValue newValue = do
+ let promptAnd = if skipPrompt
+ then withoutPrompt
+ else withPrompt $ oldNewMessage profile varName (show oldValue) (show newValue)
+ let engrave = WindowsEnv.engrave profile varName newValue
+ void $ promptAnd engrave
diff --git a/app/ListPaths.hs b/app/ListPaths.hs
index 4193ad6..8a31cb8 100644
--- a/app/ListPaths.hs
+++ b/app/ListPaths.hs
@@ -22,7 +22,7 @@ import qualified WindowsEnv
data WhichPaths = All | ExistingOnly | MissingOnly
deriving (Eq, Show)
-shouldListPath :: WhichPaths -> WindowsEnv.VarValue -> IO Bool
+shouldListPath :: WhichPaths -> String -> IO Bool
shouldListPath All = return . const True
shouldListPath ExistingOnly = doesDirectoryExist
shouldListPath MissingOnly = fmap not . doesDirectoryExist
@@ -72,7 +72,7 @@ listPaths options = runExceptT doListPaths >>= either ioError return
query = queryFrom $ optSource options
queryFrom Environment = lift $ fromMaybe "" <$> lookupEnv varName
- queryFrom (Registry profile) = WindowsEnv.query profile varName
+ queryFrom (Registry profile) = show <$> WindowsEnv.query profile varName
filterPaths = filterM (shouldListPath whichPaths . WindowsEnv.pathExpanded)
diff --git a/app/RemovePath.hs b/app/RemovePath.hs
index bc2a076..2d0d47c 100644
--- a/app/RemovePath.hs
+++ b/app/RemovePath.hs
@@ -22,7 +22,7 @@ data Options = Options
{ optName :: WindowsEnv.VarName
, optYes :: Bool
, optGlobal :: Bool
- , optPaths :: [WindowsEnv.VarValue]
+ , optPaths :: [String]
} deriving (Eq, Show)
optionParser :: Parser Options
@@ -63,9 +63,15 @@ removePath options = runExceptT doRemovePath >>= either ioError return
skipPrompt = optYes options
emptyIfMissing e
- | isDoesNotExistError e = return ""
+ | isDoesNotExistError e = defaultValue
| otherwise = throwE e
+ defaultValue = do
+ expandedPaths <- mapM WindowsEnv.expand pathsToRemove
+ if pathsToRemove == expandedPaths
+ then return $ WindowsEnv.VarValue False ""
+ else return $ WindowsEnv.VarValue True ""
+
doRemovePath = do
removePathFrom WindowsEnv.CurrentUser
when forAllUsers $
@@ -73,12 +79,12 @@ removePath options = runExceptT doRemovePath >>= either ioError return
removePathFrom profile = do
oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing
- let oldPaths = WindowsEnv.pathSplit oldValue
+ let oldPaths = WindowsEnv.pathSplit $ show oldValue
let newPaths = filter (flip notElem pathsToRemove) oldPaths
when (length oldPaths /= length newPaths) $ do
- let newValue = WindowsEnv.pathJoin newPaths
+ let newValue = WindowsEnv.VarValue (WindowsEnv.varValueExpandable oldValue) (WindowsEnv.pathJoin newPaths)
let promptAnd = if skipPrompt
then withoutPrompt
- else withPrompt $ oldNewMessage profile varName oldValue newValue
+ else withPrompt $ oldNewMessage profile varName (show oldValue) (show newValue)
let engrave = WindowsEnv.engrave profile varName newValue
void $ promptAnd engrave
diff --git a/app/SetEnv.hs b/app/SetEnv.hs
index 5948d3e..bb058d8 100644
--- a/app/SetEnv.hs
+++ b/app/SetEnv.hs
@@ -22,7 +22,7 @@ data Options = Options
{ optYes :: Bool
, optGlobal :: Bool
, optName :: WindowsEnv.VarName
- , optValue :: WindowsEnv.VarValue
+ , optValue :: String
} deriving (Eq, Show)
optionParser :: Parser Options
@@ -67,6 +67,6 @@ setEnv options = runExceptT doSetEnv >>= either ioError return
| skipPrompt = withoutPrompt
| otherwise = withPrompt $ newMessage profile varName varValue
- engrave = WindowsEnv.engraveForce profile varName varValue
+ engrave = WindowsEnv.engrave profile varName $ WindowsEnv.VarValue False varValue
doSetEnv = void $ promptAnd engrave
diff --git a/app/Utils/PromptMessage.hs b/app/Utils/PromptMessage.hs
index 37fc1e6..9afffb1 100644
--- a/app/Utils/PromptMessage.hs
+++ b/app/Utils/PromptMessage.hs
@@ -15,7 +15,7 @@ import Text.Printf (printf)
import qualified WindowsEnv
-oldNewMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> WindowsEnv.VarValue -> String
+oldNewMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> String -> String -> String
oldNewMessage profile name oldValue newValue =
descrMsg ++ oldValueMsg ++ newValueMsg
where
@@ -24,7 +24,7 @@ oldNewMessage profile name oldValue newValue =
oldValueMsg = printf "\tOld value: %s\n" oldValue
newValueMsg = printf "\tNew value: %s\n" newValue
-newMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> String
+newMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> String -> String
newMessage profile name newValue =
descrMsg ++ newValueMsg
where
diff --git a/src/WindowsEnv/Environment.hs b/src/WindowsEnv/Environment.hs
index 8060b14..e56f5c9 100644
--- a/src/WindowsEnv/Environment.hs
+++ b/src/WindowsEnv/Environment.hs
@@ -15,11 +15,10 @@ module WindowsEnv.Environment
, profileKeyPath
, VarName
- , VarValue
+ , VarValue(..)
, query
, engrave
- , engraveForce
, wipe
, pathJoin
@@ -56,21 +55,33 @@ profileKeyPath AllUsers = Registry.KeyPath Registry.LocalMachine
, "Environment"
]
-type VarName = String
-type VarValue = String
+type VarName = String
+
+data VarValue = VarValue
+ { varValueExpandable :: Bool
+ , varValueString :: String
+ } deriving (Eq)
+
+instance Show VarValue where
+ show = varValueString
+
+valueFromRegistry :: Registry.StringValue -> VarValue
+valueFromRegistry (valueType, valueData)
+ | valueType == Registry.TypeString = VarValue False valueData
+ | valueType == Registry.TypeExpandableString = VarValue True valueData
+ | otherwise = error "WindowsEnv.Environment: unexpected"
+
+valueToRegistry :: VarValue -> Registry.StringValue
+valueToRegistry value
+ | varValueExpandable value = (Registry.TypeExpandableString, varValueString value)
+ | otherwise = (Registry.TypeString, varValueString value)
query :: Profile -> VarName -> ExceptT IOError IO VarValue
-query profile name = Registry.getStringDoNotExpand (profileKeyPath profile) name
+query profile name = valueFromRegistry <$> Registry.getStringValue (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
+ ret <- Registry.setStringValue (profileKeyPath profile) name $ valueToRegistry value
lift notifyEnvironmentUpdate
return ret
@@ -80,13 +91,13 @@ wipe profile name = do
lift notifyEnvironmentUpdate
return ret
-pathSep :: VarValue
+pathSep :: String
pathSep = ";"
-pathSplit :: VarValue -> [VarValue]
+pathSplit :: String -> [String]
pathSplit = filter (not . null) . splitOn pathSep
-pathJoin :: [VarValue] -> VarValue
+pathJoin :: [String] -> String
pathJoin = intercalate pathSep . filter (not . null)
#include "ccall.h"
@@ -96,7 +107,7 @@ pathJoin = intercalate pathSep . filter (not . null)
foreign import WINDOWS_ENV_CCALL unsafe "Windows.h ExpandEnvironmentStringsW"
c_ExpandEnvironmentStrings :: WinAPI.LPCTSTR -> WinAPI.LPTSTR -> WinAPI.DWORD -> IO WinAPI.ErrCode
-expand :: VarValue -> ExceptT IOError IO VarValue
+expand :: String -> ExceptT IOError IO String
expand value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left)
where
doExpandIn valuePtr bufferPtr bufferLength = do
@@ -109,18 +120,18 @@ expand value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left)
doExpand = WinAPI.withTString value $ \valuePtr -> doExpandIn valuePtr WinAPI.nullPtr 0
data ExpandedPath = ExpandedPath
- { pathOriginal :: VarValue
- , pathExpanded :: VarValue
+ { pathOriginal :: String
+ , pathExpanded :: String
} deriving (Eq, Show)
-pathSplitAndExpand :: VarValue -> ExceptT IOError IO [ExpandedPath]
-pathSplitAndExpand pathValue = do
+pathSplitAndExpand :: String -> ExceptT IOError IO [ExpandedPath]
+pathSplitAndExpand value = do
expandedOnce <- expandOnce
zipWith ExpandedPath originalPaths <$>
if length expandedOnce == length originalPaths
then return expandedOnce
else expandEach
where
- originalPaths = pathSplit pathValue
- expandOnce = pathSplit <$> expand pathValue
+ originalPaths = pathSplit value
+ expandOnce = pathSplit <$> expand value
expandEach = mapM expand originalPaths
diff --git a/src/WindowsEnv/Registry.hs b/src/WindowsEnv/Registry.hs
index 48200b2..73606d9 100644
--- a/src/WindowsEnv/Registry.hs
+++ b/src/WindowsEnv/Registry.hs
@@ -16,8 +16,9 @@ module WindowsEnv.Registry
, KeyPath(..)
, ValueName
- , ValueType
- , ValueData
+ , ValueType(..)
+ , Value
+ , StringValue
, openKey
, closeKey
@@ -30,16 +31,14 @@ module WindowsEnv.Registry
, getValue
, GetValueFlag(..)
, getValueType
- , getStringDoNotExpand
+ , getStringValue
, setValue
- , setString
- , setExpandableString
- , setStringPreserveType
+ , setStringValue
) where
import Control.Exception (bracket)
-import Control.Monad.Trans.Except (ExceptT(..), catchE, throwE)
+import Control.Monad.Trans.Except (ExceptT(..))
import Data.Bits ((.|.))
import qualified Data.ByteString as B
import Data.List (intercalate)
@@ -51,7 +50,7 @@ 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 System.IO.Error (catchIOError)
import qualified System.Win32.Types as WinAPI
import qualified System.Win32.Registry as WinAPI
@@ -89,16 +88,16 @@ instance Show RootKey where
data KeyPath = KeyPath RootKey [String]
-pathSep :: String
-pathSep = "\\"
+keyPathSep :: String
+keyPathSep = "\\"
instance IsKeyPath KeyPath where
openKeyUnsafe (KeyPath root path) = do
rootHandle <- openKeyUnsafe root
- WinAPI.regOpenKey rootHandle $ intercalate pathSep path
+ WinAPI.regOpenKey rootHandle $ intercalate keyPathSep path
instance Show KeyPath where
- show (KeyPath root path) = intercalate pathSep $ show root : path
+ show (KeyPath root path) = intercalate keyPathSep $ show root : path
type ValueName = String
@@ -130,24 +129,25 @@ valueTypeNumbers =
, (TypeLink, 6)
]
-type ValueData = (ValueType, B.ByteString)
+type Value = (ValueType, B.ByteString)
+type StringValue = (ValueType, String)
-encodeString :: String -> B.ByteString
-encodeString str = encodeUtf16LE addLastZero
+encodeString :: StringValue -> Value
+encodeString (valueType, valueData) = (valueType, encodeUtf16LE addLastZero)
where
addLastZero
| T.null text = text
| T.last text == '\0' = text
| otherwise = T.snoc text '\0'
- text = T.pack str
+ text = T.pack valueData
-decodeString :: ValueData -> String
-decodeString (_, bytes) = T.unpack dropLastZero
+decodeString :: Value -> StringValue
+decodeString (valueType, valueData) = (valueType, T.unpack dropLastZero)
where
dropLastZero
| T.null text = text
| otherwise = T.takeWhile (/= '\0') text
- text = decodeUtf16LE bytes
+ text = decodeUtf16LE valueData
#include "ccall.h"
@@ -162,7 +162,7 @@ foreign import WINDOWS_ENV_CCALL unsafe "Windows.h RegSetValueExW"
foreign import WINDOWS_ENV_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 :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO Value
queryValue keyPath valueName =
withHandle keyPath $ \keyHandle ->
withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -221,7 +221,7 @@ getValueFlagNumbers =
collapseGetValueFlags :: Num a => [GetValueFlag] -> a
collapseGetValueFlags = fromIntegral . foldr ((.|.) . fromEnum) 0
-getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueData
+getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO Value
getValue keyPath valueName flags =
withHandle keyPath $ \keyHandle ->
withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -254,12 +254,11 @@ getValueType keyPath valueName flags =
where
collapsedFlags = collapseGetValueFlags $ DoNotExpand : flags
-getStringDoNotExpand :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String
-getStringDoNotExpand keyPath valueName = do
- valueData <- getValue keyPath valueName [RestrictExpandableString, RestrictString]
- return $ decodeString valueData
+getStringValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO StringValue
+getStringValue keyPath valueName =
+ decodeString <$> getValue keyPath valueName [RestrictExpandableString, RestrictString]
-setValue :: IsKeyPath a => a -> ValueName -> ValueData -> ExceptT IOError IO ()
+setValue :: IsKeyPath a => a -> ValueName -> Value -> ExceptT IOError IO ()
setValue keyPath valueName (valueType, valueData) =
withHandle keyPath $ \keyHandle ->
withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -273,23 +272,9 @@ setValue keyPath valueName (valueType, valueData) =
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 <- getValueType keyPath valueName flags `catchE` stringByDefault
- setValue keyPath valueName (valueType, encodeString valueData)
- where
- flags = [RestrictString, RestrictExpandableString]
- stringByDefault e
- | isDoesNotExistError e = return TypeString
- | otherwise = throwE e
+setStringValue :: IsKeyPath a => a -> ValueName -> StringValue -> ExceptT IOError IO ()
+setStringValue keyPath valueName value =
+ setValue keyPath valueName $ encodeString value
deleteValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ()
deleteValue keyPath valueName =