diff --git a/README.markdown b/README.markdown index 28788f5..8e8f208 100644 --- a/README.markdown +++ b/README.markdown @@ -7,26 +7,40 @@ ldap-client This library implements (the parts of) [RFC 4511][rfc4511] - Feature | RFC Section | Support -:--------------------------- |:-----------:|:-----------: -Bind Operation | 4.2 | ✔ -Unbind Operation | 4.3 | ✔ -Unsolicited Notification | 4.4 | ✔ -Notice of Disconnection | 4.4.1 | ✔ -Search Operation | 4.5 | ✔\* -Modify Operation | 4.6 | ✔ -Add Operation | 4.7 | ✔ -Delete Operation | 4.8 | ✔ -Modify DN Operation | 4.9 | ✔ -Compare Operation | 4.10 | ✔ -Abandon Operation | 4.11 | ✘ -Extended Operation | 4.12 | ✔ -IntermediateResponse Message | 4.13 | ✔ -StartTLS Operation | 4.14 | ✔† -LDAP over TLS | - | ✔ + 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/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs index b0ed155..8a35643 100644 --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/src/Ldap/Asn1/FromAsn1.hs @@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-} +-- | This module contains convertions from ASN.1 to LDAP types. module Ldap.Asn1.FromAsn1 - ( FromAsn1(..) - , Parser - , parseAsn1 - , parse - , next + ( parseAsn1 + , FromAsn1 ) where #if __GLASGOW_HASKELL__ >= 710 @@ -25,6 +23,13 @@ import Ldap.Asn1.Type {-# ANN module "HLint: ignore Avoid lambda" #-} +-- | Convert a part of ASN.1 stream to a LDAP type returning the remainder of the stream. +parseAsn1 :: FromAsn1 a => [ASN1] -> Maybe ([ASN1], a) +parseAsn1 = parse fromAsn1 + +-- | ASN.1 stream parsers. +-- +-- When it's relevant, instances include the part of RFC describing the encoding. class FromAsn1 a where fromAsn1 :: Parser [ASN1] a @@ -84,7 +89,9 @@ LDAPOID ::= OCTET STRING -- Constrained to \ instance FromAsn1 LdapOid where fromAsn1 = do Asn1.OctetString s <- next - return (LdapOid s) + case Text.decodeUtf8' s of + Right t -> return (LdapOid t) + Left _ -> empty {- | @ @@ -335,9 +342,12 @@ instance FromAsn1 ProtocolServerOp where , do Asn1.Start (Asn1.Container Asn1.Application 24) <- next res <- fromAsn1 - name <- optional $ do + 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 @@ -406,9 +416,6 @@ instance MonadPlus (Parser s) where Parser ma `mplus` Parser mb = Parser (\s -> ma s `mplus` mb s) -parseAsn1 :: FromAsn1 a => [ASN1] -> Maybe ([ASN1], a) -parseAsn1 = parse fromAsn1 - parse :: Parser s a -> s -> Maybe (s, a) parse = unParser diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index 944b10f..5987294 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -1,3 +1,9 @@ +-- | 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 @@ -15,6 +21,9 @@ 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] @@ -62,7 +71,7 @@ LDAPOID ::= OCTET STRING -- Constrained to \ @ -} instance ToAsn1 LdapOid where - toAsn1 (LdapOid s) = single (Asn1.OctetString s) + toAsn1 (LdapOid s) = single (Asn1.OctetString (Text.encodeUtf8 s)) {- | @ @@ -292,7 +301,7 @@ instance ToAsn1 ProtocolClientOp where application 14 (toAsn1 dn <> sequence (toAsn1 av)) toAsn1 (ExtendedRequest (LdapOid oid) mv) = application 23 (fold - [ other Asn1.Context 0 oid + [ other Asn1.Context 0 (Text.encodeUtf8 oid) , maybe mempty (other Asn1.Context 1) mv ]) diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index a18aa59..beecafe 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/src/Ldap/Asn1/Type.hs @@ -6,56 +6,62 @@ 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, Ord) + } 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 + 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, Ord) + | 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, Ord) + 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) -data AuthenticationChoice = Simple ByteString - deriving (Show, Eq, Ord) +newtype AuthenticationChoice = Simple ByteString + deriving (Show, Eq) data Scope = BaseObject | SingleLevel | WholeSubtree - deriving (Show, Eq, Ord) + deriving (Show, Eq) data DerefAliases = NeverDerefAliases | DerefInSearching | DerefFindingBaseObject | DerefAlways - deriving (Show, Eq, Ord) + deriving (Show, Eq) data Filter = And (NonEmpty Filter) @@ -68,40 +74,44 @@ data Filter = | Present AttributeDescription | ApproxMatch AttributeValueAssertion | ExtensibleMatch MatchingRuleAssertion - deriving (Show, Eq, Ord) + deriving (Show, Eq) data SubstringFilter = SubstringFilter AttributeDescription (NonEmpty Substring) - deriving (Show, Eq, Ord) + deriving (Show, Eq) data Substring = Initial AssertionValue | Any AssertionValue | Final AssertionValue - deriving (Show, Eq, Ord) + deriving (Show, Eq) data MatchingRuleAssertion = MatchingRuleAssertion (Maybe MatchingRuleId) (Maybe AttributeDescription) AssertionValue Bool - deriving (Show, Eq, Ord) + 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, Ord) + deriving (Show, Eq) newtype AttributeSelection = AttributeSelection [LdapString] - deriving (Show, Eq, Ord) + deriving (Show, Eq) newtype AttributeList = AttributeList [Attribute] - deriving (Show, Eq, Ord) + deriving (Show, Eq) newtype PartialAttributeList = PartialAttributeList [PartialAttribute] - deriving (Show, Eq, Ord) + deriving (Show, Eq) newtype Controls = Controls [Control] - deriving (Show, Eq, Ord) + deriving (Show, Eq) data Control = Control LdapOid Bool (Maybe ByteString) - deriving (Show, Eq, Ord) + deriving (Show, Eq) data LdapResult = LdapResult ResultCode LdapDn LdapString (Maybe ReferralUris) - deriving (Show, Eq, Ord) + deriving (Show, Eq) data ResultCode = Success @@ -143,50 +153,62 @@ data ResultCode = | ObjectClassModsProhibited | AffectsMultipleDSAs | Other - deriving (Show, Eq, Ord) + deriving (Show, Eq) newtype AttributeDescription = AttributeDescription LdapString - deriving (Show, Eq, Ord) + deriving (Show, Eq) newtype AttributeValue = AttributeValue ByteString - deriving (Show, Eq, Ord) + deriving (Show, Eq) data AttributeValueAssertion = AttributeValueAssertion AttributeDescription AssertionValue - deriving (Show, Eq, Ord) + deriving (Show, Eq) newtype AssertionValue = AssertionValue ByteString - deriving (Show, Eq, Ord) + deriving (Show, Eq) data Attribute = Attribute AttributeDescription (NonEmpty AttributeValue) - deriving (Show, Eq, Ord) + deriving (Show, Eq) data PartialAttribute = PartialAttribute AttributeDescription [AttributeValue] - deriving (Show, Eq, Ord) + 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, Ord) + 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, Ord) + deriving (Show, Eq) newtype ReferralUris = ReferralUris (NonEmpty Uri) - deriving (Show, Eq, Ord) + deriving (Show, Eq) newtype Uri = Uri LdapString - deriving (Show, Eq, Ord) + deriving (Show, Eq) data Operation = Add | Delete | Replace - deriving (Show, Eq, Ord) + 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. +-- following the UTF-8 [RFC3629] algorithm. (Section 4.1.2.) newtype LdapString = LdapString Text - deriving (Show, Eq, Ord) + deriving (Show, Eq) -newtype LdapOid = LdapOid ByteString - deriving (Show, Eq, Ord) +-- | 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 index 5f409ee..06796db 100644 --- a/src/Ldap/Client.hs +++ b/src/Ldap/Client.hs @@ -47,6 +47,7 @@ module Ldap.Client , Password(..) , AttrList , Attr(..) + , AttrValue -- * Re-exports , NonEmpty , PortNumber @@ -64,7 +65,6 @@ 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 Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.Foldable (asum) @@ -84,7 +84,7 @@ 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 (bind, unbindAsync) +import Ldap.Client.Bind (bind) import Ldap.Client.Search ( search , Search @@ -248,7 +248,7 @@ dispatch Ldap { client } inq outq = _ -> return req probablyDisconnect mid op req = done mid op req - noticeOfDisconnection :: ByteString + noticeOfDisconnection :: Text noticeOfDisconnection = fromString "1.3.6.1.4.1.1466.20036" wrap :: IO a -> IO a diff --git a/src/Ldap/Client/Add.hs b/src/Ldap/Client/Add.hs index 8b553cb..f76aa7b 100644 --- a/src/Ldap/Client/Add.hs +++ b/src/Ldap/Client/Add.hs @@ -1,3 +1,16 @@ +-- | 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 @@ -12,18 +25,27 @@ 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 diff --git a/src/Ldap/Client/Bind.hs b/src/Ldap/Client/Bind.hs index 933cbd7..7f926bc 100644 --- a/src/Ldap/Client/Bind.hs +++ b/src/Ldap/Client/Bind.hs @@ -1,13 +1,23 @@ +-- | 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 ( bind , bindEither , bindAsync , bindAsyncSTM - , unbindAsync - , unbindAsyncSTM ) where -import Control.Monad (void) import Control.Monad.STM (STM, atomically) import Data.List.NonEmpty (NonEmpty((:|))) @@ -15,18 +25,27 @@ import qualified Ldap.Asn1.Type as Type import Ldap.Client.Internal +-- | 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 @@ -45,22 +64,3 @@ bindResult req (Type.BindResponse (Type.LdapResult code (Type.LdapDn (Type.LdapS | Type.Success <- code = Right () | otherwise = Left (ResponseErrorCode req code (Dn dn) msg) bindResult req res = Left (ResponseInvalid req res) - - --- | 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 - --- | 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/Compare.hs b/src/Ldap/Client/Compare.hs index fead35d..1dd6441 100644 --- a/src/Ldap/Client/Compare.hs +++ b/src/Ldap/Client/Compare.hs @@ -1,3 +1,17 @@ +-- | 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 @@ -6,7 +20,6 @@ module Ldap.Client.Compare ) where import Control.Monad.STM (STM, atomically) -import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty((:|))) import Prelude hiding (compare) @@ -14,23 +27,32 @@ import Ldap.Client.Internal import qualified Ldap.Asn1.Type as Type -compare :: Ldap -> Dn -> Attr -> ByteString -> IO Bool +-- | 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 -compareEither :: Ldap -> Dn -> Attr -> ByteString -> IO (Either ResponseError Bool) +-- | 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 -compareAsync :: Ldap -> Dn -> Attr -> ByteString -> IO (Async Bool) +-- | 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) -compareAsyncSTM :: Ldap -> Dn -> Attr -> ByteString -> STM (Async Bool) +-- | 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 -> ByteString -> Request +compareRequest :: Dn -> Attr -> AttrValue -> Request compareRequest (Dn dn) (Attr k) v = Type.CompareRequest (Type.LdapDn (Type.LdapString dn)) (Type.AttributeValueAssertion diff --git a/src/Ldap/Client/Delete.hs b/src/Ldap/Client/Delete.hs index b5c4b60..68facc3 100644 --- a/src/Ldap/Client/Delete.hs +++ b/src/Ldap/Client/Delete.hs @@ -1,3 +1,16 @@ +-- | 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 @@ -12,18 +25,27 @@ 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 diff --git a/src/Ldap/Client/Extended.hs b/src/Ldap/Client/Extended.hs index 7a722bb..e1a0d61 100644 --- a/src/Ldap/Client/Extended.hs +++ b/src/Ldap/Client/Extended.hs @@ -1,4 +1,17 @@ {-# 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 , extendedEither @@ -19,18 +32,27 @@ import qualified Ldap.Asn1.Type as Type import Ldap.Client.Internal +-- | 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 diff --git a/src/Ldap/Client/Internal.hs b/src/Ldap/Client/Internal.hs index 692f204..8913a76 100644 --- a/src/Ldap/Client/Internal.hs +++ b/src/Ldap/Client/Internal.hs @@ -12,6 +12,8 @@ module Ldap.Client.Internal -- * Waiting for Request Completion , wait , waitSTM + , unbindAsync + , unbindAsyncSTM -- * Misc , Response , ResponseError(..) @@ -22,6 +24,7 @@ module Ldap.Client.Internal , RelativeDn(..) , Password(..) , Attr(..) + , AttrValue , unAttr ) where @@ -29,6 +32,7 @@ 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) @@ -58,20 +62,18 @@ data Async a = Async (STM (Either ResponseError a)) instance Functor Async where fmap f (Async stm) = Async (fmap (fmap f) stm) - newtype Dn = Dn Text deriving (Show, Eq) newtype RelativeDn = RelativeDn Text deriving (Show, Eq) -newtype Oid = Oid ByteString +newtype Oid = Oid Text deriving (Show, Eq) newtype Password = Password ByteString deriving (Show, Eq) - data ResponseError = ResponseInvalid Request Response | ResponseErrorCode Request Type.ResultCode Dn Text @@ -79,26 +81,24 @@ data ResponseError = instance Exception ResponseError - - newtype Attr = Attr Text deriving (Show, Eq) -type AttrList f = [(Attr, f ByteString)] +type AttrValue = ByteString + +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 :: Async a -> IO (Either ResponseError a) wait = atomically . waitSTM 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 @@ -110,3 +110,22 @@ writeRequest Ldap { client } var msg = writeTQueue client (New msg var) raise :: Exception e => Either e a -> IO a raise = either throwIO return + + +-- | 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 + +-- | 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 index 8b567ce..ad49730 100644 --- a/src/Ldap/Client/Modify.hs +++ b/src/Ldap/Client/Modify.hs @@ -1,3 +1,19 @@ +-- | 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 @@ -11,31 +27,40 @@ module Ldap.Client.Modify ) where import Control.Monad.STM (STM, atomically) -import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Ldap.Asn1.Type as Type import Ldap.Client.Internal +-- | Type of modification being performed. data Operation = - Delete Attr [ByteString] - | Add Attr [ByteString] - | Replace Attr [ByteString] + 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 @@ -61,18 +86,27 @@ modifyResult req (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.L modifyResult req res = Left (ResponseInvalid req res) +-- | 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 diff --git a/src/Ldap/Client/Search.hs b/src/Ldap/Client/Search.hs index 4353cb4..37cefa8 100644 --- a/src/Ldap/Client/Search.hs +++ b/src/Ldap/Client/Search.hs @@ -1,5 +1,18 @@ {-# 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 @@ -18,7 +31,6 @@ module Ldap.Client.Search ) where import Control.Monad.STM (STM, atomically) -import Data.ByteString (ByteString) import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NonEmpty @@ -33,10 +45,13 @@ 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 @@ -47,11 +62,23 @@ searchEither 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) -searchAsyncSTM :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> STM (Async [SearchEntry]) +-- | 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 @@ -167,12 +194,12 @@ data Filter = | And (NonEmpty Filter) | Or (NonEmpty Filter) | Present Attr - | Attr := ByteString - | Attr :>= ByteString - | Attr :<= ByteString - | Attr :~= ByteString - | Attr :=* (Maybe ByteString, [ByteString], Maybe ByteString) - | (Maybe Attr, Maybe Attr, Bool) ::= ByteString + | Attr := AttrValue + | Attr :>= AttrValue + | Attr :<= AttrValue + | Attr :~= AttrValue + | Attr :=* (Maybe AttrValue, [AttrValue], Maybe AttrValue) + | (Maybe Attr, Maybe Attr, Bool) ::= AttrValue data SearchEntry = SearchEntry Dn (AttrList []) deriving (Show, Eq) diff --git a/test/Ldap/Client/ModifySpec.hs b/test/Ldap/Client/ModifySpec.hs index e2e947c..1185e1c 100644 --- a/test/Ldap/Client/ModifySpec.hs +++ b/test/Ldap/Client/ModifySpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Ldap.Client.ModifySpec (spec) where -import Data.ByteString (ByteString) import Data.Monoid ((<>)) import Test.Hspec import qualified Ldap.Asn1.Type as Ldap.Type @@ -87,5 +86,5 @@ spec = do ] res `shouldBe` Right () -lookupAttr :: Attr -> SearchEntry -> Maybe [ByteString] +lookupAttr :: Attr -> SearchEntry -> Maybe [AttrValue] lookupAttr a (SearchEntry _ as) = lookup a as