{-# LINE 1 "LDAP/Utils.hsc" #-}
{- -*- 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



{- 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 :: String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLE = (LDAPInt -> Bool) -> String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEe (\LDAPInt
r -> LDAPInt
r LDAPInt -> LDAPInt -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> LDAPInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LDAPReturnCode -> Int
forall a. Enum a => a -> Int
fromEnum LDAPReturnCode
LdapSuccess))

checkLEn1 :: String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEn1 :: String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEn1 = (LDAPInt -> Bool) -> String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEe (\LDAPInt
r -> LDAPInt
r LDAPInt -> LDAPInt -> Bool
forall a. Eq a => a -> a -> Bool
/= -LDAPInt
1)

checkLEe :: (LDAPInt -> Bool) -> String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEe :: (LDAPInt -> Bool) -> String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEe LDAPInt -> Bool
test String
callername LDAP
ld IO LDAPInt
action =
    do LDAPInt
result <- IO LDAPInt
action
       if LDAPInt -> Bool
test LDAPInt
result
          then LDAPInt -> IO LDAPInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LDAPInt
result
          else do LDAPInt
errornum <- LDAP -> LDAPOptionCode -> IO LDAPInt
ldapGetOptionIntNoEc LDAP
ld LDAPOptionCode
LdapOptErrorNumber
                  let hserror :: LDAPReturnCode
hserror = Int -> LDAPReturnCode
forall a. Enum a => Int -> a
toEnum (LDAPInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LDAPInt
errornum)
                  String
err2string <- (LDAPInt -> IO (Ptr CChar)
ldap_err2string LDAPInt
errornum IO (Ptr CChar) -> (Ptr CChar -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr CChar -> IO String
peekCString)
                  Maybe String
objstring <- LDAP -> LDAPOptionCode -> IO (Maybe String)
ldapGetOptionStrNoEc LDAP
ld LDAPOptionCode
LdapOptErrorString
                  let desc :: String
desc = case Maybe String
objstring of
                                             Maybe String
Nothing -> String
err2string
                                             Just String
x -> String
err2string String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                       String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                  let exc :: LDAPException
exc = LDAPException {code :: LDAPReturnCode
code = LDAPReturnCode
hserror,
                                           description :: String
description = String
desc,
                                           caller :: String
caller = String
callername }
                  LDAPException -> IO LDAPInt
forall a. LDAPException -> IO a
throwLDAP LDAPException
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 :: forall a. String -> IO (Ptr a) -> IO (Ptr a)
checkNULL = String -> IO (Ptr a) -> IO (Ptr a)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
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 :: String -> IO LDAPPtr -> IO LDAP
fromLDAPPtr String
caller IO LDAPPtr
action =
    do LDAPPtr
ptr <- String -> IO LDAPPtr -> IO LDAPPtr
forall a. String -> IO (Ptr a) -> IO (Ptr a)
checkNULL String
caller IO LDAPPtr
action
       FinalizerPtr CLDAP -> LDAPPtr -> IO LDAP
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr CLDAP
ldap_unbind LDAPPtr
ptr

{- | Use a 'LDAP' in a function that needs 'LDAPPtr'. -}
withLDAPPtr :: LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr :: forall a. LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr LDAP
ld = LDAP -> (LDAPPtr -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr LDAP
ld

{- | Same as 'withLDAPPtr', but uses nullPtr if the input is Nothing. -}
maybeWithLDAPPtr :: Maybe LDAP -> (LDAPPtr -> IO a) -> IO a
maybeWithLDAPPtr :: forall a. Maybe LDAP -> (LDAPPtr -> IO a) -> IO a
maybeWithLDAPPtr Maybe LDAP
Nothing LDAPPtr -> IO a
func = LDAPPtr -> IO a
func LDAPPtr
forall a. Ptr a
nullPtr
maybeWithLDAPPtr (Just LDAP
x) LDAPPtr -> IO a
y = LDAP -> (LDAPPtr -> IO a) -> IO a
forall a. LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr LDAP
x LDAPPtr -> IO a
y

{- | Returns an int, doesn't raise exceptions on err (just crashes) -}
ldapGetOptionIntNoEc :: LDAP -> LDAPOptionCode -> IO LDAPInt
ldapGetOptionIntNoEc :: LDAP -> LDAPOptionCode -> IO LDAPInt
ldapGetOptionIntNoEc LDAP
ld LDAPOptionCode
oc =
    LDAP -> (LDAPPtr -> IO LDAPInt) -> IO LDAPInt
forall a. LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr LDAP
ld (\LDAPPtr
pld -> (Ptr LDAPInt -> IO LDAPInt) -> IO LDAPInt
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca (LDAPPtr -> Ptr LDAPInt -> IO LDAPInt
f LDAPPtr
pld))
    where oci :: LDAPInt
oci = Int -> LDAPInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> LDAPInt) -> Int -> LDAPInt
forall a b. (a -> b) -> a -> b
$ LDAPOptionCode -> Int
forall a. Enum a => a -> Int
fromEnum LDAPOptionCode
oc
          f :: LDAPPtr -> Ptr LDAPInt -> IO LDAPInt
f LDAPPtr
pld (Ptr LDAPInt
ptr::Ptr LDAPInt) =
              do LDAPInt
res <- LDAPPtr -> LDAPInt -> Ptr () -> IO LDAPInt
ldap_get_option LDAPPtr
pld LDAPInt
oci (Ptr LDAPInt -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr LDAPInt
ptr)
                 if LDAPInt
res LDAPInt -> LDAPInt -> Bool
forall a. Eq a => a -> a -> Bool
/= LDAPInt
0
                    then String -> IO LDAPInt
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO LDAPInt) -> String -> IO LDAPInt
forall a b. (a -> b) -> a -> b
$ String
"Crash in int ldap_get_option, code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LDAPInt -> String
forall a. Show a => a -> String
show LDAPInt
res
                    else Ptr LDAPInt -> IO LDAPInt
forall a. Storable a => Ptr a -> IO a
peek Ptr LDAPInt
ptr

{- | Returns a string, doesn't raise exceptions on err (just crashes) -}
ldapGetOptionStrNoEc :: LDAP -> LDAPOptionCode -> IO (Maybe String)
ldapGetOptionStrNoEc :: LDAP -> LDAPOptionCode -> IO (Maybe String)
ldapGetOptionStrNoEc LDAP
ld LDAPOptionCode
oc =
    LDAP -> (LDAPPtr -> IO (Maybe String)) -> IO (Maybe String)
forall a. LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr LDAP
ld (\LDAPPtr
pld -> (Ptr (Ptr CChar) -> IO (Maybe String)) -> IO (Maybe String)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca (LDAPPtr -> Ptr (Ptr CChar) -> IO (Maybe String)
f LDAPPtr
pld))
    where
    oci :: Int
oci = LDAPOptionCode -> Int
forall a. Enum a => a -> Int
fromEnum LDAPOptionCode
oc
    f :: LDAPPtr -> Ptr (Ptr CChar) -> IO (Maybe String)
f LDAPPtr
pld (Ptr (Ptr CChar)
ptr::Ptr CString) = 
        do LDAPInt
res <- LDAPPtr -> LDAPInt -> Ptr () -> IO LDAPInt
ldap_get_option LDAPPtr
pld (Int -> LDAPInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
oci) (Ptr (Ptr CChar) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr CChar)
ptr)
           if LDAPInt
res LDAPInt -> LDAPInt -> Bool
forall a. Eq a => a -> a -> Bool
/= LDAPInt
0
              then String -> IO (Maybe String)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String
"Crash in str ldap_get_option, code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LDAPInt -> String
forall a. Show a => a -> String
show LDAPInt
res
              else do Ptr CChar
cstr <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CChar)
ptr
                      ForeignPtr CChar
fp <- Ptr CChar -> IO (ForeignPtr CChar)
wrap_memfree Ptr CChar
cstr
                      ForeignPtr CChar
-> (Ptr CChar -> IO (Maybe String)) -> IO (Maybe String)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fp (\Ptr CChar
cs ->
                       do if Ptr CChar
cs Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar
forall a. Ptr a
nullPtr
                             then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                             else do String
hstr <- Ptr CChar -> IO String
peekCString Ptr CChar
cs
                                     Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
hstr
                                        )

wrap_memfree :: CString -> IO (ForeignPtr Foreign.C.Types.CChar)
wrap_memfree :: Ptr CChar -> IO (ForeignPtr CChar)
wrap_memfree Ptr CChar
p = FinalizerPtr CChar -> Ptr CChar -> IO (ForeignPtr CChar)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr CChar
ldap_memfree_call Ptr CChar
p

withMString :: Maybe String -> (CString -> IO a) -> IO a
withMString :: forall a. Maybe String -> (Ptr CChar -> IO a) -> IO a
withMString Maybe String
Nothing Ptr CChar -> IO a
action = Ptr CChar -> IO a
action (Ptr CChar
forall a. Ptr a
nullPtr)
withMString (Just String
str) Ptr CChar -> IO a
action = String -> (Ptr CChar -> IO a) -> IO a
forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
str Ptr CChar -> IO a
action

withCStringArr0 :: [String] -> (Ptr CString -> IO a) -> IO a
withCStringArr0 :: forall a. [String] -> (Ptr (Ptr CChar) -> IO a) -> IO a
withCStringArr0 [String]
inp Ptr (Ptr CChar) -> IO a
action = (String -> IO (Ptr CChar))
-> (Ptr CChar -> IO ())
-> [String]
-> (Ptr (Ptr CChar) -> IO a)
-> IO a
forall a b c.
(a -> IO (Ptr b))
-> (Ptr b -> IO ()) -> [a] -> (Ptr (Ptr b) -> IO c) -> IO c
withAnyArr0 String -> IO (Ptr CChar)
newCString Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
free [String]
inp Ptr (Ptr CChar) -> IO a
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 :: forall a b c.
(a -> IO (Ptr b))
-> (Ptr b -> IO ()) -> [a] -> (Ptr (Ptr b) -> IO c) -> IO c
withAnyArr0 a -> IO (Ptr b)
input2ptract Ptr b -> IO ()
freeact [a]
inp Ptr (Ptr b) -> IO c
action =
    IO [Ptr b] -> ([Ptr b] -> IO ()) -> ([Ptr b] -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((a -> IO (Ptr b)) -> [a] -> IO [Ptr b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> IO (Ptr b)
input2ptract [a]
inp)
            (\[Ptr b]
clist -> (Ptr b -> IO ()) -> [Ptr b] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ptr b -> IO ()
freeact [Ptr b]
clist)
            (\[Ptr b]
clist -> Ptr b -> [Ptr b] -> (Ptr (Ptr b) -> IO c) -> IO c
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 Ptr b
forall a. Ptr a
nullPtr [Ptr b]
clist Ptr (Ptr b) -> IO c
action)

withBervalArr0 :: [String] -> (Ptr (Ptr Berval) -> IO a) -> IO a
withBervalArr0 :: forall a. [String] -> (Ptr (Ptr Berval) -> IO a) -> IO a
withBervalArr0 = (String -> IO (Ptr Berval))
-> (Ptr Berval -> IO ())
-> [String]
-> (Ptr (Ptr Berval) -> IO a)
-> IO a
forall a b c.
(a -> IO (Ptr b))
-> (Ptr b -> IO ()) -> [a] -> (Ptr (Ptr b) -> IO c) -> IO c
withAnyArr0 String -> IO (Ptr Berval)
newBerval Ptr Berval -> IO ()
freeHSBerval

bv2str :: Ptr Berval -> IO String
bv2str :: Ptr Berval -> IO String
bv2str Ptr Berval
bptr = 
    do (BERLen
len::BERLen) <- ( (\Ptr Berval
hsc_ptr -> Ptr Berval -> Int -> IO BERLen
forall b. Ptr b -> Int -> IO BERLen
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Berval
hsc_ptr Int
0) ) Ptr Berval
bptr
{-# LINE 170 "LDAP/Utils.hsc" #-}
       cstr <- ( (\hsc_ptr -> peekByteOff hsc_ptr 8) ) bptr
{-# LINE 171 "LDAP/Utils.hsc" #-}
       peekCStringLen (cstr, fromIntegral len)

{- | Must be freed later with freeHSBerval! -}

newBerval :: String -> IO (Ptr Berval)
newBerval :: String -> IO (Ptr Berval)
newBerval String
str =
           do (Ptr Berval
ptr::Ptr Berval) <- Int -> IO (Ptr Berval)
forall a. Int -> IO (Ptr a)
mallocBytes (Int
16)
{-# LINE 178 "LDAP/Utils.hsc" #-}
              (Ptr CChar
cstr, Int
len) <- String -> IO CStringLen
newCStringLen String
str
              let (BERLen
clen::BERLen) = Int -> BERLen
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
              ( (\Ptr Berval
hsc_ptr -> Ptr Berval -> Int -> BERLen -> IO ()
forall b. Ptr b -> Int -> BERLen -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Berval
hsc_ptr Int
0) ) Ptr Berval
ptr BERLen
clen
{-# LINE 181 "LDAP/Utils.hsc" #-}
              ( (\Ptr Berval
hsc_ptr -> Ptr Berval -> Int -> Ptr CChar -> IO ()
forall b. Ptr b -> Int -> Ptr CChar -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Berval
hsc_ptr Int
8) ) Ptr Berval
ptr Ptr CChar
cstr
{-# LINE 182 "LDAP/Utils.hsc" #-}
              Ptr Berval -> IO (Ptr Berval)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Berval
ptr

{- | Free a berval allocated from Haskell. -}
freeHSBerval :: Ptr Berval -> IO ()
freeHSBerval :: Ptr Berval -> IO ()
freeHSBerval Ptr Berval
ptr =
    do Ptr Any
cstr <- ( (\Ptr Berval
hsc_ptr -> Ptr Berval -> Int -> IO (Ptr Any)
forall b. Ptr b -> Int -> IO (Ptr Any)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Berval
hsc_ptr Int
8) ) Ptr Berval
ptr
{-# LINE 188 "LDAP/Utils.hsc" #-}
       free cstr
       Ptr Berval -> IO ()
forall a. Ptr a -> IO ()
free Ptr Berval
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 ()