{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module Ldap.Client.Search
( search
, searchEither
, searchAsync
, searchAsyncSTM
, Search
, Mod
, Type.Scope(..)
, scope
, size
, time
, typesOnly
, Type.DerefAliases(..)
, derefAliases
, Filter(..)
, SearchEntry(..)
, Async
, wait
, waitSTM
) where
import Control.Monad.STM (STM, atomically)
import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (mapMaybe)
import qualified Ldap.Asn1.Type as Type
import Ldap.Client.Internal
search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
search Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes =
forall e a. Exception e => Either e a -> IO a
raise forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> IO (Either ResponseError [SearchEntry])
searchEither Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes
searchEither
:: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> IO (Either ResponseError [SearchEntry])
searchEither :: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> IO (Either ResponseError [SearchEntry])
searchEither Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes =
forall a. Async a -> IO (Either ResponseError a)
wait forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ldap
-> Dn -> Mod Search -> Filter -> [Attr] -> IO (Async [SearchEntry])
searchAsync Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes
searchAsync :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO (Async [SearchEntry])
searchAsync :: Ldap
-> Dn -> Mod Search -> Filter -> [Attr] -> IO (Async [SearchEntry])
searchAsync Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes =
forall a. STM a -> IO a
atomically (Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> STM (Async [SearchEntry])
searchAsyncSTM Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes)
searchAsyncSTM
:: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> STM (Async [SearchEntry])
searchAsyncSTM :: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> STM (Async [SearchEntry])
searchAsyncSTM Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes =
let req :: Request
req = Dn -> Mod Search -> Filter -> [Attr] -> Request
searchRequest Dn
base Mod Search
opts Filter
flt [Attr]
attributes in forall a.
Ldap
-> (Response -> Either ResponseError a) -> Request -> STM (Async a)
sendRequest Ldap
l (Request -> Response -> Either ResponseError [SearchEntry]
searchResult Request
req) Request
req
searchRequest :: Dn -> Mod Search -> Filter -> [Attr] -> Request
searchRequest :: Dn -> Mod Search -> Filter -> [Attr] -> Request
searchRequest (Dn Text
base) (Mod Search -> Search
m) Filter
flt [Attr]
attributes =
LdapDn
-> Scope
-> DerefAliases
-> Int32
-> Int32
-> Bool
-> Filter
-> AttributeSelection
-> Request
Type.SearchRequest (LdapString -> LdapDn
Type.LdapDn (Text -> LdapString
Type.LdapString Text
base))
Scope
_scope
DerefAliases
_derefAliases
Int32
_size
Int32
_time
Bool
_typesOnly
(Filter -> Filter
fromFilter Filter
flt)
([LdapString] -> AttributeSelection
Type.AttributeSelection (forall a b. (a -> b) -> [a] -> [b]
map (Text -> LdapString
Type.LdapString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Text
unAttr) [Attr]
attributes))
where
Search { Scope
_scope :: Search -> Scope
_scope :: Scope
_scope, DerefAliases
_derefAliases :: Search -> DerefAliases
_derefAliases :: DerefAliases
_derefAliases, Int32
_size :: Search -> Int32
_size :: Int32
_size, Int32
_time :: Search -> Int32
_time :: Int32
_time, Bool
_typesOnly :: Search -> Bool
_typesOnly :: Bool
_typesOnly } =
Search -> Search
m Search
defaultSearch
fromFilter :: Filter -> Filter
fromFilter (Not Filter
x) = Filter -> Filter
Type.Not (Filter -> Filter
fromFilter Filter
x)
fromFilter (And NonEmpty Filter
xs) = NonEmpty Filter -> Filter
Type.And (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Filter -> Filter
fromFilter NonEmpty Filter
xs)
fromFilter (Or NonEmpty Filter
xs) = NonEmpty Filter -> Filter
Type.Or (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Filter -> Filter
fromFilter NonEmpty Filter
xs)
fromFilter (Present (Attr Text
x)) =
AttributeDescription -> Filter
Type.Present (LdapString -> AttributeDescription
Type.AttributeDescription (Text -> LdapString
Type.LdapString Text
x))
fromFilter (Attr Text
x := AttrValue
y) =
AttributeValueAssertion -> Filter
Type.EqualityMatch
(AttributeDescription -> AssertionValue -> AttributeValueAssertion
Type.AttributeValueAssertion (LdapString -> AttributeDescription
Type.AttributeDescription (Text -> LdapString
Type.LdapString Text
x))
(AttrValue -> AssertionValue
Type.AssertionValue AttrValue
y))
fromFilter (Attr Text
x :>= AttrValue
y) =
AttributeValueAssertion -> Filter
Type.GreaterOrEqual
(AttributeDescription -> AssertionValue -> AttributeValueAssertion
Type.AttributeValueAssertion (LdapString -> AttributeDescription
Type.AttributeDescription (Text -> LdapString
Type.LdapString Text
x))
(AttrValue -> AssertionValue
Type.AssertionValue AttrValue
y))
fromFilter (Attr Text
x :<= AttrValue
y) =
AttributeValueAssertion -> Filter
Type.LessOrEqual
(AttributeDescription -> AssertionValue -> AttributeValueAssertion
Type.AttributeValueAssertion (LdapString -> AttributeDescription
Type.AttributeDescription (Text -> LdapString
Type.LdapString Text
x))
(AttrValue -> AssertionValue
Type.AssertionValue AttrValue
y))
fromFilter (Attr Text
x :~= AttrValue
y) =
AttributeValueAssertion -> Filter
Type.ApproxMatch
(AttributeDescription -> AssertionValue -> AttributeValueAssertion
Type.AttributeValueAssertion (LdapString -> AttributeDescription
Type.AttributeDescription (Text -> LdapString
Type.LdapString Text
x))
(AttrValue -> AssertionValue
Type.AssertionValue AttrValue
y))
fromFilter (Attr Text
x :=* (Maybe AttrValue
mi, [AttrValue]
xs, Maybe AttrValue
mf)) =
SubstringFilter -> Filter
Type.Substrings
(AttributeDescription -> NonEmpty Substring -> SubstringFilter
Type.SubstringFilter (LdapString -> AttributeDescription
Type.AttributeDescription (Text -> LdapString
Type.LdapString Text
x))
(forall a. [a] -> NonEmpty a
NonEmpty.fromList (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\AttrValue
i -> [AssertionValue -> Substring
Type.Initial (AttrValue -> AssertionValue
Type.AssertionValue AttrValue
i)]) Maybe AttrValue
mi
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AssertionValue -> Substring
Type.Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrValue -> AssertionValue
Type.AssertionValue) [AttrValue]
xs
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\AttrValue
f -> [AssertionValue -> Substring
Type.Final (AttrValue -> AssertionValue
Type.AssertionValue AttrValue
f)]) Maybe AttrValue
mf
])))
fromFilter ((Maybe Attr
mx, Maybe Attr
mr, Bool
b) ::= AttrValue
y) =
MatchingRuleAssertion -> Filter
Type.ExtensibleMatch
(Maybe MatchingRuleId
-> Maybe AttributeDescription
-> AssertionValue
-> Bool
-> MatchingRuleAssertion
Type.MatchingRuleAssertion (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Attr Text
r) -> LdapString -> MatchingRuleId
Type.MatchingRuleId (Text -> LdapString
Type.LdapString Text
r)) Maybe Attr
mr)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Attr Text
x) -> LdapString -> AttributeDescription
Type.AttributeDescription (Text -> LdapString
Type.LdapString Text
x)) Maybe Attr
mx)
(AttrValue -> AssertionValue
Type.AssertionValue AttrValue
y)
Bool
b)
searchResult :: Request -> Response -> Either ResponseError [SearchEntry]
searchResult :: Request -> Response -> Either ResponseError [SearchEntry]
searchResult Request
req (Type.SearchResultDone (Type.LdapResult ResultCode
code (Type.LdapDn (Type.LdapString Text
dn'))
(Type.LdapString Text
msg) Maybe ReferralUris
_) :| [ProtocolServerOp]
xs)
| ResultCode
Type.Success <- ResultCode
code = forall a b. b -> Either a b
Right (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolServerOp -> Maybe SearchEntry
g [ProtocolServerOp]
xs)
| ResultCode
Type.AdminLimitExceeded <- ResultCode
code = forall a b. b -> Either a b
Right (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolServerOp -> Maybe SearchEntry
g [ProtocolServerOp]
xs)
| ResultCode
Type.SizeLimitExceeded <- ResultCode
code = forall a b. b -> Either a b
Right (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolServerOp -> Maybe SearchEntry
g [ProtocolServerOp]
xs)
| Bool
otherwise = forall a b. a -> Either a b
Left (Request -> ResultCode -> Dn -> Text -> ResponseError
ResponseErrorCode Request
req ResultCode
code (Text -> Dn
Dn Text
dn') Text
msg)
where
g :: ProtocolServerOp -> Maybe SearchEntry
g (Type.SearchResultEntry (Type.LdapDn (Type.LdapString Text
dn))
(Type.PartialAttributeList [PartialAttribute]
ys)) =
forall a. a -> Maybe a
Just (Dn -> AttrList [] -> SearchEntry
SearchEntry (Text -> Dn
Dn Text
dn) (forall a b. (a -> b) -> [a] -> [b]
map PartialAttribute -> (Attr, [AttrValue])
h [PartialAttribute]
ys))
g ProtocolServerOp
_ = forall a. Maybe a
Nothing
h :: PartialAttribute -> (Attr, [AttrValue])
h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString Text
x))
[AttributeValue]
y) = (Text -> Attr
Attr Text
x, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AttributeValue -> AttrValue
j [AttributeValue]
y)
j :: AttributeValue -> AttrValue
j (Type.AttributeValue AttrValue
x) = AttrValue
x
searchResult Request
req Response
res = forall a b. a -> Either a b
Left (Request -> Response -> ResponseError
ResponseInvalid Request
req Response
res)
data Search = Search
{ Search -> Scope
_scope :: !Type.Scope
, Search -> DerefAliases
_derefAliases :: !Type.DerefAliases
, Search -> Int32
_size :: !Int32
, Search -> Int32
_time :: !Int32
, Search -> Bool
_typesOnly :: !Bool
} deriving (Int -> Search -> ShowS
[Search] -> ShowS
Search -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Search] -> ShowS
$cshowList :: [Search] -> ShowS
show :: Search -> String
$cshow :: Search -> String
showsPrec :: Int -> Search -> ShowS
$cshowsPrec :: Int -> Search -> ShowS
Show, Search -> Search -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Search -> Search -> Bool
$c/= :: Search -> Search -> Bool
== :: Search -> Search -> Bool
$c== :: Search -> Search -> Bool
Eq)
defaultSearch :: Search
defaultSearch :: Search
defaultSearch = Search
{ _scope :: Scope
_scope = Scope
Type.WholeSubtree
, _size :: Int32
_size = Int32
0
, _time :: Int32
_time = Int32
0
, _typesOnly :: Bool
_typesOnly = Bool
False
, _derefAliases :: DerefAliases
_derefAliases = DerefAliases
Type.NeverDerefAliases
}
scope :: Type.Scope -> Mod Search
scope :: Scope -> Mod Search
scope Scope
x = forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
y { _scope :: Scope
_scope = Scope
x })
size :: Int32 -> Mod Search
size :: Int32 -> Mod Search
size Int32
x = forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
y { _size :: Int32
_size = Int32
x })
time :: Int32 -> Mod Search
time :: Int32 -> Mod Search
time Int32
x = forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
y { _time :: Int32
_time = Int32
x })
typesOnly :: Bool -> Mod Search
typesOnly :: Bool -> Mod Search
typesOnly Bool
x = forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
y { _typesOnly :: Bool
_typesOnly = Bool
x })
derefAliases :: Type.DerefAliases -> Mod Search
derefAliases :: DerefAliases -> Mod Search
derefAliases DerefAliases
x = forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
y { _derefAliases :: DerefAliases
_derefAliases = DerefAliases
x })
newtype Mod a = Mod (a -> a)
instance Semigroup (Mod a) where
Mod a -> a
f <> :: Mod a -> Mod a -> Mod a
<> Mod a -> a
g = forall a. (a -> a) -> Mod a
Mod (a -> a
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)
instance Monoid (Mod a) where
mempty :: Mod a
mempty = forall a. (a -> a) -> Mod a
Mod forall a. a -> a
id
mappend :: Mod a -> Mod a -> Mod a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
data Filter =
Not !Filter
| And !(NonEmpty Filter)
| Or !(NonEmpty Filter)
| Present !Attr
| !Attr := !AttrValue
| !Attr :>= !AttrValue
| !Attr :<= !AttrValue
| !Attr :~= !AttrValue
| !Attr :=* !(Maybe AttrValue, [AttrValue], Maybe AttrValue)
| !(Maybe Attr, Maybe Attr, Bool) ::= !AttrValue
data SearchEntry = SearchEntry !Dn !(AttrList [])
deriving (Int -> SearchEntry -> ShowS
[SearchEntry] -> ShowS
SearchEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SearchEntry] -> ShowS
$cshowList :: [SearchEntry] -> ShowS
show :: SearchEntry -> String
$cshow :: SearchEntry -> String
showsPrec :: Int -> SearchEntry -> ShowS
$cshowsPrec :: Int -> SearchEntry -> ShowS
Show, SearchEntry -> SearchEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SearchEntry -> SearchEntry -> Bool
$c/= :: SearchEntry -> SearchEntry -> Bool
== :: SearchEntry -> SearchEntry -> Bool
$c== :: SearchEntry -> SearchEntry -> Bool
Eq)