aboutsummaryrefslogtreecommitdiffstatshomepage
path: root/src/Windows
diff options
context:
space:
mode:
Diffstat (limited to 'src/Windows')
-rw-r--r--src/Windows/Environment.hs88
-rw-r--r--src/Windows/Registry.hs145
-rw-r--r--src/Windows/Utils.hs28
3 files changed, 261 insertions, 0 deletions
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 <Egor.Tensin@gmail.com>
+ - 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 <Egor.Tensin@gmail.com>
+ - 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 <Egor.Tensin@gmail.com>
+ - 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-26 10:30:23 +0000