fix nix-build

The main purpose of this is to allow `ToAsn1` instances to match
the spec closer. It also lets us implement Abandon operation fairly
easily (see the subsequent commit).

.github_changelog_generator

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

.gitignore

@@ -1,9 +1,5 @@
 dist/
-dist-newstyle/
 .cabal-sandbox/
 cabal.sandbox.config
 node_modules
 Gemfile.lock
-*~
-*.swp
-/result

.travis.yml

@@ -1,26 +1,35 @@
-language: haskell
+env:
+  - CABALVER=1.18 GHCVER=7.6.3
+  - CABALVER=1.18 GHCVER=7.8.4
+  - CABALVER=1.22 GHCVER=7.10.1
 
-sudo: false
-
-git:
-  depth: 5
-
-cache:
-  directories:
-    - "$HOME/.cabal/store"
-
-matrix:
-  include:
-    - ghc: 8.0.1
-    - ghc: 8.2.2
-    - ghc: 8.4.4
-    - ghc: 8.6.5
+before_install:
+  - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
+  - travis_retry sudo apt-get update
+  - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER npm
+  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
 
 install:
-  - cabal update
-  - cabal install --only-dependencies --enable-tests ldap-client.cabal
+  - cabal --version
+  - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+  - travis_retry cabal update
+  - cabal install --only-dependencies --enable-tests --enable-benchmarks
   - npm install ldapjs
 
 script:
-  - cabal install --enable-tests $RUN_TESTS ldap-client.cabal
-  - cabal sdist && cabal install --enable-tests dist/ldap-client-*.tar.gz
+  - cabal configure --enable-tests -v2
+  - cabal build
+  - 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

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

LICENSE

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

README.markdown

@@ -1,29 +1,28 @@
 ldap-client
 ===========
 [![Hackage](https://budueba.com/hackage/ldap-client)](https://hackage.haskell.org/package/ldap-client)
-[![Build Status](https://travis-ci.org/alasconnect/ldap-client.svg?branch=master)](https://travis-ci.org/alasconnect/ldap-client)
+[![Build Status](https://travis-ci.org/supki/ldap-client.svg?branch=master)](https://travis-ci.org/supki/ldap-client)
 
 This library implements (the parts of) [RFC 4511][rfc4511]
 
-|           Feature            |   RFC Section   |   Support
-|:---------------------------- |:---------------:|:-----------:
-| 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.
 
   [rfc4511]: https://tools.ietf.org/html/rfc4511

default.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc802" }: let
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc7102" }: 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     :: Int
+  , port     :: PortNumber
   , dn       :: Dn
   , password :: Password
   , base     :: Dn
@@ -55,7 +55,7 @@ main = do
 
 login :: Conf -> IO (Either LdapError ())
 login conf =
-  Ldap.with (Ldap.Tls (host conf) Ldap.defaultTlsSettings) (port conf) $ \l -> do
+  Ldap.with (Ldap.Secure (host conf)) (port conf) $ \l -> do
     Ldap.bind l (dn conf) (password conf)
     fix $ \loop -> do
       uid <- prompt "Username: "

ldap-client.cabal

@@ -1,37 +1,30 @@
 name:                ldap-client
-version:             0.4.0
+version:             0.1.0
 synopsis:            Pure Haskell LDAP Client Library
 description:
   Pure Haskell LDAP client library implementing (the parts of) RFC 4511.
-homepage:            https://github.com/alasconnect/ldap-client
+homepage:            https://supki.github.io/ldap-client
 license:             BSD2
 license-file:        LICENSE
-author:              Matvey Aksenov, AlasConnect LLC
-maintainer:          matvey.aksenov@gmail.com, software@alasconnect.com
-copyright:           2015 Matvey Aksenov, 2019 AlasConnect LLC
+author:              Matvey Aksenov
+maintainer:          matvey.aksenov@gmail.com
+copyright:           2015 Matvey Aksenov
 category:            Network
 build-type:          Simple
 cabal-version:       >= 1.10
 tested-with:
-    GHC == 8.0.1
-  , GHC == 8.2.2
-  , GHC == 8.4.4
-  , GHC == 8.6.5
+    GHC == 7.6.3
+  , GHC == 7.8.4
+  , GHC == 7.10.1
 extra-source-files:
-  README.md
-  CHANGELOG.md
+  README.markdown
 
 source-repository head
   type:     git
-  location: git@github.com:alasconnect/ldap-client
-  tag:      0.4.0
+  location: git@github.com:supki/ldap-client
+  tag:      0.1.0
 
 library
-  ghc-options:
-    -Wall
-    -fwarn-incomplete-uni-patterns
-    -fwarn-incomplete-record-updates
-    -fwarn-unrecognised-pragmas
   default-language:
     Haskell2010
   hs-source-dirs:
@@ -41,7 +34,9 @@ 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
@@ -57,18 +52,12 @@ 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:
@@ -94,3 +83,16 @@ 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/default.nix

@@ -6,4 +6,4 @@ let
     };
     in nodeLib.generatePackages {
       rootPath = ./nodePackages;
-    }
+    }

npm/nodeLib/default.nix

@@ -75,7 +75,7 @@ let
 in
 
 rec {
-  nodejs = pkgs.nodejs or (
+  nodejs = pkgs."nodejs-${replaceDots "_" nodejsVersion}" 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.4.0";
+  version = "0.1.0";
   src = ./.;
   buildDepends = [
     asn1-encoding asn1-types async base bytestring connection

shell.nix

@@ -1,23 +1,17 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc802" }: let
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc7102" }: let
   inherit (nixpkgs) pkgs;
-  haskell = pkgs.haskell.packages.${compiler};
-
-  ghc = haskell.ghcWithPackages(ps: [
+  ghc = pkgs.haskell.packages.${compiler}.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 = this.pname;
-    buildInputs = [
-      ghc
-      haskell.cabal-install
-      npm.nodePackages.ldapjs
-    ] ++ this.env.buildInputs;
+    name = pkg.pname;
+    buildInputs = [ ghc cabal-install npm.nodePackages.ldapjs ] ++ pkg.env.buildInputs;
     shellHook = ''
-      ${this.env.shellHook}
+      ${pkg.env.shellHook}
       cabal configure --enable-tests --package-db=$NIX_GHC_LIBDIR/package.conf.d
     '';
   }

src/Ldap/Asn1/FromAsn1.hs

@@ -11,9 +11,6 @@ import           Control.Applicative (Alternative(..), liftA2, optional)
 import           Control.Applicative (Applicative(..), Alternative(..), liftA2, optional)
 #endif
 import           Control.Monad (MonadPlus(..), (>=>), guard)
-#if __GLASGOW_HASKELL__ >= 86
-import           Control.Monad.Fail (MonadFail, fail)
-#endif
 import           Data.ASN1.Types (ASN1)
 import qualified Data.ASN1.Types as Asn1
 import           Data.Foldable (asum)
@@ -22,8 +19,8 @@ import qualified Data.Text.Encoding as Text
 
 import           Ldap.Asn1.Type
 
-{-# ANN module ("HLint: ignore Use const" :: String) #-}
-{-# ANN module ("HLint: ignore Avoid lambda" :: String) #-}
+{-# ANN module "HLint: ignore Use const" #-}
+{-# ANN module "HLint: ignore Avoid lambda" #-}
 
 
 -- | Convert a part of ASN.1 stream to a LDAP type returning the remainder of the stream.
@@ -419,11 +416,6 @@ instance MonadPlus (Parser s) where
   Parser ma `mplus` Parser mb =
     Parser (\s -> ma s `mplus` mb s)
 
-#if __GLASGOW_HASKELL__ >= 86
-instance MonadFail (Parser s) where
-  fail _ = mzero
-#endif
-
 parse :: Parser s a -> s -> Maybe (s, a)
 parse = unParser
 

src/Ldap/Asn1/ToAsn1.hs

@@ -1,440 +1,217 @@
-{-# 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.
+{-# LANGUAGE CPP #-}
 module Ldap.Asn1.ToAsn1
-  ( ToAsn1(toAsn1)
+  ( Ber
+  , encode
+  , bool
+  , int32
+  , enum
+  , octetstring
+  , null
+  , sequence
+  , set
+  , tagged
+  , Mod
+  , Tag
+  , application
+  , context
+  , tag
   ) where
 
-import           Data.ASN1.Types (ASN1, ASN1Class, ASN1Tag, ASN1ConstructionType)
-import qualified Data.ASN1.Types as Asn1
-import           Data.ByteString (ByteString)
-import           Data.Foldable (fold, foldMap)
-import           Data.List.NonEmpty (NonEmpty)
-import           Data.Maybe (maybe)
-import           Data.Monoid (Endo(Endo), (<>), mempty)
-import qualified Data.Text.Encoding as Text
-import           Prelude (Integer, (.), fromIntegral)
+import           Data.Bits (Bits((.&.), (.|.), shiftR))
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+import           Data.ByteString.Lazy (ByteString)
+import           Data.ByteString.Lazy.Builder (Builder)
+import qualified Data.ByteString.Lazy.Builder as Builder
+import           Data.Int (Int64, Int32)
+import           Data.List.NonEmpty (NonEmpty((:|)))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid (Monoid(..))
+#endif
+import           Data.Semigroup (Semigroup(..))
+import           Data.Word (Word8)
+import           Prelude hiding (null, sequence)
 
-import           Ldap.Asn1.Type
+-- $setup
+-- >>> :set -XOverloadedStrings
 
+data Ber = Ber !Int64 !Builder
 
--- | Convert a LDAP type to ASN.1.
+instance Semigroup Ber where
+  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.
 --
--- When it's relevant, instances include the part of RFC describing the encoding.
-class ToAsn1 a where
-  toAsn1 :: a -> Endo [ASN1]
+-- >>> encode (bool mempty True)
+-- "\SOH\SOH\255"
+--
+-- >>> 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)
 
-{- |
-@
-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 (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
-      ])
+-- | Encoding of an integer value.
+--
+-- >>> encode (int32 mempty 0)
+-- "\STX\SOH\NUL"
+--
+-- >>> encode (int32 mempty 127)
+-- "\STX\SOH\DEL"
+--
+-- >>> encode (int32 mempty 128)
+-- "\STX\STX\NUL\128"
+int32 :: Mod -> Int32 -> Ber
+int32 f n = fromBytes ((t .|. classBit f) : ts ++ fromIntegral (length bytes) : bytes)
+ where
+  t :| ts = tagBits (tag 0x02 <> f)
+  bytes
+    | n .&. 0x80 == 0x80 = 0x00 : reverse (go n)
+    | otherwise = reverse (go n)
    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) =
-    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
-     ])
+    go i
+      | i <= 0xff = return (fromIntegral i)
+      | otherwise = (fromIntegral i .&. 0xff) : go (i `shiftR` 8)
 
-{- |
-@
-AuthenticationChoice ::= CHOICE {
-     simple                  [0] OCTET STRING,
-     sasl                    [3] SaslCredentials,
-     ...  }
+-- | Encoding of an enumerated value.
+--
+-- It is encoded exactly the same as an integer value, but the tag number is different.
+enum :: Mod -> Int32 -> Ber
+enum f = int32 (tag 0x0a <> f)
 
+-- | 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)
 
-SaslCredentials ::= SEQUENCE {
-     mechanism               LDAPString,
-     credentials             OCTET STRING OPTIONAL }
-@
--}
-instance ToAsn1 AuthenticationChoice where
-  toAsn1 (Simple s) = other Asn1.Context 0 s
-  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 NULL
+--
+-- >>> encode (null mempty)
+-- "\ENQ\NUL"
+null :: Mod -> Ber
+null f = fromBytes ((t .|. classBit f) : ts ++ [0])
+ where
+  t :| ts = tagBits (tag 0x05 <> f)
 
-{- |
-@
-Filter ::= CHOICE {
-     and             [0] SET SIZE (1..MAX) OF filter Filter,
-     or              [1] SET SIZE (1..MAX) OF filter Filter,
-     not             [2] Filter,
-     equalityMatch   [3] AttributeValueAssertion,
-     substrings      [4] SubstringFilter,
-     greaterOrEqual  [5] AttributeValueAssertion,
-     lessOrEqual     [6] AttributeValueAssertion,
-     present         [7] AttributeDescription,
-     approxMatch     [8] AttributeValueAssertion,
-     extensibleMatch [9] MatchingRuleAssertion,
-     ...  }
-@
--}
-instance ToAsn1 Filter where
-  toAsn1 f = case f of
-    And xs            -> context 0 (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 sequence [of].
+--
+-- >>> encode (sequence mempty (octetstring mempty "Smith" <> bool mempty True))
+-- "0\n\EOT\ENQSmith\SOH\SOH\255"
+sequence :: Mod -> Ber -> Ber
+sequence m = tagged (tag 0x10 <> m)
 
-{- |
-@
-SubstringFilter ::= SEQUENCE {
-     type           AttributeDescription,
-     substrings     SEQUENCE SIZE (1..MAX) OF substring CHOICE {
-          initial [0] AssertionValue,  -- can occur at most once
-          any     [1] AssertionValue,
-          final   [2] AssertionValue } -- can occur at most once
-     }
-@
--}
-instance ToAsn1 SubstringFilter where
-  toAsn1 (SubstringFilter ad ss) =
-    toAsn1 ad <> sequence (foldMap (\s -> case s of
-      Initial (AssertionValue v) -> other Asn1.Context 0 v
-      Any (AssertionValue v)     -> other Asn1.Context 1 v
-      Final (AssertionValue v)   -> other Asn1.Context 2 v) ss)
+-- | Encoding of a set [of].
+--
+-- >>> encode (set mempty (octetstring mempty "Smith" <> bool mempty True))
+-- "1\n\EOT\ENQSmith\SOH\SOH\255"
+set :: Mod -> Ber -> Ber
+set m = tagged (tag 0x11 <> m)
 
-{- |
-@
-MatchingRuleAssertion ::= SEQUENCE {
-     matchingRule    [1] MatchingRuleId OPTIONAL,
-     type            [2] AttributeDescription OPTIONAL,
-     matchValue      [3] AssertionValue,
-     dnAttributes    [4] BOOLEAN DEFAULT FALSE }
-@
--}
-instance ToAsn1 MatchingRuleAssertion where
-  toAsn1 (MatchingRuleAssertion mmr mad (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)
+-- | 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
+ where
+  t :| ts = tagBits f
+  constructedTag = 0x20
 
-{- |
-@
-AttributeList ::= SEQUENCE OF attribute Attribute
-@
--}
-instance ToAsn1 AttributeList where
-  toAsn1 (AttributeList xs) = sequence (toAsn1 xs)
+fromBytes :: [Word8] -> Ber
+fromBytes xs = let bs = ByteString.Lazy.pack xs in Ber (ByteString.Lazy.length bs) (Builder.lazyByteString bs)
 
-instance ToAsn1 a => ToAsn1 [a] where
-  toAsn1 = foldMap toAsn1
+defaultTag :: Tag
+defaultTag = Tag Universal (Number 0)
 
-instance ToAsn1 a => ToAsn1 (NonEmpty a) where
-  toAsn1 = foldMap toAsn1
+newtype Mod = Mod (Tag -> Tag)
 
-sequence :: Endo [ASN1] -> Endo [ASN1]
-sequence = construction Asn1.Sequence
+instance Semigroup Mod where
+  Mod f <> Mod g = Mod (g . f)
 
-set :: Endo [ASN1] -> Endo [ASN1]
-set = construction Asn1.Set
+instance Monoid Mod where
+  mappend = (<>)
+  mempty = Mod id
 
-application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
-application = construction . Asn1.Container Asn1.Application
+data Class =
+    Universal
+  | Application
+  | Context
+    deriving (Show, Eq)
 
-context :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
-context = construction . Asn1.Container Asn1.Context
+data Tag = Tag !Class !Number
+    deriving (Show, Eq)
 
-construction :: ASN1ConstructionType -> Endo [ASN1] -> Endo [ASN1]
-construction t x = single (Asn1.Start t) <> x <> single (Asn1.End t)
+newtype Number = Number Word8
+    deriving (Show, Eq)
 
-other :: ASN1Class -> ASN1Tag -> ByteString -> Endo [ASN1]
-other c t = single . Asn1.Other c t
+classBit :: Mod -> Word8
+classBit (Mod f) = case f defaultTag of
+  Tag Universal _   -> 0x00
+  Tag Application _ -> 0x40
+  Tag Context _     -> 0x80
 
-enum :: Integer -> Endo [ASN1]
-enum = single . Asn1.Enumerated
+tagBits :: Mod -> NonEmpty Word8
+tagBits (Mod f) = case f defaultTag of Tag _ t -> encodeTagNumber t
 
-single :: a -> Endo [a]
-single x = Endo (x :)
+application, context :: Mod
+application = class_ Application
+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,6 +28,7 @@ data ProtocolClientOp =
   | DeleteRequest !LdapDn
   | ModifyDnRequest !LdapDn !RelativeLdapDn !Bool !(Maybe LdapDn)
   | CompareRequest !LdapDn !AttributeValueAssertion
+  | AbandonRequest !Id
   | ExtendedRequest !LdapOid !(Maybe ByteString)
     deriving (Show, Eq)
 
@@ -37,7 +38,7 @@ data ProtocolServerOp =
     BindResponse !LdapResult !(Maybe ByteString)
   | SearchResultEntry !LdapDn !PartialAttributeList
   | SearchResultReference !(NonEmpty Uri)
-  | SearchResultDone !LdapResult
+  | SearchResultDone !(LdapResult)
   | ModifyResponse !LdapResult
   | AddResponse !LdapResult
   | DeleteResponse !LdapResult
@@ -48,14 +49,7 @@ data ProtocolServerOp =
     deriving (Show, Eq)
 
 -- | Not really a choice until SASL is supported.
-data AuthenticationChoice =
-    Simple !ByteString
-  | Sasl !SaslMechanism !(Maybe Text)
-    deriving (Show, Eq)
-
--- | SASL Mechanism, for now only SASL EXTERNAL is supported
-data SaslMechanism =
-    External
+newtype AuthenticationChoice = Simple ByteString
     deriving (Show, Eq)
 
 -- | Scope of the search to be performed.
@@ -77,16 +71,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,8 +2,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 -- | This module is intended to be imported qualified
 --
 -- @
@@ -11,24 +9,15 @@
 -- @
 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(..)
@@ -68,15 +57,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.Exception (Exception, bracket, throwIO, SomeException, fromException, throw, Handler(..))
+import           Control.Concurrent.STM.TVar (newTVarIO)
+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
@@ -86,7 +75,10 @@ import           Data.Foldable (asum)
 import           Data.Function (fix)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.Map.Strict as Map
-import           Data.Monoid (Endo(appEndo))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid (mempty)
+#endif
+import           Data.String (fromString)
 import           Data.Text (Text)
 #if __GLASGOW_HASKELL__ < 710
 import           Data.Traversable (traverse)
@@ -97,11 +89,12 @@ 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, externalBind)
+import           Ldap.Client.Bind (Password(..), bind)
 import           Ldap.Client.Search
   ( search
   , Search
@@ -118,219 +111,159 @@ 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, noticeOfDisconnectionOid)
+import           Ldap.Client.Extended (Oid(..), extended)
 
-{-# ANN module ("HLint: ignore Use first" :: String) #-}
+{-# ANN module "HLint: ignore Use first" #-}
 
 
+newLdap :: IO Ldap
+newLdap = Ldap
+  <$> newTQueueIO
+  <*> newTVarIO (Type.Id 0)
+
 -- | 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)
 
-instance Exception LdapError
+newtype WrappedIOError = WrappedIOError IOError
+    deriving (Show, Eq, Typeable)
 
-data Disconnect = Disconnect !Type.ResultCode !Dn !Text
+instance Exception WrappedIOError
+
+data Disconnect = Disconnect Type.ResultCode Dn Text
     deriving (Show, Eq, Typeable)
 
 instance Exception Disconnect
 
-newtype LdapH = LdapH Ldap
-
--- | Provide a 'LdapH' to a function needing an 'Ldap' handle.
-runsIn :: (Ldap -> IO a)
-       -> LdapH
-       -> IO a
-runsIn act (LdapH ldap) = do
-  actor <- Async.async (act ldap)
-  r <- Async.waitEitherCatch (workers ldap) actor
-  case r of
-    Left (Right _a) -> error "Unreachable"
-    Left (Left e)   -> throwIO =<< catchesHandler workerErr e
-    Right (Right r') -> pure r'
-    Right (Left e)  -> throwIO =<< catchesHandler respErr e
-
--- | Provide a 'LdapH' to a function needing an 'Ldap' handle
-runsInEither :: (Ldap -> IO a)
-             -> LdapH
-             -> IO (Either LdapError a)
-runsInEither act (LdapH ldap) = do
-  actor <- Async.async (act ldap)
-  r <- Async.waitEitherCatch (workers ldap) actor
-  case r of
-    Left (Right _a) -> error "Unreachable"
-    Left (Left e)   -> do Left <$> catchesHandler workerErr e
-    Right (Right r') -> pure (Right r')
-    Right (Left e)  -> do Left <$> catchesHandler respErr e
-
-
-workerErr :: [Handler LdapError]
-workerErr = [ Handler (\(ex :: IOError) -> pure (IOError ex))
-            , Handler (\(ex :: Asn1.ASN1Error) -> pure (ParseError ex))
-            , Handler (\(ex :: Disconnect) -> pure (DisconnectError ex))
-            ]
-
-respErr :: [Handler LdapError]
-respErr = [ Handler (\(ex :: ResponseError) -> pure (ResponseError ex))
-          ]
-
-catchesHandler :: [Handler a] -> SomeException -> IO a
-catchesHandler handlers e = foldr tryHandler (throw e) handlers
-    where tryHandler (Handler handler) res
-              = case fromException e of
-                Just e' -> handler e'
-                Nothing -> res
-
 -- | The entrypoint into LDAP.
-with' :: Host -> PortNumber -> (Ldap -> IO a) -> IO a
-with' host port act = bracket (open host port) close (runsIn act)
-
+--
+-- It catches all LDAP-related exceptions.
 with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
-with host port act = bracket (open host port) close (runsInEither act)
-
--- | 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
+with host port f = do
   context <- Conn.initConnectionContext
-  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))
+  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)
+  ]
  where
   params = Conn.ConnectionParams
     { Conn.connectionHostname =
         case host of
-          Plain h -> h
-          Tls   h _ -> h
+          Plain    h -> h
+          Secure   h -> h
+          Insecure h -> h
     , Conn.connectionPort = port
     , Conn.connectionUseSecure =
         case host of
           Plain  _ -> Nothing
-          Tls _ settings -> pure settings
+          Secure _ -> Just Conn.TLSSettingsSimple
+            { 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
     }
 
--- | 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 []
+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 []
 
--- | Transmits Asn1 DER encoded data from a TQueue into a Connection.
 output :: ToAsn1 a => TQueue a -> Connection -> IO b
-output out conn = forever $ do
+output out conn = wrap . forever $ do
   msg <- atomically (readTQueue out)
-  Conn.connectionPut conn (encode (toAsn1 msg))
- where
-  encode x = Asn1.encodeASN1' Asn1.DER (appEndo x [])
+  Conn.connectionPut conn (ByteString.Lazy.toStrict (encode (toAsn1 mempty msg)))
 
 dispatch
-  :: TQueue ClientMessage
+  :: Ldap
   -> TQueue (Type.LdapMessage Type.ProtocolServerOp)
   -> TQueue (Type.LdapMessage Request)
   -> IO a
-dispatch reqq inq outq = loop (Map.empty, 1)
-  where
-    saveUp mid op res = return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
+dispatch Ldap { client } inq outq =
+  flip fix Map.empty $ \loop !req ->
+    loop =<< atomically (asum
+      [ 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)
 
-    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)
-        ])
+  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)
 
-    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)
+  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
 
-    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
+  noticeOfDisconnection :: Text
+  noticeOfDisconnection = fromString "1.3.6.1.4.1.1466.20036"
+
+wrap :: IO a -> IO a
+wrap m = m `catch` (throwIO . WrappedIOError)

src/Ldap/Client/Abandon.hs

@@ -0,0 +1,39 @@
+-- | <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 =
-  eitherToIO =<< addEither l dn as
+  raise =<< addEither l dn as
 
 -- | Perform the Add operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.

src/Ldap/Client/Asn1/ToAsn1.hs

@@ -0,0 +1,408 @@
+-- | 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,10 +17,6 @@ module Ldap.Client.Bind
   , bindEither
   , bindAsync
   , bindAsyncSTM
-  , externalBind
-  , externalBindEither
-  , externalBindAsync
-  , externalBindAsyncSTM
   , Async
   , wait
   , waitSTM
@@ -28,7 +24,6 @@ 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
@@ -42,7 +37,7 @@ newtype Password = Password ByteString
 -- | Perform the Bind operation synchronously. Raises 'ResponseError' on failures.
 bind :: Ldap -> Dn -> Password -> IO ()
 bind l username password =
-  eitherToIO =<< bindEither l username password
+  raise =<< bindEither l username password
 
 -- | Perform the Bind operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.
@@ -78,37 +73,3 @@ 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 =
-  eitherToIO =<< compareEither l dn k v
+  raise =<< compareEither l dn k v
 
 -- | Perform the Compare operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.

src/Ldap/Client/Delete.hs

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

src/Ldap/Client/Extended.hs

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

src/Ldap/Client/Internal.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Ldap.Client.Internal
@@ -7,7 +6,7 @@ module Ldap.Client.Internal
   , Ldap(..)
   , ClientMessage(..)
   , Type.ResultCode(..)
-  , Async
+  , Async(..)
   , AttrList
     -- * Waiting for Request Completion
   , wait
@@ -16,7 +15,7 @@ module Ldap.Client.Internal
   , Response
   , ResponseError(..)
   , Request
-  , eitherToIO
+  , raise
   , sendRequest
   , Dn(..)
   , Attr(..)
@@ -27,50 +26,45 @@ 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.
-  | Tls String TLSSettings -- ^ LDAP over TLS.
-    deriving (Show)
+    Plain String    -- ^ Plain LDAP. Do not use!
+  | Insecure String -- ^ LDAP over TLS without the certificate validity check.
+                    --   Only use for testing!
+  | Secure String   -- ^ LDAP over TLS. Use!
+    deriving (Show, Eq, Ord)
 
--- | An LDAP connection handle
+-- | A token. All functions that interact with the Directory require one.
 data Ldap = Ldap
-  { reqQ    :: !(TQueue ClientMessage) -- ^ Request queue for client messages to be send.
-  , workers :: !(Async.Async Void) -- ^ Workers group for communicating with the server.
-  , conn    :: !Connection -- ^ Network connection to the server.
-  }
+  { client  :: TQueue ClientMessage
+  , counter :: TVar Type.Id
+  } deriving (Eq)
 
-data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp))
+data ClientMessage = New Type.Id 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.
-newtype Async a = Async (STM (Either ResponseError a))
+data Async a = Async Type.Id (STM (Either ResponseError a))
 
 instance Functor Async where
-  fmap f (Async stm) = Async (fmap (fmap f) stm)
+  fmap f (Async mid stm) = Async mid (fmap (fmap f) stm)
 
 -- | Unique identifier of an LDAP entry.
 newtype Dn = Dn Text
@@ -78,8 +72,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
@@ -111,19 +105,26 @@ 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
-     writeRequest l var msg
-     return (Async (fmap p (readTMVar var)))
+     mid <- newId l
+     writeRequest l (New mid msg var)
+     return (Async mid (fmap p (readTMVar var)))
 
-writeRequest :: Ldap -> TMVar Response -> Request -> STM ()
-writeRequest Ldap { reqQ } var msg = writeTQueue reqQ (New msg var)
+newId :: Ldap -> STM Type.Id
+newId Ldap { counter } =
+  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.
 --
@@ -145,4 +146,4 @@ unbindAsyncSTM :: Ldap -> STM ()
 unbindAsyncSTM l =
   void (sendRequest l die Type.UnbindRequest)
  where
-  die = error "Ldap.Client: do not wait for the response to UnbindRequest"
+  die = error "Ldap.Client.Internal: 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.
-  | 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 =
-  eitherToIO =<< modifyEither l dn as
+  raise =<< modifyEither l dn as
 
 -- | Perform the Modify operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.
@@ -98,7 +98,7 @@ newtype RelativeDn = RelativeDn Text
 -- | Perform the Modify DN operation synchronously. Raises 'ResponseError' on failures.
 modifyDn :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO ()
 modifyDn l dn rdn del new =
-  eitherToIO =<< modifyDnEither l dn rdn del new
+  raise =<< modifyDnEither l dn rdn del new
 
 -- | Perform the Modify DN operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.

src/Ldap/Client/Search.hs

@@ -52,7 +52,7 @@ import           Ldap.Client.Internal
 -- | Perform the Search operation synchronously. Raises 'ResponseError' on failures.
 search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
 search l base opts flt attributes =
-  eitherToIO =<< searchEither l base opts flt attributes
+  raise =<< searchEither l base opts flt attributes
 
 -- | Perform the Search operation synchronously. Returns @Left e@ where
 -- @e@ is a 'ResponseError' on failures.
@@ -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

@@ -0,0 +1,7 @@
+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")
-          "InvalidCredentialsError"))
+          "Invalid Credentials"))
 
   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")
-                                "InsufficientAccessRightsError"))
+                                "Insufficient Access Rights"))
 
   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, True) ::= "flying")
+      res <- go l ((Just (Attr "type"), Nothing, False) ::= "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 :: Int)) :
+                                  (Just (("PORT", show port) :
                                          ("SSL_CERT", "./ssl/cert.pem") :
                                          ("SSL_KEY", "./ssl/key.pem") :
                                          env))
-              _ <- hGetLine out
-              _ <- forkIO (() <$ tryIOError (forever (hGetLine out >>= putStrLn)))
+              hGetLine out
+              forkIO (() <$ tryIOError (forever (hGetLine out >>= putStrLn)))
               return h)
           (\h -> do terminateProcess h
                     waitForProcess h)
           (\_ -> Ldap.with localhost port f)
 
 localhost :: Host
-localhost = Tls "localhost" insecureTlsSettings
+localhost = Insecure "localhost"
 
 port :: Num a => a
 port = 24620