packages feed

ldap-client (empty) → 0.1.0

raw patch · 26 files changed

+2914/−0 lines, 26 filesdep +asn1-encodingdep +asn1-typesdep +asyncsetup-changed

Dependencies added: asn1-encoding, asn1-types, async, base, bytestring, connection, containers, hspec, ldap-client, network, process, semigroups, stm, text

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Matvey Aksenov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,43 @@+ldap-client+===========+[![Build Status](https://travis-ci.org/supki/ldap-client.svg?branch=master)](https://travis-ci.org/supki/ldap-client)++This library implements (the parts of) [RFC 4511][rfc4511]++          Feature            |   RFC Section   |   Support+:--------------------------- |:---------------:|:-----------:+Bind Operation               | [4.2][4.2]      | ✔+Unbind Operation             | [4.3][4.3]      | ✔+Unsolicited Notification     | [4.4][4.4]      | ✔+Notice of Disconnection      | [4.4.1][4.4.1]  | ✔+Search Operation             | [4.5][4.5]      | ✔\*+Modify Operation             | [4.6][4.6]      | ✔+Add Operation                | [4.7][4.7]      | ✔+Delete Operation             | [4.8][4.8]      | ✔+Modify DN Operation          | [4.9][4.9]      | ✔+Compare Operation            | [4.10][4.10]    | ✔+Abandon Operation            | [4.11][4.11]    | ✘+Extended Operation           | [4.12][4.12]    | ✔+IntermediateResponse Message | [4.13][4.13]    | ✔+StartTLS Operation           | [4.14][4.14]    | ✔†+LDAP over TLS                | -               | ✔++\* The `:dn` thing is unsupported in Extensible matches  +† Only serves as an example of Extended Operation.  It's useless for all practical purposes as it does not actually enable TLS.  In other words, use LDAP over TLS instead.++  [rfc4511]: https://tools.ietf.org/html/rfc4511+  [LDAP]: https://hackage.haskell.org/package/LDAP+  [4.2]: https://tools.ietf.org/html/rfc4511#section-4.2+  [4.3]: https://tools.ietf.org/html/rfc4511#section-4.3+  [4.4]: https://tools.ietf.org/html/rfc4511#section-4.4+  [4.4.1]: https://tools.ietf.org/html/rfc4511#section-4.4.1+  [4.5]: https://tools.ietf.org/html/rfc4511#section-4.5+  [4.6]: https://tools.ietf.org/html/rfc4511#section-4.6+  [4.7]: https://tools.ietf.org/html/rfc4511#section-4.7+  [4.8]: https://tools.ietf.org/html/rfc4511#section-4.8+  [4.9]: https://tools.ietf.org/html/rfc4511#section-4.9+  [4.10]: https://tools.ietf.org/html/rfc4511#section-4.10+  [4.11]: https://tools.ietf.org/html/rfc4511#section-4.11+  [4.12]: https://tools.ietf.org/html/rfc4511#section-4.12+  [4.13]: https://tools.ietf.org/html/rfc4511#section-4.13+  [4.14]: https://tools.ietf.org/html/rfc4511#section-4.14
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ldap-client.cabal view
@@ -0,0 +1,83 @@+name:                ldap-client+version:             0.1.0+synopsis:            Pure Haskell LDAP Client Library+description:+  Pure Haskell LDAP client library implementing (the parts of) RFC 4511.+homepage:            https://supki.github.io/ldap-client+license:             BSD2+license-file:        LICENSE+author:              Matvey Aksenov+maintainer:          matvey.aksenov@gmail.com+copyright:           2015 Matvey Aksenov+category:            Network+build-type:          Simple+cabal-version:       >= 1.10+tested-with:+    GHC == 7.6.3+  , GHC == 7.8.4+  , GHC == 7.10.1+extra-source-files:+  README.markdown++source-repository head+  type:     git+  location: git@github.com:supki/ldap-client+  tag:      0.1.0++library+  default-language:+    Haskell2010+  hs-source-dirs:+    src+  exposed-modules:+    Ldap.Asn1.FromAsn1+    Ldap.Asn1.ToAsn1+    Ldap.Asn1.Type+    Ldap.Client+    Ldap.Client.Add+    Ldap.Client.Bind+    Ldap.Client.Compare+    Ldap.Client.Delete+    Ldap.Client.Extended+    Ldap.Client.Internal+    Ldap.Client.Modify+    Ldap.Client.Search+  build-depends:+      asn1-encoding >= 0.9+    , asn1-types    >= 0.3+    , async+    , base          >= 4.6 && < 5+    , bytestring+    , connection    >= 0.2+    , containers+    , network       >= 2.6+    , semigroups    >= 0.16+    , stm+    , text++test-suite spec+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test+  main-is:+    Spec.hs+  other-modules:+    Ldap.ClientSpec+    Ldap.Client.AddSpec+    Ldap.Client.BindSpec+    Ldap.Client.CompareSpec+    Ldap.Client.DeleteSpec+    Ldap.Client.ExtendedSpec+    Ldap.Client.ModifySpec+    Ldap.Client.SearchSpec+    SpecHelper+  build-depends:+      base          >= 4.6 && < 5+    , bytestring+    , hspec+    , ldap-client+    , process+    , semigroups
+ src/Ldap/Asn1/FromAsn1.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE CPP #-}+-- | This module contains convertions from ASN.1 to LDAP types.+module Ldap.Asn1.FromAsn1+  ( parseAsn1+  , FromAsn1+  ) where++#if __GLASGOW_HASKELL__ >= 710+import           Control.Applicative (Alternative(..), liftA2, optional)+#else+import           Control.Applicative (Applicative(..), Alternative(..), liftA2, optional)+#endif+import           Control.Monad (MonadPlus(..), (>=>), guard)+import           Data.ASN1.Types (ASN1)+import qualified Data.ASN1.Types as Asn1+import           Data.Foldable (asum)+import           Data.List.NonEmpty (some1)+import qualified Data.Text.Encoding as Text++import           Ldap.Asn1.Type++{-# ANN module "HLint: ignore Use const" #-}+{-# ANN module "HLint: ignore Avoid lambda" #-}+++-- | Convert a part of ASN.1 stream to a LDAP type returning the remainder of the stream.+parseAsn1 :: FromAsn1 a => [ASN1] -> Maybe ([ASN1], a)+parseAsn1 = parse fromAsn1++-- | ASN.1 stream parsers.+--+-- When it's relevant, instances include the part of RFC describing the encoding.+class FromAsn1 a where+  fromAsn1 :: Parser [ASN1] a++{- |+@+LDAPMessage ::= SEQUENCE {+     messageID       MessageID,+     protocolOp      CHOICE {+          bindRequest           BindRequest,+          bindResponse          BindResponse,+          unbindRequest         UnbindRequest,+          searchRequest         SearchRequest,+          searchResEntry        SearchResultEntry,+          searchResDone         SearchResultDone,+          searchResRef          SearchResultReference,+          addRequest            AddRequest,+          addResponse           AddResponse,+          ... },+     controls       [0] Controls OPTIONAL }+@+-}+instance FromAsn1 op =>  FromAsn1 (LdapMessage op) where+  fromAsn1 = do+    Asn1.Start Asn1.Sequence <- next+    i  <- fromAsn1+    op <- fromAsn1+    Asn1.End Asn1.Sequence <- next+    return (LdapMessage i op Nothing)++{- |+@+MessageID ::= INTEGER (0 ..  maxInt)+@+-}+instance FromAsn1 Id where+  fromAsn1 = do+    Asn1.IntVal i <- next+    return (Id (fromIntegral i))++{- |+@+LDAPString ::= OCTET STRING -- UTF-8 encoded,+@+-}+instance FromAsn1 LdapString where+  fromAsn1 = do+    Asn1.OctetString s <- next+    case Text.decodeUtf8' s of+      Right t -> return (LdapString t)+      Left  _ -> empty++{- |+@+LDAPOID ::= OCTET STRING -- Constrained to \<numericoid\>+@+-}+instance FromAsn1 LdapOid where+  fromAsn1 = do+    Asn1.OctetString s <- next+    case Text.decodeUtf8' s of+      Right t -> return (LdapOid t)+      Left  _ -> empty++{- |+@+LDAPDN ::= LDAPString+@+-}+instance FromAsn1 LdapDn where+  fromAsn1 = fmap LdapDn fromAsn1++{- |+@+AttributeDescription ::= LDAPString+@+-}+instance FromAsn1 AttributeDescription where+  fromAsn1 = fmap AttributeDescription fromAsn1++{- |+@+AttributeValue ::= OCTET STRING+@+-}+instance FromAsn1 AttributeValue where+  fromAsn1 = do+    Asn1.OctetString s <- next+    return (AttributeValue s)++{- |+@+PartialAttribute ::= SEQUENCE {+     type       AttributeDescription,+     vals       SET OF value AttributeValue }+@+-}+instance FromAsn1 PartialAttribute where+  fromAsn1 = do+    Asn1.Start Asn1.Sequence <- next+    d  <- fromAsn1+    Asn1.Start Asn1.Set <- next+    vs <- many fromAsn1+    Asn1.End Asn1.Set <- next+    Asn1.End Asn1.Sequence <- next+    return (PartialAttribute d vs)++{- |+@+LDAPResult ::= SEQUENCE {+     resultCode         ENUMERATED {+          success                      (0),+          operationsError              (1),+          protocolError                (2),+          timeLimitExceeded            (3),+          sizeLimitExceeded            (4),+          compareFalse                 (5),+          compareTrue                  (6),+          authMethodNotSupported       (7),+          strongerAuthRequired         (8),+          -- 9 reserved --+          referral                     (10),+          adminLimitExceeded           (11),+          unavailableCriticalExtension (12),+          confidentialityRequired      (13),+          saslBindInProgress           (14),+          noSuchAttribute              (16),+          undefinedAttributeType       (17),+          inappropriateMatching        (18),+          constraintViolation          (19),+          attributeOrValueExists       (20),+          invalidAttributeSyntax       (21),+          -- 22-31 unused --+          noSuchObject                 (32),+          aliasProblem                 (33),+          invalidDNSyntax              (34),+          -- 35 reserved for undefined isLeaf --+          aliasDereferencingProblem    (36),+          -- 37-47 unused --+          inappropriateAuthentication  (48),+          invalidCredentials           (49),+          insufficientAccessRights     (50),+          busy                         (51),+          unavailable                  (52),+          unwillingToPerform           (53),+          loopDetect                   (54),+          -- 55-63 unused --+          namingViolation              (64),+          objectClassViolation         (65),+          notAllowedOnNonLeaf          (66),+          notAllowedOnRDN              (67),+          entryAlreadyExists           (68),+          objectClassModsProhibited    (69),+          -- 70 reserved for CLDAP --+          affectsMultipleDSAs          (71),+          -- 72-79 unused --+          other                        (80),+          ...  },+     matchedDN          LDAPDN,+     diagnosticMessage  LDAPString,+     referral           [3] Referral OPTIONAL }+@+-}+instance FromAsn1 LdapResult where+  fromAsn1 = do+    resultCode <- do+      Asn1.Enumerated x <- next+      case x of+        0  -> pure Success+        1  -> pure OperationError+        2  -> pure ProtocolError+        3  -> pure TimeLimitExceeded+        4  -> pure SizeLimitExceeded+        5  -> pure CompareFalse+        6  -> pure CompareTrue+        7  -> pure AuthMethodNotSupported+        8  -> pure StrongerAuthRequired+        10 -> pure Referral+        11 -> pure AdminLimitExceeded+        12 -> pure UnavailableCriticalExtension+        13 -> pure ConfidentialityRequired+        14 -> pure SaslBindInProgress+        16 -> pure NoSuchAttribute+        17 -> pure UndefinedAttributeType+        18 -> pure InappropriateMatching+        19 -> pure ConstraintViolation+        20 -> pure AttributeOrValueExists+        21 -> pure InvalidAttributeSyntax+        32 -> pure NoSuchObject+        33 -> pure AliasProblem+        34 -> pure InvalidDNSyntax+        36 -> pure AliasDereferencingProblem+        48 -> pure InappropriateAuthentication+        49 -> pure InvalidCredentials+        50 -> pure InsufficientAccessRights+        51 -> pure Busy+        52 -> pure Unavailable+        53 -> pure UnwillingToPerform+        54 -> pure LoopDetect+        64 -> pure NamingViolation+        65 -> pure ObjectClassViolation+        66 -> pure NotAllowedOnNonLeaf+        67 -> pure NotAllowedOnRDN+        68 -> pure EntryAlreadyExists+        69 -> pure ObjectClassModsProhibited+        71 -> pure AffectsMultipleDSAs+        80 -> pure Other+        _  -> empty+    matchedDn  <- fromAsn1+    diagnosticMessage+               <- fromAsn1+    referral   <- optional $ do+      Asn1.Start (Asn1.Container Asn1.Context 0) <- next+      x <- fromAsn1+      Asn1.End (Asn1.Container Asn1.Context 0) <- next+      return x+    return (LdapResult resultCode matchedDn diagnosticMessage referral)++{- |+@+Referral ::= SEQUENCE SIZE (1..MAX) OF uri URI+@+-}+instance FromAsn1 ReferralUris where+  fromAsn1 = do+    Asn1.Start Asn1.Sequence <- next+    xs <- some1 fromAsn1+    Asn1.End Asn1.Sequence <- next+    return (ReferralUris xs)++{- |+@+URI ::= LDAPString+@+-}+instance FromAsn1 Uri where+  fromAsn1 = fmap Uri fromAsn1++{- |+@+BindResponse ::= [APPLICATION 1] SEQUENCE {+     COMPONENTS OF LDAPResult,+     serverSaslCreds    [7] OCTET STRING OPTIONAL }+@++@+SearchResultEntry ::= [APPLICATION 4] SEQUENCE {+     objectName      LDAPDN,+     attributes      PartialAttributeList }+@++@+SearchResultReference ::= [APPLICATION 19] SEQUENCE+                          SIZE (1..MAX) OF uri URI+@++@+SearchResultDone ::= [APPLICATION 5] LDAPResult+@++@+ModifyResponse ::= [APPLICATION 7] LDAPResult+@++@+AddResponse ::= [APPLICATION 9] LDAPResult+@++@+DelResponse ::= [APPLICATION 11] LDAPResult+@++@+ModifyDNResponse ::= [APPLICATION 13] LDAPResult+@++@+CompareResponse ::= [APPLICATION 15] LDAPResult+@++@+ExtendedResponse ::= [APPLICATION 24] SEQUENCE {+     COMPONENTS OF LDAPResult,+     responseName     [10] LDAPOID OPTIONAL,+     responseValue    [11] OCTET STRING OPTIONAL }+@++@+IntermediateResponse ::= [APPLICATION 25] SEQUENCE {+     responseName     [0] LDAPOID OPTIONAL,+     responseValue    [1] OCTET STRING OPTIONAL }+@+-}+instance FromAsn1 ProtocolServerOp where+  fromAsn1 = asum+    [ fmap (\res -> BindResponse res Nothing) (app 1)+    , fmap (uncurry SearchResultEntry) (app 4)+    , fmap SearchResultDone (app 5)+    , fmap ModifyResponse (app 7)+    , fmap AddResponse (app 9)+    , fmap DeleteResponse (app 11)+    , fmap ModifyDnResponse (app 13)+    , fmap CompareResponse (app 15)++    , do+      Asn1.Start (Asn1.Container Asn1.Application 19) <- next+      uris <- some1 fromAsn1+      Asn1.End (Asn1.Container Asn1.Application 19) <- next+      return (SearchResultReference uris)++    , do+      Asn1.Start (Asn1.Container Asn1.Application 24) <- next+      res <- fromAsn1+      utf8Name <- optional $ do+        Asn1.Other Asn1.Context 10 s <- next+        return s+      name <- maybe (return Nothing) (\n -> case Text.decodeUtf8' n of+        Left  _    -> empty+        Right name -> return (Just name)) utf8Name+      value <- optional $ do+        Asn1.Other Asn1.Context 11 s <- next+        return s+      Asn1.End (Asn1.Container Asn1.Application 24) <- next+      return (ExtendedResponse res (fmap LdapOid name) value)++    , do+      Asn1.Start (Asn1.Container Asn1.Application 25) <- next+      name  <- optional fromAsn1+      value <- optional $ do+        Asn1.OctetString s <- next+        return s+      Asn1.End (Asn1.Container Asn1.Application 25) <- next+      return (IntermediateResponse name value)+    ]+   where+    app l = do+      Asn1.Start (Asn1.Container Asn1.Application x) <- next+      guard (x == l)+      res <- fromAsn1+      Asn1.End (Asn1.Container Asn1.Application y) <- next+      guard (y == l)+      return res++{- |+@+PartialAttributeList ::= SEQUENCE OF partialAttribute PartialAttribute+@+-}+instance FromAsn1 PartialAttributeList where+  fromAsn1 = do+    Asn1.Start Asn1.Sequence <- next+    xs <- many fromAsn1+    Asn1.End Asn1.Sequence <- next+    return (PartialAttributeList xs)++instance (FromAsn1 a, FromAsn1 b) => FromAsn1 (a, b) where+  fromAsn1 = liftA2 (,) fromAsn1 fromAsn1+++newtype Parser s a = Parser { unParser :: s -> Maybe (s, a) }++instance Functor (Parser s) where+  fmap f (Parser g) = Parser (fmap (fmap f) . g)++instance Applicative (Parser s) where+  pure x = Parser (\s -> pure (s, x))+  Parser mf <*> Parser mx = Parser $ \s -> do+    (s', f)  <- mf s+    (s'', x) <- mx s'+    pure (s'', f x)++instance Alternative (Parser s) where+  empty = Parser (\_ -> empty)+  Parser ma <|> Parser mb =+    Parser (\s -> ma s <|> mb s)++instance Monad (Parser s) where+  return x = Parser (\s -> return (s, x))+  Parser mx >>= k =+    Parser (mx >=> \(s', x) -> unParser (k x) s')+  fail _ = empty++instance MonadPlus (Parser s) where+  mzero = Parser (\_ -> mzero)+  Parser ma `mplus` Parser mb =+    Parser (\s -> ma s `mplus` mb s)++parse :: Parser s a -> s -> Maybe (s, a)+parse = unParser++next :: Parser [s] s+next = Parser (\s -> case s of [] -> Nothing; x : xs -> Just (xs, x))
+ src/Ldap/Asn1/ToAsn1.hs view
@@ -0,0 +1,429 @@+-- | This module contains convertions from LDAP types to ASN.1.+--+-- Various hacks are employed because "asn1-encoding" only encodes to DER, but+-- LDAP demands BER-encoding.  So, when a definition looks suspiciously different+-- from the spec in the comment, that's why.  I hope all that will be fixed+-- eventually.+module Ldap.Asn1.ToAsn1+  ( ToAsn1(toAsn1)+  ) where++import           Data.ASN1.Types (ASN1, ASN1Class, ASN1Tag, ASN1ConstructionType)+import qualified Data.ASN1.Types as Asn1+import           Data.ByteString (ByteString)+import           Data.Foldable (fold, foldMap)+import           Data.List.NonEmpty (NonEmpty)+import           Data.Maybe (maybe)+import           Data.Monoid (Endo(Endo), (<>), mempty)+import qualified Data.Text.Encoding as Text+import           Prelude (Integer, (.), fromIntegral)++import           Ldap.Asn1.Type+++-- | Convert a LDAP type to ASN.1.+--+-- When it's relevant, instances include the part of RFC describing the encoding.+class ToAsn1 a where+  toAsn1 :: a -> Endo [ASN1]++{- |+@+LDAPMessage ::= SEQUENCE {+     messageID       MessageID,+     protocolOp      CHOICE {+          bindRequest           BindRequest,+          bindResponse          BindResponse,+          unbindRequest         UnbindRequest,+          searchRequest         SearchRequest,+          searchResEntry        SearchResultEntry,+          searchResDone         SearchResultDone,+          searchResRef          SearchResultReference,+          addRequest            AddRequest,+          addResponse           AddResponse,+          ... },+     controls       [0] Controls OPTIONAL }+@+-}+instance ToAsn1 op => ToAsn1 (LdapMessage op) where+  toAsn1 (LdapMessage i op mc) =+    sequence (toAsn1 i <> toAsn1 op <> maybe mempty (context 0 . toAsn1) mc)++{- |+@+MessageID ::= INTEGER (0 ..  maxInt)+@+-}+instance ToAsn1 Id where+  toAsn1 (Id i) = single (Asn1.IntVal (fromIntegral i))++{- |+@+LDAPString ::= OCTET STRING -- UTF-8 encoded+@+-}+instance ToAsn1 LdapString where+  toAsn1 (LdapString s) = single (Asn1.OctetString (Text.encodeUtf8 s))++{- |+@+LDAPOID ::= OCTET STRING -- Constrained to \<numericoid\>+@+-}+instance ToAsn1 LdapOid where+  toAsn1 (LdapOid s) = single (Asn1.OctetString (Text.encodeUtf8 s))++{- |+@+LDAPDN ::= LDAPString -- Constrained to \<distinguishedName\>+@+-}+instance ToAsn1 LdapDn where+  toAsn1 (LdapDn s) = toAsn1 s++{- |+@+RelativeLDAPDN ::= LDAPString -- Constrained to \<name-component\>+@+-}+instance ToAsn1 RelativeLdapDn where+  toAsn1 (RelativeLdapDn s) = toAsn1 s++{- |+@+AttributeDescription ::= LDAPString+@+-}+instance ToAsn1 AttributeDescription where+  toAsn1 (AttributeDescription s) = toAsn1 s++{- |+@+AttributeValue ::= OCTET STRING+@+-}+instance ToAsn1 AttributeValue where+  toAsn1 (AttributeValue s) = single (Asn1.OctetString s)++{- |+@+AttributeValueAssertion ::= SEQUENCE {+     attributeDesc   AttributeDescription,+     assertionValue  AssertionValue }+@+-}+instance ToAsn1 AttributeValueAssertion where+  toAsn1 (AttributeValueAssertion d v) = toAsn1 d <> toAsn1 v++{- |+@+AssertionValue ::= OCTET STRING+@+-}+instance ToAsn1 AssertionValue where+  toAsn1 (AssertionValue s) = single (Asn1.OctetString s)+++{- |+@+PartialAttribute ::= SEQUENCE {+     type       AttributeDescription,+     vals       SET OF value AttributeValue }+@+-}+instance ToAsn1 PartialAttribute where+  toAsn1 (PartialAttribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs))++{- |+@+Attribute ::= PartialAttribute(WITH COMPONENTS {+     ...,+     vals (SIZE(1..MAX))})+@+-}+instance ToAsn1 Attribute where+  toAsn1 (Attribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs))++{- |+@+MatchingRuleId ::= LDAPString+@+-}+instance ToAsn1 MatchingRuleId where+  toAsn1 (MatchingRuleId s) = toAsn1 s++{- |+@+Controls ::= SEQUENCE OF control Control+@+-}+instance ToAsn1 Controls where+  toAsn1 (Controls cs) = sequence (toAsn1 cs)++{- |+@+Control ::= SEQUENCE {+     controlType             LDAPOID,+     criticality             BOOLEAN DEFAULT FALSE,+     controlValue            OCTET STRING OPTIONAL }+@+-}+instance ToAsn1 Control where+  toAsn1 (Control t c v) =+    sequence (fold+      [ toAsn1 t+      , single (Asn1.Boolean c)+      , maybe mempty (single . Asn1.OctetString) v+      ])++{- |+@+BindRequest ::= [APPLICATION 0] SEQUENCE {+     version                 INTEGER (1 ..  127),+     name                    LDAPDN,+     authentication          AuthenticationChoice }+@++@+UnbindRequest ::= [APPLICATION 2] NULL+@++@+SearchRequest ::= [APPLICATION 3] SEQUENCE {+     baseObject      LDAPDN,+     scope           ENUMERATED {+          baseObject              (0),+          singleLevel             (1),+          wholeSubtree            (2),+          ...  },+     derefAliases    ENUMERATED {+          neverDerefAliases       (0),+          derefInSearching        (1),+          derefFindingBaseObj     (2),+          derefAlways             (3) },+     sizeLimit       INTEGER (0 ..  maxInt),+     timeLimit       INTEGER (0 ..  maxInt),+     typesOnly       BOOLEAN,+     filter          Filter,+     attributes      AttributeSelection }+@++@+ModifyRequest ::= [APPLICATION 6] SEQUENCE {+     object          LDAPDN,+     changes         SEQUENCE OF change SEQUENCE {+          operation       ENUMERATED {+               add     (0),+               delete  (1),+               replace (2),+               ...  },+          modification    PartialAttribute } }+@++@+AddRequest ::= [APPLICATION 8] SEQUENCE {+     entry           LDAPDN,+     attributes      AttributeList }+@++@+DelRequest ::= [APPLICATION 10] LDAPDN+@++@+ModifyDNRequest ::= [APPLICATION 12] SEQUENCE {+     entry           LDAPDN,+     newrdn          RelativeLDAPDN,+     deleteoldrdn    BOOLEAN,+     newSuperior     [0] LDAPDN OPTIONAL }+@++@+CompareRequest ::= [APPLICATION 14] SEQUENCE {+     entry           LDAPDN,+     ava             AttributeValueAssertion }+@++@+ExtendedRequest ::= [APPLICATION 23] SEQUENCE {+     requestName      [0] LDAPOID,+     requestValue     [1] OCTET STRING OPTIONAL }+@+-}+instance ToAsn1 ProtocolClientOp where+  toAsn1 (BindRequest v n a) =+    application 0 (single (Asn1.IntVal (fromIntegral v)) <> toAsn1 n <> toAsn1 a)+  toAsn1 UnbindRequest =+    other Asn1.Application 2 mempty+  toAsn1 (SearchRequest bo s da sl tl to f a) =+    application 3 (fold+      [ toAsn1 bo+      , enum s'+      , enum da'+      , single (Asn1.IntVal (fromIntegral sl))+      , single (Asn1.IntVal (fromIntegral tl))+      , single (Asn1.Boolean to)+      , toAsn1 f+      , toAsn1 a+      ])+   where+    s' = case s of+      BaseObject   -> 0+      SingleLevel  -> 1+      WholeSubtree -> 2+    da' = case da of+      NeverDerefAliases      -> 0+      DerefInSearching       -> 1+      DerefFindingBaseObject -> 2+      DerefAlways            -> 3+  toAsn1 (ModifyRequest dn xs) =+    application 6 (fold+      [ toAsn1 dn+      , sequence (foldMap (\(op, pa) -> sequence (enum (case op of+          Add     -> 0+          Delete  -> 1+          Replace -> 2) <> toAsn1 pa)) xs)+      ])+  toAsn1 (AddRequest dn as) =+    application 8 (toAsn1 dn <> toAsn1 as)+  toAsn1 (DeleteRequest (LdapDn (LdapString dn))) =+    other Asn1.Application 10 (Text.encodeUtf8 dn)+  toAsn1 (ModifyDnRequest dn rdn del new) =+    application 12 (fold+      [ toAsn1 dn+      , toAsn1 rdn+      , single (Asn1.Boolean del)+      , maybe mempty+              (\(LdapDn (LdapString dn')) -> other Asn1.Context 0 (Text.encodeUtf8 dn'))+              new+      ])+  toAsn1 (CompareRequest dn av) =+    application 14 (toAsn1 dn <> sequence (toAsn1 av))+  toAsn1 (ExtendedRequest (LdapOid oid) mv) =+    application 23 (fold+     [ other Asn1.Context 0 (Text.encodeUtf8 oid)+     , maybe mempty (other Asn1.Context 1) mv+     ])++{- |+@+AuthenticationChoice ::= CHOICE {+     simple                  [0] OCTET STRING,+     ...  }+@+-}+instance ToAsn1 AuthenticationChoice where+  toAsn1 (Simple s) = other Asn1.Context 0 s++{- |+@+AttributeSelection ::= SEQUENCE OF selector LDAPString+@+-}+instance ToAsn1 AttributeSelection where+  toAsn1 (AttributeSelection as) = sequence (toAsn1 as)++{- |+@+Filter ::= CHOICE {+     and             [0] SET SIZE (1..MAX) OF filter Filter,+     or              [1] SET SIZE (1..MAX) OF filter Filter,+     not             [2] Filter,+     equalityMatch   [3] AttributeValueAssertion,+     substrings      [4] SubstringFilter,+     greaterOrEqual  [5] AttributeValueAssertion,+     lessOrEqual     [6] AttributeValueAssertion,+     present         [7] AttributeDescription,+     approxMatch     [8] AttributeValueAssertion,+     extensibleMatch [9] MatchingRuleAssertion,+     ...  }+@+-}+instance ToAsn1 Filter where+  toAsn1 f = case f of+    And xs            -> context 0 (toAsn1 xs)+    Or xs             -> context 1 (toAsn1 xs)+    Not x             -> context 2 (toAsn1 x)+    EqualityMatch x   -> context 3 (toAsn1 x)+    Substrings x      -> context 4 (toAsn1 x)+    GreaterOrEqual x  -> context 5 (toAsn1 x)+    LessOrEqual x     -> context 6 (toAsn1 x)+    Present (AttributeDescription (LdapString x))+                      -> other Asn1.Context 7 (Text.encodeUtf8 x)+    ApproxMatch x     -> context 8 (toAsn1 x)+    ExtensibleMatch x -> context 9 (toAsn1 x)++{- |+@+SubstringFilter ::= SEQUENCE {+     type           AttributeDescription,+     substrings     SEQUENCE SIZE (1..MAX) OF substring CHOICE {+          initial [0] AssertionValue,  -- can occur at most once+          any     [1] AssertionValue,+          final   [2] AssertionValue } -- can occur at most once+     }+@+-}+instance ToAsn1 SubstringFilter where+  toAsn1 (SubstringFilter ad ss) =+    toAsn1 ad <> sequence (foldMap (\s -> case s of+      Initial (AssertionValue v) -> other Asn1.Context 0 v+      Any (AssertionValue v)     -> other Asn1.Context 1 v+      Final (AssertionValue v)   -> other Asn1.Context 2 v) ss)++{- |+@+MatchingRuleAssertion ::= SEQUENCE {+     matchingRule    [1] MatchingRuleId OPTIONAL,+     type            [2] AttributeDescription OPTIONAL,+     matchValue      [3] AssertionValue,+     dnAttributes    [4] BOOLEAN DEFAULT FALSE }+@+-}+instance ToAsn1 MatchingRuleAssertion where+  toAsn1 (MatchingRuleAssertion mmr mad (AssertionValue av) _) = fold+    [ maybe mempty f mmr+    , maybe mempty g mad+    , other Asn1.Context 3 av+    ]+   where+    f (MatchingRuleId (LdapString x)) = other Asn1.Context 1 (Text.encodeUtf8 x)+    g (AttributeDescription (LdapString x)) = other Asn1.Context 2 (Text.encodeUtf8 x)++{- |+@+AttributeList ::= SEQUENCE OF attribute Attribute+@+-}+instance ToAsn1 AttributeList where+  toAsn1 (AttributeList xs) = sequence (toAsn1 xs)++instance ToAsn1 a => ToAsn1 [a] where+  toAsn1 = foldMap toAsn1++instance ToAsn1 a => ToAsn1 (NonEmpty a) where+  toAsn1 = foldMap toAsn1++sequence :: Endo [ASN1] -> Endo [ASN1]+sequence = construction Asn1.Sequence++set :: Endo [ASN1] -> Endo [ASN1]+set = construction Asn1.Set++application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]+application = construction . Asn1.Container Asn1.Application++context :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]+context = construction . Asn1.Container Asn1.Context++construction :: ASN1ConstructionType -> Endo [ASN1] -> Endo [ASN1]+construction t x = single (Asn1.Start t) <> x <> single (Asn1.End t)++other :: ASN1Class -> ASN1Tag -> ByteString -> Endo [ASN1]+other c t = single . Asn1.Other c t++enum :: Integer -> Endo [ASN1]+enum = single . Asn1.Enumerated++single :: a -> Endo [a]+single x = Endo (x :)
+ src/Ldap/Asn1/Type.hs view
@@ -0,0 +1,221 @@+module Ldap.Asn1.Type where++import Data.ByteString (ByteString)+import Data.Int (Int8, Int32)+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+++-- | Message envelope. (Section 4.1.1.)+data LdapMessage op = LdapMessage+  { ldapMessageId       :: !Id+  , ldapMessageOp       :: !op+  , ldapMessageControls :: !(Maybe Controls)+  } deriving (Show, Eq)++-- | Every message being processed has a unique non-zero integer ID. (Section 4.1.1.1.)+newtype Id = Id { unId :: Int32 }+    deriving (Show, Eq, Ord)++-- | Client requests.  The RFC doesn't make a difference between 'ProtocolClientOp'+-- and 'ProtocolServerOp' but it's useful to distinguish between them in Haskell.+data ProtocolClientOp =+    BindRequest !Int8 !LdapDn !AuthenticationChoice+  | UnbindRequest+  | SearchRequest !LdapDn !Scope !DerefAliases !Int32 !Int32 !Bool !Filter !AttributeSelection+  | ModifyRequest !LdapDn ![(Operation, PartialAttribute)]+  | AddRequest !LdapDn !AttributeList+  | DeleteRequest !LdapDn+  | ModifyDnRequest !LdapDn !RelativeLdapDn !Bool !(Maybe LdapDn)+  | CompareRequest !LdapDn !AttributeValueAssertion+  | ExtendedRequest !LdapOid !(Maybe ByteString)+    deriving (Show, Eq)++-- | Server responses.  The RFC doesn't make a difference between 'ProtocolClientOp'+-- and 'ProtocolServerOp' but it's useful to distinguish between them in Haskell.+data ProtocolServerOp =+    BindResponse !LdapResult !(Maybe ByteString)+  | SearchResultEntry !LdapDn !PartialAttributeList+  | SearchResultReference !(NonEmpty Uri)+  | SearchResultDone !(LdapResult)+  | ModifyResponse !LdapResult+  | AddResponse !LdapResult+  | DeleteResponse !LdapResult+  | ModifyDnResponse !LdapResult+  | CompareResponse !LdapResult+  | ExtendedResponse !LdapResult !(Maybe LdapOid) !(Maybe ByteString)+  | IntermediateResponse !(Maybe LdapOid) !(Maybe ByteString)+    deriving (Show, Eq)++-- | Not really a choice until SASL is supported.+newtype AuthenticationChoice = Simple ByteString+    deriving (Show, Eq)++-- | Scope of the search to be performed.+data Scope =+    BaseObject   -- ^ Constrained to the entry named by baseObject.+  | SingleLevel  -- ^ Constrained to the immediate subordinates of the entry named by baseObject.+  | WholeSubtree -- ^ Constrained to the entry named by baseObject and to all its subordinates.+    deriving (Show, Eq)++-- | An indicator as to whether or not alias entries (as defined in+-- [RFC4512]) are to be dereferenced during stages of the Search+-- operation.+data DerefAliases =+    NeverDerefAliases      -- ^ Do not dereference aliases in searching or in locating the base object of the Search.+  | DerefInSearching       -- ^ While searching subordinates of the base object, dereference any alias within the search scope.+  | DerefFindingBaseObject -- ^ Dereference aliases in locating the base object of the Search.+  | DerefAlways            -- ^ Dereference aliases both in searching and in locating the base object of the Search.+    deriving (Show, Eq)++-- | Conditions that must be fulfilled in order for the Search to match a given entry.+data Filter =+    And !(NonEmpty Filter)                 -- ^ All filters evaluate to @TRUE@+  | Or !(NonEmpty Filter)                  -- ^ Any filter evaluates to @TRUE@+  | Not Filter                             -- ^ Filter evaluates to @FALSE@+  | EqualityMatch AttributeValueAssertion  -- ^ @EQUALITY@ rule returns @TRUE@+  | Substrings SubstringFilter             -- ^ @SUBSTR@ rule returns @TRUE@+  | GreaterOrEqual AttributeValueAssertion -- ^ @ORDERING@ rule returns @FALSE@+  | LessOrEqual AttributeValueAssertion    -- ^ @ORDERING@ or @EQUALITY@ rule returns @TRUE@+  | Present AttributeDescription           -- ^ Attribute is present in the entry+  | ApproxMatch AttributeValueAssertion    -- ^ Same as 'EqualityMatch' for most servers+  | ExtensibleMatch MatchingRuleAssertion+    deriving (Show, Eq)++data SubstringFilter = SubstringFilter !AttributeDescription !(NonEmpty Substring)+    deriving (Show, Eq)++data Substring =+    Initial !AssertionValue+  | Any !AssertionValue+  | Final !AssertionValue+    deriving (Show, Eq)++data MatchingRuleAssertion = MatchingRuleAssertion !(Maybe MatchingRuleId) !(Maybe AttributeDescription) !AssertionValue !Bool+    deriving (Show, Eq)++-- | Matching rules are defined in Section 4.1.3 of [RFC4512].  A matching+-- rule is identified in the protocol by the printable representation of+-- either its <numericoid> or one of its short name descriptors+-- [RFC4512], e.g., 'caseIgnoreMatch' or '2.5.13.2'. (Section 4.1.8.)+newtype MatchingRuleId = MatchingRuleId LdapString+    deriving (Show, Eq)++newtype AttributeSelection = AttributeSelection [LdapString]+    deriving (Show, Eq)++newtype AttributeList = AttributeList [Attribute]+    deriving (Show, Eq)++newtype PartialAttributeList = PartialAttributeList [PartialAttribute]+    deriving (Show, Eq)++newtype Controls = Controls [Control]+    deriving (Show, Eq)++data Control = Control !LdapOid !Bool !(Maybe ByteString)+    deriving (Show, Eq)++data LdapResult = LdapResult !ResultCode !LdapDn !LdapString !(Maybe ReferralUris)+    deriving (Show, Eq)++-- | LDAP operation's result.+data ResultCode =+    Success+  | OperationError+  | ProtocolError+  | TimeLimitExceeded+  | SizeLimitExceeded+  | CompareFalse+  | CompareTrue+  | AuthMethodNotSupported+  | StrongerAuthRequired+  | Referral+  | AdminLimitExceeded+  | UnavailableCriticalExtension+  | ConfidentialityRequired+  | SaslBindInProgress+  | NoSuchAttribute+  | UndefinedAttributeType+  | InappropriateMatching+  | ConstraintViolation+  | AttributeOrValueExists+  | InvalidAttributeSyntax+  | NoSuchObject+  | AliasProblem+  | InvalidDNSyntax+  | AliasDereferencingProblem+  | InappropriateAuthentication+  | InvalidCredentials+  | InsufficientAccessRights+  | Busy+  | Unavailable+  | UnwillingToPerform+  | LoopDetect+  | NamingViolation+  | ObjectClassViolation+  | NotAllowedOnNonLeaf+  | NotAllowedOnRDN+  | EntryAlreadyExists+  | ObjectClassModsProhibited+  | AffectsMultipleDSAs+  | Other+    deriving (Show, Eq)++newtype AttributeDescription = AttributeDescription LdapString+    deriving (Show, Eq)++newtype AttributeValue = AttributeValue ByteString+    deriving (Show, Eq)++data AttributeValueAssertion = AttributeValueAssertion !AttributeDescription !AssertionValue+    deriving (Show, Eq)++newtype AssertionValue = AssertionValue ByteString+    deriving (Show, Eq)++data Attribute = Attribute !AttributeDescription !(NonEmpty AttributeValue)+    deriving (Show, Eq)++data PartialAttribute = PartialAttribute !AttributeDescription ![AttributeValue]+    deriving (Show, Eq)++++-- | An LDAPDN is defined to be the representation of a Distinguished Name+-- (DN) after encoding according to the specification in [RFC4514].+newtype LdapDn = LdapDn LdapString+    deriving (Show, Eq)++-- | A RelativeLDAPDN is defined to be the representation of a Relative+-- Distinguished Name (RDN) after encoding according to the+-- specification in [RFC4514].+newtype RelativeLdapDn = RelativeLdapDn LdapString+    deriving (Show, Eq)++newtype ReferralUris = ReferralUris (NonEmpty Uri)+    deriving (Show, Eq)++newtype Uri = Uri LdapString+    deriving (Show, Eq)++data Operation =+    Add+  | Delete+  | Replace+    deriving (Show, Eq)++-- | The LDAPString is a notational convenience to indicate that, although+-- strings of LDAPString type encode as ASN.1 OCTET STRING types, the+-- [ISO10646] character set (a superset of [Unicode]) is used, encoded+-- following the UTF-8 [RFC3629] algorithm. (Section 4.1.2.)+newtype LdapString = LdapString Text+    deriving (Show, Eq)++-- | The LDAPOID is a notational convenience to indicate that the+-- permitted value of this string is a (UTF-8 encoded) dotted-decimal+-- representation of an OBJECT IDENTIFIER.  Although an LDAPOID is+-- encoded as an OCTET STRING, values are limited to the definition of+-- \<numericoid\> given in Section 1.4 of [RFC4512].+newtype LdapOid = LdapOid Text+    deriving (Show, Eq)
+ src/Ldap/Client.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NamedFieldPuns #-}+-- | This module is intended to be imported qualified+--+-- @+-- import qualified Ldap.Client as Ldap+-- @+module Ldap.Client+  ( with+  , Host(..)+  , PortNumber+  , Ldap+  , LdapError(..)+  , ResponseError(..)+  , Type.ResultCode(..)+    -- * Bind+  , Password(..)+  , bind+    -- * Search+  , search+  , SearchEntry(..)+    -- ** Search modifiers+  , Search+  , Mod+  , Type.Scope(..)+  , scope+  , size+  , time+  , typesOnly+  , Type.DerefAliases(..)+  , derefAliases+  , Filter(..)+    -- * Modify+  , modify+  , Operation(..)+    -- * Add+  , add+    -- * Delete+  , delete+    -- * ModifyDn+  , RelativeDn(..)+  , modifyDn+    -- * Compare+  , compare+    -- * Extended+  , Oid(..)+  , extended+    -- * Miscellanous+  , Dn(..)+  , Attr(..)+  , AttrValue+  , AttrList+    -- * Re-exports+  , NonEmpty+  ) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative ((<$>))+#endif+import qualified Control.Concurrent.Async as Async+import           Control.Concurrent.STM (atomically, throwSTM)+import           Control.Concurrent.STM.TMVar (putTMVar)+import           Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue)+import           Control.Exception (Exception, Handler(..), bracket, throwIO, catch, catches)+import           Control.Monad (forever)+import qualified Data.ASN1.BinaryEncoding as Asn1+import qualified Data.ASN1.Encoding as Asn1+import qualified Data.ASN1.Error as Asn1+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as ByteString.Lazy+import           Data.Foldable (asum)+import           Data.Function (fix)+import           Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.Map.Strict as Map+import           Data.Monoid (Endo(appEndo))+import           Data.String (fromString)+import           Data.Text (Text)+#if __GLASGOW_HASKELL__ < 710+import           Data.Traversable (traverse)+#endif+import           Data.Typeable (Typeable)+import           Network.Connection (Connection)+import qualified Network.Connection as Conn+import           Prelude hiding (compare)+import qualified System.IO.Error as IO++import           Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1))+import           Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1)+import qualified Ldap.Asn1.Type as Type+import           Ldap.Client.Internal+import           Ldap.Client.Bind (Password(..), bind)+import           Ldap.Client.Search+  ( search+  , Search+  , Mod+  , scope+  , size+  , time+  , typesOnly+  , derefAliases+  , Filter(..)+  , SearchEntry(..)+  )+import           Ldap.Client.Modify (Operation(..), modify, RelativeDn(..), modifyDn)+import           Ldap.Client.Add (add)+import           Ldap.Client.Delete (delete)+import           Ldap.Client.Compare (compare)+import           Ldap.Client.Extended (Oid(..), extended)++{-# ANN module "HLint: ignore Use first" #-}+++newLdap :: IO Ldap+newLdap = Ldap+  <$> newTQueueIO++-- | Various failures that can happen when working with LDAP.+data LdapError =+    IOError IOError             -- ^ Network failure.+  | ParseError Asn1.ASN1Error   -- ^ Invalid ASN.1 data received from the server.+  | ResponseError ResponseError -- ^ An LDAP operation failed.+  | DisconnectError Disconnect  -- ^ Notice of Disconnection has been received.+    deriving (Show, Eq)++newtype WrappedIOError = WrappedIOError IOError+    deriving (Show, Eq, Typeable)++instance Exception WrappedIOError++data Disconnect = Disconnect Type.ResultCode Dn Text+    deriving (Show, Eq, Typeable)++instance Exception Disconnect++-- | The entrypoint into LDAP.+--+-- It catches all LDAP-related exceptions.+with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)+with host port f = do+  context <- Conn.initConnectionContext+  bracket (Conn.connectTo context params) Conn.connectionClose (\conn ->+    bracket newLdap unbindAsync (\l -> do+      inq  <- newTQueueIO+      outq <- newTQueueIO+      as   <- traverse Async.async+        [ input inq conn+        , output outq conn+        , dispatch l inq outq+        , f l+        ]+      fmap (Right . snd) (Async.waitAnyCancel as)))+ `catches`+  [ Handler (\(WrappedIOError e) -> return (Left (IOError e)))+  , Handler (return . Left . ParseError)+  , Handler (return . Left . ResponseError)+  ]+ where+  params = Conn.ConnectionParams+    { Conn.connectionHostname =+        case host of+          Plain    h -> h+          Secure   h -> h+          Insecure h -> h+    , Conn.connectionPort = port+    , Conn.connectionUseSecure =+        case host of+          Plain  _ -> Nothing+          Secure _ -> Just Conn.TLSSettingsSimple+            { Conn.settingDisableCertificateValidation = False+            , Conn.settingDisableSession = False+            , Conn.settingUseServerName = False+            }+          Insecure _ -> Just Conn.TLSSettingsSimple+            { Conn.settingDisableCertificateValidation = True+            , Conn.settingDisableSession = False+            , Conn.settingUseServerName = False+            }+    , Conn.connectionUseSocks = Nothing+    }++input :: FromAsn1 a => TQueue a -> Connection -> IO b+input inq conn = wrap . flip fix [] $ \loop chunks -> do+  chunk <- Conn.connectionGet conn 8192+  case ByteString.length chunk of+    0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)+    _ -> do+      let chunks' = chunk : chunks+      case Asn1.decodeASN1 Asn1.DER (ByteString.Lazy.fromChunks (reverse chunks')) of+        Left  Asn1.ParsingPartial+                   -> loop chunks'+        Left  e    -> throwIO e+        Right asn1 -> do+          flip fix asn1 $ \loop' asn1' ->+            case parseAsn1 asn1' of+              Nothing -> return ()+              Just (asn1'', a) -> do+                atomically (writeTQueue inq a)+                loop' asn1''+          loop []++output :: ToAsn1 a => TQueue a -> Connection -> IO b+output out conn = wrap . forever $ do+  msg <- atomically (readTQueue out)+  Conn.connectionPut conn (encode (toAsn1 msg))+ where+  encode x = Asn1.encodeASN1' Asn1.DER (appEndo x [])++dispatch+  :: Ldap+  -> TQueue (Type.LdapMessage Type.ProtocolServerOp)+  -> TQueue (Type.LdapMessage Request)+  -> IO a+dispatch Ldap { client } inq outq =+  flip fix (Map.empty, 1) $ \loop (!req, !counter) ->+    loop =<< atomically (asum+      [ do New new var <- readTQueue client+           writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing)+           return (Map.insert (Type.Id counter) ([], var) req, counter + 1)+      , do Type.LdapMessage mid op _+               <- readTQueue inq+           res <- case op of+             Type.BindResponse {}          -> done mid op req+             Type.SearchResultEntry {}     -> saveUp mid op req+             Type.SearchResultReference {} -> return req+             Type.SearchResultDone {}      -> done mid op req+             Type.ModifyResponse {}        -> done mid op req+             Type.AddResponse {}           -> done mid op req+             Type.DeleteResponse {}        -> done mid op req+             Type.ModifyDnResponse {}      -> done mid op req+             Type.CompareResponse {}       -> done mid op req+             Type.ExtendedResponse {}      -> probablyDisconnect mid op req+             Type.IntermediateResponse {}  -> saveUp mid op req+           return (res, counter)+      ])+ where+  saveUp mid op res =+    return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)++  done mid op req =+    case Map.lookup mid req of+      Nothing -> return req+      Just (stack, var) -> do+        putTMVar var (op :| stack)+        return (Map.delete mid req)++  probablyDisconnect (Type.Id 0)+                     (Type.ExtendedResponse+                       (Type.LdapResult code+                                        (Type.LdapDn (Type.LdapString dn))+                                        (Type.LdapString reason)+                                        _)+                       moid _)+                     req =+    case moid of+      Just (Type.LdapOid oid)+        | oid == noticeOfDisconnection -> throwSTM (Disconnect code (Dn dn) reason)+      _ -> return req+  probablyDisconnect mid op req = done mid op req++  noticeOfDisconnection :: Text+  noticeOfDisconnection = fromString "1.3.6.1.4.1.1466.20036"++wrap :: IO a -> IO a+wrap m = m `catch` (throwIO . WrappedIOError)
+ src/Ldap/Client/Add.hs view
@@ -0,0 +1,69 @@+-- | <https://tools.ietf.org/html/rfc4511#section-4.7 Add> operation.+--+-- This operation comes in four flavours:+--+--   * synchronous, exception throwing ('add')+--+--   * synchronous, returning 'Either' 'ResponseError' @()@ ('addEither')+--+--   * asynchronous, 'IO' based ('addAsync')+--+--   * asynchronous, 'STM' based ('addAsyncSTM')+--+-- Of those, the first one ('add') is probably the most useful for the typical usecase.+module Ldap.Client.Add+  ( add+  , addEither+  , addAsync+  , addAsyncSTM+  , Async+  , wait+  , waitSTM+  ) where++import           Control.Monad.STM (STM, atomically)+import           Data.List.NonEmpty (NonEmpty((:|)))++import qualified Ldap.Asn1.Type as Type+import           Ldap.Client.Internal+++-- | Perform the Add operation synchronously. Raises 'ResponseError' on failures.+add :: Ldap -> Dn -> AttrList NonEmpty -> IO ()+add l dn as =+  raise =<< addEither l dn as++-- | Perform the Add operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+addEither :: Ldap -> Dn -> AttrList NonEmpty -> IO (Either ResponseError ())+addEither l dn as =+  wait =<< addAsync l dn as++-- | Perform the Add operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+addAsync :: Ldap -> Dn -> AttrList NonEmpty -> IO (Async ())+addAsync l dn as =+  atomically (addAsyncSTM l dn as)++-- | Perform the Add operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+addAsyncSTM :: Ldap -> Dn -> AttrList NonEmpty -> STM (Async ())+addAsyncSTM l dn as =+  let req = addRequest dn as in sendRequest l (addResult req) req++addRequest :: Dn -> AttrList NonEmpty -> Request+addRequest (Dn dn) as =+  Type.AddRequest (Type.LdapDn (Type.LdapString dn))+                  (Type.AttributeList (map f as))+ where+  f (Attr x, xs) = Type.Attribute (Type.AttributeDescription (Type.LdapString x))+                                  (fmap Type.AttributeValue xs)++addResult :: Request -> Response -> Either ResponseError ()+addResult req (Type.AddResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))+                                                      (Type.LdapString msg) _) :| [])+  | Type.Success <- code = Right ()+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)+addResult req res = Left (ResponseInvalid req res)
+ src/Ldap/Client/Bind.hs view
@@ -0,0 +1,75 @@+-- | <https://tools.ietf.org/html/rfc4511#section-4.2 Bind> operation.+--+-- This operation comes in four flavours:+--+--   * synchronous, exception throwing ('bind')+--+--   * synchronous, returning 'Either' 'ResponseError' @()@ ('bindEither')+--+--   * asynchronous, 'IO' based ('bindAsync')+--+--   * asynchronous, 'STM' based ('bindAsyncSTM')+--+-- Of those, the first one ('bind') is probably the most useful for the typical usecase.+module Ldap.Client.Bind+  ( Password(..)+  , bind+  , bindEither+  , bindAsync+  , bindAsyncSTM+  , Async+  , wait+  , waitSTM+  ) where++import           Control.Monad.STM (STM, atomically)+import           Data.ByteString (ByteString)+import           Data.List.NonEmpty (NonEmpty((:|)))++import qualified Ldap.Asn1.Type as Type+import           Ldap.Client.Internal+++-- | User's password.+newtype Password = Password ByteString+    deriving (Show, Eq)++-- | Perform the Bind operation synchronously. Raises 'ResponseError' on failures.+bind :: Ldap -> Dn -> Password -> IO ()+bind l username password =+  raise =<< bindEither l username password++-- | Perform the Bind operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+bindEither :: Ldap -> Dn -> Password -> IO (Either ResponseError ())+bindEither l username password =+  wait =<< bindAsync l username password++-- | Perform the Bind operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+bindAsync :: Ldap -> Dn -> Password -> IO (Async ())+bindAsync l username password =+  atomically (bindAsyncSTM l username password)++-- | Perform the Bind operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+bindAsyncSTM :: Ldap -> Dn -> Password -> STM (Async ())+bindAsyncSTM l username password =+  let req = bindRequest username password in sendRequest l (bindResult req) req++bindRequest :: Dn -> Password -> Request+bindRequest (Dn username) (Password password) =+  Type.BindRequest ldapVersion+                   (Type.LdapDn (Type.LdapString username))+                   (Type.Simple password)+ where+  ldapVersion = 3++bindResult :: Request -> Response -> Either ResponseError ()+bindResult req (Type.BindResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))+                                                        (Type.LdapString msg) _) _ :| [])+  | Type.Success <- code = Right ()+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)+bindResult req res = Left (ResponseInvalid req res)
+ src/Ldap/Client/Compare.hs view
@@ -0,0 +1,71 @@+-- | <https://tools.ietf.org/html/rfc4511#section-4.10 Compare> operation.+--+-- This operation comes in four flavours:+--+--   * synchronous, exception throwing ('compare')+--+--   * synchronous, returning 'Either' 'ResponseError' @()@ ('compareEither')+--+--   * asynchronous, 'IO' based ('compareAsync')+--+--   * asynchronous, 'STM' based ('compareAsyncSTM')+--+-- Of those, the first one ('compare') is probably the most useful for the+-- typical usecase.+module Ldap.Client.Compare+  ( compare+  , compareEither+  , compareAsync+  , compareAsyncSTM+  , Async+  , wait+  , waitSTM+  ) where++import           Control.Monad.STM (STM, atomically)+import           Data.List.NonEmpty (NonEmpty((:|)))+import           Prelude hiding (compare)++import           Ldap.Client.Internal+import qualified Ldap.Asn1.Type as Type+++-- | Perform the Compare operation synchronously. Raises 'ResponseError' on failures.+compare :: Ldap -> Dn -> Attr -> AttrValue -> IO Bool+compare l dn k v =+  raise =<< compareEither l dn k v++-- | Perform the Compare operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+compareEither :: Ldap -> Dn -> Attr -> AttrValue -> IO (Either ResponseError Bool)+compareEither l dn k v =+  wait =<< compareAsync l dn k v++-- | Perform the Compare operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+compareAsync :: Ldap -> Dn -> Attr -> AttrValue -> IO (Async Bool)+compareAsync l dn k v =+  atomically (compareAsyncSTM l dn k v)++-- | Perform the Compare operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+compareAsyncSTM :: Ldap -> Dn -> Attr -> AttrValue -> STM (Async Bool)+compareAsyncSTM l dn k v =+  let req = compareRequest dn k v in sendRequest l (compareResult req) req++compareRequest :: Dn -> Attr -> AttrValue -> Request+compareRequest (Dn dn) (Attr k) v =+  Type.CompareRequest (Type.LdapDn (Type.LdapString dn))+                      (Type.AttributeValueAssertion+                        (Type.AttributeDescription (Type.LdapString k))+                        (Type.AssertionValue v))++compareResult :: Request -> Response -> Either ResponseError Bool+compareResult req (Type.CompareResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))+                                                              (Type.LdapString msg) _) :| [])+  | Type.CompareTrue  <- code = Right True+  | Type.CompareFalse <- code = Right False+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)+compareResult req res = Left (ResponseInvalid req res)
+ src/Ldap/Client/Delete.hs view
@@ -0,0 +1,65 @@+-- | <https://tools.ietf.org/html/rfc4511#section-4.8 Delete> operation.+--+-- This operation comes in four flavours:+--+--   * synchronous, exception throwing ('delete')+--+--   * synchronous, returning 'Either' 'ResponseError' @()@ ('deleteEither')+--+--   * asynchronous, 'IO' based ('deleteAsync')+--+--   * asynchronous, 'STM' based ('deleteAsyncSTM')+--+-- Of those, the first one ('delete') is probably the most useful for the typical usecase.+module Ldap.Client.Delete+  ( delete+  , deleteEither+  , deleteAsync+  , deleteAsyncSTM+  , Async+  , wait+  , waitSTM+  ) where++import           Control.Concurrent.STM (STM, atomically)+import           Data.List.NonEmpty (NonEmpty((:|)))++import qualified Ldap.Asn1.Type as Type+import           Ldap.Client.Internal+++-- | Perform the Delete operation synchronously. Raises 'ResponseError' on failures.+delete :: Ldap -> Dn -> IO ()+delete l dn =+  raise =<< deleteEither l dn++-- | Perform the Delete operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+deleteEither :: Ldap -> Dn -> IO (Either ResponseError ())+deleteEither l dn =+  wait =<< deleteAsync l dn++-- | Perform the Delete operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+deleteAsync :: Ldap -> Dn -> IO (Async ())+deleteAsync l dn =+  atomically (deleteAsyncSTM l dn)++-- | Perform the Delete operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+deleteAsyncSTM :: Ldap -> Dn -> STM (Async ())+deleteAsyncSTM l dn =+  let req = deleteRequest dn in sendRequest l (deleteResult req) req++deleteRequest :: Dn -> Request+deleteRequest (Dn dn) =+  Type.DeleteRequest (Type.LdapDn (Type.LdapString dn))++deleteResult :: Request -> Response -> Either ResponseError ()+deleteResult req (Type.DeleteResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))+                                                            (Type.LdapString msg) _) :| [])+  | Type.Success <- code = Right ()+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)+deleteResult req res = Left (ResponseInvalid req res)
+ src/Ldap/Client/Extended.hs view
@@ -0,0 +1,103 @@+-- | <https://tools.ietf.org/html/rfc4511#section-4.12 Extended> operation.+--+-- This operation comes in four flavours:+--+--   * synchronous, exception throwing ('extended')+--+--   * synchronous, returning 'Either' 'ResponseError' @()@ ('extendedEither')+--+--   * asynchronous, 'IO' based ('extendedAsync')+--+--   * asynchronous, 'STM' based ('extendedAsyncSTM')+--+-- Of those, the first one ('extended') is probably the most useful for the typical usecase.+module Ldap.Client.Extended+  ( -- * Extended Operation+    Oid(..)+  , extended+  , extendedEither+  , extendedAsync+  , extendedAsyncSTM+    -- ** StartTLS Operation+  , startTls+  , startTlsEither+  , startTlsAsync+  , startTlsAsyncSTM+  , Async+  , wait+  , waitSTM+  ) where++import           Control.Monad ((<=<))+import           Control.Monad.STM (STM, atomically)+import           Data.ByteString (ByteString)+import           Data.List.NonEmpty (NonEmpty((:|)))+import           Data.String (fromString)+import           Data.Text (Text)++import qualified Ldap.Asn1.Type as Type+import           Ldap.Client.Internal+++-- | Globally unique LDAP object identifier.+newtype Oid = Oid Text+    deriving (Show, Eq)++-- | Perform the Extended operation synchronously. Raises 'ResponseError' on failures.+extended :: Ldap -> Oid -> Maybe ByteString -> IO ()+extended l oid mv =+  raise =<< extendedEither l oid mv++-- | Perform the Extended operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+extendedEither :: Ldap -> Oid -> Maybe ByteString -> IO (Either ResponseError ())+extendedEither l oid mv =+  wait =<< extendedAsync l oid mv++-- | Perform the Extended operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+extendedAsync :: Ldap -> Oid -> Maybe ByteString -> IO (Async ())+extendedAsync l oid mv =+  atomically (extendedAsyncSTM l oid mv)++-- | Perform the Extended operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+extendedAsyncSTM :: Ldap -> Oid -> Maybe ByteString -> STM (Async ())+extendedAsyncSTM l oid mv =+  let req = extendedRequest oid mv in sendRequest l (extendedResult req) req++extendedRequest :: Oid -> Maybe ByteString -> Request+extendedRequest (Oid oid) =+  Type.ExtendedRequest (Type.LdapOid oid)++extendedResult :: Request -> Response -> Either ResponseError ()+extendedResult req (Type.ExtendedResponse+                     (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))+                                           (Type.LdapString msg) _) _ _ :| [])+  | Type.Success <- code = Right ()+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)+extendedResult req res = Left (ResponseInvalid req res)+++-- | An example of @Extended Operation@, cf. 'extended'.+startTls :: Ldap -> IO ()+startTls =+  raise <=< startTlsEither++-- | An example of @Extended Operation@, cf. 'extendedEither'.+startTlsEither :: Ldap -> IO (Either ResponseError ())+startTlsEither =+  wait <=< startTlsAsync++-- | An example of @Extended Operation@, cf. 'extendedAsync'.+startTlsAsync :: Ldap -> IO (Async ())+startTlsAsync =+  atomically . startTlsAsyncSTM++-- | An example of @Extended Operation@, cf. 'extendedAsyncSTM'.+startTlsAsyncSTM :: Ldap -> STM (Async ())+startTlsAsyncSTM l =+  extendedAsyncSTM l (Oid (fromString "1.3.6.1.4.1.1466.20037"))+                     Nothing
+ src/Ldap/Client/Internal.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NamedFieldPuns #-}+module Ldap.Client.Internal+  ( Host(..)+  , PortNumber+  , Ldap(..)+  , ClientMessage(..)+  , Type.ResultCode(..)+  , Async+  , AttrList+    -- * Waiting for Request Completion+  , wait+  , waitSTM+    -- * Misc+  , Response+  , ResponseError(..)+  , Request+  , raise+  , sendRequest+  , Dn(..)+  , Attr(..)+  , AttrValue+  , unAttr+    -- * Unbind operation+  , unbindAsync+  , unbindAsyncSTM+  ) where++import           Control.Concurrent.STM (STM, atomically)+import           Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, readTMVar)+import           Control.Concurrent.STM.TQueue (TQueue, writeTQueue)+import           Control.Exception (Exception, throwIO)+import           Control.Monad (void)+import           Data.ByteString (ByteString)+import           Data.List.NonEmpty (NonEmpty)+import           Data.Text (Text)+import           Data.Typeable (Typeable)+import           Network (PortNumber)++import qualified Ldap.Asn1.Type as Type+++-- | LDAP host.+data Host =+    Plain String    -- ^ Plain LDAP. Do not use!+  | Insecure String -- ^ LDAP over TLS without the certificate validity check.+                    --   Only use for testing!+  | Secure String   -- ^ LDAP over TLS. Use!+    deriving (Show, Eq, Ord)++-- | A token. All functions that interact with the Directory require one.+data Ldap = Ldap+  { client  :: TQueue ClientMessage+  } deriving (Eq)++data ClientMessage = New Request (TMVar (NonEmpty Type.ProtocolServerOp))+type Request = Type.ProtocolClientOp+type InMessage = Type.ProtocolServerOp+type Response = NonEmpty InMessage++-- | Asynchronous LDAP operation. Use 'wait' or 'waitSTM' to wait for its completion.+data Async a = Async (STM (Either ResponseError a))++instance Functor Async where+  fmap f (Async stm) = Async (fmap (fmap f) stm)++-- | Unique identifier of an LDAP entry.+newtype Dn = Dn Text+    deriving (Show, Eq)++-- | Response indicates a failed operation.+data ResponseError =+    ResponseInvalid Request Response -- ^ LDAP server did not follow the protocol, so @ldap-client@ couldn't make sense of the response.+  | ResponseErrorCode Request Type.ResultCode Dn Text -- ^ The response contains a result code indicating failure and an error message.+    deriving (Show, Eq, Typeable)++instance Exception ResponseError++-- | Attribute name.+newtype Attr = Attr Text+    deriving (Show, Eq)++-- | Attribute value.+type AttrValue = ByteString++-- | List of attributes and their values. @f@ is the structure these+-- values are in, e.g. 'NonEmpty'.+type AttrList f = [(Attr, f AttrValue)]++-- 'Attr' unwrapper. This is a separate function not to turn 'Attr''s+-- 'Show' instance into complete and utter shit.+unAttr :: Attr -> Text+unAttr (Attr a) = a++-- | Wait for operation completion.+wait :: Async a -> IO (Either ResponseError a)+wait = atomically . waitSTM++-- | Wait for operation completion inside 'STM'.+--+-- Do not use this inside the same 'STM' transaction the operation was+-- requested in! To give LDAP the chance to respond to it that transaction+-- should commit. After that, applying 'waitSTM' to the corresponding 'Async'+-- starts to make sense.+waitSTM :: Async a -> STM (Either ResponseError a)+waitSTM (Async stm) = stm++sendRequest :: Ldap -> (Response -> Either ResponseError a) -> Request -> STM (Async a)+sendRequest l p msg =+  do var <- newEmptyTMVar+     writeRequest l var msg+     return (Async (fmap p (readTMVar var)))++writeRequest :: Ldap -> TMVar Response -> Request -> STM ()+writeRequest Ldap { client } var msg = writeTQueue client (New msg var)++raise :: Exception e => Either e a -> IO a+raise = either throwIO return+++-- | Terminate the connection to the Directory.+--+-- Note that 'unbindAsync' does not return an 'Async',+-- because LDAP server never responds to @UnbindRequest@s, hence+-- a call to 'wait' on a hypothetical 'Async' would have resulted+-- in an exception anyway.+unbindAsync :: Ldap -> IO ()+unbindAsync =+  atomically . unbindAsyncSTM++-- | Terminate the connection to the Directory.+--+-- Note that 'unbindAsyncSTM' does not return an 'Async',+-- because LDAP server never responds to @UnbindRequest@s, hence+-- a call to 'wait' on a hypothetical 'Async' would have resulted+-- in an exception anyway.+unbindAsyncSTM :: Ldap -> STM ()+unbindAsyncSTM l =+  void (sendRequest l die Type.UnbindRequest)+ where+  die = error "Ldap.Client: do not wait for the response to UnbindRequest"
+ src/Ldap/Client/Modify.hs view
@@ -0,0 +1,134 @@+-- | <https://tools.ietf.org/html/rfc4511#section-4.6 Modify> and+-- <https://tools.ietf.org/html/rfc4511#section-4.9 Modify DN> operations.+--+-- These operations come in four flavours:+--+--   * synchronous, exception throwing ('modify' / 'modifyDn')+--+--   * synchronous, returning 'Either' 'ResponseError' @()@+--     ('modifyEither' / 'modifyDnEither')+--+--   * asynchronous, 'IO' based ('modifyAsync' / 'modifyDnAsync')+--+--   * asynchronous, 'STM' based ('modifyAsyncSTM' / 'modifyDnAsyncSTM')+--+-- Of those, the first one ('modify' / 'modifyDn') is probably the most+-- useful for the typical usecase.+module Ldap.Client.Modify+  ( Operation(..)+  , modify+  , modifyEither+  , modifyAsync+  , modifyAsyncSTM+  , RelativeDn(..)+  , modifyDn+  , modifyDnEither+  , modifyDnAsync+  , modifyDnAsyncSTM+  , Async+  , wait+  , waitSTM+  ) where++import           Control.Monad.STM (STM, atomically)+import           Data.List.NonEmpty (NonEmpty((:|)))+import           Data.Text (Text)++import qualified Ldap.Asn1.Type as Type+import           Ldap.Client.Internal+++-- | Type of modification being performed.+data Operation =+    Delete Attr [AttrValue] -- ^ Delete values from the attribute. Deletes the attribute if the list is empty or all current values are listed.+  | Add Attr [AttrValue] -- ^ Add values to the attribute, creating it if necessary.+  | Replace Attr [AttrValue] -- ^ Replace all existing values of the attribute with the new list. Deletes the attribute if the list is empty.+    deriving (Show, Eq)++-- | Perform the Modify operation synchronously. Raises 'ResponseError' on failures.+modify :: Ldap -> Dn -> [Operation] -> IO ()+modify l dn as =+  raise =<< modifyEither l dn as++-- | Perform the Modify operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+modifyEither :: Ldap -> Dn -> [Operation] -> IO (Either ResponseError ())+modifyEither l dn as =+  wait =<< modifyAsync l dn as++-- | Perform the Modify operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+modifyAsync :: Ldap -> Dn -> [Operation] -> IO (Async ())+modifyAsync l dn as =+  atomically (modifyAsyncSTM l dn as)++-- | Perform the Modify operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+modifyAsyncSTM :: Ldap -> Dn -> [Operation] -> STM (Async ())+modifyAsyncSTM l dn xs =+  let req = modifyRequest dn xs in sendRequest l (modifyResult req) req++modifyRequest :: Dn -> [Operation] -> Request+modifyRequest (Dn dn) xs =+  Type.ModifyRequest (Type.LdapDn (Type.LdapString dn)) (map f xs)+ where+  f (Delete (Attr k) vs) =+    (Type.Delete, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k))+                                        (map Type.AttributeValue vs))+  f (Add (Attr k) vs) =+    (Type.Add, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k))+                                     (map Type.AttributeValue vs))+  f (Replace (Attr k) vs) =+    (Type.Replace, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k))+                                         (map Type.AttributeValue vs))++modifyResult :: Request -> Response -> Either ResponseError ()+modifyResult req (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])+  | Type.Success <- code = Right ()+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)+modifyResult req res = Left (ResponseInvalid req res)+++-- | A component of 'Dn'.+newtype RelativeDn = RelativeDn Text+    deriving (Show, Eq)++-- | Perform the Modify DN operation synchronously. Raises 'ResponseError' on failures.+modifyDn :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO ()+modifyDn l dn rdn del new =+  raise =<< modifyDnEither l dn rdn del new++-- | Perform the Modify DN operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+modifyDnEither :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO (Either ResponseError ())+modifyDnEither l dn rdn del new =+  wait =<< modifyDnAsync l dn rdn del new++-- | Perform the Modify DN operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+modifyDnAsync :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO (Async ())+modifyDnAsync l dn rdn del new =+  atomically (modifyDnAsyncSTM l dn rdn del new)++-- | Perform the Modify DN operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+modifyDnAsyncSTM :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> STM (Async ())+modifyDnAsyncSTM l dn rdn del new =+  let req = modifyDnRequest dn rdn del new in sendRequest l (modifyDnResult req) req++modifyDnRequest :: Dn -> RelativeDn -> Bool -> Maybe Dn -> Request+modifyDnRequest (Dn dn) (RelativeDn rdn) del new =+  Type.ModifyDnRequest (Type.LdapDn (Type.LdapString dn))+                       (Type.RelativeLdapDn (Type.LdapString rdn))+                       del+                       (fmap (\(Dn dn') -> Type.LdapDn (Type.LdapString dn')) new)++modifyDnResult :: Request -> Response -> Either ResponseError ()+modifyDnResult req (Type.ModifyDnResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])+  | Type.Success <- code = Right ()+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)+modifyDnResult req res = Left (ResponseInvalid req res)
+ src/Ldap/Client/Search.hs view
@@ -0,0 +1,223 @@+{-# 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)
+ test/Ldap/Client/AddSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.AddSpec (spec) where++import qualified Data.List.NonEmpty as NonEmpty+import           Test.Hspec++import           Ldap.Client (Dn(..), Filter(..), Attr(..))+import qualified Ldap.Client as Ldap++import           SpecHelper (locally , dns , vulpix)+++spec :: Spec+spec = do+  let go l f = Ldap.search l (Dn "o=localhost") (Ldap.typesOnly True) f []++  it "adds an entry" $ do+    res <- locally $ \l -> do+      Ldap.add l vulpix+                 [ (Attr "cn",        NonEmpty.fromList ["vulpix"])+                 , (Attr "evolution", NonEmpty.fromList ["0"])+                 , (Attr "type",      NonEmpty.fromList ["fire"])+                 ]+      res <- go l (Attr "cn" := "vulpix")+      dns res `shouldBe` [vulpix]+    res `shouldBe` Right ()
+ test/Ldap/Client/BindSpec.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.BindSpec (spec) where++#if __GLASGOW_HASKELL__ < 710+import           Data.Monoid (mempty)+#endif+import           Test.Hspec+import qualified Ldap.Asn1.Type as Ldap.Type+import           Ldap.Client as Ldap++import           SpecHelper (locally)+++spec :: Spec+spec = do+  it "binds as ‘admin’" $ do+    res <- locally $ \l ->+      Ldap.bind l (Dn "cn=admin") (Password "secret")+    res `shouldBe` Right ()++  it "tries to bind as ‘admin’ with the wrong password, unsuccessfully" $ do+    res <- locally $ \l ->+      Ldap.bind l (Dn "cn=admin") (Password "public")+    res `shouldBe` Left+      (Ldap.ResponseError+        (Ldap.ResponseErrorCode+          (Ldap.Type.BindRequest 3+                                 (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=admin"))+                                 (Ldap.Type.Simple "public"))+          Ldap.InvalidCredentials+          (Dn "cn=admin")+          "Invalid Credentials"))++  it "binds as ‘pikachu’" $ do+    res <- locally $ \l -> do+      Ldap.bind l (Dn "cn=admin") (Password "secret")+      [Ldap.SearchEntry udn _]+        <- Ldap.search l (Dn "o=localhost") mempty (Attr "cn" := "pikachu") []+      Ldap.bind l udn (Password "i-choose-you")+    res `shouldBe` Right ()
+ test/Ldap/Client/CompareSpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.CompareSpec (spec) where++import           Test.Hspec+import qualified Ldap.Asn1.Type as Ldap.Type+import           Ldap.Client as Ldap++import SpecHelper (locally, charmander, charizard)+++spec :: Spec+spec = do+  it "compares and wins" $ do+    res <- locally $ \l -> do+      res <- Ldap.compare l charizard (Attr "type") "fire"+      res `shouldBe` True+    res `shouldBe` Right ()++  it "compares and looses" $ do+    res <- locally $ \l -> do+      res <- Ldap.compare l charmander (Attr "type") "flying"+      res `shouldBe` False+    res `shouldBe` Right ()++  it "tries to compare non-existing object, unsuccessfully" $ do+    res <- locally $ \l -> do+      res <- Ldap.compare l (Dn "cn=nope") (Attr "type") "flying"+      res `shouldBe` False+    res `shouldBe` Left+      (Ldap.ResponseError+        (Ldap.ResponseErrorCode+          (Ldap.Type.CompareRequest+                                 (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=nope"))+                                 (Ldap.Type.AttributeValueAssertion+                                    (Ldap.Type.AttributeDescription (Ldap.Type.LdapString "type"))+                                    (Ldap.Type.AssertionValue "flying")))+          Ldap.NoSuchObject+          (Dn "")+          "No tree found for: cn=nope"))
+ test/Ldap/Client/DeleteSpec.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.DeleteSpec (spec) where++import           Test.Hspec++import           Ldap.Client (Dn(..), Filter(..), Attr(..))+import qualified Ldap.Client as Ldap+import qualified Ldap.Asn1.Type as Ldap.Type++import           SpecHelper (locally, dns, pikachu, oddish)+++spec :: Spec+spec = do+  let go l f = Ldap.search l (Dn "o=localhost") (Ldap.typesOnly True) f []++  it "deletes an entry" $ do+    res <- locally $ \l -> do+      Ldap.delete l pikachu+      res <- go l (Attr "cn" := "pikachu")+      dns res `shouldBe` []+    res `shouldBe` Right ()++  it "tries to delete an non-existing entry, unsuccessfully" $ do+    res <- locally $ \l ->+      Ldap.delete l oddish+    res `shouldBe` Left+      (Ldap.ResponseError+        (Ldap.ResponseErrorCode (Ldap.Type.DeleteRequest+                                  (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=oddish,o=localhost")))+                                Ldap.NoSuchObject+                                (Dn "o=localhost")+                                "cn=oddish,o=localhost"))
+ test/Ldap/Client/ExtendedSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.ExtendedSpec (spec) where++import           Test.Hspec++import           Ldap.Client as Ldap+import           Ldap.Client.Extended as Ldap+import qualified Ldap.Asn1.Type as Ldap.Type++import           SpecHelper (locally )+++spec :: Spec+spec = do+  it "sends an extended request" $ do+    res <- locally $ \l ->+      Ldap.extended l (Oid "0") Nothing+    res `shouldBe` Left+      (ResponseError (ResponseErrorCode (Ldap.Type.ExtendedRequest (Ldap.Type.LdapOid "0") Nothing)+                                        ProtocolError+                                        (Dn "")+                                        "0 not supported"))++  it "sends a StartTLS request" $ do+    res <- locally $ \l ->+      Ldap.startTls l+    res `shouldBe` Left+      (ResponseError (ResponseErrorCode (Ldap.Type.ExtendedRequest (Ldap.Type.LdapOid "1.3.6.1.4.1.1466.20037")+                                                                   Nothing)+                                        ProtocolError+                                        (Dn "")+                                        "1.3.6.1.4.1.1466.20037 not supported"))
+ test/Ldap/Client/ModifySpec.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.ModifySpec (spec) where++import           Test.Hspec+import qualified Ldap.Asn1.Type as Ldap.Type+import           Ldap.Client as Ldap++import           SpecHelper (locally, charizard, pikachu, raichu)+++spec :: Spec+spec = do+  let go l f = Ldap.search l (Dn "o=localhost") (Ldap.typesOnly True) f []++  context "delete" $ do+    it "can land ‘charizard’" $ do+      res <- locally $ \l -> do+        [x] <- go l (Attr "cn" := "charizard")+        lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"]++        Ldap.modify l charizard [Attr "type" `Delete` ["flying"]]++        [y] <- go l (Attr "cn" := "charizard")+        lookupAttr (Attr "type") y `shouldBe` Just ["fire"]+      res `shouldBe` Right ()++    it "tries to remove ‘pikachu’'s password, unsuccessfully" $ do+      res <- locally $ \l ->+        Ldap.modify l pikachu [Attr "password" `Delete` []]+      res `shouldBe` Left+        (ResponseError+          (ResponseErrorCode+            (Ldap.Type.ModifyRequest (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=pikachu,o=localhost"))+                                     [( Ldap.Type.Delete+                                     , Ldap.Type.PartialAttribute+                                         (Ldap.Type.AttributeDescription (Ldap.Type.LdapString "password"))+                                         []+                                     )])+                                     UnwillingToPerform+                                     (Dn "o=localhost")+                                     "cannot delete password"))++  context "add" $+    it "can feed ‘charizard’" $ do+      res <- locally $ \l -> do+        [x] <- go l (Attr "cn" := "charizard")+        lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"]++        Ldap.modify l charizard [Attr "type" `Add` ["fed"]]++        [y] <- go l (Attr "cn" := "charizard")+        lookupAttr (Attr "type") y `shouldBe` Just ["fire", "flying", "fed"]+      res `shouldBe` Right ()++  context "replace" $+    it "can put ‘charizard’ to sleep" $ do+      res <- locally $ \l -> do+        [x] <- go l (Attr "cn" := "charizard")+        lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"]++        Ldap.modify l charizard [Attr "type" `Replace` ["sleeping"]]++        [y] <- go l (Attr "cn" := "charizard")+        lookupAttr (Attr "type") y `shouldBe` Just ["sleeping"]+      res `shouldBe` Right ()++  context "modify dn" $+    it "evolves ‘pikachu’ into ‘raichu’" $ do+      res <- locally $ \l -> do+        [] <- go l (Attr "cn" := "raichu")++        Ldap.modifyDn l pikachu (RelativeDn "cn=raichu") False Nothing+        Ldap.modify l raichu [Attr "evolution" `Replace` ["1"]]++        [res] <- go l (Attr "cn" := "raichu")+        res `shouldBe`+          SearchEntry raichu+                      [ (Attr "cn",        ["raichu"])+                      , (Attr "evolution", ["1"])+                      , (Attr "type",      ["electric"])+                      , (Attr "password",  ["i-choose-you"])+                      ]+      res `shouldBe` Right ()++lookupAttr :: Attr -> SearchEntry -> Maybe [AttrValue]+lookupAttr a (SearchEntry _ as) = lookup a as
+ test/Ldap/Client/SearchSpec.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.SearchSpec (spec) where++import qualified Data.List.NonEmpty as NonEmpty+import           Test.Hspec+import           Ldap.Client as Ldap+import qualified Ldap.Asn1.Type as Ldap.Type++import           SpecHelper+  ( locally+  , dns+  , bulbasaur+  , ivysaur+  , venusaur+  , charmander+  , charmeleon+  , charizard+  , squirtle+  , wartortle+  , blastoise+  , caterpie+  , metapod+  , butterfree+  , pikachu+  )+++spec :: Spec+spec = do+  let go l f = Ldap.search l (Dn "o=localhost") (Ldap.typesOnly True) f []++  it "cannot search as ‘pikachu’" $ do+    res <- locally $ \l -> do+      Ldap.bind l pikachu (Password "i-choose-you")+      go l (Present (Attr "password"))+    let req = Ldap.Type.SearchRequest+          (Ldap.Type.LdapDn (Ldap.Type.LdapString "o=localhost"))+          Ldap.Type.WholeSubtree+          Ldap.Type.NeverDerefAliases+          0+          0+          True+          (Ldap.Type.Present (Ldap.Type.AttributeDescription (Ldap.Type.LdapString "password")))+          (Ldap.Type.AttributeSelection [])+    res `shouldBe` Left+      (Ldap.ResponseError+        (Ldap.ResponseErrorCode req+                                Ldap.InsufficientAccessRights+                                (Dn "o=localhost")+                                "Insufficient Access Rights"))++  it "‘present’ filter" $ do+    res <- locally $ \l -> do+      res <- go l (Present (Attr "password"))+      dns res `shouldBe` [pikachu]+    res `shouldBe` Right ()++  it "‘equality’ filter" $ do+    res <- locally $ \l -> do+      res <- go l (Attr "type" := "flying")+      dns res `shouldMatchList`+        [ butterfree+        , charizard+        ]+    res `shouldBe` Right ()++  it "‘and’ filter" $ do+    res <- locally $ \l -> do+      res <- go l (And (NonEmpty.fromList [ Attr "type" := "fire"+                                          , Attr "evolution" := "1"+                                          ]))+      dns res `shouldBe` [charmeleon]+    res `shouldBe` Right ()++  it "‘or’ filter" $ do+    res <- locally $ \l -> do+      res <- go l (Or (NonEmpty.fromList [ Attr "type" := "fire"+                                         , Attr "evolution" := "1"+                                         ]))+      dns res `shouldMatchList`+        [ ivysaur+        , charizard+        , charmeleon+        , charmander+        , wartortle+        , metapod+        ]+    res `shouldBe` Right ()++  it "‘ge’ filter" $ do+    res <- locally $ \l -> do+      res <- go l (Attr "evolution" :>= "2")+      dns res `shouldMatchList`+        [ venusaur+        , charizard+        , blastoise+        , butterfree+        ]+    res `shouldBe` Right ()++  it "‘le’ filter" $ do+    res <- locally $ \l -> do+      res <- go l (Attr "evolution" :<= "0")+      dns res `shouldMatchList`+        [ bulbasaur+        , charmander+        , squirtle+        , caterpie+        , pikachu+        ]+    res `shouldBe` Right ()++  it "‘not’ filter" $ do+    res <- locally $ \l -> do+      res <- go l (Not (Or (NonEmpty.fromList [ Attr "type" := "fire"+                                              , Attr "evolution" :>= "1"+                                              ])))+      dns res `shouldMatchList`+        [ bulbasaur+        , squirtle+        , caterpie+        , pikachu+        ]+    res `shouldBe` Right ()++  it "‘substrings’ filter" $ do+    res <- locally $ \l -> do+      x <- go l (Attr "cn" :=* (Just "char", [], Nothing))+      dns x `shouldMatchList`+        [ charmander+        , charmeleon+        , charizard+        ]+      y <- go l (Attr "cn" :=* (Nothing, [], Just "saur"))+      dns y `shouldMatchList`+        [ bulbasaur+        , ivysaur+        , venusaur+        ]+      z <- go l (Attr "cn" :=* (Nothing, ["a", "o"], Just "e"))+      dns z `shouldMatchList`+        [ blastoise+        , wartortle+        ]+    res `shouldBe` Right ()++  it "‘approximate’ filter (actually, another ‘equality’ filter)" $ do+    res <- locally $ \l -> do+      res <- go l (Attr "type" :~= "flying")+      dns res `shouldMatchList`+        [ butterfree+        , charizard+        ]+    res `shouldBe` Right ()++  it "‘extensible’ filter" $ do+    res <- locally $ \l -> do+      res <- go l ((Just (Attr "type"), Nothing, True) ::= "flying")+      dns res `shouldMatchList`+        [ butterfree+        , charizard+        ]+    res `shouldBe` Right ()
+ test/Ldap/ClientSpec.hs view
@@ -0,0 +1,18 @@+module Ldap.ClientSpec (spec) where++import Control.Exception (IOException, throwIO)+import Test.Hspec++import SpecHelper (locally)+++spec :: Spec+spec =+  context "exceptions" $+    it "propagates unrelated ‘IOException’s through" $+      locally (\_ -> throwIO unrelated)+     `shouldThrow`+      (== unrelated)++unrelated :: IOException+unrelated = userError "unrelated"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/SpecHelper.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}+module SpecHelper+  ( locally+  , port+  , dns+  -- * Users+  , bulbasaur+  , ivysaur+  , venusaur+  , charmander+  , charmeleon+  , charizard+  , squirtle+  , wartortle+  , blastoise+  , caterpie+  , metapod+  , butterfree+  , pikachu+  , raichu+  , vulpix+  , oddish+  ) where++import Control.Exception (bracket)+import System.IO (hGetLine)+import System.Process (runInteractiveProcess, terminateProcess, waitForProcess)++import Ldap.Client as Ldap+++locally :: (Ldap -> IO a) -> IO (Either LdapError a)+locally f =+  bracket (do (_, out, _, h) <- runInteractiveProcess "./test/ldap.js" [] Nothing+                                  (Just [ ("PORT", show port)+                                        , ("SSL_CERT", "./ssl/cert.pem")+                                        , ("SSL_KEY", "./ssl/key.pem")+                                        ])+              hGetLine out+              return h)+          (\h -> do terminateProcess h+                    waitForProcess h)+          (\_ -> Ldap.with localhost port f)++localhost :: Host+localhost = Insecure "localhost"++port :: Num a => a+port = 24620++dns :: [SearchEntry] -> [Dn]+dns (SearchEntry dn _ : es) = dn : dns es+dns [] = []++bulbasaur :: Dn+bulbasaur = Dn "cn=bulbasaur,o=localhost"++ivysaur :: Dn+ivysaur = Dn "cn=ivysaur,o=localhost"++venusaur :: Dn+venusaur = Dn "cn=venusaur,o=localhost"++charmander :: Dn+charmander = Dn "cn=charmander,o=localhost"++charmeleon :: Dn+charmeleon = Dn "cn=charmeleon,o=localhost"++charizard :: Dn+charizard = Dn "cn=charizard,o=localhost"++squirtle :: Dn+squirtle = Dn "cn=squirtle,o=localhost"++wartortle :: Dn+wartortle = Dn "cn=wartortle,o=localhost"++blastoise :: Dn+blastoise = Dn "cn=blastoise,o=localhost"++caterpie :: Dn+caterpie = Dn "cn=caterpie,o=localhost"++metapod :: Dn+metapod = Dn "cn=metapod,o=localhost"++butterfree :: Dn+butterfree = Dn "cn=butterfree,o=localhost"++pikachu :: Dn+pikachu = Dn "cn=pikachu,o=localhost"++raichu :: Dn+raichu = Dn "cn=raichu,o=localhost"++vulpix :: Dn+vulpix = Dn "cn=vulpix,o=localhost"++oddish :: Dn+oddish = Dn "cn=oddish,o=localhost"