aboutsummaryrefslogtreecommitdiffstatshomepage
path: root/lib/WindowsEnv/Registry.hs
diff options
context:
space:
mode:
authorEgor Tensin <Egor.Tensin@gmail.com>2017-03-25 05:56:02 +0300
committerEgor Tensin <Egor.Tensin@gmail.com>2017-03-25 05:56:02 +0300
commit80f6847645459dfd21e531946e1eeaf2384a2dff (patch)
tree8a93e818fe647974bd724be08092e9475d03425f /lib/WindowsEnv/Registry.hs
parentadd README to the package (diff)
downloadwindows-env-80f6847645459dfd21e531946e1eeaf2384a2dff.tar.gz
windows-env-80f6847645459dfd21e531946e1eeaf2384a2dff.zip
rename directories
Diffstat (limited to 'lib/WindowsEnv/Registry.hs')
-rw-r--r--lib/WindowsEnv/Registry.hs292
1 files changed, 292 insertions, 0 deletions
diff --git a/lib/WindowsEnv/Registry.hs b/lib/WindowsEnv/Registry.hs
new file mode 100644
index 0000000..da889d4
--- /dev/null
+++ b/lib/WindowsEnv/Registry.hs
@@ -0,0 +1,292 @@
+-- |
+-- Description : Lower-level registry access wrappers
+-- Copyright : (c) 2015 Egor Tensin <Egor.Tensin@gmail.com>
+-- License : MIT
+-- Maintainer : Egor.Tensin@gmail.com
+-- Stability : experimental
+-- Portability : Windows-only
+--
+-- Lower-level functions for reading and writing registry values.
+
+module WindowsEnv.Registry
+ ( IsKeyPath(..)
+ , RootKey(..)
+ , KeyPath(..)
+
+ , ValueName
+ , ValueType
+ , ValueData
+
+ , open
+ , close
+
+ , deleteValue
+
+ , queryValue
+ , queryType
+
+ , getValue
+ , GetValueFlag(..)
+ , getType
+
+ , getExpandedString
+
+ , setValue
+ , setString
+ , setExpandableString
+ , setStringPreserveType
+ ) where
+
+import Control.Exception (bracket)
+import Control.Monad.Trans.Except (ExceptT(..), catchE, throwE)
+import Data.Bits ((.|.))
+import qualified Data.ByteString as B
+import Data.List (intercalate)
+import Data.Maybe (fromJust)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf16LE, encodeUtf16LE)
+import Data.Tuple (swap)
+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 qualified System.Win32.Types as WinAPI
+import qualified System.Win32.Registry as WinAPI
+
+type Handle = WinAPI.HKEY
+
+class IsKeyPath a where
+ openUnsafe :: a -> IO Handle
+
+close :: Handle -> IO ()
+close = WinAPI.regCloseKey
+
+open :: IsKeyPath a => a -> IO (Either IOError Handle)
+open keyPath = catchIOError doOpen wrapError
+ where
+ doOpen = Right <$> openUnsafe keyPath
+ wrapError = return . Left
+
+withHandle :: IsKeyPath a => a -> (Handle -> IO b) -> ExceptT IOError IO b
+withHandle keyPath f = ExceptT $ catchIOError doStuff wrapError
+ where
+ doStuff = Right <$> bracket (openUnsafe keyPath) close f
+ wrapError = return . Left
+
+data RootKey = CurrentUser
+ | LocalMachine
+ deriving (Eq)
+
+instance IsKeyPath RootKey where
+ openUnsafe CurrentUser = return WinAPI.hKEY_CURRENT_USER
+ openUnsafe LocalMachine = return WinAPI.hKEY_LOCAL_MACHINE
+
+instance Show RootKey where
+ show CurrentUser = "HKCU"
+ show LocalMachine = "HKLM"
+
+data KeyPath = KeyPath RootKey [String]
+
+pathSep :: String
+pathSep = "\\"
+
+instance IsKeyPath KeyPath where
+ openUnsafe (KeyPath root path) = do
+ rootHandle <- openUnsafe root
+ WinAPI.regOpenKey rootHandle $ intercalate pathSep path
+
+instance Show KeyPath where
+ show (KeyPath root path) = intercalate pathSep $ show root : path
+
+type ValueName = String
+
+data ValueType = TypeNone
+ | TypeBinary
+ | TypeDWord
+ | TypeDWordBE
+ | TypeQWord
+ | TypeString
+ | TypeMultiString
+ | TypeExpandableString
+ | TypeLink
+ deriving (Eq, Show)
+
+instance Enum ValueType where
+ fromEnum = fromJust . flip lookup valueTypeTable
+ toEnum = fromJust . flip lookup (map swap valueTypeTable)
+
+valueTypeTable :: [(ValueType, Int)]
+valueTypeTable =
+ [ (TypeNone, 0)
+ , (TypeBinary, 3)
+ , (TypeDWord, 4)
+ , (TypeDWordBE, 5)
+ , (TypeQWord, 11)
+ , (TypeString, 1)
+ , (TypeMultiString, 7)
+ , (TypeExpandableString, 2)
+ , (TypeLink, 6)
+ ]
+
+type ValueData = (ValueType, B.ByteString)
+
+encodeString :: String -> B.ByteString
+encodeString str = encodeUtf16LE addLastZero
+ where
+ addLastZero
+ | T.null text = text
+ | T.last text == '\0' = text
+ | otherwise = T.snoc text '\0'
+ text = T.pack str
+
+decodeString :: ValueData -> String
+decodeString (_, bytes) = T.unpack dropLastZero
+ where
+ dropLastZero
+ | T.null text = text
+ | otherwise = T.takeWhile (/= '\0') text
+ text = decodeUtf16LE bytes
+
+foreign import ccall unsafe "Windows.h RegQueryValueExW"
+ c_RegQueryValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPDWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode
+
+foreign import ccall unsafe "Windows.h RegSetValueExW"
+ c_RegSetValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.DWORD -> WinAPI.DWORD -> WinAPI.LPBYTE -> WinAPI.DWORD -> IO WinAPI.ErrCode
+
+foreign import 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 keyPath valueName =
+ withHandle keyPath $ \keyHandle ->
+ withForeignPtr keyHandle $ \keyHandlePtr ->
+ WinAPI.withTString valueName $ \valueNamePtr ->
+ alloca $ \valueSizePtr -> do
+ poke valueSizePtr 0
+ WinAPI.failUnlessSuccess "RegQueryValueExW" $
+ c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr WinAPI.nullPtr WinAPI.nullPtr valueSizePtr
+ valueSize <- fromIntegral <$> peek valueSizePtr
+ alloca $ \valueTypePtr ->
+ allocaBytes valueSize $ \bufferPtr -> do
+ WinAPI.failUnlessSuccess "RegQueryValueExW" $
+ c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr valueTypePtr bufferPtr valueSizePtr
+ buffer <- B.pack <$> peekArray valueSize bufferPtr
+ valueType <- toEnum . fromIntegral <$> peek valueTypePtr
+ return (valueType, buffer)
+
+queryType :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueType
+queryType keyPath valueName =
+ withHandle keyPath $ \keyHandle ->
+ withForeignPtr keyHandle $ \keyHandlePtr ->
+ WinAPI.withTString valueName $ \valueNamePtr ->
+ alloca $ \valueTypePtr -> do
+ WinAPI.failUnlessSuccess "RegQueryValueExW" $
+ c_RegQueryValueEx keyHandlePtr valueNamePtr WinAPI.nullPtr valueTypePtr WinAPI.nullPtr WinAPI.nullPtr
+ toEnum . fromIntegral <$> peek valueTypePtr
+
+data GetValueFlag = RestrictAny
+ | RestrictNone
+ | RestrictBinary
+ | RestrictDWord
+ | RestrictQWord
+ | RestrictString
+ | RestrictMultiString
+ | RestrictExpandableString
+ | DoNotExpand
+ deriving (Eq, Show)
+
+instance Enum GetValueFlag where
+ fromEnum = fromJust . flip lookup getValueFlagsTable
+ toEnum = fromJust . flip lookup (map swap getValueFlagsTable)
+
+getValueFlagsTable :: [(GetValueFlag, Int)]
+getValueFlagsTable =
+ [ (RestrictAny, 0x0000ffff)
+ , (RestrictNone, 0x00000001)
+ , (RestrictBinary, 0x00000008)
+ , (RestrictDWord, 0x00000010)
+ , (RestrictQWord, 0x00000040)
+ , (RestrictString, 0x00000002)
+ , (RestrictMultiString, 0x00000020)
+ , (RestrictExpandableString, 0x00000004)
+ , (DoNotExpand, 0x10000000)
+ ]
+
+getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueData
+getValue keyPath valueName flags =
+ withHandle keyPath $ \keyHandle ->
+ withForeignPtr keyHandle $ \keyHandlePtr ->
+ WinAPI.withTString valueName $ \valueNamePtr ->
+ alloca $ \valueSizePtr -> do
+ poke valueSizePtr 0
+ WinAPI.failUnlessSuccess "RegGetValueW" $
+ c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags WinAPI.nullPtr WinAPI.nullPtr valueSizePtr
+ bufferCapacity <- fromIntegral <$> peek valueSizePtr
+ alloca $ \valueTypePtr ->
+ allocaBytes bufferCapacity $ \bufferPtr -> do
+ WinAPI.failUnlessSuccess "RegGetValueW" $
+ c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags valueTypePtr bufferPtr valueSizePtr
+ bufferSize <- fromIntegral <$> peek valueSizePtr
+ buffer <- B.pack <$> peekArray bufferSize bufferPtr
+ valueType <- toEnum . fromIntegral <$> peek valueTypePtr
+ return (valueType, buffer)
+ where
+ rawFlags = fromIntegral $ foldr ((.|.) . fromEnum) 0 flags
+
+getType :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueType
+getType keyPath valueName flags =
+ withHandle keyPath $ \keyHandle ->
+ withForeignPtr keyHandle $ \keyHandlePtr ->
+ WinAPI.withTString valueName $ \valueNamePtr ->
+ alloca $ \valueTypePtr -> do
+ WinAPI.failUnlessSuccess "RegGetValueW" $
+ c_RegGetValue keyHandlePtr WinAPI.nullPtr valueNamePtr rawFlags valueTypePtr WinAPI.nullPtr WinAPI.nullPtr
+ toEnum . fromIntegral <$> peek valueTypePtr
+ where
+ rawFlags = fromIntegral $ foldr ((.|.) . fromEnum) 0 (DoNotExpand : flags)
+
+getExpandedString :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String
+getExpandedString keyPath valueName = do
+ valueData <- getValue keyPath valueName [RestrictString]
+ return $ decodeString valueData
+
+setValue :: IsKeyPath a => a -> ValueName -> ValueData -> ExceptT IOError IO ()
+setValue keyPath valueName (valueType, valueData) =
+ withHandle keyPath $ \keyHandle ->
+ withForeignPtr keyHandle $ \keyHandlePtr ->
+ WinAPI.withTString valueName $ \valueNamePtr ->
+ allocaBytes bufferSize $ \bufferPtr -> do
+ pokeArray bufferPtr buffer
+ WinAPI.failUnlessSuccess "RegSetValueExW" $
+ c_RegSetValueEx keyHandlePtr valueNamePtr 0 rawValueType bufferPtr (fromIntegral bufferSize)
+ where
+ rawValueType = fromIntegral $ fromEnum valueType
+ 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 <- getType keyPath valueName flags `catchE` stringByDefault
+ setValue keyPath valueName (valueType, encodeString valueData)
+ where
+ flags = [RestrictString, RestrictExpandableString]
+ stringByDefault e
+ | isDoesNotExistError e = return TypeString
+ | otherwise = throwE e
+
+deleteValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ()
+deleteValue keyPath valueName =
+ withHandle keyPath $ \keyHandle ->
+ withForeignPtr keyHandle $ \keyHandlePtr ->
+ WinAPI.withTString valueName $ \valueNamePtr ->
+ WinAPI.failUnlessSuccess "RegDeleteValueW" $
+ WinAPI.c_RegDeleteValue keyHandlePtr valueNamePtr