.github_changelog_generator

@@ -1,9 +0,0 @@
-user=alasconnect
-project=ldap-client
-output=CHANGELOG.md
-
-release-branch=master
-since-tag=0.2.0
-
-header=# LDAP Client Changelog
-exclude-labels=documentation

.gitignore

@@ -1,5 +1,4 @@
 dist/
-dist-newstyle/
 .cabal-sandbox/
 cabal.sandbox.config
 node_modules

.travis.yml

@@ -1,20 +1,27 @@
-language: haskell
+language: c
 
 sudo: false
 
-git:
-  depth: 5
-
-cache:
-  directories:
-    - "$HOME/.cabal/store"
-
 matrix:
   include:
-    - ghc: 8.0.1
+    - env: CABALVER=1.16 GHCVER=7.6.3
-    - ghc: 8.2.2
+      addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}
-    - ghc: 8.4.4
+    - env: CABALVER=1.18 GHCVER=7.8.4
-    - ghc: 8.6.5
+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.3 RUN_TESTS=--run-tests
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3],sources: [hvr-ghc]}}
+    - env: CABALVER=1.24 GHCVER=8.0.1 RUN_TESTS=--run-tests
+      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1],sources: [hvr-ghc]}}
+    - env: CABALVER=head GHCVER=head RUN_TESTS=--run-tests
+      addons: {apt: {packages: [cabal-install-head,ghc-head],  sources: [hvr-ghc]}}
+
+  allow_failures:
+    - env: CABALVER=1.16 GHCVER=7.6.3 # weird spec problems
+    - env: CABALVER=1.18 GHCVER=7.8.4 # weird spec problems
+    - env: CABALVER=head GHCVER=head RUN_TESTS=--run-tests
+
+before_install:
+  - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
 
 install:
   - cabal update

CHANGELOG.markdown

@@ -0,0 +1,13 @@
+next
+====
+
+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)

CHANGELOG.md

@@ -1,18 +0,0 @@
-# LDAP Client Changelog
-
-
-## [0.4.0](https://github.com/alasconnect/ldap-client/tree/0.4.0) (2019-11-07)
-
-[Full Changelog](https://github.com/alasconnect/ldap-client/compare/0.3.0...0.4.0)
-
-**Merged pull requests:**
-
-- Poolable  [\#1](https://github.com/alasconnect/ldap-client/pull/1) ([dminuoso](https://github.com/dminuoso))
-
-## [0.3.0](https://github.com/alasconnect/ldap-client/tree/0.3.0) (2019-11-06)
-
-[Full Changelog](https://github.com/alasconnect/ldap-client/compare/0.2.0...0.3.0)
-
-
-
-\* *This Changelog was automatically generated by [github_changelog_generator](https://github.com/github-changelog-generator/github-changelog-generator)*

README.markdown

@@ -1,27 +1,27 @@
 ldap-client
 ===========
 [![Hackage](https://budueba.com/hackage/ldap-client)](https://hackage.haskell.org/package/ldap-client)
-[![Build Status](https://travis-ci.org/alasconnect/ldap-client.svg?branch=master)](https://travis-ci.org/alasconnect/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
+          Feature            |   RFC Section   |   Support
-|:---------------------------- |:---------------:|:-----------:
+:--------------------------- |:---------------:|:-----------:
-| Bind Operation               | [4.2][4.2]      | ✔
+Bind Operation               | [4.2][4.2]      | ✔
-| Unbind Operation             | [4.3][4.3]      | ✔
+Unbind Operation             | [4.3][4.3]      | ✔
-| Unsolicited Notification     | [4.4][4.4]      | ✔
+Unsolicited Notification     | [4.4][4.4]      | ✔
-| Notice of Disconnection      | [4.4.1][4.4.1]  | ✔
+Notice of Disconnection      | [4.4.1][4.4.1]  | ✔
-| Search Operation             | [4.5][4.5]      | ✔\*
+Search Operation             | [4.5][4.5]      | ✔\*
-| Modify Operation             | [4.6][4.6]      | ✔
+Modify Operation             | [4.6][4.6]      | ✔
-| Add Operation                | [4.7][4.7]      | ✔
+Add Operation                | [4.7][4.7]      | ✔
-| Delete Operation             | [4.8][4.8]      | ✔
+Delete Operation             | [4.8][4.8]      | ✔
-| Modify DN Operation          | [4.9][4.9]      | ✔
+Modify DN Operation          | [4.9][4.9]      | ✔
-| Compare Operation            | [4.10][4.10]    | ✔
+Compare Operation            | [4.10][4.10]    | ✔
-| Abandon Operation            | [4.11][4.11]    | ✘
+Abandon Operation            | [4.11][4.11]    | ✘
-| Extended Operation           | [4.12][4.12]    | ✔
+Extended Operation           | [4.12][4.12]    | ✔
-| IntermediateResponse Message | [4.13][4.13]    | ✔
+IntermediateResponse Message | [4.13][4.13]    | ✔
-| StartTLS Operation           | [4.14][4.14]    | ✔†
+StartTLS Operation           | [4.14][4.14]    | ✔†
-| LDAP over TLS                | -               | ✔
+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.

example/login.hs

@@ -31,7 +31,7 @@ import qualified System.IO as IO              -- base
 
 data Conf = Conf
   { host     :: String
-  , port     :: Int
+  , port     :: PortNumber
   , dn       :: Dn
   , password :: Password
   , base     :: Dn

ldap-client.cabal

@@ -1,30 +1,30 @@
 name:                ldap-client
-version:             0.4.0
+version:             0.2.0
 synopsis:            Pure Haskell LDAP Client Library
 description:
   Pure Haskell LDAP client library implementing (the parts of) RFC 4511.
-homepage:            https://github.com/alasconnect/ldap-client
+homepage:            https://supki.github.io/ldap-client
 license:             BSD2
 license-file:        LICENSE
-author:              Matvey Aksenov, AlasConnect LLC
+author:              Matvey Aksenov
-maintainer:          matvey.aksenov@gmail.com, software@alasconnect.com
+maintainer:          matvey.aksenov@gmail.com
-copyright:           2015 Matvey Aksenov, 2019 AlasConnect LLC
+copyright:           2015 Matvey Aksenov
 category:            Network
 build-type:          Simple
 cabal-version:       >= 1.10
 tested-with:
-    GHC == 8.0.1
+    GHC == 7.6.3
-  , GHC == 8.2.2
+  , GHC == 7.8.4
-  , GHC == 8.4.4
+  , GHC == 7.10.1
-  , GHC == 8.6.5
+  , GHC == 8.0.1
 extra-source-files:
-  README.md
+  README.markdown
-  CHANGELOG.md
+  CHANGELOG.markdown
 
 source-repository head
   type:     git
-  location: git@github.com:alasconnect/ldap-client
+  location: git@github.com:supki/ldap-client
-  tag:      0.4.0
+  tag:      0.2.0
 
 library
   ghc-options:
@@ -57,7 +57,6 @@ library
     , bytestring
     , connection    >= 0.2
     , containers
-    , fail
     , network       >= 2.6
     , semigroups    >= 0.16
     , stm

package.nix

@@ -4,7 +4,7 @@
 }:
 mkDerivation {
   pname = "ldap-client";
-  version = "0.4.0";
+  version = "0.1.0";
   src = ./.;
   buildDepends = [
     asn1-encoding asn1-types async base bytestring connection

src/Ldap/Asn1/FromAsn1.hs

@@ -11,9 +11,6 @@ import           Control.Applicative (Alternative(..), liftA2, optional)
 import           Control.Applicative (Applicative(..), Alternative(..), liftA2, optional)
 #endif
 import           Control.Monad (MonadPlus(..), (>=>), guard)
-#if __GLASGOW_HASKELL__ >= 86
-import           Control.Monad.Fail (MonadFail, fail)
-#endif
 import           Data.ASN1.Types (ASN1)
 import qualified Data.ASN1.Types as Asn1
 import           Data.Foldable (asum)
@@ -419,11 +416,6 @@ instance MonadPlus (Parser s) where
   Parser ma `mplus` Parser mb =
     Parser (\s -> ma s `mplus` mb s)
 
-#if __GLASGOW_HASKELL__ >= 86
-instance MonadFail (Parser s) where
-  fail _ = mzero
-#endif
-
 parse :: Parser s a -> s -> Maybe (s, a)
 parse = unParser
 

src/Ldap/Client.hs

@@ -2,8 +2,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 -- | This module is intended to be imported qualified
 --
 -- @
@@ -11,17 +9,11 @@
 -- @
 module Ldap.Client
   ( with
-  , with'
-  , runsIn
-  , runsInEither
-  , open
-  , close
   , Host(..)
   , defaultTlsSettings
   , insecureTlsSettings
   , PortNumber
   , Ldap
-  , LdapH
   , LdapError(..)
   , ResponseError(..)
   , Type.ResultCode(..)
@@ -74,9 +66,8 @@ 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, bracket, throwIO, SomeException, fromException, throw, Handler(..))
+import           Control.Exception (Exception, Handler(..), bracket, throwIO, catch, catches)
 import           Control.Monad (forever)
-import           Data.Void (Void)
 import qualified Data.ASN1.BinaryEncoding as Asn1
 import qualified Data.ASN1.Encoding as Asn1
 import qualified Data.ASN1.Error as Asn1
@@ -123,99 +114,50 @@ import           Ldap.Client.Extended (Oid(..), extended, noticeOfDisconnectionO
 {-# ANN module ("HLint: ignore Use first" :: String) #-}
 
 
+newLdap :: IO Ldap
+newLdap = Ldap
+  <$> newTQueueIO
+
 -- | Various failures that can happen when working with LDAP.
-data LdapError
+data LdapError =
-  = IOError !IOError             -- ^ Network failure.
+    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)
 
-instance Exception LdapError
+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
 
-newtype LdapH = LdapH Ldap
-
--- | Provide a 'LdapH' to a function needing an 'Ldap' handle.
-runsIn :: (Ldap -> IO a)
-       -> LdapH
-       -> IO a
-runsIn act (LdapH ldap) = do
-  actor <- Async.async (act ldap)
-  r <- Async.waitEitherCatch (workers ldap) actor
-  case r of
-    Left (Right _a) -> error "Unreachable"
-    Left (Left e)   -> throwIO =<< catchesHandler workerErr e
-    Right (Right r') -> pure r'
-    Right (Left e)  -> throwIO =<< catchesHandler respErr e
-
--- | Provide a 'LdapH' to a function needing an 'Ldap' handle
-runsInEither :: (Ldap -> IO a)
-             -> LdapH
-             -> IO (Either LdapError a)
-runsInEither act (LdapH ldap) = do
-  actor <- Async.async (act ldap)
-  r <- Async.waitEitherCatch (workers ldap) actor
-  case r of
-    Left (Right _a) -> error "Unreachable"
-    Left (Left e)   -> do Left <$> catchesHandler workerErr e
-    Right (Right r') -> pure (Right r')
-    Right (Left e)  -> do Left <$> catchesHandler respErr e
-
-
-workerErr :: [Handler LdapError]
-workerErr = [ Handler (\(ex :: IOError) -> pure (IOError ex))
-            , Handler (\(ex :: Asn1.ASN1Error) -> pure (ParseError ex))
-            , Handler (\(ex :: Disconnect) -> pure (DisconnectError ex))
-            ]
-
-respErr :: [Handler LdapError]
-respErr = [ Handler (\(ex :: ResponseError) -> pure (ResponseError ex))
-          ]
-
-catchesHandler :: [Handler a] -> SomeException -> IO a
-catchesHandler handlers e = foldr tryHandler (throw e) handlers
-    where tryHandler (Handler handler) res
-              = case fromException e of
-                Just e' -> handler e'
-                Nothing -> res
-
 -- | The entrypoint into LDAP.
-with' :: Host -> PortNumber -> (Ldap -> IO a) -> IO a
+--
-with' host port act = bracket (open host port) close (runsIn act)
+-- It catches all LDAP-related exceptions.
-
 with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
-with host port act = bracket (open host port) close (runsInEither act)
+with host port f = do
-
--- | Creates an LDAP handle. This action is useful for creating your own resource
--- management, such as with 'resource-pool'. The handle must be manually closed
--- with 'close'.
-open :: Host -> PortNumber -> IO (LdapH)
-open host port = do
   context <- Conn.initConnectionContext
-  conn <- Conn.connectTo context params
+  bracket (Conn.connectTo context params) Conn.connectionClose (\conn ->
-  reqQ <- newTQueueIO
+    bracket newLdap unbindAsync (\l -> do
-  inQ  <- newTQueueIO
+      inq  <- newTQueueIO
-  outQ <- newTQueueIO
+      outq <- newTQueueIO
-
+      as   <- traverse Async.async
-  -- The input worker that reads data off the network.
+        [ input inq conn
-  (inW :: Async.Async Void)   <- Async.async (input inQ conn)
+        , output outq conn
-
+        , dispatch l inq outq
-  -- The output worker that sends data onto the network.
+        , f l
-  (outW :: Async.Async Void)  <- Async.async (output outQ conn)
+        ]
-
+      fmap (Right . snd) (Async.waitAnyCancel as)))
-  -- The dispatch worker that sends data between the three queues.
+ `catches`
-  (dispW :: Async.Async Void) <- Async.async (dispatch reqQ inQ outQ)
+  [ Handler (\(WrappedIOError e) -> return (Left (IOError e)))
-
+  , Handler (return . Left . ParseError)
-  -- We use this to propagate exceptions between the workers. The `workers` Async is just a tool to
+  , Handler (return . Left . ResponseError)
-  -- exchange exceptions between the entire worker group and another thread.
+  ]
-  workers <- Async.async (snd <$> Async.waitAnyCancel [inW, outW, dispW])
-
-  pure (LdapH (Ldap reqQ workers conn))
  where
   params = Conn.ConnectionParams
     { Conn.connectionHostname =
@@ -230,14 +172,6 @@ open host port = do
     , Conn.connectionUseSocks = Nothing
     }
 
--- | Closes an LDAP connection.
--- This is to be used in together with 'open'.
-close :: LdapH -> IO ()
-close (LdapH ldap) = do
-  unbindAsync ldap
-  Conn.connectionClose (conn ldap)
-  Async.cancel (workers ldap)
-
 defaultTlsSettings :: Conn.TLSSettings
 defaultTlsSettings = Conn.TLSSettingsSimple
   { Conn.settingDisableCertificateValidation = False
@@ -252,85 +186,84 @@ insecureTlsSettings = Conn.TLSSettingsSimple
   , Conn.settingUseServerName = False
   }
 
--- | Reads Asn1 BER encoded chunks off a connection into a TQueue.
 input :: FromAsn1 a => TQueue a -> Connection -> IO b
-input inq conn = loop []
+input inq conn = wrap . flip fix [] $ \loop chunks -> do
-  where
+  chunk <- Conn.connectionGet conn 8192
-    loop chunks = do
+  case ByteString.length chunk of
-      chunk <- Conn.connectionGet conn 8192
+    0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)
-      case ByteString.length chunk of
+    _ -> do
-        0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)
+      let chunks' = chunk : chunks
-        _ -> do
+      case Asn1.decodeASN1 Asn1.BER (ByteString.Lazy.fromChunks (reverse chunks')) of
-          let chunks' = chunk : chunks
+        Left  Asn1.ParsingPartial
-          case Asn1.decodeASN1 Asn1.BER (ByteString.Lazy.fromChunks (reverse chunks')) of
+                   -> loop chunks'
-            Left  Asn1.ParsingPartial
+        Left  e    -> throwIO e
-                      -> loop chunks'
+        Right asn1 -> do
-            Left  e    -> throwIO e
+          flip fix asn1 $ \loop' asn1' ->
-            Right asn1 -> do
+            case parseAsn1 asn1' of
-              flip fix asn1 $ \loop' asn1' ->
+              Nothing -> return ()
-                case parseAsn1 asn1' of
+              Just (asn1'', a) -> do
-                  Nothing -> return ()
+                atomically (writeTQueue inq a)
-                  Just (asn1'', a) -> do
+                loop' asn1''
-                    atomically (writeTQueue inq a)
+          loop []
-                    loop' asn1''
-              loop []
 
--- | Transmits Asn1 DER encoded data from a TQueue into a Connection.
 output :: ToAsn1 a => TQueue a -> Connection -> IO b
-output out conn = forever $ do
+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
-  :: TQueue ClientMessage
+  :: Ldap
   -> TQueue (Type.LdapMessage Type.ProtocolServerOp)
   -> TQueue (Type.LdapMessage Request)
   -> IO a
-dispatch reqq inq outq = loop (Map.empty, 1)
+dispatch Ldap { client } inq outq =
-  where
+  flip fix (Map.empty, 1) $ \loop (!req, !counter) ->
-    saveUp mid op res = return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
+    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)
 
-    loop (!req, !counter) =
+  done mid op req =
-      loop =<< atomically (asum
+    case Map.lookup mid req of
-        [ do New new var <- readTQueue reqq
+      Nothing -> return req
-             writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing)
+      Just (stack, var) -> do
-             return (Map.insert (Type.Id counter) ([], var) req, counter + 1)
+        putTMVar var (op :| stack)
-        , do Type.LdapMessage mid op _
+        return (Map.delete mid req)
-                <- 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)
-        ])
 
-    done mid op req =
+  probablyDisconnect (Type.Id 0)
-      case Map.lookup mid req of
+                     (Type.ExtendedResponse
-        Nothing -> return req
+                       (Type.LdapResult code
-        Just (stack, var) -> do
+                                        (Type.LdapDn (Type.LdapString dn))
-          putTMVar var (op :| stack)
+                                        (Type.LdapString reason)
-          return (Map.delete mid req)
+                                        _)
+                       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
 
-    probablyDisconnect (Type.Id 0)
+wrap :: IO a -> IO a
-                      (Type.ExtendedResponse
+wrap m = m `catch` (throwIO . WrappedIOError)
-                        (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

src/Ldap/Client/Add.hs

@@ -31,7 +31,7 @@ import           Ldap.Client.Internal
 -- | Perform the Add operation synchronously. Raises 'ResponseError' on failures.
 add :: Ldap -> Dn -> AttrList NonEmpty -> IO ()
 add l dn as =
-  eitherToIO =<< addEither l dn as
+  raise =<< addEither l dn as
 
 -- | Perform the Add operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.

src/Ldap/Client/Bind.hs

@@ -42,7 +42,7 @@ newtype Password = Password ByteString
 -- | Perform the Bind operation synchronously. Raises 'ResponseError' on failures.
 bind :: Ldap -> Dn -> Password -> IO ()
 bind l username password =
-  eitherToIO =<< bindEither l username password
+  raise =<< bindEither l username password
 
 -- | Perform the Bind operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.
@@ -82,7 +82,7 @@ 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 =
-  eitherToIO =<< externalBindEither 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.

src/Ldap/Client/Compare.hs

@@ -33,7 +33,7 @@ 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 =
-  eitherToIO =<< compareEither 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.

src/Ldap/Client/Delete.hs

@@ -31,7 +31,7 @@ import           Ldap.Client.Internal
 -- | Perform the Delete operation synchronously. Raises 'ResponseError' on failures.
 delete :: Ldap -> Dn -> IO ()
 delete l dn =
-  eitherToIO =<< deleteEither l dn
+  raise =<< deleteEither l dn
 
 -- | Perform the Delete operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.

src/Ldap/Client/Extended.hs

@@ -54,7 +54,7 @@ instance IsString Oid where
 -- | Perform the Extended operation synchronously. Raises 'ResponseError' on failures.
 extended :: Ldap -> Oid -> Maybe ByteString -> IO ()
 extended l oid mv =
-  eitherToIO =<< extendedEither l oid mv
+  raise =<< extendedEither l oid mv
 
 -- | Perform the Extended operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.
@@ -92,7 +92,7 @@ extendedResult req res = Left (ResponseInvalid req res)
 -- | An example of @Extended Operation@, cf. 'extended'.
 startTls :: Ldap -> IO ()
 startTls =
-  eitherToIO <=< startTlsEither
+  raise <=< startTlsEither
 
 -- | An example of @Extended Operation@, cf. 'extendedEither'.
 startTlsEither :: Ldap -> IO (Either ResponseError ())

src/Ldap/Client/Internal.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Ldap.Client.Internal
@@ -16,7 +15,7 @@ module Ldap.Client.Internal
   , Response
   , ResponseError(..)
   , Request
-  , eitherToIO
+  , raise
   , sendRequest
   , Dn(..)
   , Attr(..)
@@ -27,7 +26,6 @@ module Ldap.Client.Internal
   , unbindAsyncSTM
   ) where
 
-import qualified Control.Concurrent.Async as Async (Async)
 import           Control.Concurrent.STM (STM, atomically)
 import           Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, readTMVar)
 import           Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
@@ -37,13 +35,8 @@ import           Data.ByteString (ByteString)
 import           Data.List.NonEmpty (NonEmpty)
 import           Data.Text (Text)
 import           Data.Typeable (Typeable)
-#if __GLASGOW_HASKELL__ >= 84
-import           Network.Socket (PortNumber)
-#else
 import           Network (PortNumber)
-#endif
+import           Network.Connection (TLSSettings)
-import           Network.Connection (TLSSettings, Connection)
-import           Data.Void (Void)
 
 import qualified Ldap.Asn1.Type as Type
 
@@ -54,12 +47,10 @@ data Host =
   | Tls String TLSSettings -- ^ LDAP over TLS.
     deriving (Show)
 
--- | An LDAP connection handle
+-- | A token. All functions that interact with the Directory require one.
-data Ldap = Ldap
+newtype Ldap = Ldap
-  { reqQ    :: !(TQueue ClientMessage) -- ^ Request queue for client messages to be send.
+  { client  :: TQueue ClientMessage
-  , workers :: !(Async.Async Void) -- ^ Workers group for communicating with the server.
+  } deriving (Eq)
-  , conn    :: !Connection -- ^ Network connection to the server.
-  }
 
 data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp))
 type Request = Type.ProtocolClientOp
@@ -120,10 +111,11 @@ sendRequest l p msg =
      return (Async (fmap p (readTMVar var)))
 
 writeRequest :: Ldap -> TMVar Response -> Request -> STM ()
-writeRequest Ldap { reqQ } var msg = writeTQueue reqQ (New msg var)
+writeRequest Ldap { client } var msg = writeTQueue client (New msg var)
+
+raise :: Exception e => Either e a -> IO a
+raise = either throwIO return
 
-eitherToIO :: Exception e => Either e a -> IO a
-eitherToIO = either throwIO pure
 
 -- | Terminate the connection to the Directory.
 --

src/Ldap/Client/Modify.hs

@@ -48,7 +48,7 @@ data Operation =
 -- | Perform the Modify operation synchronously. Raises 'ResponseError' on failures.
 modify :: Ldap -> Dn -> [Operation] -> IO ()
 modify l dn as =
-  eitherToIO =<< modifyEither l dn as
+  raise =<< modifyEither l dn as
 
 -- | Perform the Modify operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.
@@ -98,7 +98,7 @@ newtype RelativeDn = RelativeDn Text
 -- | Perform the Modify DN operation synchronously. Raises 'ResponseError' on failures.
 modifyDn :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO ()
 modifyDn l dn rdn del new =
-  eitherToIO =<< modifyDnEither 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.

src/Ldap/Client/Search.hs

@@ -52,7 +52,7 @@ 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 =
-  eitherToIO =<< searchEither 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.