ldap-client-og (empty) → 0.2.0
raw patch · 27 files changed
+3007/−0 lines, 27 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
- CHANGELOG.markdown +17/−0
- LICENSE +26/−0
- README.markdown +44/−0
- Setup.hs +2/−0
- ldap-client-og.cabal +95/−0
- src/Ldap/Asn1/FromAsn1.hs +421/−0
- src/Ldap/Asn1/ToAsn1.hs +440/−0
- src/Ldap/Asn1/Type.hs +228/−0
- src/Ldap/Client.hs +263/−0
- src/Ldap/Client/Add.hs +69/−0
- src/Ldap/Client/Bind.hs +114/−0
- src/Ldap/Client/Compare.hs +71/−0
- src/Ldap/Client/Delete.hs +65/−0
- src/Ldap/Client/Extended.hs +116/−0
- src/Ldap/Client/Internal.hs +140/−0
- src/Ldap/Client/Modify.hs +134/−0
- src/Ldap/Client/Search.hs +218/−0
- test/Ldap/Client/AddSpec.hs +26/−0
- test/Ldap/Client/BindSpec.hs +38/−0
- test/Ldap/Client/CompareSpec.hs +39/−0
- test/Ldap/Client/DeleteSpec.hs +33/−0
- test/Ldap/Client/ExtendedSpec.hs +32/−0
- test/Ldap/Client/ModifySpec.hs +86/−0
- test/Ldap/Client/SearchSpec.hs +163/−0
- test/Ldap/ClientSpec.hs +18/−0
- test/Spec.hs +1/−0
- test/SpecHelper.hs +108/−0
+ CHANGELOG.markdown view
@@ -0,0 +1,17 @@+0.3.0+===++ * Supported lts-19.33 (GHC 9.0.2)++ * The package got stolen by an already dead company (KEKW), so I had to rename it++0.2.0+===++ * Supported SASL authentication via the EXTERNAL mechanism. (https://github.com/supki/ldap-client/pull/9)++ * Added the `SecureWithTLSSettings` constructor to the `Host` datatype for the+ cases where the user needs more control over TLS connection settings.+ (https://github.com/supki/ldap-client/issues/5, https://github.com/supki/ldap-client/pull/6)++ * Switched the decoding of server's messages to BER (See https://tools.ietf.org/html/rfc4511#section-5.1) (https://github.com/supki/ldap-client/pull/11)
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015-2017, 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,44 @@+ldap-client+===========+[](https://hackage.haskell.org/package/ldap-client)+[](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-og.cabal view
@@ -0,0 +1,95 @@+name: ldap-client-og+version: 0.2.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+ , GHC == 8.0.1+extra-source-files:+ README.markdown+ CHANGELOG.markdown++source-repository head+ type: git+ location: git@github.com:supki/ldap-client+ tag: 0.3.0++library+ ghc-options:+ -Wall+ -fwarn-incomplete-uni-patterns+ -fwarn-incomplete-record-updates+ -fwarn-unrecognised-pragmas+ 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+ ghc-options:+ -Wall+ -fwarn-incomplete-uni-patterns+ -fwarn-incomplete-record-updates+ -fwarn-unrecognised-pragmas+ 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,421 @@+{-# LANGUAGE CPP #-}+-- | This module contains convertions from ASN.1 to LDAP types.+module Ldap.Asn1.FromAsn1+ ( parseAsn1+ , FromAsn1+ ) where++import Control.Applicative (Alternative(..), liftA2, optional)+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" :: String) #-}+{-# ANN module ("HLint: ignore Avoid lambda" :: String) #-}+++-- | 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')++instance MonadFail (Parser s) where+ 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,440 @@+{-# LANGUAGE OverloadedStrings #-}+-- | 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,+ sasl [3] SaslCredentials,+ ... }+++SaslCredentials ::= SEQUENCE {+ mechanism LDAPString,+ credentials OCTET STRING OPTIONAL }+@+-}+instance ToAsn1 AuthenticationChoice where+ toAsn1 (Simple s) = other Asn1.Context 0 s+ toAsn1 (Sasl External c) =+ context 3 (fold+ [ toAsn1 (LdapString "EXTERNAL")+ , maybe mempty (toAsn1 . LdapString) c+ ])+{- |+@+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,228 @@+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.+data AuthenticationChoice =+ Simple !ByteString+ | Sasl !SaslMechanism !(Maybe Text)+ deriving (Show, Eq)++-- | SASL Mechanism, for now only SASL EXTERNAL is supported+data SaslMechanism =+ External+ 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,263 @@+{-# 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(..)+ , defaultTlsSettings+ , insecureTlsSettings+ , PortNumber+ , Ldap+ , LdapError(..)+ , ResponseError(..)+ , Type.ResultCode(..)+ -- * Bind+ , Password(..)+ , bind+ , externalBind+ -- * 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++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.Text (Text)+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, externalBind)+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, noticeOfDisconnectionOid)++{-# ANN module ("HLint: ignore Use first" :: String) #-}+++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+ Tls h _ -> h+ , Conn.connectionPort = port+ , Conn.connectionUseSecure =+ case host of+ Plain _ -> Nothing+ Tls _ settings -> pure settings+ , Conn.connectionUseSocks = Nothing+ }++defaultTlsSettings :: Conn.TLSSettings+defaultTlsSettings = Conn.TLSSettingsSimple+ { Conn.settingDisableCertificateValidation = False+ , Conn.settingDisableSession = False+ , Conn.settingUseServerName = False+ }++insecureTlsSettings :: Conn.TLSSettings+insecureTlsSettings = Conn.TLSSettingsSimple+ { Conn.settingDisableCertificateValidation = True+ , Conn.settingDisableSession = False+ , Conn.settingUseServerName = False+ }++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.BER (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 oid == noticeOfDisconnectionOid -> throwSTM (Disconnect code (Dn dn) reason)+ _ -> return req+ probablyDisconnect mid op req = done mid op req++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,114 @@+-- | <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+ , externalBind+ , externalBindEither+ , externalBindAsync+ , externalBindAsyncSTM+ , Async+ , wait+ , waitSTM+ ) where++import Control.Monad.STM (STM, atomically)+import Data.ByteString (ByteString)+import Data.Text (Text)+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)++-- | Perform a SASL EXTERNAL Bind operation synchronously. Raises 'ResponseError' on failures.+externalBind :: Ldap -> Dn -> Maybe Text -> IO ()+externalBind l username mCredentials =+ raise =<< externalBindEither l username mCredentials++-- | Perform a SASL EXTERNAL Bind operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+externalBindEither :: Ldap -> Dn -> Maybe Text -> IO (Either ResponseError ())+externalBindEither l username mCredentials =+ wait =<< externalBindAsync l username mCredentials++-- | Perform the SASL EXTERNAL Bind operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+externalBindAsync :: Ldap -> Dn -> Maybe Text -> IO (Async ())+externalBindAsync l username mCredentials =+ atomically (externalBindAsyncSTM l username mCredentials)++-- | Perform the SASL EXTERNAL Bind operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+externalBindAsyncSTM :: Ldap -> Dn -> Maybe Text -> STM (Async ())+externalBindAsyncSTM l username mCredentials =+ let req = externalBindRequest username mCredentials in sendRequest l (bindResult req) req++externalBindRequest :: Dn -> Maybe Text -> Request+externalBindRequest (Dn username) mCredentials =+ Type.BindRequest ldapVersion+ (Type.LdapDn (Type.LdapString username))+ (Type.Sasl Type.External mCredentials)+ where+ ldapVersion = 3+
+ 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,116 @@+{-# LANGUAGE OverloadedStrings #-}+-- | <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+ -- * OIDs+ , noticeOfDisconnectionOid+ , startTlsOid+ , 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 (IsString(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)++instance IsString Oid where+ fromString =+ Oid . fromString++-- | 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 startTlsOid Nothing++noticeOfDisconnectionOid :: Oid+noticeOfDisconnectionOid = "1.3.6.1.4.1.1466.20036"++startTlsOid :: Oid+startTlsOid = "1.3.6.1.4.1.1466.20037"
+ src/Ldap/Client/Internal.hs view
@@ -0,0 +1,140 @@+{-# 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.Connection (TLSSettings)+import Network.Socket (PortNumber)++import qualified Ldap.Asn1.Type as Type+++-- | LDAP host.+data Host =+ Plain String -- ^ Plain LDAP.+ | Tls String TLSSettings -- ^ LDAP over TLS.+ deriving (Show)++-- | A token. All functions that interact with the Directory require one.+newtype 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.+newtype 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,218 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+-- | <https://tools.ietf.org/html/rfc4511#section-4.5 Search> operation.+--+-- This operation comes in four flavours:+--+-- * synchronous, exception throwing ('search')+--+-- * synchronous, returning 'Either' 'ResponseError' @()@ ('searchEither')+--+-- * asynchronous, 'IO' based ('searchAsync')+--+-- * asynchronous, 'STM' based ('searchAsyncSTM')+--+-- Of those, the first one ('search') is probably the most useful for the typical usecase.+module Ldap.Client.Search+ ( search+ , searchEither+ , searchAsync+ , searchAsyncSTM+ , Search+ , Mod+ , Type.Scope(..)+ , scope+ , size+ , time+ , typesOnly+ , Type.DerefAliases(..)+ , derefAliases+ , Filter(..)+ , SearchEntry(..)+ , Async+ , wait+ , waitSTM+ ) where++import Control.Monad.STM (STM, atomically)+import Data.Int (Int32)+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (mapMaybe)++import qualified Ldap.Asn1.Type as Type+import Ldap.Client.Internal+++-- | Perform the Search operation synchronously. Raises 'ResponseError' on failures.+search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]+search 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,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Ldap.Client.BindSpec (spec) where++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")+ "InvalidCredentialsError"))++ 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 loses" $ 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")+ "InsufficientAccessRightsError"))++ 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,108 @@+{-# LANGUAGE CPP #-}+{-# 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.Monad (forever)+import Control.Concurrent (forkIO)+import Control.Exception (bracket)+import System.Environment (getEnvironment)+import System.IO (hGetLine)+import System.IO.Error (tryIOError)+import System.Process (runInteractiveProcess, terminateProcess, waitForProcess)++import Ldap.Client as Ldap+++locally :: (Ldap -> IO a) -> IO (Either LdapError a)+locally f =+ bracket (do env <- getEnvironment+ (_, out, _, h) <- runInteractiveProcess "./test/ldap.js" [] Nothing+ (Just (("PORT", show (port :: Int)) :+ ("SSL_CERT", "./ssl/cert.pem") :+ ("SSL_KEY", "./ssl/key.pem") :+ env))+ _ <- hGetLine out+ _ <- forkIO (() <$ tryIOError (forever (hGetLine out >>= putStrLn)))+ return h)+ (\h -> do terminateProcess h+ waitForProcess h)+ (\_ -> Ldap.with localhost port f)++localhost :: Host+localhost = Tls "localhost" insecureTlsSettings++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"