diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,44 @@ +ldap-client +=========== +[![Hackage](https://budueba.com/hackage/ldap-client)](https://hackage.haskell.org/package/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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ldap-client-og.cabal b/ldap-client-og.cabal new file mode 100644 --- /dev/null +++ b/ldap-client-og.cabal @@ -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 diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Asn1/FromAsn1.hs @@ -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 \ +@ +-} +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)) diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -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 \ +@ +-} +instance ToAsn1 LdapOid where + toAsn1 (LdapOid s) = single (Asn1.OctetString (Text.encodeUtf8 s)) + +{- | +@ +LDAPDN ::= LDAPString -- Constrained to \ +@ +-} +instance ToAsn1 LdapDn where + toAsn1 (LdapDn s) = toAsn1 s + +{- | +@ +RelativeLDAPDN ::= LDAPString -- Constrained to \ +@ +-} +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 :) diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Asn1/Type.hs @@ -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 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 +-- \ given in Section 1.4 of [RFC4512]. +newtype LdapOid = LdapOid Text + deriving (Show, Eq) diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client.hs @@ -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) diff --git a/src/Ldap/Client/Add.hs b/src/Ldap/Client/Add.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Add.hs @@ -0,0 +1,69 @@ +-- | 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) diff --git a/src/Ldap/Client/Bind.hs b/src/Ldap/Client/Bind.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Bind.hs @@ -0,0 +1,114 @@ +-- | 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 + diff --git a/src/Ldap/Client/Compare.hs b/src/Ldap/Client/Compare.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Compare.hs @@ -0,0 +1,71 @@ +-- | 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) diff --git a/src/Ldap/Client/Delete.hs b/src/Ldap/Client/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Delete.hs @@ -0,0 +1,65 @@ +-- | 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) diff --git a/src/Ldap/Client/Extended.hs b/src/Ldap/Client/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Extended.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | 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" diff --git a/src/Ldap/Client/Internal.hs b/src/Ldap/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Internal.hs @@ -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" diff --git a/src/Ldap/Client/Modify.hs b/src/Ldap/Client/Modify.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Modify.hs @@ -0,0 +1,134 @@ +-- | and +-- 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) diff --git a/src/Ldap/Client/Search.hs b/src/Ldap/Client/Search.hs new file mode 100644 --- /dev/null +++ b/src/Ldap/Client/Search.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | 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) diff --git a/test/Ldap/Client/AddSpec.hs b/test/Ldap/Client/AddSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/Client/AddSpec.hs @@ -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 () diff --git a/test/Ldap/Client/BindSpec.hs b/test/Ldap/Client/BindSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/Client/BindSpec.hs @@ -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 () diff --git a/test/Ldap/Client/CompareSpec.hs b/test/Ldap/Client/CompareSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/Client/CompareSpec.hs @@ -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")) diff --git a/test/Ldap/Client/DeleteSpec.hs b/test/Ldap/Client/DeleteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/Client/DeleteSpec.hs @@ -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")) diff --git a/test/Ldap/Client/ExtendedSpec.hs b/test/Ldap/Client/ExtendedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/Client/ExtendedSpec.hs @@ -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")) diff --git a/test/Ldap/Client/ModifySpec.hs b/test/Ldap/Client/ModifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/Client/ModifySpec.hs @@ -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 diff --git a/test/Ldap/Client/SearchSpec.hs b/test/Ldap/Client/SearchSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/Client/SearchSpec.hs @@ -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 () diff --git a/test/Ldap/ClientSpec.hs b/test/Ldap/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ldap/ClientSpec.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs new file mode 100644 --- /dev/null +++ b/test/SpecHelper.hs @@ -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"