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,5 +1,9 @@
 dist/
+dist-newstyle/
 .cabal-sandbox/
 cabal.sandbox.config
 node_modules
 Gemfile.lock
+*~
+*.swp
+/result

.travis.yml

@@ -1,35 +1,26 @@
-env:
+language: haskell
-  - CABALVER=1.18 GHCVER=7.6.3
-  - CABALVER=1.18 GHCVER=7.8.4
-  - CABALVER=1.22 GHCVER=7.10.1
 
-before_install:
+sudo: false
-  - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
+
-  - travis_retry sudo apt-get update
+git:
-  - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER npm
+  depth: 5
-  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+
+cache:
+  directories:
+    - "$HOME/.cabal/store"
+
+matrix:
+  include:
+    - ghc: 8.0.1
+    - ghc: 8.2.2
+    - ghc: 8.4.4
+    - ghc: 8.6.5
 
 install:
-  - cabal --version
+  - cabal update
-  - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+  - cabal install --only-dependencies --enable-tests ldap-client.cabal
-  - travis_retry cabal update
-  - cabal install --only-dependencies --enable-tests --enable-benchmarks
   - npm install ldapjs
 
 script:
-  - cabal configure --enable-tests -v2
+  - cabal install --enable-tests $RUN_TESTS ldap-client.cabal
-  - cabal build
+  - cabal sdist && cabal install --enable-tests dist/ldap-client-*.tar.gz
-  - cabal test
-  - |
-    if [ $GHCVER = "7.10.1" ]; then
-      cabal check
-    fi
-  - cabal sdist
-  - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
-    cd dist/;
-    if [ -f "$SRC_TGZ" ]; then
-      cabal install --force-reinstalls "$SRC_TGZ";
-    else
-    echo "expected '$SRC_TGZ' not found";
-      exit 1;
-    fi

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,28 +1,29 @@
 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
+|           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.
 
   [rfc4511]: https://tools.ietf.org/html/rfc4511

default.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc7102" }: 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,30 +1,37 @@
 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
+author:              Matvey Aksenov, AlasConnect LLC
-maintainer:          matvey.aksenov@gmail.com
+maintainer:          matvey.aksenov@gmail.com, software@alasconnect.com
-copyright:           2015 Matvey Aksenov
+copyright:           2015 Matvey Aksenov, 2019 AlasConnect LLC
 category:            Network
 build-type:          Simple
 cabal-version:       >= 1.10
 tested-with:
-    GHC == 7.6.3
+    GHC == 8.0.1
-  , GHC == 7.8.4
+  , GHC == 8.2.2
-  , GHC == 7.10.1
+  , GHC == 8.4.4
+  , GHC == 8.6.5
 extra-source-files:
-  README.markdown
+  README.md
+  CHANGELOG.md
 
 source-repository head
   type:     git
-  location: git@github.com:supki/ldap-client
+  location: git@github.com:alasconnect/ldap-client
-  tag:      0.1.0
+  tag:      0.4.0
 
 library
+  ghc-options:
+    -Wall
+    -fwarn-incomplete-uni-patterns
+    -fwarn-incomplete-record-updates
+    -fwarn-unrecognised-pragmas
   default-language:
     Haskell2010
   hs-source-dirs:
@@ -34,9 +41,7 @@ library
     Ldap.Asn1.ToAsn1
     Ldap.Asn1.Type
     Ldap.Client
-    Ldap.Client.Abandon
     Ldap.Client.Add
-    Ldap.Client.Asn1.ToAsn1
     Ldap.Client.Bind
     Ldap.Client.Compare
     Ldap.Client.Delete
@@ -52,12 +57,18 @@ library
     , bytestring
     , connection    >= 0.2
     , containers
+    , fail
     , network       >= 2.6
     , semigroups    >= 0.16
     , stm
     , text
 
 test-suite spec
+  ghc-options:
+    -Wall
+    -fwarn-incomplete-uni-patterns
+    -fwarn-incomplete-record-updates
+    -fwarn-unrecognised-pragmas
   default-language:
     Haskell2010
   type:
@@ -83,16 +94,3 @@ test-suite spec
     , ldap-client
     , process
     , semigroups
-
-test-suite doctests
-  default-language:
-    Haskell2010
-  type:
-    exitcode-stdio-1.0
-  hs-source-dirs:
-    test
-  main-is:
-    Doctests.hs
-  build-depends:
-      base          >= 4.6 && < 5
-    , doctest

npm/nodeLib/default.nix

@@ -75,7 +75,7 @@ let
 in
 
 rec {
-  nodejs = pkgs."nodejs-${replaceDots "_" nodejsVersion}" or (
+  nodejs = pkgs.nodejs or (
     throw "The given nodejs version ${nodejsVersion} has not been defined."
   );
   buildNodePackage = import ./buildNodePackage.nix ({

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 ? "ghc7102" }: 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;
+    name = this.pname;
-    buildInputs = [ ghc cabal-install npm.nodePackages.ldapjs ] ++ pkg.env.buildInputs;
+    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)
@@ -19,8 +22,8 @@ import qualified Data.Text.Encoding as Text
 
 import           Ldap.Asn1.Type
 
-{-# ANN module "HLint: ignore Use const" #-}
+{-# ANN module ("HLint: ignore Use const" :: String) #-}
-{-# ANN module "HLint: ignore Avoid lambda" #-}
+{-# ANN module ("HLint: ignore Avoid lambda" :: String) #-}
 
 
 -- | Convert a part of ASN.1 stream to a LDAP type returning the remainder of the stream.
@@ -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,217 +1,440 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | This module contains convertions from LDAP types to ASN.1.
+--
+-- Various hacks are employed because "asn1-encoding" only encodes to DER, but
+-- LDAP demands BER-encoding.  So, when a definition looks suspiciously different
+-- from the spec in the comment, that's why.  I hope all that will be fixed
+-- eventually.
 module Ldap.Asn1.ToAsn1
-  ( Ber
+  ( ToAsn1(toAsn1)
-  , encode
-  , bool
-  , int32
-  , enum
-  , octetstring
-  , null
-  , sequence
-  , set
-  , tagged
-  , Mod
-  , Tag
-  , application
-  , context
-  , tag
   ) where
 
-import           Data.Bits (Bits((.&.), (.|.), shiftR))
+import           Data.ASN1.Types (ASN1, ASN1Class, ASN1Tag, ASN1ConstructionType)
-import qualified Data.ByteString as ByteString
+import qualified Data.ASN1.Types as Asn1
-import qualified Data.ByteString.Lazy as ByteString.Lazy
+import           Data.ByteString (ByteString)
-import           Data.ByteString.Lazy (ByteString)
+import           Data.Foldable (fold, foldMap)
-import           Data.ByteString.Lazy.Builder (Builder)
+import           Data.List.NonEmpty (NonEmpty)
-import qualified Data.ByteString.Lazy.Builder as Builder
+import           Data.Maybe (maybe)
-import           Data.Int (Int64, Int32)
+import           Data.Monoid (Endo(Endo), (<>), mempty)
-import           Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.Text.Encoding as Text
-#if __GLASGOW_HASKELL__ < 710
+import           Prelude (Integer, (.), fromIntegral)
-import           Data.Monoid (Monoid(..))
-#endif
-import           Data.Semigroup (Semigroup(..))
-import           Data.Word (Word8)
-import           Prelude hiding (null, sequence)
 
--- $setup
+import           Ldap.Asn1.Type
--- >>> :set -XOverloadedStrings
 
-data Ber = Ber !Int64 !Builder
 
-instance Semigroup Ber where
+-- | Convert a LDAP type to ASN.1.
-  Ber l b <> Ber l' b' = Ber (l + l') (b <> b')
-
-instance Monoid Ber where
-  mempty = Ber 0 mempty
-  mappend = (<>)
-
-encode :: Ber -> ByteString
-encode (Ber _ b) = Builder.toLazyByteString b
-
--- | Encoding of a boolean value.
 --
--- >>> encode (bool mempty True)
+-- When it's relevant, instances include the part of RFC describing the encoding.
--- "\SOH\SOH\255"
+class ToAsn1 a where
---
+  toAsn1 :: a -> Endo [ASN1]
--- >>> encode (bool mempty False)
--- "\SOH\SOH\NUL"
-bool :: Mod -> Bool -> Ber
-bool f b = fromBytes ((t .|. classBit f) : ts ++ [0x01, if b then 0xFF else 0x00])
- where
-  t :| ts = tagBits (tag 0x01 <> f)
 
--- | Encoding of an integer value.
+{- |
---
+@
--- >>> encode (int32 mempty 0)
+LDAPMessage ::= SEQUENCE {
--- "\STX\SOH\NUL"
+     messageID       MessageID,
---
+     protocolOp      CHOICE {
--- >>> encode (int32 mempty 127)
+          bindRequest           BindRequest,
--- "\STX\SOH\DEL"
+          bindResponse          BindResponse,
---
+          unbindRequest         UnbindRequest,
--- >>> encode (int32 mempty 128)
+          searchRequest         SearchRequest,
--- "\STX\STX\NUL\128"
+          searchResEntry        SearchResultEntry,
-int32 :: Mod -> Int32 -> Ber
+          searchResDone         SearchResultDone,
-int32 f n = fromBytes ((t .|. classBit f) : ts ++ fromIntegral (length bytes) : bytes)
+          searchResRef          SearchResultReference,
- where
+          addRequest            AddRequest,
-  t :| ts = tagBits (tag 0x02 <> f)
+          addResponse           AddResponse,
-  bytes
+          ... },
-    | n .&. 0x80 == 0x80 = 0x00 : reverse (go n)
+     controls       [0] Controls OPTIONAL }
-    | otherwise = reverse (go n)
+@
+-}
+instance ToAsn1 op => ToAsn1 (LdapMessage op) where
+  toAsn1 (LdapMessage i op mc) =
+    sequence (toAsn1 i <> toAsn1 op <> maybe mempty (context 0 . toAsn1) mc)
+
+{- |
+@
+MessageID ::= INTEGER (0 ..  maxInt)
+@
+-}
+instance ToAsn1 Id where
+  toAsn1 (Id i) = single (Asn1.IntVal (fromIntegral i))
+
+{- |
+@
+LDAPString ::= OCTET STRING -- UTF-8 encoded
+@
+-}
+instance ToAsn1 LdapString where
+  toAsn1 (LdapString s) = single (Asn1.OctetString (Text.encodeUtf8 s))
+
+{- |
+@
+LDAPOID ::= OCTET STRING -- Constrained to \<numericoid\>
+@
+-}
+instance ToAsn1 LdapOid where
+  toAsn1 (LdapOid s) = single (Asn1.OctetString (Text.encodeUtf8 s))
+
+{- |
+@
+LDAPDN ::= LDAPString -- Constrained to \<distinguishedName\>
+@
+-}
+instance ToAsn1 LdapDn where
+  toAsn1 (LdapDn s) = toAsn1 s
+
+{- |
+@
+RelativeLDAPDN ::= LDAPString -- Constrained to \<name-component\>
+@
+-}
+instance ToAsn1 RelativeLdapDn where
+  toAsn1 (RelativeLdapDn s) = toAsn1 s
+
+{- |
+@
+AttributeDescription ::= LDAPString
+@
+-}
+instance ToAsn1 AttributeDescription where
+  toAsn1 (AttributeDescription s) = toAsn1 s
+
+{- |
+@
+AttributeValue ::= OCTET STRING
+@
+-}
+instance ToAsn1 AttributeValue where
+  toAsn1 (AttributeValue s) = single (Asn1.OctetString s)
+
+{- |
+@
+AttributeValueAssertion ::= SEQUENCE {
+     attributeDesc   AttributeDescription,
+     assertionValue  AssertionValue }
+@
+-}
+instance ToAsn1 AttributeValueAssertion where
+  toAsn1 (AttributeValueAssertion d v) = toAsn1 d <> toAsn1 v
+
+{- |
+@
+AssertionValue ::= OCTET STRING
+@
+-}
+instance ToAsn1 AssertionValue where
+  toAsn1 (AssertionValue s) = single (Asn1.OctetString s)
+
+
+{- |
+@
+PartialAttribute ::= SEQUENCE {
+     type       AttributeDescription,
+     vals       SET OF value AttributeValue }
+@
+-}
+instance ToAsn1 PartialAttribute where
+  toAsn1 (PartialAttribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs))
+
+{- |
+@
+Attribute ::= PartialAttribute(WITH COMPONENTS {
+     ...,
+     vals (SIZE(1..MAX))})
+@
+-}
+instance ToAsn1 Attribute where
+  toAsn1 (Attribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs))
+
+{- |
+@
+MatchingRuleId ::= LDAPString
+@
+-}
+instance ToAsn1 MatchingRuleId where
+  toAsn1 (MatchingRuleId s) = toAsn1 s
+
+{- |
+@
+Controls ::= SEQUENCE OF control Control
+@
+-}
+instance ToAsn1 Controls where
+  toAsn1 (Controls cs) = sequence (toAsn1 cs)
+
+{- |
+@
+Control ::= SEQUENCE {
+     controlType             LDAPOID,
+     criticality             BOOLEAN DEFAULT FALSE,
+     controlValue            OCTET STRING OPTIONAL }
+@
+-}
+instance ToAsn1 Control where
+  toAsn1 (Control t c v) =
+    sequence (fold
+      [ toAsn1 t
+      , single (Asn1.Boolean c)
+      , maybe mempty (single . Asn1.OctetString) v
+      ])
+
+{- |
+@
+BindRequest ::= [APPLICATION 0] SEQUENCE {
+     version                 INTEGER (1 ..  127),
+     name                    LDAPDN,
+     authentication          AuthenticationChoice }
+@
+
+@
+UnbindRequest ::= [APPLICATION 2] NULL
+@
+
+@
+SearchRequest ::= [APPLICATION 3] SEQUENCE {
+     baseObject      LDAPDN,
+     scope           ENUMERATED {
+          baseObject              (0),
+          singleLevel             (1),
+          wholeSubtree            (2),
+          ...  },
+     derefAliases    ENUMERATED {
+          neverDerefAliases       (0),
+          derefInSearching        (1),
+          derefFindingBaseObj     (2),
+          derefAlways             (3) },
+     sizeLimit       INTEGER (0 ..  maxInt),
+     timeLimit       INTEGER (0 ..  maxInt),
+     typesOnly       BOOLEAN,
+     filter          Filter,
+     attributes      AttributeSelection }
+@
+
+@
+ModifyRequest ::= [APPLICATION 6] SEQUENCE {
+     object          LDAPDN,
+     changes         SEQUENCE OF change SEQUENCE {
+          operation       ENUMERATED {
+               add     (0),
+               delete  (1),
+               replace (2),
+               ...  },
+          modification    PartialAttribute } }
+@
+
+@
+AddRequest ::= [APPLICATION 8] SEQUENCE {
+     entry           LDAPDN,
+     attributes      AttributeList }
+@
+
+@
+DelRequest ::= [APPLICATION 10] LDAPDN
+@
+
+@
+ModifyDNRequest ::= [APPLICATION 12] SEQUENCE {
+     entry           LDAPDN,
+     newrdn          RelativeLDAPDN,
+     deleteoldrdn    BOOLEAN,
+     newSuperior     [0] LDAPDN OPTIONAL }
+@
+
+@
+CompareRequest ::= [APPLICATION 14] SEQUENCE {
+     entry           LDAPDN,
+     ava             AttributeValueAssertion }
+@
+
+@
+ExtendedRequest ::= [APPLICATION 23] SEQUENCE {
+     requestName      [0] LDAPOID,
+     requestValue     [1] OCTET STRING OPTIONAL }
+@
+-}
+instance ToAsn1 ProtocolClientOp where
+  toAsn1 (BindRequest v n a) =
+    application 0 (single (Asn1.IntVal (fromIntegral v)) <> toAsn1 n <> toAsn1 a)
+  toAsn1 UnbindRequest =
+    other Asn1.Application 2 mempty
+  toAsn1 (SearchRequest bo s da sl tl to f a) =
+    application 3 (fold
+      [ toAsn1 bo
+      , enum s'
+      , enum da'
+      , single (Asn1.IntVal (fromIntegral sl))
+      , single (Asn1.IntVal (fromIntegral tl))
+      , single (Asn1.Boolean to)
+      , toAsn1 f
+      , toAsn1 a
+      ])
    where
-    go i
+    s' = case s of
-      | i <= 0xff = return (fromIntegral i)
+      BaseObject   -> 0
-      | otherwise = (fromIntegral i .&. 0xff) : go (i `shiftR` 8)
+      SingleLevel  -> 1
+      WholeSubtree -> 2
+    da' = case da of
+      NeverDerefAliases      -> 0
+      DerefInSearching       -> 1
+      DerefFindingBaseObject -> 2
+      DerefAlways            -> 3
+  toAsn1 (ModifyRequest dn xs) =
+    application 6 (fold
+      [ toAsn1 dn
+      , sequence (foldMap (\(op, pa) -> sequence (enum (case op of
+          Add     -> 0
+          Delete  -> 1
+          Replace -> 2) <> toAsn1 pa)) xs)
+      ])
+  toAsn1 (AddRequest dn as) =
+    application 8 (toAsn1 dn <> toAsn1 as)
+  toAsn1 (DeleteRequest (LdapDn (LdapString dn))) =
+    other Asn1.Application 10 (Text.encodeUtf8 dn)
+  toAsn1 (ModifyDnRequest dn rdn del new) =
+    application 12 (fold
+      [ toAsn1 dn
+      , toAsn1 rdn
+      , single (Asn1.Boolean del)
+      , maybe mempty
+              (\(LdapDn (LdapString dn')) -> other Asn1.Context 0 (Text.encodeUtf8 dn'))
+              new
+      ])
+  toAsn1 (CompareRequest dn av) =
+    application 14 (toAsn1 dn <> sequence (toAsn1 av))
+  toAsn1 (ExtendedRequest (LdapOid oid) mv) =
+    application 23 (fold
+     [ other Asn1.Context 0 (Text.encodeUtf8 oid)
+     , maybe mempty (other Asn1.Context 1) mv
+     ])
 
--- | Encoding of an enumerated value.
+{- |
---
+@
--- It is encoded exactly the same as an integer value, but the tag number is different.
+AuthenticationChoice ::= CHOICE {
-enum :: Mod -> Int32 -> Ber
+     simple                  [0] OCTET STRING,
-enum f = int32 (tag 0x0a <> f)
+     sasl                    [3] SaslCredentials,
+     ...  }
 
--- | Encoding of an octet string.
-octetstring :: Mod -> ByteString.ByteString -> Ber
-octetstring f bs = Ber
-  (fromIntegral (ByteString.length bs) + 2 + fromIntegral (length ts))
-  (Builder.word8 (t .|. classBit f) <> Builder.lazyByteString (ByteString.Lazy.pack ts) <>
-   Builder.byteString (ByteString.pack (encodeLength (ByteString.length bs))) <>
-   Builder.byteString bs)
- where
-  t :| ts = tagBits (tag 0x04 <> f)
 
--- | Encoding of NULL
+SaslCredentials ::= SEQUENCE {
---
+     mechanism               LDAPString,
--- >>> encode (null mempty)
+     credentials             OCTET STRING OPTIONAL }
--- "\ENQ\NUL"
+@
-null :: Mod -> Ber
+-}
-null f = fromBytes ((t .|. classBit f) : ts ++ [0])
+instance ToAsn1 AuthenticationChoice where
- where
+  toAsn1 (Simple s) = other Asn1.Context 0 s
-  t :| ts = tagBits (tag 0x05 <> f)
+  toAsn1 (Sasl External c) =
+    context 3 (fold
+      [ toAsn1 (LdapString "EXTERNAL")
+      , maybe mempty (toAsn1 . LdapString) c
+      ])
+{- |
+@
+AttributeSelection ::= SEQUENCE OF selector LDAPString
+@
+-}
+instance ToAsn1 AttributeSelection where
+  toAsn1 (AttributeSelection as) = sequence (toAsn1 as)
 
--- | Encoding of a sequence [of].
+{- |
---
+@
--- >>> encode (sequence mempty (octetstring mempty "Smith" <> bool mempty True))
+Filter ::= CHOICE {
--- "0\n\EOT\ENQSmith\SOH\SOH\255"
+     and             [0] SET SIZE (1..MAX) OF filter Filter,
-sequence :: Mod -> Ber -> Ber
+     or              [1] SET SIZE (1..MAX) OF filter Filter,
-sequence m = tagged (tag 0x10 <> m)
+     not             [2] Filter,
+     equalityMatch   [3] AttributeValueAssertion,
+     substrings      [4] SubstringFilter,
+     greaterOrEqual  [5] AttributeValueAssertion,
+     lessOrEqual     [6] AttributeValueAssertion,
+     present         [7] AttributeDescription,
+     approxMatch     [8] AttributeValueAssertion,
+     extensibleMatch [9] MatchingRuleAssertion,
+     ...  }
+@
+-}
+instance ToAsn1 Filter where
+  toAsn1 f = case f of
+    And xs            -> context 0 (toAsn1 xs)
+    Or xs             -> context 1 (toAsn1 xs)
+    Not x             -> context 2 (toAsn1 x)
+    EqualityMatch x   -> context 3 (toAsn1 x)
+    Substrings x      -> context 4 (toAsn1 x)
+    GreaterOrEqual x  -> context 5 (toAsn1 x)
+    LessOrEqual x     -> context 6 (toAsn1 x)
+    Present (AttributeDescription (LdapString x))
+                      -> other Asn1.Context 7 (Text.encodeUtf8 x)
+    ApproxMatch x     -> context 8 (toAsn1 x)
+    ExtensibleMatch x -> context 9 (toAsn1 x)
 
--- | Encoding of a set [of].
+{- |
---
+@
--- >>> encode (set mempty (octetstring mempty "Smith" <> bool mempty True))
+SubstringFilter ::= SEQUENCE {
--- "1\n\EOT\ENQSmith\SOH\SOH\255"
+     type           AttributeDescription,
-set :: Mod -> Ber -> Ber
+     substrings     SEQUENCE SIZE (1..MAX) OF substring CHOICE {
-set m = tagged (tag 0x11 <> m)
+          initial [0] AssertionValue,  -- can occur at most once
+          any     [1] AssertionValue,
+          final   [2] AssertionValue } -- can occur at most once
+     }
+@
+-}
+instance ToAsn1 SubstringFilter where
+  toAsn1 (SubstringFilter ad ss) =
+    toAsn1 ad <> sequence (foldMap (\s -> case s of
+      Initial (AssertionValue v) -> other Asn1.Context 0 v
+      Any (AssertionValue v)     -> other Asn1.Context 1 v
+      Final (AssertionValue v)   -> other Asn1.Context 2 v) ss)
 
--- | Encoding of a (possibly tagged) constructed value.
+{- |
-tagged :: Mod -> Ber -> Ber
+@
-tagged f b@(Ber l _) = fromBytes ((t .|. constructedTag .|. classBit f) : ts ++ encodeLength l) <> b
+MatchingRuleAssertion ::= SEQUENCE {
- where
+     matchingRule    [1] MatchingRuleId OPTIONAL,
-  t :| ts = tagBits f
+     type            [2] AttributeDescription OPTIONAL,
-  constructedTag = 0x20
+     matchValue      [3] AssertionValue,
+     dnAttributes    [4] BOOLEAN DEFAULT FALSE }
+@
+-}
+instance ToAsn1 MatchingRuleAssertion where
+  toAsn1 (MatchingRuleAssertion mmr mad (AssertionValue av) _) = fold
+    [ maybe mempty f mmr
+    , maybe mempty g mad
+    , other Asn1.Context 3 av
+    ]
+   where
+    f (MatchingRuleId (LdapString x)) = other Asn1.Context 1 (Text.encodeUtf8 x)
+    g (AttributeDescription (LdapString x)) = other Asn1.Context 2 (Text.encodeUtf8 x)
 
-fromBytes :: [Word8] -> Ber
+{- |
-fromBytes xs = let bs = ByteString.Lazy.pack xs in Ber (ByteString.Lazy.length bs) (Builder.lazyByteString bs)
+@
+AttributeList ::= SEQUENCE OF attribute Attribute
+@
+-}
+instance ToAsn1 AttributeList where
+  toAsn1 (AttributeList xs) = sequence (toAsn1 xs)
 
-defaultTag :: Tag
+instance ToAsn1 a => ToAsn1 [a] where
-defaultTag = Tag Universal (Number 0)
+  toAsn1 = foldMap toAsn1
 
-newtype Mod = Mod (Tag -> Tag)
+instance ToAsn1 a => ToAsn1 (NonEmpty a) where
+  toAsn1 = foldMap toAsn1
 
-instance Semigroup Mod where
+sequence :: Endo [ASN1] -> Endo [ASN1]
-  Mod f <> Mod g = Mod (g . f)
+sequence = construction Asn1.Sequence
 
-instance Monoid Mod where
+set :: Endo [ASN1] -> Endo [ASN1]
-  mappend = (<>)
+set = construction Asn1.Set
-  mempty = Mod id
 
-data Class =
+application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
-    Universal
+application = construction . Asn1.Container Asn1.Application
-  | Application
-  | Context
-    deriving (Show, Eq)
 
-data Tag = Tag !Class !Number
+context :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
-    deriving (Show, Eq)
+context = construction . Asn1.Container Asn1.Context
 
-newtype Number = Number Word8
+construction :: ASN1ConstructionType -> Endo [ASN1] -> Endo [ASN1]
-    deriving (Show, Eq)
+construction t x = single (Asn1.Start t) <> x <> single (Asn1.End t)
 
-classBit :: Mod -> Word8
+other :: ASN1Class -> ASN1Tag -> ByteString -> Endo [ASN1]
-classBit (Mod f) = case f defaultTag of
+other c t = single . Asn1.Other c t
-  Tag Universal _   -> 0x00
-  Tag Application _ -> 0x40
-  Tag Context _     -> 0x80
 
-tagBits :: Mod -> NonEmpty Word8
+enum :: Integer -> Endo [ASN1]
-tagBits (Mod f) = case f defaultTag of Tag _ t -> encodeTagNumber t
+enum = single . Asn1.Enumerated
 
-application, context :: Mod
+single :: a -> Endo [a]
-application = class_ Application
+single x = Endo (x :)
-context     = class_ Context
-
-class_ :: Class -> Mod
-class_ c = Mod (\(Tag _ t) -> Tag c t)
-
-tag :: Word8 -> Mod
-tag t = Mod (\(Tag c _) -> Tag c (Number t))
-
--- | Small tag numbers (up to and including 30) are bit-OR'd
--- directly with the first Identifier byte, while the bigger ones
--- are encoded idiosyncratically.
---
--- >>> encodeTagNumber (Number 19)
--- 19 :| []
---
--- >>> encodeTagNumber (Number 31)
--- 31 :| [31]
---
--- >>> encodeTagNumber (Number 137)
--- 31 :| [129,9]
-encodeTagNumber :: Number -> NonEmpty Word8
-encodeTagNumber (Number n)
-  | n < 30    = return n
-  | otherwise = 0x1f :| reverse (go n)
- where
-  go  x = fromIntegral (x .&. 0x7f) : go' (x `shiftR` 7)
-  go' 0 = []
-  go' x = (fromIntegral (x .&. 0x7f) .|. 0x80) : go' (x `shiftR` 7)
-
--- | Small lengths (up to and including 127) are returned as a single
--- byte equal to length itself, while the bigger one are encoded
--- idiosyncratically.
---
--- >>> encodeLength 7
--- [7]
---
--- >>> encodeLength 12238
--- [130,47,206]
---
--- @
--- encodeLength :: (Integral a, Bits a) => a -> NonEmpty Word8
--- @
-encodeLength :: (Integral a, Bits a) => a -> [Word8]
-encodeLength n
-  | n < 0x80  = [fromIntegral n]
-  | otherwise = let (l, xs) = go n in (l .|. 0x80) : reverse xs
- where
-  go x
-    | x <= 0xff = (1, [fromIntegral x])
-    | otherwise = let (l, xs) = go (x `shiftR` 8) in (l + 1, (fromIntegral x .&. 0xff) : xs)

src/Ldap/Asn1/Type.hs

@@ -28,7 +28,6 @@ data ProtocolClientOp =
   | DeleteRequest !LdapDn
   | ModifyDnRequest !LdapDn !RelativeLdapDn !Bool !(Maybe LdapDn)
   | CompareRequest !LdapDn !AttributeValueAssertion
-  | AbandonRequest !Id
   | ExtendedRequest !LdapOid !(Maybe ByteString)
     deriving (Show, Eq)
 
@@ -38,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 +48,14 @@ data ProtocolServerOp =
     deriving (Show, Eq)
 
 -- | Not really a choice until SASL is supported.
-newtype AuthenticationChoice = Simple ByteString
+data AuthenticationChoice =
+    Simple !ByteString
+  | Sasl !SaslMechanism !(Maybe Text)
+    deriving (Show, Eq)
+
+-- | SASL Mechanism, for now only SASL EXTERNAL is supported
+data SaslMechanism =
+    External
     deriving (Show, Eq)
 
 -- | Scope of the search to be performed.
@@ -71,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@
+    And !(NonEmpty Filter)                  -- ^ All filters evaluate to @TRUE@
-  | Or !(NonEmpty Filter)                  -- ^ Any filter evaluates to @TRUE@
+  | Or !(NonEmpty Filter)                   -- ^ Any filter evaluates to @TRUE@
-  | Not Filter                             -- ^ Filter evaluates to @FALSE@
+  | Not !Filter                             -- ^ Filter evaluates to @FALSE@
-  | EqualityMatch AttributeValueAssertion  -- ^ @EQUALITY@ rule returns @TRUE@
+  | EqualityMatch !AttributeValueAssertion  -- ^ @EQUALITY@ rule returns @TRUE@
-  | Substrings SubstringFilter             -- ^ @SUBSTR@ rule returns @TRUE@
+  | Substrings !SubstringFilter             -- ^ @SUBSTR@ rule returns @TRUE@
-  | GreaterOrEqual AttributeValueAssertion -- ^ @ORDERING@ rule returns @FALSE@
+  | GreaterOrEqual !AttributeValueAssertion -- ^ @ORDERING@ rule returns @FALSE@
-  | LessOrEqual AttributeValueAssertion    -- ^ @ORDERING@ or @EQUALITY@ rule returns @TRUE@
+  | LessOrEqual !AttributeValueAssertion    -- ^ @ORDERING@ or @EQUALITY@ rule returns @TRUE@
-  | Present AttributeDescription           -- ^ Attribute is present in the entry
+  | Present !AttributeDescription           -- ^ Attribute is present in the entry
-  | ApproxMatch AttributeValueAssertion    -- ^ Same as 'EqualityMatch' for most servers
+  | ApproxMatch !AttributeValueAssertion    -- ^ Same as 'EqualityMatch' for most servers
-  | ExtensibleMatch MatchingRuleAssertion
+  | 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,15 +11,24 @@
 -- @
 module Ldap.Client
   ( with
+  , with'
+  , runsIn
+  , runsInEither
+  , open
+  , close
   , Host(..)
+  , defaultTlsSettings
+  , insecureTlsSettings
   , PortNumber
   , Ldap
+  , LdapH
   , LdapError(..)
   , ResponseError(..)
   , Type.ResultCode(..)
     -- * Bind
   , Password(..)
   , bind
+  , externalBind
     -- * Search
   , search
   , SearchEntry(..)
@@ -57,15 +68,15 @@ module Ldap.Client
   ) where
 
 #if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative ((<$>), (<*>))
+import           Control.Applicative ((<$>))
 #endif
 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.Concurrent.STM.TVar (newTVarIO)
+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
@@ -75,10 +86,7 @@ import           Data.Foldable (asum)
 import           Data.Function (fix)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.Map.Strict as Map
-#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid (Endo(appEndo))
-import           Data.Monoid (mempty)
-#endif
-import           Data.String (fromString)
 import           Data.Text (Text)
 #if __GLASGOW_HASKELL__ < 710
 import           Data.Traversable (traverse)
@@ -89,12 +97,11 @@ import qualified Network.Connection as Conn
 import           Prelude hiding (compare)
 import qualified System.IO.Error as IO
 
+import           Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1))
 import           Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1)
-import           Ldap.Asn1.ToAsn1 (encode)
 import qualified Ldap.Asn1.Type as Type
-import           Ldap.Client.Asn1.ToAsn1 (ToAsn1(toAsn1))
 import           Ldap.Client.Internal
-import           Ldap.Client.Bind (Password(..), bind)
+import           Ldap.Client.Bind (Password(..), bind, externalBind)
 import           Ldap.Client.Search
   ( search
   , Search
@@ -111,159 +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" #-}
+{-# ANN module ("HLint: ignore Use first" :: String) #-}
 
 
-newLdap :: IO Ldap
-newLdap = Ldap
-  <$> newTQueueIO
-  <*> newTVarIO (Type.Id 0)
-
 -- | 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.
+  | ParseError !Asn1.ASN1Error   -- ^ Invalid ASN.1 data received from the server.
-  | ResponseError ResponseError -- ^ An LDAP operation failed.
+  | ResponseError !ResponseError -- ^ An LDAP operation failed.
-  | DisconnectError Disconnect  -- ^ Notice of Disconnection has been received.
+  | DisconnectError !Disconnect  -- ^ Notice of Disconnection has been received.
     deriving (Show, Eq)
 
-newtype WrappedIOError = WrappedIOError IOError
+instance Exception LdapError
-    deriving (Show, Eq, Typeable)
 
-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.
---
+with' :: Host -> PortNumber -> (Ldap -> IO a) -> IO a
--- It catches all LDAP-related exceptions.
+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 ->
+  conn <- Conn.connectTo context params
-    bracket newLdap unbindAsync (\l -> do
+  reqQ <- newTQueueIO
-      inq  <- newTQueueIO
+  inQ  <- newTQueueIO
-      outq <- newTQueueIO
+  outQ <- newTQueueIO
-      as   <- traverse Async.async
+
-        [ input inq conn
+  -- The input worker that reads data off the network.
-        , output outq conn
+  (inW :: Async.Async Void)   <- Async.async (input inQ conn)
-        , dispatch l inq outq
+
-        , f l
+  -- The output worker that sends data onto the network.
-        ]
+  (outW :: Async.Async Void)  <- Async.async (output outQ conn)
-      fmap (Right . snd) (Async.waitAnyCancel as)))
+
- `catches`
+  -- The dispatch worker that sends data between the three queues.
-  [ Handler (\(WrappedIOError e) -> return (Left (IOError e)))
+  (dispW :: Async.Async Void) <- Async.async (dispatch reqQ inQ outQ)
-  , Handler (return . Left . ParseError)
+
-  , Handler (return . Left . ResponseError)
+  -- 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
+          Plain h -> h
-          Secure   h -> h
+          Tls   h _ -> h
-          Insecure h -> h
     , Conn.connectionPort = port
     , Conn.connectionUseSecure =
         case host of
           Plain  _ -> Nothing
-          Secure _ -> Just Conn.TLSSettingsSimple
+          Tls _ settings -> pure settings
-            { Conn.settingDisableCertificateValidation = False
-            , Conn.settingDisableSession = False
-            , Conn.settingUseServerName = False
-            }
-          Insecure _ -> Just Conn.TLSSettingsSimple
-            { Conn.settingDisableCertificateValidation = True
-            , Conn.settingDisableSession = False
-            , Conn.settingUseServerName = False
-            }
     , Conn.connectionUseSocks = Nothing
     }
 
-input :: FromAsn1 a => TQueue a -> Connection -> IO b
+-- | Closes an LDAP connection.
-input inq conn = wrap . flip fix [] $ \loop chunks -> do
+-- This is to be used in together with 'open'.
-  chunk <- Conn.connectionGet conn 8192
+close :: LdapH -> IO ()
-  case ByteString.length chunk of
+close (LdapH ldap) = do
-    0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)
+  unbindAsync ldap
-    _ -> do
+  Conn.connectionClose (conn ldap)
-      let chunks' = chunk : chunks
+  Async.cancel (workers ldap)
-      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 []
 
+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 (ByteString.Lazy.toStrict (encode (toAsn1 mempty msg)))
+  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 =
+dispatch reqq inq outq = loop (Map.empty, 1)
-  flip fix Map.empty $ \loop !req ->
+  where
-    loop =<< atomically (asum
+    saveUp mid op res = return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
-      [ do New mid new var <- readTQueue client
-           writeTQueue outq (Type.LdapMessage mid new Nothing)
-           return (Map.insert mid ([], var) req)
-      , 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
-      ])
- where
-  saveUp mid op res =
-    return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
 
-  done mid op req =
+    loop (!req, !counter) =
-    case Map.lookup mid req of
+      loop =<< atomically (asum
-      Nothing -> return req
+        [ do New new var <- readTQueue reqq
-      Just (stack, var) -> do
+             writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing)
-        putTMVar var (op :| stack)
+             return (Map.insert (Type.Id counter) ([], var) req, counter + 1)
-        return (Map.delete mid req)
+        , 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)
+    done mid op req =
-                     (Type.ExtendedResponse
+      case Map.lookup mid req of
-                       (Type.LdapResult code
+        Nothing -> return req
-                                        (Type.LdapDn (Type.LdapString dn))
+        Just (stack, var) -> do
-                                        (Type.LdapString reason)
+          putTMVar var (op :| stack)
-                                        _)
+          return (Map.delete mid req)
-                       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
 
-  noticeOfDisconnection :: Text
+    probablyDisconnect (Type.Id 0)
-  noticeOfDisconnection = fromString "1.3.6.1.4.1.1466.20036"
+                      (Type.ExtendedResponse
-
+                        (Type.LdapResult code
-wrap :: IO a -> IO a
+                                          (Type.LdapDn (Type.LdapString dn))
-wrap m = m `catch` (throwIO . WrappedIOError)
+                                          (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/Abandon.hs

@@ -1,39 +0,0 @@
--- | <https://tools.ietf.org/html/rfc4511#section-4.11 Abandon> operation.
---
--- This operation comes in two flavours:
---
---   * asynchronous, 'IO' based ('abandonAsync')
---
---   * asynchronous, 'STM' based ('abandonAsyncSTM')
---
--- Of those, the first one ('abandonAsync') is probably the most useful for the typical usecase.
---
--- Synchronous variants are unavailable because the Directory does not
--- respond to @AbandonRequest@s.
-module Ldap.Client.Abandon
-  ( abandonAsync
-  , abandonAsyncSTM
-  ) where
-
-import           Control.Monad (void)
-import           Control.Monad.STM (STM, atomically)
-
-import qualified Ldap.Asn1.Type as Type
-import           Ldap.Client.Internal
-
-
--- | Perform the Abandon operation asynchronously.
-abandonAsync :: Ldap -> Async a -> IO ()
-abandonAsync l =
-  atomically . abandonAsyncSTM l
-
--- | Perform the Abandon operation asynchronously.
-abandonAsyncSTM :: Ldap -> Async a -> STM ()
-abandonAsyncSTM l =
-  void . sendRequest l die . abandonRequest
- where
-  die = error "Ldap.Client.Abandon: do not wait for the response to UnbindRequest"
-
-abandonRequest :: Async a -> Request
-abandonRequest (Async i _)  =
-  Type.AbandonRequest i

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

@@ -1,408 +0,0 @@
--- | This module contains convertions from LDAP types to ASN.1.
-module Ldap.Client.Asn1.ToAsn1
-  ( ToAsn1(toAsn1)
-  ) where
-
-import           Data.Bool (Bool(False))
-import           Data.Foldable (foldMap)
-import           Data.Eq (Eq((==)))
-import           Data.List.NonEmpty (NonEmpty)
-import           Data.Monoid (Monoid(mempty), (<>))
-import qualified Data.Text.Encoding as Text
-import           Prelude (fromIntegral)
-
-import           Ldap.Asn1.Type
-import           Ldap.Asn1.ToAsn1
-
-
--- | Convert a LDAP type to ASN.1.
---
--- When it's relevant, instances include the part of the RFC describing the encoding.
-class ToAsn1 a where
-  toAsn1 :: Mod -> a -> Ber
-
-{- |
-@
-LDAPMessage ::= SEQUENCE {
-     messageID       MessageID,
-     protocolOp      CHOICE {
-          bindRequest           BindRequest,
-          bindResponse          BindResponse,
-          unbindRequest         UnbindRequest,
-          searchRequest         SearchRequest,
-          searchResEntry        SearchResultEntry,
-          searchResDone         SearchResultDone,
-          searchResRef          SearchResultReference,
-          addRequest            AddRequest,
-          addResponse           AddResponse,
-          ... },
-     controls       [0] Controls OPTIONAL }
-@
--}
-instance ToAsn1 op => ToAsn1 (LdapMessage op) where
-  toAsn1 m (LdapMessage i op mc) =
-    sequence m
-      (toAsn1 mempty i <>
-       toAsn1 mempty op <>
-       foldMap (toAsn1 (context <> tag 0)) mc)
-
-{- |
-@
-MessageID ::= INTEGER (0 ..  maxInt)
-@
--}
-instance ToAsn1 Id where
-  toAsn1 m (Id i) = int32 m i
-
-{- |
-@
-LDAPString ::= OCTET STRING -- UTF-8 encoded
-@
--}
-instance ToAsn1 LdapString where
-  toAsn1 m (LdapString s) = octetstring m (Text.encodeUtf8 s)
-
-{- |
-@
-LDAPOID ::= OCTET STRING -- Constrained to \<numericoid\>
-@
--}
-instance ToAsn1 LdapOid where
-  toAsn1 m (LdapOid s) = octetstring m (Text.encodeUtf8 s)
-
-{- |
-@
-LDAPDN ::= LDAPString -- Constrained to \<distinguishedName\>
-@
--}
-instance ToAsn1 LdapDn where
-  toAsn1 m (LdapDn s) = toAsn1 m s
-
-{- |
-@
-RelativeLDAPDN ::= LDAPString -- Constrained to \<name-component\>
-@
--}
-instance ToAsn1 RelativeLdapDn where
-  toAsn1 m (RelativeLdapDn s) = toAsn1 m s
-
-{- |
-@
-AttributeDescription ::= LDAPString
-@
--}
-instance ToAsn1 AttributeDescription where
-  toAsn1 m (AttributeDescription s) = toAsn1 m s
-
-{- |
-@
-AttributeValue ::= OCTET STRING
-@
--}
-instance ToAsn1 AttributeValue where
-  toAsn1 m (AttributeValue s) = octetstring m s
-
-{- |
-@
-AttributeValueAssertion ::= SEQUENCE {
-     attributeDesc   AttributeDescription,
-     assertionValue  AssertionValue }
-@
--}
-instance ToAsn1 AttributeValueAssertion where
-  toAsn1 m (AttributeValueAssertion d v) =
-    sequence m (toAsn1 mempty d <> toAsn1 mempty v)
-
-{- |
-@
-AssertionValue ::= OCTET STRING
-@
--}
-instance ToAsn1 AssertionValue where
-  toAsn1 m (AssertionValue s) = octetstring m s
-
-
-{- |
-@
-PartialAttribute ::= SEQUENCE {
-     type       AttributeDescription,
-     vals       SET OF value AttributeValue }
-@
--}
-instance ToAsn1 PartialAttribute where
-  toAsn1 m (PartialAttribute d xs) =
-    sequence m (toAsn1 mempty d <> set mempty (toAsn1 mempty xs))
-
-{- |
-@
-Attribute ::= PartialAttribute(WITH COMPONENTS {
-     ...,
-     vals (SIZE(1..MAX))})
-@
--}
-instance ToAsn1 Attribute where
-  toAsn1 m (Attribute d xs) =
-    sequence m (toAsn1 mempty d <> set mempty (toAsn1 mempty xs))
-
-{- |
-@
-MatchingRuleId ::= LDAPString
-@
--}
-instance ToAsn1 MatchingRuleId where
-  toAsn1 m (MatchingRuleId s) = toAsn1 m s
-
-{- |
-@
-Controls ::= SEQUENCE OF control Control
-@
--}
-instance ToAsn1 Controls where
-  toAsn1 m (Controls cs) = sequence m (toAsn1 mempty cs)
-
-{- |
-@
-Control ::= SEQUENCE {
-     controlType             LDAPOID,
-     criticality             BOOLEAN DEFAULT FALSE,
-     controlValue            OCTET STRING OPTIONAL }
-@
--}
-instance ToAsn1 Control where
-  toAsn1 m (Control t c v) =
-    sequence m
-      (toAsn1 mempty t <>
-       default_ False c (bool mempty c) <>
-       foldMap (octetstring mempty) v)
-
-{- |
-@
-BindRequest ::= [APPLICATION 0] SEQUENCE {
-     version                 INTEGER (1 ..  127),
-     name                    LDAPDN,
-     authentication          AuthenticationChoice }
-@
-
-@
-UnbindRequest ::= [APPLICATION 2] NULL
-@
-
-@
-SearchRequest ::= [APPLICATION 3] SEQUENCE {
-     baseObject      LDAPDN,
-     scope           ENUMERATED {
-          baseObject              (0),
-          singleLevel             (1),
-          wholeSubtree            (2),
-          ...  },
-     derefAliases    ENUMERATED {
-          neverDerefAliases       (0),
-          derefInSearching        (1),
-          derefFindingBaseObj     (2),
-          derefAlways             (3) },
-     sizeLimit       INTEGER (0 ..  maxInt),
-     timeLimit       INTEGER (0 ..  maxInt),
-     typesOnly       BOOLEAN,
-     filter          Filter,
-     attributes      AttributeSelection }
-@
-
-@
-ModifyRequest ::= [APPLICATION 6] SEQUENCE {
-     object          LDAPDN,
-     changes         SEQUENCE OF change SEQUENCE {
-          operation       ENUMERATED {
-               add     (0),
-               delete  (1),
-               replace (2),
-               ...  },
-          modification    PartialAttribute } }
-@
-
-@
-AddRequest ::= [APPLICATION 8] SEQUENCE {
-     entry           LDAPDN,
-     attributes      AttributeList }
-@
-
-@
-DelRequest ::= [APPLICATION 10] LDAPDN
-@
-
-@
-ModifyDNRequest ::= [APPLICATION 12] SEQUENCE {
-     entry           LDAPDN,
-     newrdn          RelativeLDAPDN,
-     deleteoldrdn    BOOLEAN,
-     newSuperior     [0] LDAPDN OPTIONAL }
-@
-
-@
-CompareRequest ::= [APPLICATION 14] SEQUENCE {
-     entry           LDAPDN,
-     ava             AttributeValueAssertion }
-@
-
-@
-AbandonRequest ::= [APPLICATION 16] MessageID
-@
-
-@
-ExtendedRequest ::= [APPLICATION 23] SEQUENCE {
-     requestName      [0] LDAPOID,
-     requestValue     [1] OCTET STRING OPTIONAL }
-@
--}
-instance ToAsn1 ProtocolClientOp where
-  toAsn1 _ (BindRequest v n a) =
-    sequence (application <> tag 0)
-      (int32 mempty (fromIntegral v) <>
-       toAsn1 mempty n <>
-       toAsn1 mempty a)
-  toAsn1 _ UnbindRequest =
-    null (application <> tag 2)
-  toAsn1 _ (SearchRequest bo s da sl tl to f a) =
-    sequence (application <> tag 3)
-      (toAsn1 mempty bo <>
-       enum mempty s' <>
-       enum mempty da' <>
-       int32 mempty sl <>
-       int32 mempty tl <>
-       bool mempty to <>
-       toAsn1 mempty f <>
-       toAsn1 mempty a)
-   where
-    s' = case s of
-      BaseObject   -> 0
-      SingleLevel  -> 1
-      WholeSubtree -> 2
-    da' = case da of
-      NeverDerefAliases      -> 0
-      DerefInSearching       -> 1
-      DerefFindingBaseObject -> 2
-      DerefAlways            -> 3
-  toAsn1 _ (ModifyRequest dn xs) =
-    sequence (application <> tag 6)
-      (toAsn1 mempty dn <>
-       sequence mempty (foldMap (\(op, pa) -> sequence mempty (enum mempty (case op of
-         Add     -> 0
-         Delete  -> 1
-         Replace -> 2) <> toAsn1 mempty pa)) xs))
-  toAsn1 _ (AddRequest dn as) =
-    sequence (application <> tag 8) (toAsn1 mempty dn <> toAsn1 mempty as)
-  toAsn1 _ (DeleteRequest dn) =
-    toAsn1 (application <> tag 10) dn
-  toAsn1 _ (ModifyDnRequest dn rdn del new) =
-    sequence (application <> tag 12)
-      (toAsn1 mempty dn <>
-       toAsn1 mempty rdn <>
-       bool mempty del <>
-       foldMap (toAsn1 (context <> tag 0)) new)
-  toAsn1 _ (CompareRequest dn av) =
-    sequence (application <> tag 14) (toAsn1 mempty dn <> toAsn1 mempty av)
-  toAsn1 _ (AbandonRequest i) =
-    toAsn1 (application <> tag 16) i
-  toAsn1 _ (ExtendedRequest oid mv) =
-    sequence (application <> tag 23)
-     (toAsn1 (context <> tag 0) oid <>
-      foldMap (octetstring (context <> tag 1)) mv)
-
-{- |
-@
-AuthenticationChoice ::= CHOICE {
-     simple                  [0] OCTET STRING,
-     ...  }
-@
--}
-instance ToAsn1 AuthenticationChoice where
-  toAsn1 _ (Simple s) = octetstring (context <> tag 0) s
-
-{- |
-@
-AttributeSelection ::= SEQUENCE OF selector LDAPString
-@
--}
-instance ToAsn1 AttributeSelection where
-  toAsn1 m (AttributeSelection as) = sequence m (toAsn1 mempty as)
-
-{- |
-@
-Filter ::= CHOICE {
-     and             [0] SET SIZE (1..MAX) OF filter Filter,
-     or              [1] SET SIZE (1..MAX) OF filter Filter,
-     not             [2] Filter,
-     equalityMatch   [3] AttributeValueAssertion,
-     substrings      [4] SubstringFilter,
-     greaterOrEqual  [5] AttributeValueAssertion,
-     lessOrEqual     [6] AttributeValueAssertion,
-     present         [7] AttributeDescription,
-     approxMatch     [8] AttributeValueAssertion,
-     extensibleMatch [9] MatchingRuleAssertion,
-     ...  }
-@
--}
-instance ToAsn1 Filter where
-  toAsn1 _ f = case f of
-    And xs            -> set (context <> tag 0) (toAsn1 mempty xs)
-    Or xs             -> set (context <> tag 1) (toAsn1 mempty xs)
-    Not x             -> tagged (context <> tag 2) (toAsn1 mempty x)
-    EqualityMatch x   -> toAsn1 (context <> tag 3) x
-    Substrings x      -> toAsn1 (context <> tag 4) x
-    GreaterOrEqual x  -> toAsn1 (context <> tag 5) x
-    LessOrEqual x     -> toAsn1 (context <> tag 6) x
-    Present x         -> toAsn1 (context <> tag 7) x
-    ApproxMatch x     -> toAsn1 (context <> tag 8) x
-    ExtensibleMatch x -> toAsn1 (context <> tag 9) x
-
-{- |
-@
-SubstringFilter ::= SEQUENCE {
-     type           AttributeDescription,
-     substrings     SEQUENCE SIZE (1..MAX) OF substring CHOICE {
-          initial [0] AssertionValue,  -- can occur at most once
-          any     [1] AssertionValue,
-          final   [2] AssertionValue } -- can occur at most once
-     }
-@
--}
-instance ToAsn1 SubstringFilter where
-  toAsn1 m (SubstringFilter ad ss) =
-    sequence m
-      (toAsn1 mempty ad <>
-       sequence mempty (foldMap (\s -> case s of
-         Initial v -> toAsn1 (context <> tag 0) v
-         Any v     -> toAsn1 (context <> tag 1) v
-         Final v   -> toAsn1 (context <> tag 2) v) ss))
-
-{- |
-@
-MatchingRuleAssertion ::= SEQUENCE {
-     matchingRule    [1] MatchingRuleId OPTIONAL,
-     type            [2] AttributeDescription OPTIONAL,
-     matchValue      [3] AssertionValue,
-     dnAttributes    [4] BOOLEAN DEFAULT FALSE }
-@
--}
-instance ToAsn1 MatchingRuleAssertion where
-  toAsn1 m (MatchingRuleAssertion mmr mad av b) = sequence m
-    (foldMap (toAsn1 (context <> tag 1)) mmr <>
-     foldMap (toAsn1 (context <> tag 2)) mad <>
-     toAsn1 (context <> tag 3) av <>
-     default_ False b (bool (context <> tag 4) b))
-
-{- |
-@
-AttributeList ::= SEQUENCE OF attribute Attribute
-@
--}
-instance ToAsn1 AttributeList where
-  toAsn1 m (AttributeList xs) = sequence m (toAsn1 mempty xs)
-
-instance ToAsn1 a => ToAsn1 [a] where
-  toAsn1 _ = foldMap (toAsn1 mempty)
-
-instance ToAsn1 a => ToAsn1 (NonEmpty a) where
-  toAsn1 _ = foldMap (toAsn1 mempty)
-
-default_ :: (Eq a, Monoid m) => a -> a -> m -> m
-default_ a b c = if a == b then mempty else c

src/Ldap/Client/Bind.hs

@@ -17,6 +17,10 @@ module Ldap.Client.Bind
   , bindEither
   , bindAsync
   , bindAsyncSTM
+  , externalBind
+  , externalBindEither
+  , externalBindAsync
+  , externalBindAsyncSTM
   , Async
   , wait
   , waitSTM
@@ -24,6 +28,7 @@ module Ldap.Client.Bind
 
 import           Control.Monad.STM (STM, atomically)
 import           Data.ByteString (ByteString)
+import           Data.Text (Text)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 
 import qualified Ldap.Asn1.Type as Type
@@ -37,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.
@@ -73,3 +78,37 @@ bindResult req (Type.BindResponse (Type.LdapResult code (Type.LdapDn (Type.LdapS
   | Type.Success <- code = Right ()
   | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
 bindResult req res = Left (ResponseInvalid req res)
+
+-- | 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
+
+-- | Perform a SASL EXTERNAL Bind operation synchronously. Returns @Left e@ where
+-- @e@ is a 'ResponseError' on failures.
+externalBindEither :: Ldap -> Dn -> Maybe Text -> IO (Either ResponseError ())
+externalBindEither l username mCredentials =
+  wait =<< externalBindAsync l username mCredentials
+
+-- | Perform the SASL EXTERNAL Bind operation asynchronously. Call 'Ldap.Client.wait' to wait
+-- for its completion.
+externalBindAsync :: Ldap -> Dn -> Maybe Text -> IO (Async ())
+externalBindAsync l username mCredentials =
+  atomically (externalBindAsyncSTM l username mCredentials)
+
+-- | Perform the SASL EXTERNAL Bind operation asynchronously.
+--
+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the
+-- same transaction you've performed it in.
+externalBindAsyncSTM :: Ldap -> Dn -> Maybe Text -> STM (Async ())
+externalBindAsyncSTM l username mCredentials =
+  let req = externalBindRequest username mCredentials in sendRequest l (bindResult req) req
+
+externalBindRequest :: Dn -> Maybe Text -> Request
+externalBindRequest (Dn username) mCredentials =
+  Type.BindRequest ldapVersion
+                   (Type.LdapDn (Type.LdapString username))
+                   (Type.Sasl Type.External mCredentials)
+ where
+  ldapVersion = 3
+

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"))
+  extendedAsyncSTM l startTlsOid Nothing
-                     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
@@ -6,7 +7,7 @@ module Ldap.Client.Internal
   , Ldap(..)
   , ClientMessage(..)
   , Type.ResultCode(..)
-  , Async(..)
+  , Async
   , AttrList
     -- * Waiting for Request Completion
   , wait
@@ -15,7 +16,7 @@ module Ldap.Client.Internal
   , Response
   , ResponseError(..)
   , Request
-  , raise
+  , eitherToIO
   , sendRequest
   , Dn(..)
   , Attr(..)
@@ -26,45 +27,50 @@ 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)
-import           Control.Concurrent.STM.TVar (TVar, modifyTVar, readTVar)
 import           Control.Exception (Exception, throwIO)
 import           Control.Monad (void)
 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, Connection)
+import           Data.Void (Void)
 
 import qualified Ldap.Asn1.Type as Type
 
 
 -- | LDAP host.
 data Host =
-    Plain String    -- ^ Plain LDAP. Do not use!
+    Plain String           -- ^ Plain LDAP.
-  | Insecure String -- ^ LDAP over TLS without the certificate validity check.
+  | Tls String TLSSettings -- ^ LDAP over TLS.
-                    --   Only use for testing!
+    deriving (Show)
-  | Secure String   -- ^ LDAP over TLS. Use!
-    deriving (Show, Eq, Ord)
 
--- | A token. All functions that interact with the Directory require one.
+-- | An LDAP connection handle
 data Ldap = Ldap
-  { client  :: TQueue ClientMessage
+  { reqQ    :: !(TQueue ClientMessage) -- ^ Request queue for client messages to be send.
-  , counter :: TVar Type.Id
+  , workers :: !(Async.Async Void) -- ^ Workers group for communicating with the server.
-  } deriving (Eq)
+  , conn    :: !Connection -- ^ Network connection to the server.
+  }
 
-data ClientMessage = New Type.Id 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 Type.Id (STM (Either ResponseError a))
+newtype Async a = Async (STM (Either ResponseError a))
 
 instance Functor Async where
-  fmap f (Async mid stm) = Async mid (fmap (fmap f) stm)
+  fmap f (Async stm) = Async (fmap (fmap f) stm)
 
 -- | Unique identifier of an LDAP entry.
 newtype Dn = Dn Text
@@ -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.
+    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.
+  | 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
@@ -105,26 +111,19 @@ wait = atomically . waitSTM
 -- should commit. After that, applying 'waitSTM' to the corresponding 'Async'
 -- starts to make sense.
 waitSTM :: Async a -> STM (Either ResponseError a)
-waitSTM (Async _ stm) = stm
+waitSTM (Async stm) = stm
 
 sendRequest :: Ldap -> (Response -> Either ResponseError a) -> Request -> STM (Async a)
 sendRequest l p msg =
   do var <- newEmptyTMVar
-     mid <- newId l
+     writeRequest l var msg
-     writeRequest l (New mid msg var)
+     return (Async (fmap p (readTMVar var)))
-     return (Async mid (fmap p (readTMVar var)))
 
-newId :: Ldap -> STM Type.Id
+writeRequest :: Ldap -> TMVar Response -> Request -> STM ()
-newId Ldap { counter } =
+writeRequest Ldap { reqQ } var msg = writeTQueue reqQ (New msg var)
-  do modifyTVar counter (\(Type.Id mid) -> Type.Id (mid + 1))
-     readTVar counter
-
-writeRequest :: Ldap -> ClientMessage -> STM ()
-writeRequest Ldap { client } = writeTQueue client
-
-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.
 --
@@ -146,4 +145,4 @@ unbindAsyncSTM :: Ldap -> STM ()
 unbindAsyncSTM l =
   void (sendRequest l die Type.UnbindRequest)
  where
-  die = error "Ldap.Client.Internal: do not wait for the response to UnbindRequest"
+  die = error "Ldap.Client: do not wait for the response to UnbindRequest"

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.
+    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.
+  | 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.
+  | 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/Doctests.hs

@@ -1,7 +0,0 @@
-module Main (main) where
-
-import Test.DocTest (doctest)
-
-
-main :: IO ()
-main = doctest ["src//Ldap/Asn1/ToAsn1.hs"]

test/Ldap/Client/BindSpec.hs

@@ -30,7 +30,7 @@ spec = do
                                  (Ldap.Type.Simple "public"))
           Ldap.InvalidCredentials
           (Dn "cn=admin")
-          "Invalid Credentials"))
+          "InvalidCredentialsError"))
 
   it "binds as ‘pikachu’" $ do
     res <- locally $ \l -> do

test/Ldap/Client/SearchSpec.hs

@@ -47,7 +47,7 @@ spec = do
         (Ldap.ResponseErrorCode req
                                 Ldap.InsufficientAccessRights
                                 (Dn "o=localhost")
-                                "Insufficient Access Rights"))
+                                "InsufficientAccessRightsError"))
 
   it "‘present’ filter" $ do
     res <- locally $ \l -> do
@@ -155,7 +155,7 @@ spec = do
 
   it "‘extensible’ filter" $ do
     res <- locally $ \l -> do
-      res <- go l ((Just (Attr "type"), Nothing, False) ::= "flying")
+      res <- go l ((Just (Attr "type"), Nothing, True) ::= "flying")
       dns res `shouldMatchList`
         [ butterfree
         , charizard

test/SpecHelper.hs

@@ -41,19 +41,19 @@ locally :: (Ldap -> IO a) -> IO (Either LdapError a)
 locally f =
   bracket (do env <- getEnvironment
               (_, out, _, h) <- runInteractiveProcess "./test/ldap.js" [] Nothing
-                                  (Just (("PORT", show port) :
+                                  (Just (("PORT", show (port :: Int)) :
                                          ("SSL_CERT", "./ssl/cert.pem") :
                                          ("SSL_KEY", "./ssl/key.pem") :
                                          env))
-              hGetLine out
+              _ <- hGetLine out
-              forkIO (() <$ tryIOError (forever (hGetLine out >>= putStrLn)))
+              _ <- forkIO (() <$ tryIOError (forever (hGetLine out >>= putStrLn)))
               return h)
           (\h -> do terminateProcess h
                     waitForProcess h)
           (\_ -> Ldap.with localhost port f)
 
 localhost :: Host
-localhost = Insecure "localhost"
+localhost = Tls "localhost" insecureTlsSettings
 
 port :: Num a => a
 port = 24620