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 RUN_TESTS=
-      addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}
-    - env: CABALVER=1.18 GHCVER=7.8.4 RUN_TESTS=
-      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
-
-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,6 +0,0 @@
-next
-====
-
-  * 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)

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)*

LICENSE

@@ -1,4 +1,4 @@
-Copyright (c) 2015, Matvey Aksenov
+Copyright (c) 2015-2017, Matvey Aksenov
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

README.md

@@ -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/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]
 
-          Feature            |   RFC Section   |   Support
-:--------------------------- |:---------------:|:-----------:
-Bind Operation               | [4.2][4.2]      | ✔
-Unbind Operation             | [4.3][4.3]      | ✔
-Unsolicited Notification     | [4.4][4.4]      | ✔
-Notice of Disconnection      | [4.4.1][4.4.1]  | ✔
-Search Operation             | [4.5][4.5]      | ✔\*
-Modify Operation             | [4.6][4.6]      | ✔
-Add Operation                | [4.7][4.7]      | ✔
-Delete Operation             | [4.8][4.8]      | ✔
-Modify DN Operation          | [4.9][4.9]      | ✔
-Compare Operation            | [4.10][4.10]    | ✔
-Abandon Operation            | [4.11][4.11]    | ✘
-Extended Operation           | [4.12][4.12]    | ✔
-IntermediateResponse Message | [4.13][4.13]    | ✔
-StartTLS Operation           | [4.14][4.14]    | ✔†
-LDAP over TLS                | -               | ✔
+|           Feature            |   RFC Section   |   Support
+|:---------------------------- |:---------------:|:-----------:
+| Bind Operation               | [4.2][4.2]      | ✔
+| Unbind Operation             | [4.3][4.3]      | ✔
+| Unsolicited Notification     | [4.4][4.4]      | ✔
+| Notice of Disconnection      | [4.4.1][4.4.1]  | ✔
+| Search Operation             | [4.5][4.5]      | ✔\*
+| Modify Operation             | [4.6][4.6]      | ✔
+| Add Operation                | [4.7][4.7]      | ✔
+| Delete Operation             | [4.8][4.8]      | ✔
+| Modify DN Operation          | [4.9][4.9]      | ✔
+| Compare Operation            | [4.10][4.10]    | ✔
+| Abandon Operation            | [4.11][4.11]    | ✘
+| Extended Operation           | [4.12][4.12]    | ✔
+| IntermediateResponse Message | [4.13][4.13]    | ✔
+| StartTLS Operation           | [4.14][4.14]    | ✔†
+| LDAP over TLS                | -               | ✔
 
 \* The `:dn` thing is unsupported in Extensible matches  
 † Only serves as an example of Extended Operation.  It's useless for all practical purposes as it does not actually enable TLS.  In other words, use LDAP over TLS instead.

default.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc801" }: let
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc802" }: let
   ghc = nixpkgs.pkgs.haskell.packages.${compiler};
   npm = import ./npm {};
 in

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
@@ -55,7 +55,7 @@ main = do
 
 login :: Conf -> IO (Either LdapError ())
 login conf =
-  Ldap.with (Ldap.Secure (host conf)) (port conf) $ \l -> do
+  Ldap.with (Ldap.Tls (host conf) Ldap.defaultTlsSettings) (port conf) $ \l -> do
     Ldap.bind l (dn conf) (password conf)
     fix $ \loop -> do
       uid <- prompt "Username: "

ldap-client.cabal

@@ -1,29 +1,30 @@
 name:                ldap-client
-version:             0.1.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.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.1.0
+  location: git@github.com:alasconnect/ldap-client
+  tag:      0.4.0
 
 library
   ghc-options:
@@ -56,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

shell.nix

@@ -1,17 +1,23 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc801" }: let
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc802" }: let
   inherit (nixpkgs) pkgs;
-  ghc = pkgs.haskell.packages.${compiler}.ghcWithPackages(ps: [
+  haskell = pkgs.haskell.packages.${compiler};
+
+  ghc = haskell.ghcWithPackages(ps: [
     ps.hdevtools ps.doctest ps.hspec-discover ps.hlint ps.ghc-mod
   ]);
-  cabal-install = pkgs.haskell.packages.${compiler}.cabal-install;
-  pkg = import ./default.nix { inherit nixpkgs compiler; };
   npm = import ./npm {};
+
+  this = import ./default.nix { inherit nixpkgs compiler; };
 in
   pkgs.stdenv.mkDerivation rec {
-    name = pkg.pname;
-    buildInputs = [ ghc cabal-install npm.nodePackages.ldapjs ] ++ pkg.env.buildInputs;
+    name = this.pname;
+    buildInputs = [
+      ghc
+      haskell.cabal-install
+      npm.nodePackages.ldapjs
+    ] ++ this.env.buildInputs;
     shellHook = ''
-      ${pkg.env.shellHook}
+      ${this.env.shellHook}
       cabal configure --enable-tests --package-db=$NIX_GHC_LIBDIR/package.conf.d
     '';
   }

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/Asn1/ToAsn1.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | This module contains convertions from LDAP types to ASN.1.
 --
 -- Various hacks are employed because "asn1-encoding" only encodes to DER, but
@@ -15,7 +16,6 @@ import           Data.Foldable (fold, foldMap)
 import           Data.List.NonEmpty (NonEmpty)
 import           Data.Maybe (maybe)
 import           Data.Monoid (Endo(Endo), (<>), mempty)
-import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import           Prelude (Integer, (.), fromIntegral)
 
@@ -323,7 +323,7 @@ instance ToAsn1 AuthenticationChoice where
   toAsn1 (Simple s) = other Asn1.Context 0 s
   toAsn1 (Sasl External c) =
     context 3 (fold
-      [ toAsn1 (LdapString (Text.pack "EXTERNAL"))
+      [ toAsn1 (LdapString "EXTERNAL")
       , maybe mempty (toAsn1 . LdapString) c
       ])
 {- |

src/Ldap/Asn1/Type.hs

@@ -37,7 +37,7 @@ data ProtocolServerOp =
     BindResponse !LdapResult !(Maybe ByteString)
   | SearchResultEntry !LdapDn !PartialAttributeList
   | SearchResultReference !(NonEmpty Uri)
-  | SearchResultDone !(LdapResult)
+  | SearchResultDone !LdapResult
   | ModifyResponse !LdapResult
   | AddResponse !LdapResult
   | DeleteResponse !LdapResult
@@ -49,7 +49,7 @@ data ProtocolServerOp =
 
 -- | Not really a choice until SASL is supported.
 data AuthenticationChoice =
-    Simple ByteString
+    Simple !ByteString
   | Sasl !SaslMechanism !(Maybe Text)
     deriving (Show, Eq)
 
@@ -77,16 +77,16 @@ data DerefAliases =
 
 -- | Conditions that must be fulfilled in order for the Search to match a given entry.
 data Filter =
-    And !(NonEmpty Filter)                 -- ^ All filters evaluate to @TRUE@
-  | Or !(NonEmpty Filter)                  -- ^ Any filter evaluates to @TRUE@
-  | Not Filter                             -- ^ Filter evaluates to @FALSE@
-  | EqualityMatch AttributeValueAssertion  -- ^ @EQUALITY@ rule returns @TRUE@
-  | Substrings SubstringFilter             -- ^ @SUBSTR@ rule returns @TRUE@
-  | GreaterOrEqual AttributeValueAssertion -- ^ @ORDERING@ rule returns @FALSE@
-  | LessOrEqual AttributeValueAssertion    -- ^ @ORDERING@ or @EQUALITY@ rule returns @TRUE@
-  | Present AttributeDescription           -- ^ Attribute is present in the entry
-  | ApproxMatch AttributeValueAssertion    -- ^ Same as 'EqualityMatch' for most servers
-  | ExtensibleMatch MatchingRuleAssertion
+    And !(NonEmpty Filter)                  -- ^ All filters evaluate to @TRUE@
+  | Or !(NonEmpty Filter)                   -- ^ Any filter evaluates to @TRUE@
+  | Not !Filter                             -- ^ Filter evaluates to @FALSE@
+  | EqualityMatch !AttributeValueAssertion  -- ^ @EQUALITY@ rule returns @TRUE@
+  | Substrings !SubstringFilter             -- ^ @SUBSTR@ rule returns @TRUE@
+  | GreaterOrEqual !AttributeValueAssertion -- ^ @ORDERING@ rule returns @FALSE@
+  | LessOrEqual !AttributeValueAssertion    -- ^ @ORDERING@ or @EQUALITY@ rule returns @TRUE@
+  | Present !AttributeDescription           -- ^ Attribute is present in the entry
+  | ApproxMatch !AttributeValueAssertion    -- ^ Same as 'EqualityMatch' for most servers
+  | ExtensibleMatch !MatchingRuleAssertion
     deriving (Show, Eq)
 
 data SubstringFilter = SubstringFilter !AttributeDescription !(NonEmpty Substring)

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,9 +11,17 @@
 -- @
 module Ldap.Client
   ( with
+  , with'
+  , runsIn
+  , runsInEither
+  , open
+  , close
   , Host(..)
+  , defaultTlsSettings
+  , insecureTlsSettings
   , PortNumber
   , Ldap
+  , LdapH
   , LdapError(..)
   , ResponseError(..)
   , Type.ResultCode(..)
@@ -64,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
@@ -76,7 +87,6 @@ import           Data.Function (fix)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.Map.Strict as Map
 import           Data.Monoid (Endo(appEndo))
-import           Data.String (fromString)
 import           Data.Text (Text)
 #if __GLASGOW_HASKELL__ < 710
 import           Data.Traversable (traverse)
@@ -108,162 +118,219 @@ import           Ldap.Client.Modify (Operation(..), modify, RelativeDn(..), modi
 import           Ldap.Client.Add (add)
 import           Ldap.Client.Delete (delete)
 import           Ldap.Client.Compare (compare)
-import           Ldap.Client.Extended (Oid(..), extended)
+import           Ldap.Client.Extended (Oid(..), extended, noticeOfDisconnectionOid)
 
 {-# ANN module ("HLint: ignore Use first" :: String) #-}
 
 
-newLdap :: IO Ldap
-newLdap = Ldap
-  <$> newTQueueIO
-
 -- | Various failures that can happen when working with LDAP.
-data LdapError =
-    IOError IOError             -- ^ Network failure.
-  | ParseError Asn1.ASN1Error   -- ^ Invalid ASN.1 data received from the server.
-  | ResponseError ResponseError -- ^ An LDAP operation failed.
-  | DisconnectError Disconnect  -- ^ Notice of Disconnection has been received.
+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 LdapError
 
-instance Exception WrappedIOError
-
-data Disconnect = Disconnect Type.ResultCode Dn Text
+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 =
         case host of
-          Plain    h -> h
-          Secure   h -> h
-          SecureWithTLSSettings h _ -> h
-          Insecure h -> h
+          Plain h -> h
+          Tls   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
-            }
-          SecureWithTLSSettings _ settings -> Just settings
-          Insecure _ -> Just Conn.TLSSettingsSimple
-            { Conn.settingDisableCertificateValidation = True
-            , Conn.settingDisableSession = False
-            , Conn.settingUseServerName = False
-            }
+          Tls _ settings -> pure settings
     , Conn.connectionUseSocks = Nothing
     }
 
-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.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 []
+-- | 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
+  , Conn.settingDisableSession = False
+  , Conn.settingUseServerName = False
+  }
+
+insecureTlsSettings :: Conn.TLSSettings
+insecureTlsSettings = Conn.TLSSettingsSimple
+  { Conn.settingDisableCertificateValidation = True
+  , Conn.settingDisableSession = False
+  , 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 []
+  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 == noticeOfDisconnection -> 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)
 
-  noticeOfDisconnection :: Text
-  noticeOfDisconnection = fromString "1.3.6.1.4.1.1466.20036"
-
-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

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | <https://tools.ietf.org/html/rfc4511#section-4.12 Extended> operation.
 --
 -- This operation comes in four flavours:
@@ -18,11 +19,14 @@ module Ldap.Client.Extended
   , extendedEither
   , extendedAsync
   , extendedAsyncSTM
-    -- ** StartTLS Operation
+    -- * StartTLS Operation
   , startTls
   , startTlsEither
   , startTlsAsync
   , startTlsAsyncSTM
+    -- * OIDs
+  , noticeOfDisconnectionOid
+  , startTlsOid
   , Async
   , wait
   , waitSTM
@@ -32,7 +36,7 @@ import           Control.Monad ((<=<))
 import           Control.Monad.STM (STM, atomically)
 import           Data.ByteString (ByteString)
 import           Data.List.NonEmpty (NonEmpty((:|)))
-import           Data.String (fromString)
+import           Data.String (IsString(fromString))
 import           Data.Text (Text)
 
 import qualified Ldap.Asn1.Type as Type
@@ -43,10 +47,14 @@ import           Ldap.Client.Internal
 newtype Oid = Oid Text
     deriving (Show, Eq)
 
+instance IsString Oid where
+  fromString =
+    Oid . fromString
+
 -- | Perform the Extended operation synchronously. Raises 'ResponseError' on failures.
 extended :: Ldap -> Oid -> Maybe ByteString -> IO ()
 extended l oid mv =
-  raise =<< extendedEither l oid mv
+  eitherToIO =<< extendedEither l oid mv
 
 -- | Perform the Extended operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.
@@ -84,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 ())
@@ -99,5 +107,10 @@ startTlsAsync =
 -- | An example of @Extended Operation@, cf. 'extendedAsyncSTM'.
 startTlsAsyncSTM :: Ldap -> STM (Async ())
 startTlsAsyncSTM l =
-  extendedAsyncSTM l (Oid (fromString "1.3.6.1.4.1.1466.20037"))
-                     Nothing
+  extendedAsyncSTM l startTlsOid Nothing
+
+noticeOfDisconnectionOid :: Oid
+noticeOfDisconnectionOid = "1.3.6.1.4.1.1466.20036"
+
+startTlsOid :: Oid
+startTlsOid = "1.3.6.1.4.1.1466.20037"

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,33 +37,37 @@ 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
 
 
 -- | LDAP host.
 data Host =
-    Plain String    -- ^ Plain LDAP.
-  | Insecure String -- ^ LDAP over TLS without the certificate validity check.
-  | Secure String   -- ^ LDAP over TLS.
-  | SecureWithTLSSettings String TLSSettings
-                    -- ^ LDAP over TLS with the ability to specify detailed TLS settings.
+    Plain String           -- ^ Plain LDAP.
+  | Tls String TLSSettings -- ^ LDAP over TLS.
     deriving (Show)
 
--- | A token. All functions that interact with the Directory require one.
+-- | An LDAP connection handle
 data Ldap = Ldap
-  { client  :: TQueue ClientMessage
-  } deriving (Eq)
+  { 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))
+data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp))
 type Request = Type.ProtocolClientOp
 type InMessage = Type.ProtocolServerOp
 type Response = NonEmpty InMessage
 
 -- | Asynchronous LDAP operation. Use 'wait' or 'waitSTM' to wait for its completion.
-data Async a = Async (STM (Either ResponseError a))
+newtype Async a = Async (STM (Either ResponseError a))
 
 instance Functor Async where
   fmap f (Async stm) = Async (fmap (fmap f) stm)
@@ -72,8 +78,8 @@ newtype Dn = Dn Text
 
 -- | Response indicates a failed operation.
 data ResponseError =
-    ResponseInvalid Request Response -- ^ LDAP server did not follow the protocol, so @ldap-client@ couldn't make sense of the response.
-  | ResponseErrorCode Request Type.ResultCode Dn Text -- ^ The response contains a result code indicating failure and an error message.
+    ResponseInvalid !Request !Response -- ^ LDAP server did not follow the protocol, so @ldap-client@ couldn't make sense of the response.
+  | ResponseErrorCode !Request !Type.ResultCode !Dn !Text -- ^ The response contains a result code indicating failure and an error message.
     deriving (Show, Eq, Typeable)
 
 instance Exception ResponseError
@@ -114,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

@@ -40,15 +40,15 @@ import           Ldap.Client.Internal
 
 -- | Type of modification being performed.
 data Operation =
-    Delete Attr [AttrValue] -- ^ Delete values from the attribute. Deletes the attribute if the list is empty or all current values are listed.
-  | Add Attr [AttrValue] -- ^ Add values to the attribute, creating it if necessary.
-  | Replace Attr [AttrValue] -- ^ Replace all existing values of the attribute with the new list. Deletes the attribute if the list is empty.
+    Delete !Attr ![AttrValue]  -- ^ Delete values from the attribute. Deletes the attribute if the list is empty or all current values are listed.
+  | Add !Attr ![AttrValue]     -- ^ Add values to the attribute, creating it if necessary.
+  | Replace !Attr ![AttrValue] -- ^ Replace all existing values of the attribute with the new list. Deletes the attribute if the list is empty.
     deriving (Show, Eq)
 
 -- | Perform the Modify operation synchronously. Raises 'ResponseError' on failures.
 modify :: Ldap -> Dn -> [Operation] -> IO ()
 modify l dn as =
-  raise =<< modifyEither l dn as
+  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.
@@ -215,7 +215,7 @@ data Filter =
   | !Attr :~= !AttrValue    -- ^ Attribute's value approximately matches the assertion
   | !Attr :=* !(Maybe AttrValue, [AttrValue], Maybe AttrValue)
                             -- ^ Glob match
-  | (Maybe Attr, Maybe Attr, Bool) ::= AttrValue
+  | !(Maybe Attr, Maybe Attr, Bool) ::= !AttrValue
                             -- ^ Extensible match
 
 -- | Entry found during the Search.

test/SpecHelper.hs

@@ -53,7 +53,7 @@ locally f =
           (\_ -> Ldap.with localhost port f)
 
 localhost :: Host
-localhost = Insecure "localhost"
+localhost = Tls "localhost" insecureTlsSettings
 
 port :: Num a => a
 port = 24620