224 lines
8.2 KiB
Haskell
224 lines
8.2 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
-- | <https://tools.ietf.org/html/rfc4511#section-4.5 Search> operation.
|
|
--
|
|
-- This operation comes in four flavours:
|
|
--
|
|
-- * synchronous, exception throwing ('search')
|
|
--
|
|
-- * synchronous, returning 'Either' 'ResponseError' @()@ ('searchEither')
|
|
--
|
|
-- * asynchronous, 'IO' based ('searchAsync')
|
|
--
|
|
-- * asynchronous, 'STM' based ('searchAsyncSTM')
|
|
--
|
|
-- Of those, the first one ('search') is probably the most useful for the typical usecase.
|
|
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)
|
|
#if __GLASGOW_HASKELL__ >= 710
|
|
import Data.Semigroup (Semigroup(..))
|
|
#else
|
|
import Data.Semigroup (Semigroup(..), Monoid(..))
|
|
#endif
|
|
|
|
import qualified Ldap.Asn1.Type as Type
|
|
import Ldap.Client.Internal
|
|
|
|
|
|
-- | Perform the Search operation synchronously. Raises 'ResponseError' on failures.
|
|
search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
|
|
search l base opts flt attributes =
|
|
raise =<< searchEither l base opts flt attributes
|
|
|
|
-- | Perform the Search operation synchronously. Returns @Left e@ where
|
|
-- @e@ is a 'ResponseError' on failures.
|
|
searchEither
|
|
:: Ldap
|
|
-> Dn
|
|
-> Mod Search
|
|
-> Filter
|
|
-> [Attr]
|
|
-> IO (Either ResponseError [SearchEntry])
|
|
searchEither l base opts flt attributes =
|
|
wait =<< searchAsync l base opts flt attributes
|
|
|
|
-- | Perform the Search operation asynchronously. Call 'Ldap.Client.wait' to wait
|
|
-- for its completion.
|
|
searchAsync :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO (Async [SearchEntry])
|
|
searchAsync l base opts flt attributes =
|
|
atomically (searchAsyncSTM l base opts flt attributes)
|
|
|
|
-- | Perform the Search operation asynchronously.
|
|
--
|
|
-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the
|
|
-- same transaction you've performed it in.
|
|
searchAsyncSTM
|
|
:: Ldap
|
|
-> Dn
|
|
-> Mod Search
|
|
-> Filter
|
|
-> [Attr]
|
|
-> STM (Async [SearchEntry])
|
|
searchAsyncSTM l base opts flt attributes =
|
|
let req = searchRequest base opts flt attributes in sendRequest l (searchResult req) req
|
|
|
|
searchRequest :: Dn -> Mod Search -> Filter -> [Attr] -> Request
|
|
searchRequest (Dn base) (Mod m) flt attributes =
|
|
Type.SearchRequest (Type.LdapDn (Type.LdapString base))
|
|
_scope
|
|
_derefAliases
|
|
_size
|
|
_time
|
|
_typesOnly
|
|
(fromFilter flt)
|
|
(Type.AttributeSelection (map (Type.LdapString . unAttr) attributes))
|
|
where
|
|
Search { _scope, _derefAliases, _size, _time, _typesOnly } =
|
|
m defaultSearch
|
|
fromFilter (Not x) = Type.Not (fromFilter x)
|
|
fromFilter (And xs) = Type.And (fmap fromFilter xs)
|
|
fromFilter (Or xs) = Type.Or (fmap fromFilter xs)
|
|
fromFilter (Present (Attr x)) =
|
|
Type.Present (Type.AttributeDescription (Type.LdapString x))
|
|
fromFilter (Attr x := y) =
|
|
Type.EqualityMatch
|
|
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
|
(Type.AssertionValue y))
|
|
fromFilter (Attr x :>= y) =
|
|
Type.GreaterOrEqual
|
|
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
|
(Type.AssertionValue y))
|
|
fromFilter (Attr x :<= y) =
|
|
Type.LessOrEqual
|
|
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
|
(Type.AssertionValue y))
|
|
fromFilter (Attr x :~= y) =
|
|
Type.ApproxMatch
|
|
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
|
(Type.AssertionValue y))
|
|
fromFilter (Attr x :=* (mi, xs, mf)) =
|
|
Type.Substrings
|
|
(Type.SubstringFilter (Type.AttributeDescription (Type.LdapString x))
|
|
(NonEmpty.fromList (concat
|
|
[ maybe [] (\i -> [Type.Initial (Type.AssertionValue i)]) mi
|
|
, fmap (Type.Any . Type.AssertionValue) xs
|
|
, maybe [] (\f -> [Type.Final (Type.AssertionValue f)]) mf
|
|
])))
|
|
fromFilter ((mx, mr, b) ::= y) =
|
|
Type.ExtensibleMatch
|
|
(Type.MatchingRuleAssertion (fmap (\(Attr r) -> Type.MatchingRuleId (Type.LdapString r)) mr)
|
|
(fmap (\(Attr x) -> Type.AttributeDescription (Type.LdapString x)) mx)
|
|
(Type.AssertionValue y)
|
|
b)
|
|
|
|
searchResult :: Request -> Response -> Either ResponseError [SearchEntry]
|
|
searchResult req (Type.SearchResultDone (Type.LdapResult code (Type.LdapDn (Type.LdapString dn'))
|
|
(Type.LdapString msg) _) :| xs)
|
|
| Type.Success <- code = Right (mapMaybe g xs)
|
|
| Type.AdminLimitExceeded <- code = Right (mapMaybe g xs)
|
|
| Type.SizeLimitExceeded <- code = Right (mapMaybe g xs)
|
|
| otherwise = Left (ResponseErrorCode req code (Dn dn') msg)
|
|
where
|
|
g (Type.SearchResultEntry (Type.LdapDn (Type.LdapString dn))
|
|
(Type.PartialAttributeList ys)) =
|
|
Just (SearchEntry (Dn dn) (map h ys))
|
|
g _ = Nothing
|
|
h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x))
|
|
y) = (Attr x, fmap j y)
|
|
j (Type.AttributeValue x) = x
|
|
searchResult req res = Left (ResponseInvalid req res)
|
|
|
|
-- | Search options. Use 'Mod' to change some of those.
|
|
data Search = Search
|
|
{ _scope :: !Type.Scope
|
|
, _derefAliases :: !Type.DerefAliases
|
|
, _size :: !Int32
|
|
, _time :: !Int32
|
|
, _typesOnly :: !Bool
|
|
} deriving (Show, Eq)
|
|
|
|
defaultSearch :: Search
|
|
defaultSearch = Search
|
|
{ _scope = Type.WholeSubtree
|
|
, _size = 0
|
|
, _time = 0
|
|
, _typesOnly = False
|
|
, _derefAliases = Type.NeverDerefAliases
|
|
}
|
|
|
|
-- | Scope of the search (default: 'WholeSubtree').
|
|
scope :: Type.Scope -> Mod Search
|
|
scope x = Mod (\y -> y { _scope = x })
|
|
|
|
-- | Maximum number of entries to be returned as a result of the Search.
|
|
-- No limit if the value is @0@ (default: @0@).
|
|
size :: Int32 -> Mod Search
|
|
size x = Mod (\y -> y { _size = x })
|
|
|
|
-- | Maximum time (in seconds) allowed for the Search. No limit if the value
|
|
-- is @0@ (default: @0@).
|
|
time :: Int32 -> Mod Search
|
|
time x = Mod (\y -> y { _time = x })
|
|
|
|
-- | Whether Search results are to contain just attribute descriptions, or
|
|
-- both attribute descriptions and values (default: 'False').
|
|
typesOnly :: Bool -> Mod Search
|
|
typesOnly x = Mod (\y -> y { _typesOnly = x })
|
|
|
|
-- | Alias dereference policy (default: 'NeverDerefAliases').
|
|
derefAliases :: Type.DerefAliases -> Mod Search
|
|
derefAliases x = Mod (\y -> y { _derefAliases = x })
|
|
|
|
-- | Search modifier. Combine using 'Semigroup' and/or 'Monoid' instance.
|
|
newtype Mod a = Mod (a -> a)
|
|
|
|
instance Semigroup (Mod a) where
|
|
Mod f <> Mod g = Mod (g . f)
|
|
|
|
instance Monoid (Mod a) where
|
|
mempty = Mod id
|
|
mappend = (<>)
|
|
|
|
-- | Conditions that must be fulfilled in order for the Search to match a given entry.
|
|
data Filter =
|
|
Not !Filter -- ^ Filter does not match the entry
|
|
| And !(NonEmpty Filter) -- ^ All filters match the entry
|
|
| Or !(NonEmpty Filter) -- ^ Any filter matches the entry
|
|
| Present !Attr -- ^ Attribute is present in the entry
|
|
| !Attr := !AttrValue -- ^ Attribute's value is equal to the assertion
|
|
| !Attr :>= !AttrValue -- ^ Attribute's value is equal to or greater than the assertion
|
|
| !Attr :<= !AttrValue -- ^ Attribute's value is equal to or less than the assertion
|
|
| !Attr :~= !AttrValue -- ^ Attribute's value approximately matches the assertion
|
|
| !Attr :=* !(Maybe AttrValue, [AttrValue], Maybe AttrValue)
|
|
-- ^ Glob match
|
|
| (Maybe Attr, Maybe Attr, Bool) ::= AttrValue
|
|
-- ^ Extensible match
|
|
|
|
-- | Entry found during the Search.
|
|
data SearchEntry = SearchEntry !Dn !(AttrList [])
|
|
deriving (Show, Eq)
|