{-# OPTIONS -fglasgow-exts #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Registry
-- Copyright   :  (c) The University of Glasgow 2004
-- License     :  BSD-style
-- 
-- Maintainer  :  simonmar@microsoft.com
-- Stability   :  experimental
-- Portability :  non-portable (Win32 only)
--
-- I don't much like the registry interface in ComDll, or the one in the Win32
-- library, so in true NIH stylee I'm going to write my own...
--
-----------------------------------------------------------------------------

module Registry (
  RegistryKey,
  RegHive,
  regCreateEntry,
  withRegKey,
  regSetValueString,
  regSetValueDWORD,
  regQueryValueString,
  regDeleteKey,
  regDeleteValue,
 ) where

import ComDll	( RegHive )

import Foreign
import Foreign.C
import Control.Exception ( bracket )

#include <windows.h>
#include "RegistryUtils.h"

-- | Abstract type of registry keys
newtype RegistryKey = RegistryKey (Ptr ())
  deriving Storable -- isn't GHC great

type DWORD = (#type DWORD)
type LONG = (#type LONG)

-- | creates a key and sets its value
regCreateEntry :: RegHive -> String -> String -> IO ()
regCreateEntry hive subkey val = do
  withRegKey hive subkey $ \k -> 
    regSetValueString k Nothing val

-- | creates a key (or open it if it already exists), performs some
-- operations on it, and closes the key afterward.
withRegKey :: RegHive -> String -> (RegistryKey -> IO a) -> IO a
withRegKey hive subkey scope
  = bracket (regCreateKey hive subkey)
	    c_RegCloseKey
	    scope

regCreateKey :: RegHive -> String -> IO RegistryKey
regCreateKey hive subkey =
  withCString subkey $ \subkey_cstr ->
    alloca  $ \p_hkey -> do
	key <- hiveKey (fromEnum hive)
	r <- c_RegCreateKeyEx 
		key
		subkey_cstr
		0
		nullPtr
		(#const REG_OPTION_NON_VOLATILE)
		(#const KEY_ALL_ACCESS)
		nullPtr
		p_hkey
		nullPtr
	peek p_hkey
	
-- | Sets the value of a key to a string
regSetValueString
  :: RegistryKey  -- ^ The key to set
  -> Maybe String -- ^ Optionally, the name of the value (otherwise set the
		  --   default value for this key).
  -> String       -- ^ The value
  -> IO ()
regSetValueString key val_name value =
  withMaybeCString val_name $ \val_name_cstr ->
  withCStringLen value      $ \(value_cstr,len) -> do
  r <- c_RegSetValueEx key val_name_cstr 0 (#const REG_SZ) 
	value_cstr (fromIntegral (len+1)) -- +1 for the null terminator
  return ()

-- | Sets the value of a key to a string
regQueryValueString
  :: RegistryKey  -- ^ The key to set
  -> Maybe String -- ^ Optionally, the name of the value (otherwise set the
		  --   default value for this key).
  -> IO String
regQueryValueString key val_name =
  withMaybeCString val_name $ \val_name_cstr ->
  alloca                    $ \pType  ->
  allocaBytes buffer_len    $ \buffer ->
  alloca                    $ \pCount -> do
    poke pCount (fromIntegral buffer_len)
    r <- c_RegQueryValueEx key val_name_cstr 0 pType buffer pCount
    peekCString buffer
  where
    buffer_len = 1024

withMaybeCString :: Maybe String -> (CString -> IO a) -> IO a
withMaybeCString Nothing k = k nullPtr
withMaybeCString (Just s) k = withCString s $ \p -> k p

-- | Sets the value of a key to a DWORD (or Int32 in Haskell)
regSetValueDWORD
  :: RegistryKey  -- ^ The key to set
  -> Maybe String -- ^ Optionally, the name of the value (otherwise set the
		  --   default value for this key).
  -> Int32	  -- ^ The value
  -> IO ()
regSetValueDWORD key val_name val =
  withMaybeCString val_name $ \val_name_cstr ->
  with (fromIntegral val :: DWORD) $ \p_val -> do
  r <- c_RegSetValueEx key val_name_cstr 0 (#const REG_DWORD) 
	p_val (fromIntegral (sizeOf val))
  return ()

regDeleteKey :: RegHive -> String -> IO ()
regDeleteKey hive subkey = do
  key <- hiveKey (fromEnum hive)
  withCString subkey $ \subkey_cstr -> do
    r <- c_RegDeleteKey key subkey_cstr
    return ()

regDeleteValue :: RegistryKey -> String -> IO ()
regDeleteValue key val_name = do
  withCString val_name $ \val_name_cstr -> do
    r <- c_RegDeleteValue key val_name_cstr
    return ()

-- ----------------------------------------------------------------------------
-- Foreign functions

-- NB. Windows normally #defines RegSetValueEx to either
-- RegSetValueExA or RegSetValueExW depending on the setting of
-- UNICODE.  We don't want to rely on this #defining (would require
-- compiling via C), so we go straight for the ASCII versions.
--
-- ToDo: unicode support later.

-- LONG RegSetValueEx(
--   HKEY hKey,
--   LPCTSTR lpValueName,
--   DWORD Reserved,
--   DWORD dwType,
--   const BYTE* lpData,
--   DWORD cbData
-- );

foreign import stdcall unsafe "RegSetValueExA"
  c_RegSetValueEx :: RegistryKey
		  -> CString
		  -> DWORD		-- reserved
		  -> DWORD		-- type
		  -> Ptr a		-- data
		  -> DWORD		-- count
		  -> IO LONG

-- LONG RegQueryValueEx(
--   HKEY hKey,
--   LPCTSTR lpValueName,
--   DWORD Reserved,
--   LPDWORD dwType,
--   LPBYTE lpData,
--   LPDWORD lpcbData
-- );

foreign import stdcall unsafe "RegQueryValueExA"
  c_RegQueryValueEx :: RegistryKey
		    -> CString
		    -> DWORD		-- reserved
		    -> Ptr DWORD	-- type
		    -> Ptr a		-- data
		    -> Ptr DWORD	-- count
		    -> IO LONG

-- LONG RegCreateKeyEx(
--   HKEY hKey,
--   LPCTSTR lpSubKey,
--   DWORD Reserved,
--   LPTSTR lpClass, 0
--   DWORD dwOptions, null
--   REGSAM samDesired, 
--   LPSECURITY_ATTRIBUTES lpSecurityAttributes, 
--   PHKEY phkResult,
--   LPDWORD lpdwDisposition
-- );

foreign import stdcall unsafe "RegCreateKeyExA"
  c_RegCreateKeyEx :: RegistryKey	-- hive
		   -> CString		-- subkey
		   -> DWORD		-- reserved
		   -> CString		-- class
		   -> DWORD		-- options
		   -> (#type REGSAM)	-- samDesired
		   -> Ptr a		-- lpSecurityAttributes
		   -> Ptr RegistryKey	-- result
		   -> Ptr DWORD		-- disposition
		   -> IO LONG

foreign import ccall unsafe "hiveKey"
  hiveKey :: Int -> IO RegistryKey

foreign import stdcall unsafe "RegCloseKey"
  c_RegCloseKey :: RegistryKey -> IO LONG

-- LONG RegDeleteKey(
--   HKEY hKey,
--   LPCTSTR lpSubKey
-- );
foreign import stdcall unsafe "RegDeleteKeyA"
  c_RegDeleteKey :: RegistryKey -> CString -> IO LONG

-- LONG RegDeleteValue(
--   HKEY hKey,
--   LPCTSTR lpValueName
-- );
foreign import stdcall unsafe "RegDeleteValueA"
  c_RegDeleteValue :: RegistryKey -> CString -> IO LONG