commit 7aa270331965c27e11dcdcedfc42d3ff32219427 Author: Matvey Aksenov Date: Sat Mar 28 12:13:51 2015 +0300 Initial commit Only Bind and Search operations are (partially) implemented. More tests and documentation are needed. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..80aa10a --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +dist/ +.cabal-sandbox/ +cabal.sandbox.config diff --git a/.vim.custom b/.vim.custom new file mode 100644 index 0000000..7444394 --- /dev/null +++ b/.vim.custom @@ -0,0 +1,27 @@ +function s:hdevtools_options(rgs) + return join(map(a:rgs, "'-g ' . v:val")) +endfunction + +function s:discover_cabal_sandbox(glob) + let l:sandboxes = split(glob(a:glob, "."), "\n") + if len(l:sandboxes) > 0 + return ['-no-user-package-db', '-package-db=' . l:sandboxes[-1]] + else + return [] + endif +endfunction + +let g:syntastic_haskell_hdevtools_args = s:hdevtools_options + \ ( + \ [ '-isrc' + \ , '-ibin' + \ , '-itest' + \ , '-idist/build/autogen' + \ , '-DTEST' + \ , '-O0' + \ , '-fdefer-type-errors' + \ , '-Wall' + \ , '-fno-warn-unused-do-bind' + \ , '-fno-warn-type-defaults' + \ ] + s:discover_cabal_sandbox(".cabal-sandbox/*.conf.d") + \ ) diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..66c1ad9 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2015, Matvey Aksenov +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 index 0000000..977780e --- /dev/null +++ b/README.markdown @@ -0,0 +1,28 @@ +ldap-client +----------- + +This library implements (the parts of) [RFC 4511][rfc4511] + + Feature | RFC Section | Support +:--------------------------- |:-----------:|:-----------: +Bind Operation | 4.2 | ✔ +Unbind Operation | 4.3 | ✔ +Notice of Disconnection | 4.4.1 | ✘ +Search Operation | 4.5 | ✔ (partial) +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 | - | ✔ + +``` +% git grep '\bString\b' | wc -l +2 +``` + + [rfc4511]: https://tools.ietf.org/html/rfc4511 diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/login.hs b/example/login.hs new file mode 100644 index 0000000..36dadb7 --- /dev/null +++ b/example/login.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +-- | An example of how to do LDAP logins with ldap-client. +-- +-- First, the assumptions this example makes. It defaults to LDAP over TLS, +-- so if you only have a plaintext server, please replace `Secure` with `Plain`. +-- It also assumes the accounts you may want to log in as all have +-- `objectClass` "Person". +-- +-- To run the example you have to provide a bunch of environment variables: +-- +-- - `HOST` is the LDAP host to connect to (without "ldap://", "ldaps://", etc). +-- - `POST` is the port LDAP server listens on. +-- - `MANAGER_DN` is the DN of the account the first bind is made with. +-- - `MANAGER_PASSWORD` is its password. +-- - `BASE_OBJECT` is the search root +module Main (main) where + +import Control.Exception (bracket_) -- base +import Control.Monad (when) -- base +import Data.Function (fix) -- base +import Data.Text (Text) -- text +import qualified Data.Text.Encoding as Text -- text +import qualified Data.Text.IO as Text -- text +import Env -- envparse +import qualified Ldap.Client as Ldap -- ldap-client +import Ldap.Client -- ldap-client + ( LdapError + , Scope(..) + , Filter(..) + , Attr(..) + ) +import System.Exit (die) -- base +import qualified System.IO as IO -- base + + +data Conf = Conf + { host :: String + , port :: Ldap.PortNumber + , dn :: Ldap.Dn + , password :: Ldap.Password + , base :: Ldap.Dn + } deriving (Show, Eq) + +getConf :: IO Conf +getConf = Env.parse (header "LDAP login example") $ Conf + <$> var str "HOST" (help "LDAP hostname") + <*> var (fmap fromIntegral . auto) "PORT" (help "LDAP port") + <*> var (fmap Ldap.Dn . str) "MANAGER_DN" (help "Manager login DN") + <*> var (fmap Ldap.Password . str) "MANAGER_PASSWORD" (help "Manager password") + <*> var (fmap Ldap.Dn . str) "BASE_OBJECT" (help "Search root") + +main :: IO () +main = do + conf <- getConf + res <- login conf + case res of + Left e -> die (show e) + Right _ -> return () + +login :: Conf -> IO (Either LdapError ()) +login conf = + Ldap.with (Ldap.Secure (host conf)) (port conf) $ \l -> do + Ldap.bind l (dn conf) (password conf) + fix $ \loop -> do + uid <- prompt "Username: " + us <- Ldap.search l (base conf) + (Ldap.scope WholeSubtree <> Ldap.typesOnly True) + (And [ Attr "objectClass" := "Person" + , Attr "uid" := Text.encodeUtf8 uid + ]) + [] + case us of + Ldap.SearchEntry udn _ : _ -> + fix $ \loop' -> do + pwd <- bracket_ hideOutput + showOutput + (do pwd <- prompt ("Password for ‘" <> uid <> "’: ") + Text.putStr "\n" + return pwd) + res <- Ldap.bindEither l udn (Ldap.Password (Text.encodeUtf8 pwd)) + case res of + Left _ -> do again <- question "Invalid password. Try again? [y/n] " + when again loop' + Right _ -> Text.putStrLn "OK" + [] -> do again <- question "Invalid username. Try again? [y/n] " + when again loop + +prompt :: Text -> IO Text +prompt msg = do Text.putStr msg; IO.hFlush IO.stdout; Text.getLine + +question :: Text -> IO Bool +question msg = fix $ \loop -> do + res <- prompt msg + case res of + "y" -> return True + "n" -> return False + _ -> do Text.putStrLn "Please, answer either ‘y’ or ‘n’."; loop + +hideOutput, showOutput :: IO () +hideOutput = IO.hSetEcho IO.stdout False +showOutput = IO.hSetEcho IO.stdout True diff --git a/ldap-client.cabal b/ldap-client.cabal new file mode 100644 index 0000000..dd04107 --- /dev/null +++ b/ldap-client.cabal @@ -0,0 +1,43 @@ +name: ldap-client +version: 0.1.0 +synopsis: Pure Haskell LDAP Client Library +description: + Pure Haskell LDAP client library implementing (the parts of) RFC 4511. +homepage: https://supki.github.io/ldap-client +license: BSD2 +license-file: LICENSE +author: Matvey Aksenov +maintainer: matvey.aksenov@gmail.com +copyright: 2015 Matvey Aksenov +category: Network +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.markdown + +source-repository head + type: git + location: git@github.com:supki/ldap-client + +library + default-language: + Haskell2010 + hs-source-dirs: + src + exposed-modules: + Ldap.Asn1.FromAsn1 + Ldap.Asn1.ToAsn1 + Ldap.Asn1.Type + Ldap.Client + build-depends: + asn1-encoding >= 0.9 + , asn1-types >= 0.3 + , async + , base >= 4.7 && < 5 + , bytestring + , connection >= 0.2 + , containers + , network >= 2.6 + , semigroups >= 0.16 + , stm + , text diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs new file mode 100644 index 0000000..b5121e3 --- /dev/null +++ b/src/Ldap/Asn1/FromAsn1.hs @@ -0,0 +1,303 @@ +module Ldap.Asn1.FromAsn1 + ( FromAsn1(..) + , Parser + , parseAsn1 + , parse + , next + ) where + +import Control.Applicative (Alternative(..), optional) +import Control.Monad ((>=>), MonadPlus(..)) +import Data.ASN1.Types (ASN1) +import qualified Data.ASN1.Types as Asn1 +import Data.Foldable (asum) +import Data.List.NonEmpty (some1) +import qualified Data.Set as Set +import qualified Data.Text.Encoding as Text + +import Ldap.Asn1.Type + + +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, + ... }, + 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 + +{- | +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 (Set.fromList 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 } + +SearchResultDone ::= [APPLICATION 5] LDAPResult +-} +instance FromAsn1 ProtocolServerOp where + fromAsn1 = asum + [ do + Asn1.Start (Asn1.Container Asn1.Application 1) <- next + result <- fromAsn1 + Asn1.End (Asn1.Container Asn1.Application 1) <- next + return (BindResponse result Nothing) + + , do + Asn1.Start (Asn1.Container Asn1.Application 4) <- next + ldapDn <- fromAsn1 + partialAttributeList <- fromAsn1 + Asn1.End (Asn1.Container Asn1.Application 4) <- next + return (SearchResultEntry ldapDn partialAttributeList) + + , do + Asn1.Start (Asn1.Container Asn1.Application 5) <- next + result <- fromAsn1 + Asn1.End (Asn1.Container Asn1.Application 5) <- next + return (SearchResultDone result) + ] + +{- | +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) + + +newtype Parser s a = Parser { unParser :: s -> Maybe (s, a) } + +instance Functor (Parser s) where + fmap f (Parser g) = Parser (fmap (fmap f) . g) + +instance Applicative (Parser s) where + pure x = Parser (\s -> pure (s, x)) + Parser mf <*> Parser mx = Parser $ \s -> do + (s', f) <- mf s + (s'', x) <- mx s' + pure (s'', f x) + +instance Alternative (Parser s) where + empty = Parser (\_ -> empty) + Parser ma <|> Parser mb = + Parser (\s -> ma s <|> mb s) + +instance Monad (Parser s) where + return x = Parser (\s -> return (s, x)) + Parser mx >>= k = + Parser (mx >=> \(s', x) -> unParser (k x) s') + fail _ = empty + +instance MonadPlus (Parser s) where + mzero = Parser (\_ -> mzero) + Parser ma `mplus` Parser mb = + Parser (\s -> ma s `mplus` mb s) + +parseAsn1 :: FromAsn1 a => [ASN1] -> Maybe ([ASN1], a) +parseAsn1 = parse fromAsn1 + +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 index 0000000..a26a58a --- /dev/null +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -0,0 +1,258 @@ +module Ldap.Asn1.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.Maybe (Maybe, maybe) +import Data.Monoid (Endo(Endo), (<>), mempty) +import qualified Data.Text.Encoding as Text +import Prelude ((.), fromIntegral) + +import Ldap.Asn1.Type + + +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, + ... }, + controls [0] Controls OPTIONAL } +-} +instance ToAsn1 op => ToAsn1 (LdapMessage op) where + toAsn1 (LdapMessage i op mc) = + sequence (toAsn1 i <> toAsn1 op <> context 0 (optional 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 s) + +{- | +LDAPDN ::= LDAPString -- Constrained to +-} +instance ToAsn1 LdapDn where + toAsn1 (LdapDn 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) + +{- | +MatchingRuleId ::= LDAPString +-} +instance ToAsn1 MatchingRuleId where + toAsn1 (MatchingRuleId s) = toAsn1 s + +{- | +Controls ::= SEQUENCE OF control Control +-} +instance ToAsn1 Controls where + toAsn1 (Controls cs) = sequence (foldMap 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 } +-} +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 + , single (Asn1.Enumerated s') + , single (Asn1.Enumerated 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 + +{- | +AuthenticationChoice ::= CHOICE { + simple [0] OCTET STRING, + ... } +-} +instance ToAsn1 AuthenticationChoice where + toAsn1 (Simple s) = other Asn1.Context 0 s + +{- | +AttributeSelection ::= SEQUENCE OF selector LDAPString +-} +instance ToAsn1 AttributeSelection where + toAsn1 (AttributeSelection as) = sequence (foldMap 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 (foldMap toAsn1 xs) + Or xs -> context 1 (foldMap 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 x -> context 7 (toAsn1 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 av b) = sequence (fold + [ context 1 (optional mmr) + , context 2 (optional mad) + , context 3 (toAsn1 av) + , context 4 (single (Asn1.Boolean b)) + ]) + +sequence :: Endo [ASN1] -> Endo [ASN1] +sequence = construction Asn1.Sequence + +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 + +optional :: ToAsn1 a => Maybe a -> Endo [ASN1] +optional = maybe mempty toAsn1 + +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 index 0000000..7d1473c --- /dev/null +++ b/src/Ldap/Asn1/Type.hs @@ -0,0 +1,165 @@ +module Ldap.Asn1.Type where + +import Data.ByteString (ByteString) +import Data.Int (Int8, Int32) +import Data.List.NonEmpty (NonEmpty) +import Data.Set (Set) +import Data.Text (Text) + + +data LdapMessage op = LdapMessage + { ldapMessageId :: !Id + , ldapMessageOp :: !op + , ldapMessageControls :: !(Maybe Controls) + } deriving (Show, Eq, Ord) + +newtype Id = Id { unId :: Int32 } + deriving (Show, Eq, Ord) + +data ProtocolClientOp = + BindRequest Int8 LdapDn AuthenticationChoice + | UnbindRequest + | SearchRequest LdapDn Scope DerefAliases Int32 Int32 Bool Filter AttributeSelection + deriving (Show, Eq, Ord) + +data ProtocolServerOp = + BindResponse LdapResult (Maybe ByteString) + | SearchResultEntry LdapDn PartialAttributeList + | SearchResultReference (NonEmpty Uri) + | SearchResultDone (LdapResult) + deriving (Show, Eq, Ord) + +data AuthenticationChoice = Simple ByteString + deriving (Show, Eq, Ord) + +data Scope = + BaseObject + | SingleLevel + | WholeSubtree + deriving (Show, Eq, Ord) + +data DerefAliases = + NeverDerefAliases + | DerefInSearching + | DerefFindingBaseObject + | DerefAlways + deriving (Show, Eq, Ord) + +data Filter = + And (NonEmpty Filter) + | Or (NonEmpty Filter) + | Not Filter + | EqualityMatch AttributeValueAssertion + | Substrings SubstringFilter + | GreaterOrEqual AttributeValueAssertion + | LessOrEqual AttributeValueAssertion + | Present AttributeDescription + | ApproxMatch AttributeValueAssertion + | ExtensibleMatch MatchingRuleAssertion + deriving (Show, Eq, Ord) + +data SubstringFilter = SubstringFilter AttributeDescription (NonEmpty Substring) + deriving (Show, Eq, Ord) + +data Substring = + Initial AssertionValue + | Any AssertionValue + | Final AssertionValue + deriving (Show, Eq, Ord) + +data MatchingRuleAssertion = MatchingRuleAssertion (Maybe MatchingRuleId) (Maybe AttributeDescription) AssertionValue Bool + deriving (Show, Eq, Ord) + +newtype MatchingRuleId = MatchingRuleId LdapString + deriving (Show, Eq, Ord) + +newtype AttributeSelection = AttributeSelection [LdapString] + deriving (Show, Eq, Ord) + +newtype PartialAttributeList = PartialAttributeList [PartialAttribute] + deriving (Show, Eq, Ord) + +newtype Controls = Controls [Control] + deriving (Show, Eq, Ord) + +data Control = Control LdapOid Bool (Maybe ByteString) + deriving (Show, Eq, Ord) + +data LdapResult = LdapResult ResultCode LdapDn LdapString (Maybe ReferralUris) + deriving (Show, Eq, Ord) + +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, Ord) + +newtype AttributeDescription = AttributeDescription LdapString + deriving (Show, Eq, Ord) + +newtype AttributeValue = AttributeValue ByteString + deriving (Show, Eq, Ord) + +data AttributeValueAssertion = AttributeValueAssertion AttributeDescription AssertionValue + deriving (Show, Eq, Ord) + +newtype AssertionValue = AssertionValue ByteString + deriving (Show, Eq, Ord) + +data PartialAttribute = PartialAttribute AttributeDescription (Set AttributeValue) + deriving (Show, Eq, Ord) + +newtype LdapDn = LdapDn LdapString + deriving (Show, Eq, Ord) + +newtype ReferralUris = ReferralUris (NonEmpty Uri) + deriving (Show, Eq, Ord) + +newtype Uri = Uri LdapString + deriving (Show, Eq, Ord) + +-- | 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. +newtype LdapString = LdapString Text + deriving (Show, Eq, Ord) + +newtype LdapOid = LdapOid ByteString + deriving (Show, Eq, Ord) diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs new file mode 100644 index 0000000..493704a --- /dev/null +++ b/src/Ldap/Client.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +module Ldap.Client + ( Host(..) + , PortNumber + , Ldap + , LdapError(..) + , Async + , with + -- * Bind Request + , Dn(..) + , Password(..) + , bind + , bindEither + , bindAsync + , bindAsyncSTM + -- * Search Request + , Type.Scope(..) + , Attr(..) + , SearchEntry(..) + , search + , searchEither + , searchAsync + , searchAsyncSTM + , Search + , defaultSearch + , scope + , size + , time + , typesOnly + , derefAliases + , Filter(..) + -- * Unbind Request + , unbindAsync + , unbindAsyncSTM + -- * Waiting for Request Completion + , wait + , waitSTM + ) where + +import qualified Control.Concurrent.Async as Async +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, putTMVar, readTMVar) +import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue) +import Control.Exception (Exception, Handler(..), bracket, throwIO, catches) +import Control.Monad (forever, void) +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 (traverse_, asum) +import Data.Function (fix) +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Monoid (Endo(appEndo)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Typeable (Typeable) +import Network.Connection (Connection) +import qualified Network.Connection as Conn +import Network (PortNumber) +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 + + +data Host = + Plain String + | Secure String + deriving (Show, Eq, Ord) + +data Ldap = Ldap + { client :: TQueue ClientMessage + } deriving (Eq) + +data ClientMessage = New Request (TMVar (NonEmpty Type.ProtocolServerOp)) +type Request = Type.ProtocolClientOp +type InMessage = Type.ProtocolServerOp +type Response = NonEmpty InMessage + +newLdap :: IO Ldap +newLdap = Ldap + <$> newTQueueIO + +data LdapError = + IOError IOError + | ParseError Asn1.ASN1Error + | BindError BindError + | SearchError SearchError + deriving (Show, Eq) + +-- | The entrypoint into LDAP. +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 + Async.withAsync (input inq conn) $ \i -> + Async.withAsync (output outq conn) $ \o -> + Async.withAsync (dispatch l inq outq) $ \d -> + Async.withAsync (f l) $ \u -> + fmap (Right . snd) (Async.waitAnyCancel [i, o, d, u]))) + `catches` + [ Handler (return . Left . IOError) + , Handler (return . Left . ParseError) + , Handler (return . Left . BindError) + , Handler (return . Left . SearchError) + ] + where + params = Conn.ConnectionParams + { Conn.connectionHostname = + case host of + Plain h -> h + Secure h -> h + , Conn.connectionPort = port + , Conn.connectionUseSecure = + case host of + Plain _ -> Nothing + Secure _ -> Just Conn.TLSSettingsSimple + { Conn.settingDisableCertificateValidation = False + , Conn.settingDisableSession = False + , Conn.settingUseServerName = False + } + , Conn.connectionUseSocks = Nothing + } + +input :: FromAsn1 a => TQueue a -> Connection -> IO b +input inq conn = flip fix [] $ \loop chunks -> do + chunk <- Conn.connectionGet conn 8192 + case ByteString.length chunk of + 0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing) + _ -> do + let chunks' = chunk : chunks + case Asn1.decodeASN1 Asn1.DER (ByteString.Lazy.fromChunks (reverse chunks')) of + Left Asn1.ParsingPartial + -> loop chunks' + Left e -> throwIO e + Right asn1 -> do + flip fix asn1 $ \loop' asn1' -> + case parseAsn1 asn1' of + Nothing -> return () + Just (asn1'', a) -> do + atomically (writeTQueue inq a) + loop' asn1'' + loop [] + +output :: ToAsn1 a => TQueue a -> Connection -> IO b +output out conn = forever $ + Conn.connectionPut conn . encode . toAsn1 =<< atomically (readTQueue out) + where + encode x = Asn1.encodeASN1' Asn1.DER (appEndo x []) + +dispatch :: Ldap -> TQueue (Type.LdapMessage InMessage) -> TQueue (Type.LdapMessage Request) -> IO a +dispatch Ldap { client } inq outq = + flip fix (Map.empty, Map.empty, 1) $ \loop (!got, !results, !counter) -> do + loop =<< atomically (asum + [ do New new var <- readTQueue client + writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing) + return (got, Map.insert (Type.Id counter) var results, counter + 1) + , do Type.LdapMessage mid op _ <- readTQueue inq + case op of + Type.BindResponse {} -> do + traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results) + return (Map.delete mid got, Map.delete mid results, counter) + Type.SearchResultEntry {} -> do + return (Map.insertWith (++) mid [op] got, results, counter) + Type.SearchResultReference {} -> do + return (got, results, counter) + Type.SearchResultDone {} -> do + let stack = Map.findWithDefault [] mid got + traverse_ (\var -> putTMVar var (op :| stack)) (Map.lookup mid results) + return (Map.delete mid got, Map.delete mid results, counter) + ]) + + +data Async e a = Async (STM (Either e a)) + +instance Functor (Async e) where + fmap f (Async stm) = Async (fmap (fmap f) stm) + + +newtype Dn = Dn Text + deriving (Show, Eq) +newtype Password = Password ByteString + deriving (Show, Eq) + +data BindError = + BindInvalidResponse Response + | BindErrorCode Type.ResultCode + deriving (Show, Eq, Typeable) + +instance Exception BindError + +-- | Throws 'BindError' on failure. Don't worry, the nearest 'with' +-- will catch it, so it won't destroy your program. +bind :: Ldap -> Dn -> Password -> IO () +bind l username password = + raise =<< bindEither l username password + +bindEither :: Ldap -> Dn -> Password -> IO (Either BindError ()) +bindEither l username password = + wait =<< bindAsync l username password + +bindAsync :: Ldap -> Dn -> Password -> IO (Async BindError ()) +bindAsync l username password = + atomically (bindAsyncSTM l username password) + +bindAsyncSTM :: Ldap -> Dn -> Password -> STM (Async BindError ()) +bindAsyncSTM l username password = + sendRequest l bindResult (bindRequest username password) + +bindRequest :: Dn -> Password -> Request +bindRequest (Dn username) (Password password) = + Type.BindRequest ldapVersion + (Type.LdapDn (Type.LdapString username)) + (Type.Simple password) + where + ldapVersion = 3 + +bindResult :: Response -> Either BindError () +bindResult (Type.BindResponse (Type.LdapResult code _ _ _) _ :| []) + | Type.Success <- code = Right () + | otherwise = Left (BindErrorCode code) +bindResult res = Left (BindInvalidResponse res) + + +data SearchError = + SearchInvalidResponse Response + | SearchErrorCode Type.ResultCode + deriving (Show, Eq, Typeable) + +instance Exception SearchError + +search + :: Ldap + -> Dn + -> Mod Search + -> Filter + -> [Attr] + -> IO [SearchEntry] +search l base opts flt attributes = + raise =<< searchEither l base opts flt attributes + +searchEither + :: Ldap + -> Dn + -> Mod Search + -> Filter + -> [Attr] + -> IO (Either SearchError [SearchEntry]) +searchEither l base opts flt attributes = + wait =<< searchAsync l base opts flt attributes + +searchAsync + :: Ldap + -> Dn + -> Mod Search + -> Filter + -> [Attr] + -> IO (Async SearchError [SearchEntry]) +searchAsync l base opts flt attributes = + atomically (searchAsyncSTM l base opts flt attributes) + +searchAsyncSTM + :: Ldap + -> Dn + -> Mod Search + -> Filter + -> [Attr] + -> STM (Async SearchError [SearchEntry]) +searchAsyncSTM l base opts flt attributes = + sendRequest l searchResult (searchRequest base opts flt attributes) + +searchResult :: Response -> Either SearchError [SearchEntry] +searchResult (Type.SearchResultDone (Type.LdapResult code _ _ _) :| xs) + | Type.Success <- code = Right (mapMaybe g xs) + | otherwise = Left (SearchErrorCode code) + 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, Set.map j y) + j (Type.AttributeValue x) = x +searchResult res = Left (SearchInvalidResponse res) + +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) + +data Search = Search + { _scope :: Type.Scope + , _derefAliases :: Type.DerefAliases + , _size :: Int32 + , _time :: Int32 + , _typesOnly :: Bool + } deriving (Show, Eq) + +defaultSearch :: Search +defaultSearch = Search + { _scope = Type.BaseObject + , _size = 0 + , _time = 0 + , _typesOnly = False + , _derefAliases = Type.NeverDerefAliases + } + +scope :: Type.Scope -> Mod Search +scope x = Mod (\y -> y { _scope = x }) + +size :: Int32 -> Mod Search +size x = Mod (\y -> y { _size = x }) + +time :: Int32 -> Mod Search +time x = Mod (\y -> y { _time = x }) + +typesOnly :: Bool -> Mod Search +typesOnly x = Mod (\y -> y { _typesOnly = x }) + +derefAliases :: Type.DerefAliases -> Mod Search +derefAliases x = Mod (\y -> y { _derefAliases = x }) + +newtype Mod a = Mod (a -> a) + +instance Monoid (Mod a) where + mempty = Mod id + Mod f `mappend` Mod g = Mod (g . f) + +data Filter = + Not 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 + +newtype Attr = Attr Text + deriving (Show, Eq) + +-- '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 + +data SearchEntry = SearchEntry Dn [(Attr, Set ByteString)] + deriving (Show, Eq) + + +-- | 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" + + +wait :: Async e a -> IO (Either e a) +wait = atomically . waitSTM + +waitSTM :: Async e a -> STM (Either e a) +waitSTM (Async stm) = stm + + +sendRequest :: Ldap -> (Response -> Either e a) -> Request -> STM (Async e 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