Merge pull request #3 from alasconnect/combinechangelogs

Updated documentation

.github_changelog_generator

@@ -0,0 +1,9 @@
+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,4 +1,5 @@
 dist/
+dist-newstyle/
 .cabal-sandbox/
 cabal.sandbox.config
 node_modules

.travis.yml

@@ -1,27 +1,20 @@
-language: c
+language: haskell
 
 sudo: false
 
+git:
+  depth: 5
+
+cache:
+  directories:
+    - "$HOME/.cabal/store"
+
 matrix:
   include:
-    - env: CABALVER=1.16 GHCVER=7.6.3
-      addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}
-    - env: CABALVER=1.18 GHCVER=7.8.4
-      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
+    - ghc: 8.0.1
+    - ghc: 8.2.2
+    - ghc: 8.4.4
+    - ghc: 8.6.5
 
 install:
   - cabal update

CHANGELOG.markdown

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

@@ -0,0 +1,18 @@
+# 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.md

@@ -1,7 +1,7 @@
 ldap-client
 ===========
 [![Hackage](https://budueba.com/hackage/ldap-client)](https://hackage.haskell.org/package/ldap-client)
-[![Build Status](https://travis-ci.org/supki/ldap-client.svg?branch=master)](https://travis-ci.org/supki/ldap-client)
+[![Build Status](https://travis-ci.org/alasconnect/ldap-client.svg?branch=master)](https://travis-ci.org/alasconnect/ldap-client)
 
 This library implements (the parts of) [RFC 4511][rfc4511]
 

example/login.hs

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

ldap-client.cabal

@@ -1,30 +1,30 @@
 name:                ldap-client
-version:             0.2.0
+version:             0.4.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
+homepage:            https://github.com/alasconnect/ldap-client
 license:             BSD2
 license-file:        LICENSE
-author:              Matvey Aksenov
-maintainer:          matvey.aksenov@gmail.com
-copyright:           2015 Matvey Aksenov
+author:              Matvey Aksenov, AlasConnect LLC
+maintainer:          matvey.aksenov@gmail.com, software@alasconnect.com
+copyright:           2015 Matvey Aksenov, 2019 AlasConnect LLC
 category:            Network
 build-type:          Simple
 cabal-version:       >= 1.10
 tested-with:
-    GHC == 7.6.3
-  , GHC == 7.8.4
-  , GHC == 7.10.1
-  , GHC == 8.0.1
+    GHC == 8.0.1
+  , GHC == 8.2.2
+  , GHC == 8.4.4
+  , GHC == 8.6.5
 extra-source-files:
-  README.markdown
-  CHANGELOG.markdown
+  README.md
+  CHANGELOG.md
 
 source-repository head
   type:     git
-  location: git@github.com:supki/ldap-client
-  tag:      0.2.0
+  location: git@github.com:alasconnect/ldap-client
+  tag:      0.4.0
 
 library
   ghc-options:
@@ -57,6 +57,7 @@ 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.1.0";
+  version = "0.4.0";
   src = ./.;
   buildDepends = [
     asn1-encoding asn1-types async base bytestring connection

src/Ldap/Asn1/FromAsn1.hs

@@ -11,6 +11,9 @@ 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)
@@ -416,6 +419,11 @@ 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,6 +2,8 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 -- | This module is intended to be imported qualified
 --
 -- @
@@ -9,11 +11,17 @@
 -- @
 module Ldap.Client
   ( with
+  , with'
+  , runsIn
+  , runsInEither
+  , open
+  , close
   , Host(..)
   , defaultTlsSettings
   , insecureTlsSettings
   , PortNumber
   , Ldap
+  , LdapH
   , LdapError(..)
   , ResponseError(..)
   , Type.ResultCode(..)
@@ -66,8 +74,9 @@ import qualified Control.Concurrent.Async as Async
 import           Control.Concurrent.STM (atomically, throwSTM)
 import           Control.Concurrent.STM.TMVar (putTMVar)
 import           Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue)
-import           Control.Exception (Exception, Handler(..), bracket, throwIO, catch, catches)
+import           Control.Exception (Exception, bracket, throwIO, SomeException, fromException, throw, Handler(..))
 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
@@ -114,50 +123,99 @@ 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 =
-    IOError !IOError             -- ^ Network failure.
+data LdapError
+  = IOError !IOError             -- ^ Network failure.
   | ParseError !Asn1.ASN1Error   -- ^ Invalid ASN.1 data received from the server.
   | ResponseError !ResponseError -- ^ An LDAP operation failed.
   | DisconnectError !Disconnect  -- ^ Notice of Disconnection has been received.
     deriving (Show, Eq)
 
-newtype WrappedIOError = WrappedIOError IOError
-    deriving (Show, Eq, Typeable)
-
-instance Exception WrappedIOError
+instance Exception LdapError
 
 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.
---
--- It catches all LDAP-related exceptions.
+with' :: Host -> PortNumber -> (Ldap -> IO a) -> IO a
+with' host port act = bracket (open host port) close (runsIn act)
+
 with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
-with host port f = do
+with host port act = bracket (open host port) close (runsInEither act)
+
+-- | 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
-  bracket (Conn.connectTo context params) Conn.connectionClose (\conn ->
-    bracket newLdap unbindAsync (\l -> do
-      inq  <- newTQueueIO
-      outq <- newTQueueIO
-      as   <- traverse Async.async
-        [ input inq conn
-        , output outq conn
-        , dispatch l inq outq
-        , f l
-        ]
-      fmap (Right . snd) (Async.waitAnyCancel as)))
- `catches`
-  [ Handler (\(WrappedIOError e) -> return (Left (IOError e)))
-  , Handler (return . Left . ParseError)
-  , Handler (return . Left . ResponseError)
-  ]
+  conn <- Conn.connectTo context params
+  reqQ <- newTQueueIO
+  inQ  <- newTQueueIO
+  outQ <- newTQueueIO
+
+  -- The input worker that reads data off the network.
+  (inW :: Async.Async Void)   <- Async.async (input inQ conn)
+
+  -- The output worker that sends data onto the network.
+  (outW :: Async.Async Void)  <- Async.async (output outQ conn)
+
+  -- The dispatch worker that sends data between the three queues.
+  (dispW :: Async.Async Void) <- Async.async (dispatch reqQ inQ outQ)
+
+  -- We use this to propagate exceptions between the workers. The `workers` Async is just a tool to
+  -- 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 =
@@ -172,6 +230,14 @@ with host port f = 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
@@ -186,84 +252,85 @@ 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 = wrap . flip fix [] $ \loop chunks -> do
-  chunk <- Conn.connectionGet conn 8192
-  case ByteString.length chunk of
-    0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)
-    _ -> do
-      let chunks' = chunk : chunks
-      case Asn1.decodeASN1 Asn1.BER (ByteString.Lazy.fromChunks (reverse chunks')) of
-        Left  Asn1.ParsingPartial
-                   -> loop chunks'
-        Left  e    -> throwIO e
-        Right asn1 -> do
-          flip fix asn1 $ \loop' asn1' ->
-            case parseAsn1 asn1' of
-              Nothing -> return ()
-              Just (asn1'', a) -> do
-                atomically (writeTQueue inq a)
-                loop' asn1''
-          loop []
+input inq conn = loop []
+  where
+    loop chunks = do
+      chunk <- Conn.connectionGet conn 8192
+      case ByteString.length chunk of
+        0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)
+        _ -> do
+          let chunks' = chunk : chunks
+          case Asn1.decodeASN1 Asn1.BER (ByteString.Lazy.fromChunks (reverse chunks')) of
+            Left  Asn1.ParsingPartial
+                      -> loop chunks'
+            Left  e    -> throwIO e
+            Right asn1 -> do
+              flip fix asn1 $ \loop' asn1' ->
+                case parseAsn1 asn1' of
+                  Nothing -> return ()
+                  Just (asn1'', a) -> do
+                    atomically (writeTQueue inq a)
+                    loop' asn1''
+              loop []
 
+-- | Transmits Asn1 DER encoded data from a TQueue into a Connection.
 output :: ToAsn1 a => TQueue a -> Connection -> IO b
-output out conn = wrap . forever $ do
+output out conn = forever $ do
   msg <- atomically (readTQueue out)
   Conn.connectionPut conn (encode (toAsn1 msg))
  where
   encode x = Asn1.encodeASN1' Asn1.DER (appEndo x [])
 
 dispatch
-  :: Ldap
+  :: TQueue ClientMessage
   -> TQueue (Type.LdapMessage Type.ProtocolServerOp)
   -> TQueue (Type.LdapMessage Request)
   -> IO a
-dispatch Ldap { client } inq outq =
-  flip fix (Map.empty, 1) $ \loop (!req, !counter) ->
-    loop =<< atomically (asum
-      [ do New new var <- readTQueue client
-           writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing)
-           return (Map.insert (Type.Id counter) ([], var) req, counter + 1)
-      , do Type.LdapMessage mid op _
-               <- readTQueue inq
-           res <- case op of
-             Type.BindResponse {}          -> done mid op req
-             Type.SearchResultEntry {}     -> saveUp mid op req
-             Type.SearchResultReference {} -> return req
-             Type.SearchResultDone {}      -> done mid op req
-             Type.ModifyResponse {}        -> done mid op req
-             Type.AddResponse {}           -> done mid op req
-             Type.DeleteResponse {}        -> done mid op req
-             Type.ModifyDnResponse {}      -> done mid op req
-             Type.CompareResponse {}       -> done mid op req
-             Type.ExtendedResponse {}      -> probablyDisconnect mid op req
-             Type.IntermediateResponse {}  -> saveUp mid op req
-           return (res, counter)
-      ])
- where
-  saveUp mid op res =
-    return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
+dispatch reqq inq outq = loop (Map.empty, 1)
+  where
+    saveUp mid op res = return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
 
-  done mid op req =
-    case Map.lookup mid req of
-      Nothing -> return req
-      Just (stack, var) -> do
-        putTMVar var (op :| stack)
-        return (Map.delete mid req)
+    loop (!req, !counter) =
+      loop =<< atomically (asum
+        [ do New new var <- readTQueue reqq
+             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)
+        ])
 
-  probablyDisconnect (Type.Id 0)
-                     (Type.ExtendedResponse
-                       (Type.LdapResult code
-                                        (Type.LdapDn (Type.LdapString dn))
-                                        (Type.LdapString reason)
-                                        _)
-                       moid _)
-                     req =
-    case moid of
-      Just (Type.LdapOid oid)
-        | Oid oid == noticeOfDisconnectionOid -> throwSTM (Disconnect code (Dn dn) reason)
-      _ -> return req
-  probablyDisconnect mid op req = done mid op req
+    done mid op req =
+      case Map.lookup mid req of
+        Nothing -> return req
+        Just (stack, var) -> do
+          putTMVar var (op :| stack)
+          return (Map.delete mid req)
 
-wrap :: IO a -> IO a
-wrap m = m `catch` (throwIO . WrappedIOError)
+    probablyDisconnect (Type.Id 0)
+                      (Type.ExtendedResponse
+                        (Type.LdapResult code
+                                          (Type.LdapDn (Type.LdapString dn))
+                                          (Type.LdapString reason)
+                                          _)
+                        moid _)
+                      req =
+      case moid of
+        Just (Type.LdapOid oid)
+          | Oid oid == noticeOfDisconnectionOid -> throwSTM (Disconnect code (Dn dn) reason)
+        _ -> return req
+    probablyDisconnect mid op req = done mid op req

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 =
-  raise =<< addEither l dn as
+  eitherToIO =<< 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 =
-  raise =<< bindEither l username password
+  eitherToIO =<< 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 =
-  raise =<< externalBindEither l username mCredentials
+  eitherToIO =<< 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 =
-  raise =<< compareEither l dn k v
+  eitherToIO =<< 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 =
-  raise =<< deleteEither l dn
+  eitherToIO =<< 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 =
-  raise =<< extendedEither l oid mv
+  eitherToIO =<< 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 =
-  raise <=< startTlsEither
+  eitherToIO <=< startTlsEither
 
 -- | An example of @Extended Operation@, cf. 'extendedEither'.
 startTlsEither :: Ldap -> IO (Either ResponseError ())

src/Ldap/Client/Internal.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Ldap.Client.Internal
@@ -15,7 +16,7 @@ module Ldap.Client.Internal
   , Response
   , ResponseError(..)
   , Request
-  , raise
+  , eitherToIO
   , sendRequest
   , Dn(..)
   , Attr(..)
@@ -26,6 +27,7 @@ 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)
@@ -35,8 +37,13 @@ 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)
-import           Network.Connection (TLSSettings)
+#endif
+import           Network.Connection (TLSSettings, Connection)
+import           Data.Void (Void)
 
 import qualified Ldap.Asn1.Type as Type
 
@@ -47,10 +54,12 @@ data Host =
   | Tls String TLSSettings -- ^ LDAP over TLS.
     deriving (Show)
 
--- | A token. All functions that interact with the Directory require one.
-newtype Ldap = Ldap
-  { client  :: TQueue ClientMessage
-  } deriving (Eq)
+-- | An LDAP connection handle
+data Ldap = Ldap
+  { reqQ    :: !(TQueue ClientMessage) -- ^ Request queue for client messages to be send.
+  , workers :: !(Async.Async Void) -- ^ Workers group for communicating with the server.
+  , conn    :: !Connection -- ^ Network connection to the server.
+  }
 
 data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp))
 type Request = Type.ProtocolClientOp
@@ -111,11 +120,10 @@ sendRequest l p 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
+writeRequest Ldap { reqQ } var msg = writeTQueue reqQ (New msg var)
 
+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 =
-  raise =<< modifyEither l dn as
+  eitherToIO =<< 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 =
-  raise =<< modifyDnEither l dn rdn del new
+  eitherToIO =<< 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 =
-  raise =<< searchEither l base opts flt attributes
+  eitherToIO =<< searchEither l base opts flt attributes
 
 -- | Perform the Search operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.