diff options
| -rw-r--r-- | app/ListPaths.hs | 25 | ||||
| -rw-r--r-- | src/WindowsEnv/Environment.hs | 63 | ||||
| -rw-r--r-- | src/WindowsEnv/Registry.hs | 8 |
3 files changed, 50 insertions, 46 deletions
diff --git a/app/ListPaths.hs b/app/ListPaths.hs index 5834f11..4193ad6 100644 --- a/app/ListPaths.hs +++ b/app/ListPaths.hs @@ -9,7 +9,7 @@ module Main (main) where import Control.Monad (filterM) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Except (runExceptT) import Data.Maybe (fromMaybe) import System.Directory (doesDirectoryExist) import System.Environment (lookupEnv) @@ -63,23 +63,6 @@ main = execParser parser >>= listPaths parser = info (helper <*> optionParser) $ fullDesc <> progDesc "List directories in your PATH" -data ExpandedPath = ExpandedPath - { pathOriginal :: WindowsEnv.VarValue - , pathExpanded :: WindowsEnv.VarValue - } deriving (Eq, Show) - -splitAndExpand :: WindowsEnv.VarValue -> ExceptT IOError IO [ExpandedPath] -splitAndExpand pathValue = do - expandedOnce <- expandOnce - zipWith ExpandedPath originalPaths <$> - if length expandedOnce == length originalPaths - then return expandedOnce - else expandEach - where - originalPaths = WindowsEnv.pathSplit pathValue - expandOnce = WindowsEnv.pathSplit <$> WindowsEnv.expand pathValue - expandEach = mapM WindowsEnv.expand originalPaths - listPaths :: Options -> IO () listPaths options = runExceptT doListPaths >>= either ioError return where @@ -91,10 +74,10 @@ listPaths options = runExceptT doListPaths >>= either ioError return queryFrom Environment = lift $ fromMaybe "" <$> lookupEnv varName queryFrom (Registry profile) = WindowsEnv.query profile varName - filterPaths = filterM (shouldListPath whichPaths . pathExpanded) + filterPaths = filterM (shouldListPath whichPaths . WindowsEnv.pathExpanded) doListPaths = do - paths <- query >>= splitAndExpand + paths <- query >>= WindowsEnv.pathSplitAndExpand lift $ do pathsToPrint <- filterPaths paths - mapM_ (putStrLn . pathOriginal) pathsToPrint + mapM_ (putStrLn . WindowsEnv.pathOriginal) pathsToPrint 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 |