Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

205 lines (168 sloc) 7.475 kB
{- -*- Mode: haskell; -*-
Haskell LDAP Interface
Copyright (C) 2005 John Goerzen <jgoerzen@complete.org>
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 <ldap.h>
{- 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 ()
Jump to Line
Something went wrong with that request. Please try again.