module LDAP.Utils(checkLE, checkLEe, checkLEn1,
checkNULL, LDAPPtr, fromLDAPPtr,
withLDAPPtr, maybeWithLDAPPtr, withMString,
withCStringArr0, ldap_memfree,
bv2str, newBerval, freeHSBerval,
withAnyArr0) where
import Foreign.Ptr
import LDAP.Constants
import LDAP.Exceptions
import LDAP.Types
import LDAP.Data
import LDAP.TypesLL
import Control.Exception
import Data.Dynamic
import Foreign.C.Error
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign
import Foreign.C.Types
checkLE :: String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLE = checkLEe (\r -> r == fromIntegral (fromEnum LdapSuccess))
checkLEn1 :: String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEn1 = checkLEe (\r -> r /= 1)
checkLEe :: (LDAPInt -> Bool) -> String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEe test callername ld action =
do result <- action
if test result
then return result
else do errornum <- ldapGetOptionIntNoEc ld LdapOptErrorNumber
let hserror = toEnum (fromIntegral errornum)
err2string <- (ldap_err2string errornum >>= peekCString)
objstring <- ldapGetOptionStrNoEc ld LdapOptErrorString
let desc = case objstring of
Nothing -> err2string
Just x -> err2string ++ " (" ++
x ++ ")"
let exc = LDAPException {code = hserror,
description = desc,
caller = callername }
throwLDAP exc
checkNULL :: String -> IO (Ptr a) -> IO (Ptr a)
checkNULL = throwErrnoIfNull
type LDAPPtr = Ptr CLDAP
fromLDAPPtr :: String -> IO LDAPPtr -> IO LDAP
fromLDAPPtr caller action =
do ptr <- checkNULL caller action
newForeignPtr ldap_unbind ptr
withLDAPPtr :: LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr ld = withForeignPtr ld
maybeWithLDAPPtr :: Maybe LDAP -> (LDAPPtr -> IO a) -> IO a
maybeWithLDAPPtr Nothing func = func nullPtr
maybeWithLDAPPtr (Just x) y = withLDAPPtr x y
ldapGetOptionIntNoEc :: LDAP -> LDAPOptionCode -> IO LDAPInt
ldapGetOptionIntNoEc ld oc =
withLDAPPtr ld (\pld -> alloca (f pld))
where oci = fromIntegral $ fromEnum oc
f pld (ptr::Ptr LDAPInt) =
do res <- ldap_get_option pld oci (castPtr ptr)
if res /= 0
then fail $ "Crash in int ldap_get_option, code " ++ show res
else peek ptr
ldapGetOptionStrNoEc :: LDAP -> LDAPOptionCode -> IO (Maybe String)
ldapGetOptionStrNoEc ld oc =
withLDAPPtr ld (\pld -> alloca (f pld))
where
oci = fromEnum oc
f pld (ptr::Ptr CString) =
do res <- ldap_get_option pld (fromIntegral oci) (castPtr ptr)
if res /= 0
then fail $ "Crash in str ldap_get_option, code " ++ show res
else do cstr <- peek ptr
fp <- wrap_memfree cstr
withForeignPtr fp (\cs ->
do if cs == nullPtr
then return Nothing
else do hstr <- peekCString cs
return $ Just hstr
)
wrap_memfree :: CString -> IO (ForeignPtr Foreign.C.Types.CChar)
wrap_memfree p = newForeignPtr ldap_memfree_call p
withMString :: Maybe String -> (CString -> IO a) -> IO a
withMString Nothing action = action (nullPtr)
withMString (Just str) action = withCString str action
withCStringArr0 :: [String] -> (Ptr CString -> IO a) -> IO a
withCStringArr0 inp action = withAnyArr0 newCString free inp action
withAnyArr0 :: (a -> IO (Ptr b))
-> (Ptr b -> IO ())
-> [a]
-> (Ptr (Ptr b) -> IO c)
-> IO c
withAnyArr0 input2ptract freeact inp action =
bracket (mapM input2ptract inp)
(\clist -> mapM_ freeact clist)
(\clist -> withArray0 nullPtr clist action)
withBervalArr0 :: [String] -> (Ptr (Ptr Berval) -> IO a) -> IO a
withBervalArr0 = withAnyArr0 newBerval freeHSBerval
bv2str :: Ptr Berval -> IO String
bv2str bptr =
do (len::BERLen) <- ( (\hsc_ptr -> peekByteOff hsc_ptr 0) ) bptr
cstr <- ( (\hsc_ptr -> peekByteOff hsc_ptr 8) ) bptr
peekCStringLen (cstr, fromIntegral len)
newBerval :: String -> IO (Ptr Berval)
newBerval str =
do (ptr::Ptr Berval) <- mallocBytes (16)
(cstr, len) <- newCStringLen str
let (clen::BERLen) = fromIntegral len
( (\hsc_ptr -> pokeByteOff hsc_ptr 0) ) ptr clen
( (\hsc_ptr -> pokeByteOff hsc_ptr 8) ) ptr cstr
return ptr
freeHSBerval :: Ptr Berval -> IO ()
freeHSBerval ptr =
do cstr <- ( (\hsc_ptr -> peekByteOff hsc_ptr 8) ) ptr
free cstr
free ptr
foreign import ccall unsafe "ldap.h &ldap_unbind"
ldap_unbind :: FunPtr (LDAPPtr -> IO ())
foreign import ccall unsafe "ldap.h ldap_err2string"
ldap_err2string :: LDAPInt -> IO CString
foreign import ccall unsafe "ldap.h ldap_get_option"
ldap_get_option :: LDAPPtr -> LDAPInt -> Ptr () -> IO LDAPInt
foreign import ccall unsafe "ldap.h &ldap_memfree"
ldap_memfree_call :: FunPtr (CString -> IO ())
foreign import ccall unsafe "ldap.h ldap_memfree"
ldap_memfree :: CString -> IO ()