From 427ae9ad54492954578cafbfcd2d815a084e0986 Mon Sep 17 00:00:00 2001 From: Egor Tensin Date: Mon, 18 Jul 2016 00:17:44 +0300 Subject: put modules to 'Windows' --- apps/AddPath.hs | 21 ++++--- apps/FixNtSymbolPath.hs | 17 +++--- apps/ListPath.hs | 9 ++- apps/RemovePath.hs | 21 ++++--- apps/SetEnv.hs | 15 +++-- apps/UnsetEnv.hs | 13 ++-- apps/Utils.hs | 2 +- src/Environment.hs | 88 --------------------------- src/Registry.hs | 145 --------------------------------------------- src/Windows/Environment.hs | 88 +++++++++++++++++++++++++++ src/Windows/Registry.hs | 145 +++++++++++++++++++++++++++++++++++++++++++++ src/Windows/Utils.hs | 28 +++++++++ src/WindowsUtils.hs | 28 --------- windows-env.cabal | 3 +- 14 files changed, 309 insertions(+), 314 deletions(-) delete mode 100644 src/Environment.hs delete mode 100644 src/Registry.hs create mode 100644 src/Windows/Environment.hs create mode 100644 src/Windows/Registry.hs create mode 100644 src/Windows/Utils.hs delete mode 100644 src/WindowsUtils.hs diff --git a/apps/AddPath.hs b/apps/AddPath.hs index 6103d1d..db0dcc2 100644 --- a/apps/AddPath.hs +++ b/apps/AddPath.hs @@ -11,17 +11,16 @@ import Data.List (union) import Data.Maybe (fromMaybe) import Text.Printf (printf) -import Options.Applicative - -import qualified Environment +import Options.Applicative +import qualified Windows.Environment as Env import qualified Utils data Options = Options - { optName :: Environment.VarName + { optName :: Env.VarName , optYes :: Bool , optGlobal :: Bool - , optPaths :: [Environment.VarValue] + , optPaths :: [Env.VarValue] } deriving (Eq, Show) options :: Parser Options @@ -52,21 +51,21 @@ main = execParser parser >>= addPath addPath :: Options -> IO () addPath options = do - oldValue <- Environment.query profile varName - let oldPaths = Environment.pathSplit $ fromMaybe "" oldValue + oldValue <- Env.query profile varName + let oldPaths = Env.pathSplit $ fromMaybe "" oldValue let newPaths = union oldPaths pathsToAdd when (length oldPaths /= length newPaths) $ do - let newValue = Environment.pathJoin newPaths + let newValue = Env.pathJoin newPaths let promptBanner = Utils.engraveBanner profile varName oldValue newValue - void $ prompt promptBanner $ Environment.engrave profile varName newValue + void $ prompt promptBanner $ Env.engrave profile varName newValue where varName = optName options pathsToAdd = optPaths options forAllUsers = optGlobal options profile = if forAllUsers - then Environment.AllUsers - else Environment.CurrentUser + then Env.AllUsers + else Env.CurrentUser skipPrompt = optYes options prompt = if skipPrompt diff --git a/apps/FixNtSymbolPath.hs b/apps/FixNtSymbolPath.hs index 3788381..8c999a8 100644 --- a/apps/FixNtSymbolPath.hs +++ b/apps/FixNtSymbolPath.hs @@ -12,9 +12,8 @@ import Data.Maybe (fromMaybe) import System.Directory (createDirectoryIfMissing, getCurrentDirectory) import System.FilePath (combine) -import Options.Applicative - -import qualified Environment +import Options.Applicative +import qualified Windows.Environment as Env import qualified Utils @@ -66,15 +65,15 @@ getLocalDirs = do fixNtSymbolPath :: Options -> IO () fixNtSymbolPath options = do - oldValue <- Environment.query profile varName - let oldPaths = Environment.pathSplit $ fromMaybe "" oldValue + oldValue <- Env.query profile varName + let oldPaths = Env.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 + let newValue = Env.pathJoin newPaths let promptBanner = Utils.engraveBanner profile varName oldValue newValue - confirmed <- prompt promptBanner $ Environment.engrave profile varName newValue + confirmed <- prompt promptBanner $ Env.engrave profile varName newValue when confirmed $ createDirs localDirs where @@ -82,8 +81,8 @@ fixNtSymbolPath options = do forAllUsers = optGlobal options profile = if forAllUsers - then Environment.AllUsers - else Environment.CurrentUser + then Env.AllUsers + else Env.CurrentUser skipPrompt = optYes options prompt = if skipPrompt diff --git a/apps/ListPath.hs b/apps/ListPath.hs index ace3ede..f33983d 100644 --- a/apps/ListPath.hs +++ b/apps/ListPath.hs @@ -11,12 +11,11 @@ import Data.Maybe (fromMaybe) import System.Directory (doesDirectoryExist) import System.Environment (lookupEnv) -import Options.Applicative - -import qualified Environment +import Options.Applicative +import qualified Windows.Environment as Env data Options = Options - { optName :: Environment.VarName + { optName :: Env.VarName } deriving (Eq, Show) options :: Parser Options @@ -35,7 +34,7 @@ main = execParser parser >>= listPath listPath :: Options -> IO () listPath options = do oldValue <- getEnv varName - let oldPaths = Environment.pathSplit oldValue + let oldPaths = Env.pathSplit oldValue mapM_ printPath oldPaths where varName = optName options diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs index a594ecd..ecc56c0 100644 --- a/apps/RemovePath.hs +++ b/apps/RemovePath.hs @@ -10,17 +10,16 @@ import Control.Monad (void, when) import Data.List ((\\)) import Data.Maybe (fromJust, isJust) -import Options.Applicative - -import qualified Environment +import Options.Applicative +import qualified Windows.Environment as Env import qualified Utils data Options = Options - { optName :: Environment.VarName + { optName :: Env.VarName , optYes :: Bool , optGlobal :: Bool - , optPaths :: [Environment.VarValue] + , optPaths :: [Env.VarValue] } deriving (Eq, Show) options = Options @@ -50,9 +49,9 @@ main = execParser parser >>= removePath removePath :: Options -> IO () removePath options = do - removePathFrom Environment.CurrentUser + removePathFrom Env.CurrentUser when forAllUsers $ do - removePathFrom Environment.AllUsers + removePathFrom Env.AllUsers where varName = optName options pathsToRemove = optPaths options @@ -60,14 +59,14 @@ removePath options = do forAllUsers = optGlobal options removePathFrom profile = do - oldValue <- Environment.query profile varName + oldValue <- Env.query profile varName when (isJust oldValue) $ do - let oldPaths = Environment.pathSplit $ fromJust oldValue + let oldPaths = Env.pathSplit $ fromJust oldValue let newPaths = oldPaths \\ pathsToRemove when (length oldPaths /= length newPaths) $ do - let newValue = Environment.pathJoin newPaths + let newValue = Env.pathJoin newPaths let promptBanner = Utils.engraveBanner profile varName oldValue newValue - void $ prompt promptBanner $ Environment.engrave profile varName newValue + void $ prompt promptBanner $ Env.engrave profile varName newValue skipPrompt = optYes options prompt = if skipPrompt diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs index 0b95176..a48fbe6 100644 --- a/apps/SetEnv.hs +++ b/apps/SetEnv.hs @@ -8,17 +8,16 @@ module Main (main) where import Control.Monad (void) -import Options.Applicative hiding (value) - -import qualified Environment +import Options.Applicative +import qualified Windows.Environment as Env import qualified Utils data Options = Options { optYes :: Bool , optGlobal :: Bool - , optName :: Environment.VarName - , optValue :: Environment.VarValue + , optName :: Env.VarName + , optValue :: Env.VarValue } deriving (Eq, Show) options :: Parser Options @@ -48,7 +47,7 @@ main = execParser parser >>= setEnv fullDesc <> progDesc "Set environment variable" setEnv :: Options -> IO () -setEnv options = void $ prompt confirmationBanner $ Environment.engrave profile varName varValue +setEnv options = void $ prompt confirmationBanner $ Env.engrave profile varName varValue where confirmationBanner = Utils.engraveBanner profile varName Nothing varValue @@ -57,8 +56,8 @@ setEnv options = void $ prompt confirmationBanner $ Environment.engrave profile forAllUsers = optGlobal options profile = if forAllUsers - then Environment.AllUsers - else Environment.CurrentUser + then Env.AllUsers + else Env.CurrentUser skipPrompt = optYes options prompt = if skipPrompt diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs index b0ed96a..88101d9 100644 --- a/apps/UnsetEnv.hs +++ b/apps/UnsetEnv.hs @@ -8,16 +8,15 @@ module Main (main) where import Control.Monad (void) -import Options.Applicative - -import qualified Environment +import Options.Applicative +import qualified Windows.Environment as Env import qualified Utils data Options = Options { optYes :: Bool , optGlobal :: Bool - , optName :: Environment.VarName + , optName :: Env.VarName } deriving (Eq, Show) options :: Parser Options @@ -43,7 +42,7 @@ main = execParser parser >>= unsetEnv fullDesc <> progDesc "Unset environment variable" unsetEnv :: Options -> IO () -unsetEnv options = void $ prompt confirmationBanner $ Environment.wipe profile varName +unsetEnv options = void $ prompt confirmationBanner $ Env.wipe profile varName where confirmationBanner = Utils.wipeBanner profile varName @@ -51,8 +50,8 @@ unsetEnv options = void $ prompt confirmationBanner $ Environment.wipe profile v forAllUsers = optGlobal options profile = if forAllUsers - then Environment.AllUsers - else Environment.CurrentUser + then Env.AllUsers + else Env.CurrentUser skipPrompt = optYes options prompt = if skipPrompt diff --git a/apps/Utils.hs b/apps/Utils.hs index 28309d4..e34950f 100644 --- a/apps/Utils.hs +++ b/apps/Utils.hs @@ -18,7 +18,7 @@ import Data.Char (toLower) import System.IO (hFlush, stdout) import Text.Printf (printf) -import Environment (Profile, profileKeyPath, VarName, VarValue) +import Windows.Environment (Profile, profileKeyPath, VarName, VarValue) prompt :: String -> IO String prompt banner = do diff --git a/src/Environment.hs b/src/Environment.hs deleted file mode 100644 index f370de4..0000000 --- a/src/Environment.hs +++ /dev/null @@ -1,88 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Environment - ( Profile(..) - , profileKeyPath - - , VarName - , VarValue - , query - , engrave - , wipe - - , pathJoin - , pathSplit - ) where - -import Data.List (intercalate) -import Data.List.Split (splitOn) -import System.IO.Error (catchIOError, isDoesNotExistError) - -import qualified Registry -import WindowsUtils (notifyEnvironmentUpdate) - -data Profile = CurrentUser - | AllUsers - deriving (Eq, Show) - -profileRootKey :: Profile -> Registry.RootKey -profileRootKey CurrentUser = Registry.CurrentUser -profileRootKey AllUsers = Registry.LocalMachine - -profileRootKeyPath :: Profile -> Registry.KeyPath -profileRootKeyPath = Registry.rootKeyPath . profileRootKey - -profileSubKeyPath :: Profile -> Registry.KeyPath -profileSubKeyPath CurrentUser = - Registry.keyPathFromString "Environment" -profileSubKeyPath AllUsers = - Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" - -profileKeyPath :: Profile -> Registry.KeyPath -profileKeyPath profile = Registry.keyPathJoin - [ profileRootKeyPath profile - , profileSubKeyPath profile - ] - -openRootProfileKey :: Profile -> Registry.KeyHandle -openRootProfileKey = Registry.openRootKey . profileRootKey - -openProfileKey :: Profile -> IO Registry.KeyHandle -openProfileKey profile = Registry.openSubKey (openRootProfileKey profile) (profileSubKeyPath profile) - -type VarName = Registry.ValueName -type VarValue = Registry.ValueData - -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 :: Profile -> VarName -> VarValue -> IO () -engrave profile name value = do - keyHandle <- openProfileKey profile - Registry.setString keyHandle name value - notifyEnvironmentUpdate - -wipe :: Profile -> VarName -> IO () -wipe profile name = do - keyHandle <- openProfileKey profile - catchIOError (Registry.delValue keyHandle name) ignoreIfDoesNotExist - notifyEnvironmentUpdate - where - ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e - -pathSep :: VarValue -pathSep = ";" - -pathSplit :: VarValue -> [VarValue] -pathSplit = filter (not . null) . splitOn pathSep - -pathJoin :: [VarValue] -> VarValue -pathJoin = intercalate pathSep . filter (not . null) diff --git a/src/Registry.hs b/src/Registry.hs deleted file mode 100644 index 48d69f0..0000000 --- a/src/Registry.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- - - Copyright 2015 Egor Tensin - - This file is licensed under the terms of the MIT License. - - See LICENSE.txt for details. --} - -module Registry - ( KeyPath - , keyPathFromString - , keyPathJoin - , keyPathSplit - - , KeyHandle - , openSubKey - - , RootKey(..) - , rootKeyPath - , openRootKey - - , ValueName - , delValue - - , ValueData - , getString - , setString - ) where - -import Data.List (intercalate) -import Data.List.Split (splitOn) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Marshal.Alloc (alloca, allocaBytes) -import Foreign.Ptr (castPtr, plusPtr) -import Foreign.Storable (peek, poke, sizeOf) -import System.IO.Error (catchIOError, doesNotExistErrorType, mkIOError, isDoesNotExistError) - -import qualified System.Win32.Registry as WinAPI -import qualified System.Win32.Types as WinAPI - -type KeyName = String -type KeyPath = KeyName - -keyPathSep :: KeyPath -keyPathSep = "\\" - -keyPathFromString :: String -> KeyPath -keyPathFromString = keyPathJoin . keyPathSplit - -keyPathSplit :: KeyPath -> [KeyName] -keyPathSplit = filter (not . null) . splitOn keyPathSep - -keyPathJoin :: [KeyName] -> KeyPath -keyPathJoin = intercalate keyPathSep . filter (not . null) - -type KeyHandle = WinAPI.HKEY - -openSubKey :: KeyHandle -> KeyPath -> IO KeyHandle -openSubKey = WinAPI.regOpenKey - -data RootKey = CurrentUser - | LocalMachine - deriving (Eq, Show) - -rootKeyPath :: RootKey -> KeyName -rootKeyPath CurrentUser = "HKCU" -rootKeyPath LocalMachine = "HKLM" - -openRootKey :: RootKey -> KeyHandle -openRootKey CurrentUser = WinAPI.hKEY_CURRENT_USER -openRootKey LocalMachine = WinAPI.hKEY_LOCAL_MACHINE - -type ValueName = String - -raiseDoesNotExistError :: String -> IO a -raiseDoesNotExistError functionName = - ioError $ mkIOError doesNotExistErrorType functionName Nothing Nothing - -raiseUnknownError :: String -> WinAPI.ErrCode -> IO a -raiseUnknownError functionName exitCode = WinAPI.failWith functionName exitCode - -exitCodeSuccess :: WinAPI.ErrCode -exitCodeSuccess = 0 - -exitCodeFileNotFound :: WinAPI.ErrCode -exitCodeFileNotFound = 0x2 - -raiseError :: String -> WinAPI.ErrCode -> IO a -raiseError functionName ret - | ret == exitCodeFileNotFound = raiseDoesNotExistError functionName - | otherwise = raiseUnknownError functionName ret - -delValue :: KeyHandle -> ValueName -> IO () -delValue keyHandle valueName = - withForeignPtr keyHandle $ \keyPtr -> - WinAPI.withTString valueName $ \valueNamePtr -> do - ret <- WinAPI.c_RegDeleteValue keyPtr valueNamePtr - if ret == exitCodeSuccess - then return () - else raiseError "RegDeleteValue" ret - -type ValueType = WinAPI.RegValueType - -getType :: KeyHandle -> ValueName -> IO ValueType -getType keyHandle valueName = - withForeignPtr keyHandle $ \keyPtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - alloca $ \typePtr -> do - ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr typePtr WinAPI.nullPtr WinAPI.nullPtr - if ret == exitCodeSuccess - then peek typePtr - else raiseError "RegQueryValueEx" ret - -type ValueData = String - -getString :: KeyHandle -> ValueName -> IO ValueData -getString keyHandle valueName = - withForeignPtr keyHandle $ \keyPtr -> - WinAPI.withTString valueName $ \valueNamePtr -> - alloca $ \dataSizePtr -> do - poke dataSizePtr 0 - ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr WinAPI.nullPtr dataSizePtr - if ret /= exitCodeSuccess - then raiseError "RegQueryValueEx" ret - else getStringTerminated keyPtr valueNamePtr dataSizePtr - where - getStringTerminated keyPtr valueNamePtr dataSizePtr = do - dataSize <- peek dataSizePtr - let newDataSize = dataSize + fromIntegral (sizeOf (undefined :: WinAPI.TCHAR)) - poke dataSizePtr newDataSize - allocaBytes (fromIntegral newDataSize) $ \dataPtr -> do - poke (castPtr $ plusPtr dataPtr $ fromIntegral dataSize) '\0' - ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr dataPtr dataSizePtr - if ret == exitCodeSuccess - then WinAPI.peekTString $ castPtr dataPtr - else raiseError "RegQueryValueEx" ret - -setString :: KeyHandle -> ValueName -> ValueData -> IO () -setString key name value = - WinAPI.withTString value $ \valuePtr -> do - type_ <- catchIOError (getType key name) stringTypeByDefault - WinAPI.regSetValueEx key name type_ valuePtr valueSize - where - stringTypeByDefault e = if isDoesNotExistError e - then return WinAPI.rEG_SZ - else ioError e - valueSize = (length value + 1) * sizeOf (undefined :: WinAPI.TCHAR) diff --git a/src/Windows/Environment.hs b/src/Windows/Environment.hs new file mode 100644 index 0000000..2bea481 --- /dev/null +++ b/src/Windows/Environment.hs @@ -0,0 +1,88 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Windows.Environment + ( Profile(..) + , profileKeyPath + + , VarName + , VarValue + , query + , engrave + , wipe + + , pathJoin + , pathSplit + ) where + +import Data.List (intercalate) +import Data.List.Split (splitOn) +import System.IO.Error (catchIOError, isDoesNotExistError) + +import qualified Windows.Registry as Registry +import Windows.Utils (notifyEnvironmentUpdate) + +data Profile = CurrentUser + | AllUsers + deriving (Eq, Show) + +profileRootKey :: Profile -> Registry.RootKey +profileRootKey CurrentUser = Registry.CurrentUser +profileRootKey AllUsers = Registry.LocalMachine + +profileRootKeyPath :: Profile -> Registry.KeyPath +profileRootKeyPath = Registry.rootKeyPath . profileRootKey + +profileSubKeyPath :: Profile -> Registry.KeyPath +profileSubKeyPath CurrentUser = + Registry.keyPathFromString "Environment" +profileSubKeyPath AllUsers = + Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment" + +profileKeyPath :: Profile -> Registry.KeyPath +profileKeyPath profile = Registry.keyPathJoin + [ profileRootKeyPath profile + , profileSubKeyPath profile + ] + +openRootProfileKey :: Profile -> Registry.KeyHandle +openRootProfileKey = Registry.openRootKey . profileRootKey + +openProfileKey :: Profile -> IO Registry.KeyHandle +openProfileKey profile = Registry.openSubKey (openRootProfileKey profile) (profileSubKeyPath profile) + +type VarName = Registry.ValueName +type VarValue = Registry.ValueData + +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 :: Profile -> VarName -> VarValue -> IO () +engrave profile name value = do + keyHandle <- openProfileKey profile + Registry.setString keyHandle name value + notifyEnvironmentUpdate + +wipe :: Profile -> VarName -> IO () +wipe profile name = do + keyHandle <- openProfileKey profile + catchIOError (Registry.delValue keyHandle name) ignoreIfDoesNotExist + notifyEnvironmentUpdate + where + ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e + +pathSep :: VarValue +pathSep = ";" + +pathSplit :: VarValue -> [VarValue] +pathSplit = filter (not . null) . splitOn pathSep + +pathJoin :: [VarValue] -> VarValue +pathJoin = intercalate pathSep . filter (not . null) diff --git a/src/Windows/Registry.hs b/src/Windows/Registry.hs new file mode 100644 index 0000000..528027f --- /dev/null +++ b/src/Windows/Registry.hs @@ -0,0 +1,145 @@ +{- + - Copyright 2015 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Windows.Registry + ( KeyPath + , keyPathFromString + , keyPathJoin + , keyPathSplit + + , KeyHandle + , openSubKey + + , RootKey(..) + , rootKeyPath + , openRootKey + + , ValueName + , delValue + + , ValueData + , getString + , setString + ) where + +import Data.List (intercalate) +import Data.List.Split (splitOn) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Ptr (castPtr, plusPtr) +import Foreign.Storable (peek, poke, sizeOf) +import System.IO.Error (catchIOError, doesNotExistErrorType, mkIOError, isDoesNotExistError) + +import qualified System.Win32.Registry as WinAPI +import qualified System.Win32.Types as WinAPI + +type KeyName = String +type KeyPath = KeyName + +keyPathSep :: KeyPath +keyPathSep = "\\" + +keyPathFromString :: String -> KeyPath +keyPathFromString = keyPathJoin . keyPathSplit + +keyPathSplit :: KeyPath -> [KeyName] +keyPathSplit = filter (not . null) . splitOn keyPathSep + +keyPathJoin :: [KeyName] -> KeyPath +keyPathJoin = intercalate keyPathSep . filter (not . null) + +type KeyHandle = WinAPI.HKEY + +openSubKey :: KeyHandle -> KeyPath -> IO KeyHandle +openSubKey = WinAPI.regOpenKey + +data RootKey = CurrentUser + | LocalMachine + deriving (Eq, Show) + +rootKeyPath :: RootKey -> KeyName +rootKeyPath CurrentUser = "HKCU" +rootKeyPath LocalMachine = "HKLM" + +openRootKey :: RootKey -> KeyHandle +openRootKey CurrentUser = WinAPI.hKEY_CURRENT_USER +openRootKey LocalMachine = WinAPI.hKEY_LOCAL_MACHINE + +type ValueName = String + +raiseDoesNotExistError :: String -> IO a +raiseDoesNotExistError functionName = + ioError $ mkIOError doesNotExistErrorType functionName Nothing Nothing + +raiseUnknownError :: String -> WinAPI.ErrCode -> IO a +raiseUnknownError functionName exitCode = WinAPI.failWith functionName exitCode + +exitCodeSuccess :: WinAPI.ErrCode +exitCodeSuccess = 0 + +exitCodeFileNotFound :: WinAPI.ErrCode +exitCodeFileNotFound = 0x2 + +raiseError :: String -> WinAPI.ErrCode -> IO a +raiseError functionName ret + | ret == exitCodeFileNotFound = raiseDoesNotExistError functionName + | otherwise = raiseUnknownError functionName ret + +delValue :: KeyHandle -> ValueName -> IO () +delValue keyHandle valueName = + withForeignPtr keyHandle $ \keyPtr -> + WinAPI.withTString valueName $ \valueNamePtr -> do + ret <- WinAPI.c_RegDeleteValue keyPtr valueNamePtr + if ret == exitCodeSuccess + then return () + else raiseError "RegDeleteValue" ret + +type ValueType = WinAPI.RegValueType + +getType :: KeyHandle -> ValueName -> IO ValueType +getType keyHandle valueName = + withForeignPtr keyHandle $ \keyPtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \typePtr -> do + ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr typePtr WinAPI.nullPtr WinAPI.nullPtr + if ret == exitCodeSuccess + then peek typePtr + else raiseError "RegQueryValueEx" ret + +type ValueData = String + +getString :: KeyHandle -> ValueName -> IO ValueData +getString keyHandle valueName = + withForeignPtr keyHandle $ \keyPtr -> + WinAPI.withTString valueName $ \valueNamePtr -> + alloca $ \dataSizePtr -> do + poke dataSizePtr 0 + ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr WinAPI.nullPtr dataSizePtr + if ret /= exitCodeSuccess + then raiseError "RegQueryValueEx" ret + else getStringTerminated keyPtr valueNamePtr dataSizePtr + where + getStringTerminated keyPtr valueNamePtr dataSizePtr = do + dataSize <- peek dataSizePtr + let newDataSize = dataSize + fromIntegral (sizeOf (undefined :: WinAPI.TCHAR)) + poke dataSizePtr newDataSize + allocaBytes (fromIntegral newDataSize) $ \dataPtr -> do + poke (castPtr $ plusPtr dataPtr $ fromIntegral dataSize) '\0' + ret <- WinAPI.c_RegQueryValueEx keyPtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr dataPtr dataSizePtr + if ret == exitCodeSuccess + then WinAPI.peekTString $ castPtr dataPtr + else raiseError "RegQueryValueEx" ret + +setString :: KeyHandle -> ValueName -> ValueData -> IO () +setString key name value = + WinAPI.withTString value $ \valuePtr -> do + type_ <- catchIOError (getType key name) stringTypeByDefault + WinAPI.regSetValueEx key name type_ valuePtr valueSize + where + stringTypeByDefault e = if isDoesNotExistError e + then return WinAPI.rEG_SZ + else ioError e + valueSize = (length value + 1) * sizeOf (undefined :: WinAPI.TCHAR) diff --git a/src/Windows/Utils.hs b/src/Windows/Utils.hs new file mode 100644 index 0000000..aad241f --- /dev/null +++ b/src/Windows/Utils.hs @@ -0,0 +1,28 @@ +{- + - Copyright 2016 Egor Tensin + - This file is licensed under the terms of the MIT License. + - See LICENSE.txt for details. +-} + +module Windows.Utils + ( 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/src/WindowsUtils.hs b/src/WindowsUtils.hs deleted file mode 100644 index 6fa1f0e..0000000 --- a/src/WindowsUtils.hs +++ /dev/null @@ -1,28 +0,0 @@ -{- - - Copyright 2016 Egor Tensin - - 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 aa0190e..d34684f 100644 --- a/windows-env.cabal +++ b/windows-env.cabal @@ -15,7 +15,8 @@ cabal-version: >=1.10 library hs-source-dirs: src - exposed-modules: Environment, Registry, WindowsUtils + exposed-modules: Windows.Environment + other-modules: Windows.Registry, Windows.Utils ghc-options: -Wall -Werror build-depends: base, split, Win32 default-language: Haskell2010 -- cgit v1.2.3