{- -*- Mode: haskell; -*- Haskell LDAP Interface Copyright (C) 2005 John Goerzen This code is under a 3-clause BSD license; see COPYING for details. -} {- | Module : LDAP.Utils Copyright : Copyright (C) 2005 John Goerzen License : BSD Maintainer : John Goerzen, Maintainer : jgoerzen\@complete.org Stability : provisional Portability: portable LDAP low-level utilities Written by John Goerzen, jgoerzen\@complete.org Please use sparingly and with caution. The documentation for their behavior should be considered to be the source code. -} 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 #include {- FIXME frmo python: return native oom for LDAP_NO_MEMORY? load up LDAP_OPT_MATCHED_DN? handle LDAP_REFERRAL? -} {- | Check the return value. If it's something other than 'LDAP.Constants.ldapSuccess', raise an LDAP exception. -} 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 {- else do s <- (ldap_err2string result >>= peekCString) let exc = LDAPException {code = (toEnum (fromIntegral result)), description = s, caller = callername} throwLDAP exc -} {- | Raise an IOError based on errno if getting a NULL. Identical to Foreign.C.Error.throwErrnoIfNull. -} checkNULL :: String -> IO (Ptr a) -> IO (Ptr a) checkNULL = throwErrnoIfNull {- | Value coming in from C -} type LDAPPtr = Ptr CLDAP {- | Convert a LDAPPtr into a LDAP type. Checks it with 'checkNULL' automatically. -} fromLDAPPtr :: String -> IO LDAPPtr -> IO LDAP fromLDAPPtr caller action = do ptr <- checkNULL caller action newForeignPtr ldap_unbind ptr {- | Use a 'LDAP' in a function that needs 'LDAPPtr'. -} withLDAPPtr :: LDAP -> (LDAPPtr -> IO a) -> IO a withLDAPPtr ld = withForeignPtr ld {- | Same as 'withLDAPPtr', but uses nullPtr if the input is Nothing. -} maybeWithLDAPPtr :: Maybe LDAP -> (LDAPPtr -> IO a) -> IO a maybeWithLDAPPtr Nothing func = func nullPtr maybeWithLDAPPtr (Just x) y = withLDAPPtr x y {- | Returns an int, doesn't raise exceptions on err (just crashes) -} 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 {- | Returns a string, doesn't raise exceptions on err (just crashes) -} 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)) -- ^ Function that transforms input data into pointer -> (Ptr b -> IO ()) -- ^ Function that frees generated data -> [a] -- ^ List of input data -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array -> IO c -- Return value 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) <- ( #{peek struct berval, bv_len} ) bptr cstr <- ( #{peek struct berval, bv_val} ) bptr peekCStringLen (cstr, fromIntegral len) {- | Must be freed later with freeHSBerval! -} newBerval :: String -> IO (Ptr Berval) newBerval str = do (ptr::Ptr Berval) <- mallocBytes #{size struct berval} (cstr, len) <- newCStringLen str let (clen::BERLen) = fromIntegral len ( #{poke struct berval, bv_len} ) ptr clen ( #{poke struct berval, bv_val} ) ptr cstr return ptr {- | Free a berval allocated from Haskell. -} freeHSBerval :: Ptr Berval -> IO () freeHSBerval ptr = do cstr <- ( #{peek struct berval, bv_val} ) ptr free cstr free ptr foreign import ccall unsafe "ldap.h &ldap_unbind" ldap_unbind :: FunPtr (LDAPPtr -> IO ()) -- ldap_unbind, ignoring retval 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 ()