diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/WindowsEnv/Environment.hs | 63 | ||||
| -rw-r--r-- | src/WindowsEnv/Registry.hs | 8 |
2 files changed, 46 insertions, 25 deletions
diff --git a/src/WindowsEnv/Environment.hs b/src/WindowsEnv/Environment.hs index 4713df3..8060b14 100644 --- a/src/WindowsEnv/Environment.hs +++ b/src/WindowsEnv/Environment.hs @@ -16,7 +16,7 @@ module WindowsEnv.Environment , VarName , VarValue - , expand + , query , engrave , engraveForce @@ -24,6 +24,10 @@ module WindowsEnv.Environment , pathJoin , pathSplit + + , expand + , ExpandedPath(..) + , pathSplitAndExpand ) where import Control.Monad.Trans.Class (lift) @@ -55,27 +59,8 @@ profileKeyPath AllUsers = Registry.KeyPath Registry.LocalMachine type VarName = String type VarValue = String -#include "ccall.h" - --- ExpandEnvironmentStrings isn't provided by Win32 (as of version 2.4.0.0). - -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 value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left) - where - doExpandIn valuePtr bufferPtr bufferLength = do - newBufferLength <- WinAPI.failIfZero "ExpandEnvironmentStringsW" $ - c_ExpandEnvironmentStrings valuePtr bufferPtr bufferLength - let newBufferSize = (fromIntegral newBufferLength) * sizeOf (undefined :: WinAPI.TCHAR) - if newBufferLength > bufferLength - then allocaBytes newBufferSize $ \newBufferPtr -> doExpandIn valuePtr newBufferPtr newBufferLength - else WinAPI.peekTString bufferPtr - doExpand = WinAPI.withTString value $ \valuePtr -> doExpandIn valuePtr WinAPI.nullPtr 0 - query :: Profile -> VarName -> ExceptT IOError IO VarValue -query profile name = Registry.getString (profileKeyPath profile) name +query profile name = Registry.getStringDoNotExpand (profileKeyPath profile) name engrave :: Profile -> VarName -> VarValue -> ExceptT IOError IO () engrave profile name value = do @@ -103,3 +88,39 @@ pathSplit = filter (not . null) . splitOn pathSep pathJoin :: [VarValue] -> VarValue pathJoin = intercalate pathSep . filter (not . null) + +#include "ccall.h" + +-- ExpandEnvironmentStrings isn't provided by Win32 (as of version 2.4.0.0). + +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 value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left) + where + doExpandIn valuePtr bufferPtr bufferLength = do + newBufferLength <- WinAPI.failIfZero "ExpandEnvironmentStringsW" $ + c_ExpandEnvironmentStrings valuePtr bufferPtr bufferLength + let newBufferSize = (fromIntegral newBufferLength) * sizeOf (undefined :: WinAPI.TCHAR) + if newBufferLength > bufferLength + then allocaBytes newBufferSize $ \newBufferPtr -> doExpandIn valuePtr newBufferPtr newBufferLength + else WinAPI.peekTString bufferPtr + doExpand = WinAPI.withTString value $ \valuePtr -> doExpandIn valuePtr WinAPI.nullPtr 0 + +data ExpandedPath = ExpandedPath + { pathOriginal :: VarValue + , pathExpanded :: VarValue + } deriving (Eq, Show) + +pathSplitAndExpand :: VarValue -> ExceptT IOError IO [ExpandedPath] +pathSplitAndExpand pathValue = do + expandedOnce <- expandOnce + zipWith ExpandedPath originalPaths <$> + if length expandedOnce == length originalPaths + then return expandedOnce + else expandEach + where + originalPaths = pathSplit pathValue + expandOnce = pathSplit <$> expand pathValue + expandEach = mapM expand originalPaths diff --git a/src/WindowsEnv/Registry.hs b/src/WindowsEnv/Registry.hs index 96a7627..f9e3cc7 100644 --- a/src/WindowsEnv/Registry.hs +++ b/src/WindowsEnv/Registry.hs @@ -30,7 +30,7 @@ module WindowsEnv.Registry , getValue , GetValueFlag(..) , getType - , getString + , getStringDoNotExpand , setValue , setString @@ -252,10 +252,10 @@ getType keyPath valueName flags = c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr collapsedFlags valueTypePtr WinAPI.nullPtr WinAPI.nullPtr toEnum . fromIntegral <$> peek valueTypePtr where - collapsedFlags = collapseGetValueFlags flags + collapsedFlags = collapseGetValueFlags $ DoNotExpand : flags -getString :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String -getString keyPath valueName = do +getStringDoNotExpand :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String +getStringDoNotExpand keyPath valueName = do valueData <- getValue keyPath valueName [RestrictExpandableString, RestrictString] return $ decodeString valueData |