{-# LINE 1 "LDAP/Search.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.Search
   Copyright  : Copyright (C) 2005 John Goerzen
   License    : BSD

   Maintainer : John Goerzen,
   Maintainer : jgoerzen\@complete.org
   Stability  : provisional
   Portability: portable

LDAP Searching

Written by John Goerzen, jgoerzen\@complete.org
-}

module LDAP.Search (SearchAttributes(..),
                    LDAPEntry(..), LDAPScope(..),
                    ldapSearch, 
                   )
where

import LDAP.Utils
import LDAP.Types
import LDAP.TypesLL
import LDAP.Data
import Foreign
import Foreign.C.String

{-# LINE 36 "LDAP/Search.hsc" #-}
import Foreign.C.Types(CInt(..))

{-# LINE 38 "LDAP/Search.hsc" #-}
import LDAP.Result
import Control.Exception(finally)



{- | Defines what attributes to return with the search result. -}
data SearchAttributes =
   LDAPNoAttrs                   -- ^ No attributes
 | LDAPAllUserAttrs              -- ^ User attributes only
 | LDAPAttrList [String]         -- ^ User-specified list
   deriving (SearchAttributes -> SearchAttributes -> Bool
(SearchAttributes -> SearchAttributes -> Bool)
-> (SearchAttributes -> SearchAttributes -> Bool)
-> Eq SearchAttributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SearchAttributes -> SearchAttributes -> Bool
== :: SearchAttributes -> SearchAttributes -> Bool
$c/= :: SearchAttributes -> SearchAttributes -> Bool
/= :: SearchAttributes -> SearchAttributes -> Bool
Eq, Int -> SearchAttributes -> ShowS
[SearchAttributes] -> ShowS
SearchAttributes -> String
(Int -> SearchAttributes -> ShowS)
-> (SearchAttributes -> String)
-> ([SearchAttributes] -> ShowS)
-> Show SearchAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SearchAttributes -> ShowS
showsPrec :: Int -> SearchAttributes -> ShowS
$cshow :: SearchAttributes -> String
show :: SearchAttributes -> String
$cshowList :: [SearchAttributes] -> ShowS
showList :: [SearchAttributes] -> ShowS
Show)

sa2sl :: SearchAttributes -> [String]
sa2sl :: SearchAttributes -> [String]
sa2sl SearchAttributes
LDAPNoAttrs = [ String
"1.1" ]
{-# LINE 52 "LDAP/Search.hsc" #-}
sa2sl LDAPAllUserAttrs = [ "*" ]
{-# LINE 53 "LDAP/Search.hsc" #-}
sa2sl (LDAPAttrList x) = x

data LDAPEntry = LDAPEntry 
    {LDAPEntry -> String
ledn :: String             -- ^ Distinguished Name of this object
    ,LDAPEntry -> [(String, [String])]
leattrs :: [(String, [String])] -- ^ Mapping from attribute name to values
                           }
    deriving (LDAPEntry -> LDAPEntry -> Bool
(LDAPEntry -> LDAPEntry -> Bool)
-> (LDAPEntry -> LDAPEntry -> Bool) -> Eq LDAPEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LDAPEntry -> LDAPEntry -> Bool
== :: LDAPEntry -> LDAPEntry -> Bool
$c/= :: LDAPEntry -> LDAPEntry -> Bool
/= :: LDAPEntry -> LDAPEntry -> Bool
Eq, Int -> LDAPEntry -> ShowS
[LDAPEntry] -> ShowS
LDAPEntry -> String
(Int -> LDAPEntry -> ShowS)
-> (LDAPEntry -> String)
-> ([LDAPEntry] -> ShowS)
-> Show LDAPEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LDAPEntry -> ShowS
showsPrec :: Int -> LDAPEntry -> ShowS
$cshow :: LDAPEntry -> String
show :: LDAPEntry -> String
$cshowList :: [LDAPEntry] -> ShowS
showList :: [LDAPEntry] -> ShowS
Show)

ldapSearch :: LDAP              -- ^ LDAP connection object
           -> Maybe String      -- ^ Base DN for search, if any
           -> LDAPScope         -- ^ Scope of the search
           -> Maybe String      -- ^ Filter to be used (none if Nothing)
           -> SearchAttributes  -- ^ Desired attributes in result set
           -> Bool              -- ^ If True, exclude attribute values (return types only)
           -> IO [LDAPEntry]

ldapSearch :: LDAP
-> Maybe String
-> LDAPScope
-> Maybe String
-> SearchAttributes
-> Bool
-> IO [LDAPEntry]
ldapSearch LDAP
ld Maybe String
base LDAPScope
scope Maybe String
filter SearchAttributes
attrs Bool
attrsonly =
  LDAP -> (LDAPPtr -> IO [LDAPEntry]) -> IO [LDAPEntry]
forall a. LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr LDAP
ld (\LDAPPtr
cld ->
  Maybe String -> (CString -> IO [LDAPEntry]) -> IO [LDAPEntry]
forall a. Maybe String -> (CString -> IO a) -> IO a
withMString Maybe String
base (\CString
cbase ->
  Maybe String -> (CString -> IO [LDAPEntry]) -> IO [LDAPEntry]
forall a. Maybe String -> (CString -> IO a) -> IO a
withMString Maybe String
filter (\CString
cfilter ->
  [String] -> (Ptr CString -> IO [LDAPEntry]) -> IO [LDAPEntry]
forall a. [String] -> (Ptr CString -> IO a) -> IO a
withCStringArr0 (SearchAttributes -> [String]
sa2sl SearchAttributes
attrs) (\Ptr CString
cattrs ->
  do LDAPInt
msgid <- String -> LDAP -> IO LDAPInt -> IO LDAPInt
checkLEn1 String
"ldapSearch" LDAP
ld (IO LDAPInt -> IO LDAPInt) -> IO LDAPInt -> IO LDAPInt
forall a b. (a -> b) -> a -> b
$
              LDAPPtr
-> CString
-> LDAPInt
-> CString
-> Ptr CString
-> LDAPInt
-> IO LDAPInt
ldap_search LDAPPtr
cld CString
cbase (Int -> LDAPInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> LDAPInt) -> Int -> LDAPInt
forall a b. (a -> b) -> a -> b
$ LDAPScope -> Int
forall a. Enum a => a -> Int
fromEnum LDAPScope
scope)
                          CString
cfilter Ptr CString
cattrs (Bool -> LDAPInt
forall a. Num a => Bool -> a
fromBool Bool
attrsonly)
     LDAP -> LDAPPtr -> LDAPInt -> IO [LDAPEntry]
procSR LDAP
ld LDAPPtr
cld LDAPInt
msgid
                               )
                      )
                    )
                  )

procSR :: LDAP -> Ptr CLDAP -> LDAPInt -> IO [LDAPEntry]
procSR :: LDAP -> LDAPPtr -> LDAPInt -> IO [LDAPEntry]
procSR LDAP
ld LDAPPtr
cld LDAPInt
msgid =
  do LDAPMessage
res1 <- LDAP -> LDAPInt -> IO LDAPMessage
ldap_1result LDAP
ld LDAPInt
msgid
     --putStrLn "Have 1result"
     LDAPMessage
-> (Ptr CLDAPMessage -> IO [LDAPEntry]) -> IO [LDAPEntry]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr LDAPMessage
res1 (\Ptr CLDAPMessage
cres1 ->
      do Ptr CLDAPMessage
felm <- LDAPPtr -> Ptr CLDAPMessage -> IO (Ptr CLDAPMessage)
ldap_first_entry LDAPPtr
cld Ptr CLDAPMessage
cres1
         if Ptr CLDAPMessage
felm Ptr CLDAPMessage -> Ptr CLDAPMessage -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CLDAPMessage
forall a. Ptr a
nullPtr
            then [LDAPEntry] -> IO [LDAPEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else do --putStrLn "Have first entry"
                    CString
cdn <- LDAPPtr -> Ptr CLDAPMessage -> IO CString
ldap_get_dn LDAPPtr
cld Ptr CLDAPMessage
felm -- FIXME: check null
                    String
dn <- CString -> IO String
peekCString CString
cdn
                    CString -> IO ()
ldap_memfree CString
cdn
                    [(String, [String])]
attrs <- LDAP -> Ptr CLDAPMessage -> IO [(String, [String])]
getattrs LDAP
ld Ptr CLDAPMessage
felm
                    [LDAPEntry]
next <- LDAP -> LDAPPtr -> LDAPInt -> IO [LDAPEntry]
procSR LDAP
ld LDAPPtr
cld LDAPInt
msgid
                    --putStrLn $ "Next is " ++ (show next)
                    [LDAPEntry] -> IO [LDAPEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LDAPEntry] -> IO [LDAPEntry]) -> [LDAPEntry] -> IO [LDAPEntry]
forall a b. (a -> b) -> a -> b
$ (LDAPEntry {ledn :: String
ledn = String
dn, leattrs :: [(String, [String])]
leattrs = [(String, [String])]
attrs})LDAPEntry -> [LDAPEntry] -> [LDAPEntry]
forall a. a -> [a] -> [a]
:[LDAPEntry]
next
                         )
      


data BerElement

getattrs :: LDAP -> (Ptr CLDAPMessage) -> IO [(String, [String])]
getattrs :: LDAP -> Ptr CLDAPMessage -> IO [(String, [String])]
getattrs LDAP
ld Ptr CLDAPMessage
lmptr =
    LDAP
-> (LDAPPtr -> IO [(String, [String])]) -> IO [(String, [String])]
forall a. LDAP -> (LDAPPtr -> IO a) -> IO a
withLDAPPtr LDAP
ld (\LDAPPtr
cld -> (Ptr (Ptr BerElement) -> IO [(String, [String])])
-> IO [(String, [String])]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca (LDAPPtr -> Ptr (Ptr BerElement) -> IO [(String, [String])]
f LDAPPtr
cld))
    where f :: LDAPPtr -> Ptr (Ptr BerElement) -> IO [(String, [String])]
f LDAPPtr
cld (Ptr (Ptr BerElement)
ptr::Ptr (Ptr BerElement)) =
              do CString
cstr <- LDAPPtr -> Ptr CLDAPMessage -> Ptr (Ptr BerElement) -> IO CString
ldap_first_attribute LDAPPtr
cld Ptr CLDAPMessage
lmptr Ptr (Ptr BerElement)
ptr
                 if CString
cstr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
                    then [(String, [String])] -> IO [(String, [String])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    else do String
str <- CString -> IO String
peekCString CString
cstr
                            CString -> IO ()
ldap_memfree CString
cstr
                            Ptr BerElement
bptr <- Ptr (Ptr BerElement) -> IO (Ptr BerElement)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr BerElement)
ptr
                            [String]
values <- LDAPPtr -> Ptr CLDAPMessage -> String -> IO [String]
getvalues LDAPPtr
cld Ptr CLDAPMessage
lmptr String
str
                            [(String, [String])]
nextitems <- LDAPPtr
-> Ptr CLDAPMessage -> Ptr BerElement -> IO [(String, [String])]
getnextitems LDAPPtr
cld Ptr CLDAPMessage
lmptr Ptr BerElement
bptr
                            [(String, [String])] -> IO [(String, [String])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [String])] -> IO [(String, [String])])
-> [(String, [String])] -> IO [(String, [String])]
forall a b. (a -> b) -> a -> b
$ (String
str, [String]
values)(String, [String]) -> [(String, [String])] -> [(String, [String])]
forall a. a -> [a] -> [a]
:[(String, [String])]
nextitems

getnextitems :: Ptr CLDAP -> Ptr CLDAPMessage -> Ptr BerElement 
             -> IO [(String, [String])]
getnextitems :: LDAPPtr
-> Ptr CLDAPMessage -> Ptr BerElement -> IO [(String, [String])]
getnextitems LDAPPtr
cld Ptr CLDAPMessage
lmptr Ptr BerElement
bptr =
    do CString
cstr <- LDAPPtr -> Ptr CLDAPMessage -> Ptr BerElement -> IO CString
ldap_next_attribute LDAPPtr
cld Ptr CLDAPMessage
lmptr Ptr BerElement
bptr
       if CString
cstr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
          then [(String, [String])] -> IO [(String, [String])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          else do String
str <- CString -> IO String
peekCString CString
cstr
                  CString -> IO ()
ldap_memfree CString
cstr
                  [String]
values <- LDAPPtr -> Ptr CLDAPMessage -> String -> IO [String]
getvalues LDAPPtr
cld Ptr CLDAPMessage
lmptr String
str
                  [(String, [String])]
nextitems <- LDAPPtr
-> Ptr CLDAPMessage -> Ptr BerElement -> IO [(String, [String])]
getnextitems LDAPPtr
cld Ptr CLDAPMessage
lmptr Ptr BerElement
bptr
                  [(String, [String])] -> IO [(String, [String])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [String])] -> IO [(String, [String])])
-> [(String, [String])] -> IO [(String, [String])]
forall a b. (a -> b) -> a -> b
$ (String
str, [String]
values)(String, [String]) -> [(String, [String])] -> [(String, [String])]
forall a. a -> [a] -> [a]
:[(String, [String])]
nextitems

getvalues :: LDAPPtr -> Ptr CLDAPMessage -> String -> IO [String]
getvalues :: LDAPPtr -> Ptr CLDAPMessage -> String -> IO [String]
getvalues LDAPPtr
cld Ptr CLDAPMessage
clm String
attr =
    String -> (CString -> IO [String]) -> IO [String]
forall a. String -> (CString -> IO a) -> IO a
withCString String
attr (\CString
cattr ->
    do Ptr (Ptr Berval)
berarr <- LDAPPtr -> Ptr CLDAPMessage -> CString -> IO (Ptr (Ptr Berval))
ldap_get_values_len LDAPPtr
cld Ptr CLDAPMessage
clm CString
cattr
       if Ptr (Ptr Berval)
berarr Ptr (Ptr Berval) -> Ptr (Ptr Berval) -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr (Ptr Berval)
forall a. Ptr a
nullPtr
            -- Work around bug between Fedora DS and OpenLDAP (ldapvi
            -- does the same thing)
            then [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else IO [String] -> IO () -> IO [String]
forall a b. IO a -> IO b -> IO a
finally (Ptr (Ptr Berval) -> IO [String]
procberarr Ptr (Ptr Berval)
berarr) (Ptr (Ptr Berval) -> IO ()
ldap_value_free_len Ptr (Ptr Berval)
berarr)
    )

procberarr :: Ptr (Ptr Berval) -> IO [String]
procberarr :: Ptr (Ptr Berval) -> IO [String]
procberarr Ptr (Ptr Berval)
pbv =
    do [Ptr Berval]
bvl <- Ptr Berval -> Ptr (Ptr Berval) -> IO [Ptr Berval]
forall a. (Storable a, Eq a) => a -> Ptr a -> IO [a]
peekArray0 Ptr Berval
forall a. Ptr a
nullPtr Ptr (Ptr Berval)
pbv
       (Ptr Berval -> IO String) -> [Ptr Berval] -> IO [String]
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 Ptr Berval -> IO String
bv2str [Ptr Berval]
bvl

foreign import ccall unsafe "ldap.h ldap_get_dn"
  ldap_get_dn :: LDAPPtr -> Ptr CLDAPMessage -> IO CString

foreign import ccall unsafe "ldap.h ldap_get_values_len"
  ldap_get_values_len :: LDAPPtr -> Ptr CLDAPMessage -> CString -> IO (Ptr (Ptr Berval))

foreign import ccall unsafe "ldap.h ldap_value_free_len"
  ldap_value_free_len :: Ptr (Ptr Berval) -> IO ()

foreign import ccall safe "ldap.h ldap_search"
  ldap_search :: LDAPPtr -> CString -> LDAPInt -> CString -> Ptr CString ->
                 LDAPInt -> IO LDAPInt

foreign import ccall unsafe "ldap.h ldap_first_entry"
  ldap_first_entry :: LDAPPtr -> Ptr CLDAPMessage -> IO (Ptr CLDAPMessage)

foreign import ccall unsafe "ldap.h ldap_first_attribute"
  ldap_first_attribute :: LDAPPtr -> Ptr CLDAPMessage -> Ptr (Ptr BerElement) 
                       -> IO CString

foreign import ccall unsafe "ldap.h ldap_next_attribute"
  ldap_next_attribute :: LDAPPtr -> Ptr CLDAPMessage -> Ptr BerElement
                       -> IO CString