diff options
Diffstat (limited to 'src/WindowsEnv/Registry.hs')
| -rw-r--r-- | src/WindowsEnv/Registry.hs | 292 |
1 files changed, 292 insertions, 0 deletions
diff --git a/src/WindowsEnv/Registry.hs b/src/WindowsEnv/Registry.hs new file mode 100644 index 0000000..da889d4 --- /dev/null +++ b/src/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 |