{-# 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)

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 :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
search Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes =
  Either ResponseError [SearchEntry] -> IO [SearchEntry]
forall e a. Exception e => Either e a -> IO a
raise (Either ResponseError [SearchEntry] -> IO [SearchEntry])
-> IO (Either ResponseError [SearchEntry]) -> IO [SearchEntry]
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

-- | 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 :: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> IO (Either ResponseError [SearchEntry])
searchEither Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes =
  Async [SearchEntry] -> IO (Either ResponseError [SearchEntry])
forall a. Async a -> IO (Either ResponseError a)
wait (Async [SearchEntry] -> IO (Either ResponseError [SearchEntry]))
-> IO (Async [SearchEntry])
-> IO (Either ResponseError [SearchEntry])
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

-- | 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 :: Ldap
-> Dn -> Mod Search -> Filter -> [Attr] -> IO (Async [SearchEntry])
searchAsync Ldap
l Dn
base Mod Search
opts Filter
flt [Attr]
attributes =
  STM (Async [SearchEntry]) -> IO (Async [SearchEntry])
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)

-- | 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 :: 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 Ldap
-> (Response -> Either ResponseError [SearchEntry])
-> Request
-> STM (Async [SearchEntry])
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 ((Attr -> LdapString) -> [Attr] -> [LdapString]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> LdapString
Type.LdapString (Text -> LdapString) -> (Attr -> Text) -> Attr -> LdapString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Text
unAttr) [Attr]
attributes))
 where
  Search { Scope
_scope :: Scope
_scope :: Search -> Scope
_scope, DerefAliases
_derefAliases :: DerefAliases
_derefAliases :: Search -> DerefAliases
_derefAliases, Int32
_size :: Int32
_size :: Search -> Int32
_size, Int32
_time :: Int32
_time :: Search -> Int32
_time, Bool
_typesOnly :: Bool
_typesOnly :: Search -> 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 ((Filter -> Filter) -> NonEmpty Filter -> NonEmpty Filter
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
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 ((Filter -> Filter) -> NonEmpty Filter -> NonEmpty Filter
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
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))
                            ([Substring] -> NonEmpty Substring
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList ([[Substring]] -> [Substring]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                              [ [Substring]
-> (AttrValue -> [Substring]) -> Maybe AttrValue -> [Substring]
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
                              , (AttrValue -> Substring) -> [AttrValue] -> [Substring]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AssertionValue -> Substring
Type.Any (AssertionValue -> Substring)
-> (AttrValue -> AssertionValue) -> AttrValue -> Substring
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrValue -> AssertionValue
Type.AssertionValue) [AttrValue]
xs
                              , [Substring]
-> (AttrValue -> [Substring]) -> Maybe AttrValue -> [Substring]
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 ((Attr -> MatchingRuleId) -> Maybe Attr -> Maybe MatchingRuleId
forall a b. (a -> b) -> Maybe a -> Maybe b
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)
                                  ((Attr -> AttributeDescription)
-> Maybe Attr -> Maybe AttributeDescription
forall a b. (a -> b) -> Maybe a -> Maybe b
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 = [SearchEntry] -> Either ResponseError [SearchEntry]
forall a b. b -> Either a b
Right ((ProtocolServerOp -> Maybe SearchEntry)
-> [ProtocolServerOp] -> [SearchEntry]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolServerOp -> Maybe SearchEntry
g [ProtocolServerOp]
xs)
  | ResultCode
Type.AdminLimitExceeded <- ResultCode
code = [SearchEntry] -> Either ResponseError [SearchEntry]
forall a b. b -> Either a b
Right ((ProtocolServerOp -> Maybe SearchEntry)
-> [ProtocolServerOp] -> [SearchEntry]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolServerOp -> Maybe SearchEntry
g [ProtocolServerOp]
xs)
  | ResultCode
Type.SizeLimitExceeded <- ResultCode
code = [SearchEntry] -> Either ResponseError [SearchEntry]
forall a b. b -> Either a b
Right ((ProtocolServerOp -> Maybe SearchEntry)
-> [ProtocolServerOp] -> [SearchEntry]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolServerOp -> Maybe SearchEntry
g [ProtocolServerOp]
xs)
  | Bool
otherwise = ResponseError -> Either ResponseError [SearchEntry]
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)) =
    SearchEntry -> Maybe SearchEntry
forall a. a -> Maybe a
Just (Dn -> AttrList [] -> SearchEntry
SearchEntry (Text -> Dn
Dn Text
dn) ((PartialAttribute -> (Attr, [AttrValue]))
-> [PartialAttribute] -> AttrList []
forall a b. (a -> b) -> [a] -> [b]
map PartialAttribute -> (Attr, [AttrValue])
h [PartialAttribute]
ys))
  g ProtocolServerOp
_ = Maybe SearchEntry
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, (AttributeValue -> AttrValue) -> [AttributeValue] -> [AttrValue]
forall a b. (a -> b) -> [a] -> [b]
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 = ResponseError -> Either ResponseError [SearchEntry]
forall a b. a -> Either a b
Left (Request -> Response -> ResponseError
ResponseInvalid Request
req Response
res)

-- | Search options. Use 'Mod' to change some of those.
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
(Int -> Search -> ShowS)
-> (Search -> String) -> ([Search] -> ShowS) -> Show Search
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Search -> ShowS
showsPrec :: Int -> Search -> ShowS
$cshow :: Search -> String
show :: Search -> String
$cshowList :: [Search] -> ShowS
showList :: [Search] -> ShowS
Show, Search -> Search -> Bool
(Search -> Search -> Bool)
-> (Search -> Search -> Bool) -> Eq Search
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Search -> Search -> Bool
== :: Search -> Search -> Bool
$c/= :: Search -> Search -> Bool
/= :: 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 of the search (default: 'WholeSubtree').
scope :: Type.Scope -> Mod Search
scope :: Scope -> Mod Search
scope Scope
x = (Search -> Search) -> Mod Search
forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
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 :: Int32 -> Mod Search
size Int32
x = (Search -> Search) -> Mod Search
forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
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 :: Int32 -> Mod Search
time Int32
x = (Search -> Search) -> Mod Search
forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
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 :: Bool -> Mod Search
typesOnly Bool
x = (Search -> Search) -> Mod Search
forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
y { _typesOnly = x })

-- | Alias dereference policy (default: 'NeverDerefAliases').
derefAliases :: Type.DerefAliases -> Mod Search
derefAliases :: DerefAliases -> Mod Search
derefAliases DerefAliases
x = (Search -> Search) -> Mod Search
forall a. (a -> a) -> Mod a
Mod (\Search
y -> Search
y { _derefAliases = x })

-- | Search modifier. Combine using 'Semigroup' and/or 'Monoid' instance.
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 = (a -> a) -> Mod a
forall a. (a -> a) -> Mod a
Mod (a -> a
g (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)

instance Monoid (Mod a) where
  mempty :: Mod a
mempty = (a -> a) -> Mod a
forall a. (a -> a) -> Mod a
Mod a -> a
forall a. a -> a
id
  mappend :: Mod a -> Mod a -> Mod a
mappend = Mod a -> Mod a -> Mod a
forall a. Semigroup a => a -> a -> a
(<>)

-- | 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 (Int -> SearchEntry -> ShowS
[SearchEntry] -> ShowS
SearchEntry -> String
(Int -> SearchEntry -> ShowS)
-> (SearchEntry -> String)
-> ([SearchEntry] -> ShowS)
-> Show SearchEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SearchEntry -> ShowS
showsPrec :: Int -> SearchEntry -> ShowS
$cshow :: SearchEntry -> String
show :: SearchEntry -> String
$cshowList :: [SearchEntry] -> ShowS
showList :: [SearchEntry] -> ShowS
Show, SearchEntry -> SearchEntry -> Bool
(SearchEntry -> SearchEntry -> Bool)
-> (SearchEntry -> SearchEntry -> Bool) -> Eq SearchEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SearchEntry -> SearchEntry -> Bool
== :: SearchEntry -> SearchEntry -> Bool
$c/= :: SearchEntry -> SearchEntry -> Bool
/= :: SearchEntry -> SearchEntry -> Bool
Eq)