diff options
Diffstat (limited to '')
| -rw-r--r-- | app/AddPath.hs | 39 | ||||
| -rw-r--r-- | app/ListPaths.hs | 4 | ||||
| -rw-r--r-- | app/RemovePath.hs | 16 | ||||
| -rw-r--r-- | app/SetEnv.hs | 4 | ||||
| -rw-r--r-- | app/Utils/PromptMessage.hs | 4 | ||||
| -rw-r--r-- | src/WindowsEnv/Environment.hs | 55 | ||||
| -rw-r--r-- | src/WindowsEnv/Registry.hs | 71 |
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 = |