aboutsummaryrefslogtreecommitdiffstatshomepage
path: root/src/Registry.hs
blob: 4a7c593e97a6084d50806c339249e937228dd46c (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
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 Registry
    ( KeyPath
    , keyPathFromString
    , keyPathJoin
    , keyPathSplit

    , KeyHandle
    , openSubKey

    , RootKey(..)
    , openRootKey
    , rootKeyPath

    , 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)