Extract as much useful information as possible from errors

ldap-client.cabal

@@ -29,6 +29,13 @@ library
     Ldap.Asn1.ToAsn1
     Ldap.Asn1.Type
     Ldap.Client
+    Ldap.Client.Add
+    Ldap.Client.Bind
+    Ldap.Client.Compare
+    Ldap.Client.Delete
+    Ldap.Client.Internal
+    Ldap.Client.Modify
+    Ldap.Client.Search
   build-depends:
       asn1-encoding >= 0.9
     , asn1-types    >= 0.3
@@ -52,7 +59,15 @@ test-suite spec
   main-is:
     Spec.hs
   other-modules:
-    Ldap.ClientSpec
+    Ldap.Client
+    Ldap.Client.AddSpec
+    Ldap.Client.BindSpec
+    Ldap.Client.CompareSpec
+    Ldap.Client.DeleteSpec
+    Ldap.Client.InternalSpec
+    Ldap.Client.ModifySpec
+    Ldap.Client.SearchSpec
+    SpecHelper
   build-depends:
       base          >= 4.7 && < 5
     , hspec

src/Ldap/Client.hs

@@ -6,17 +6,16 @@ module Ldap.Client
   , PortNumber
   , Ldap
   , LdapError(..)
+  , ResponseError(..)
   , Type.ResultCode(..)
   , Async
   , with
     -- * Bind Operation
   , Dn(..)
   , Password(..)
-  , BindError(..)
   , bind
     -- * Search Operation
   , Attr(..)
-  , SearchError(..)
   , search
   , Search
   , scope
@@ -28,18 +27,14 @@ module Ldap.Client
   , Filter(..)
   , SearchEntry(..)
     -- * Modify Operation
-  , ModifyError(..)
   , Operation(..)
   , modify
     -- * Add Operation
   , AttrList
-  , AddError(..)
   , add
     -- * Delete Operation
-  , DeleteError(..)
   , delete
     -- * Compare Operation
-  , CompareError(..)
   , compare
     -- * Waiting for Operation Completion
   , wait
@@ -71,10 +66,9 @@ import           Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1))
 import           Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1)
 import qualified Ldap.Asn1.Type as Type
 import           Ldap.Client.Internal
-import           Ldap.Client.Bind (BindError(..), bind, unbindAsync)
+import           Ldap.Client.Bind (bind, unbindAsync)
 import           Ldap.Client.Search
-  ( SearchError(..)
+  ( search
-  , search
   , Search
   , scope
   , size
@@ -84,8 +78,10 @@ import           Ldap.Client.Search
   , Filter(..)
   , SearchEntry(..)
   )
-import           Ldap.Client.Modify (ModifyError(..), Operation(..), modify)
+import           Ldap.Client.Modify (Operation(..), modify)
-import           Ldap.Client.Compare (CompareError(..), compare)
+import           Ldap.Client.Add (add)
+import           Ldap.Client.Delete (delete)
+import           Ldap.Client.Compare (compare)
 
 
 newLdap :: IO Ldap
@@ -95,12 +91,7 @@ newLdap = Ldap
 data LdapError =
     IOError IOError
   | ParseError Asn1.ASN1Error
-  | BindError BindError
+  | ResponseError ResponseError
-  | SearchError SearchError
-  | ModifyError ModifyError
-  | AddError AddError
-  | DeleteError DeleteError
-  | CompareError CompareError
     deriving (Show, Eq)
 
 -- | The entrypoint into LDAP.
@@ -119,12 +110,7 @@ with host port f = do
  `catches`
   [ Handler (return . Left . IOError)
   , Handler (return . Left . ParseError)
-  , Handler (return . Left . BindError)
+  , Handler (return . Left . ResponseError)
-  , Handler (return . Left . SearchError)
-  , Handler (return . Left . ModifyError)
-  , Handler (return . Left . AddError)
-  , Handler (return . Left . DeleteError)
-  , Handler (return . Left . CompareError)
   ]
  where
   params = Conn.ConnectionParams

src/Ldap/Client/Add.hs

@@ -0,0 +1,44 @@
+module Ldap.Client.Add
+  ( add
+  , addEither
+  , addAsync
+  , addAsyncSTM
+  ) where
+
+import           Control.Monad.STM (STM, atomically)
+import           Data.List.NonEmpty (NonEmpty((:|)))
+
+import qualified Ldap.Asn1.Type as Type
+import           Ldap.Client.Internal
+
+
+add :: Ldap -> Dn -> AttrList NonEmpty -> IO ()
+add l dn as =
+  raise =<< addEither l dn as
+
+addEither :: Ldap -> Dn -> AttrList NonEmpty -> IO (Either ResponseError ())
+addEither l dn as =
+  wait =<< addAsync l dn as
+
+addAsync :: Ldap -> Dn -> AttrList NonEmpty -> IO (Async ())
+addAsync l dn as =
+  atomically (addAsyncSTM l dn as)
+
+addAsyncSTM :: Ldap -> Dn -> AttrList NonEmpty -> STM (Async ())
+addAsyncSTM l dn as =
+  let req = addRequest dn as in sendRequest l (addResult req) req
+
+addRequest :: Dn -> AttrList NonEmpty -> Request
+addRequest (Dn dn) as =
+  Type.AddRequest (Type.LdapDn (Type.LdapString dn))
+                  (Type.AttributeList (map f as))
+ where
+  f (Attr x, xs) = Type.Attribute (Type.AttributeDescription (Type.LdapString x))
+                                  (fmap Type.AttributeValue xs)
+
+addResult :: Request -> Response -> Either ResponseError ()
+addResult req (Type.AddResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
+                                                      (Type.LdapString msg) _) :| [])
+  | Type.Success <- code = Right ()
+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
+addResult req res = Left (ResponseInvalid req res)

src/Ldap/Client/Bind.hs

@@ -1,6 +1,5 @@
 module Ldap.Client.Bind
-  ( BindError(..)
+  ( bind
-  , bind
   , bindEither
   , bindAsync
   , bindAsyncSTM
@@ -8,40 +7,31 @@ module Ldap.Client.Bind
   , unbindAsyncSTM
   ) where
 
-import           Control.Exception (Exception)
 import           Control.Monad (void)
 import           Control.Monad.STM (STM, atomically)
 import           Data.List.NonEmpty (NonEmpty((:|)))
-import           Data.Typeable (Typeable)
 
 import qualified Ldap.Asn1.Type as Type
 import           Ldap.Client.Internal
 
 
-data BindError =
-    BindInvalidResponse Response
-  | BindErrorCode Type.ResultCode
-    deriving (Show, Eq, Typeable)
-
-instance Exception BindError
-
 -- | Throws 'BindError' on failure. Don't worry, the nearest 'with'
 -- will catch it, so it won't destroy your program.
 bind :: Ldap -> Dn -> Password -> IO ()
 bind l username password =
   raise =<< bindEither l username password
 
-bindEither :: Ldap -> Dn -> Password -> IO (Either BindError ())
+bindEither :: Ldap -> Dn -> Password -> IO (Either ResponseError ())
 bindEither l username password =
   wait =<< bindAsync l username password
 
-bindAsync :: Ldap -> Dn -> Password -> IO (Async BindError ())
+bindAsync :: Ldap -> Dn -> Password -> IO (Async ())
 bindAsync l username password =
   atomically (bindAsyncSTM l username password)
 
-bindAsyncSTM :: Ldap -> Dn -> Password -> STM (Async BindError ())
+bindAsyncSTM :: Ldap -> Dn -> Password -> STM (Async ())
 bindAsyncSTM l username password =
-  sendRequest l bindResult (bindRequest username password)
+  let req = bindRequest username password in sendRequest l (bindResult req) req
 
 bindRequest :: Dn -> Password -> Request
 bindRequest (Dn username) (Password password) =
@@ -51,11 +41,12 @@ bindRequest (Dn username) (Password password) =
  where
   ldapVersion = 3
 
-bindResult :: Response -> Either BindError ()
+bindResult :: Request -> Response -> Either ResponseError ()
-bindResult (Type.BindResponse (Type.LdapResult code _ _ _) _ :| [])
+bindResult req (Type.BindResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
+                                                        (Type.LdapString msg) _) _ :| [])
   | Type.Success <- code = Right ()
-  | otherwise = Left (BindErrorCode code)
+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
-bindResult res = Left (BindInvalidResponse res)
+bindResult req res = Left (ResponseInvalid req res)
 
 
 -- | Note that 'unbindAsync' does not return an 'Async',

src/Ldap/Client/Compare.hs

@@ -1,44 +1,34 @@
 module Ldap.Client.Compare
-  ( CompareError(..)
+  ( compare
-  , compare
   , compareEither
   , compareAsync
   , compareAsyncSTM
   ) where
 
-import           Control.Exception (Exception)
 import           Control.Monad.STM (STM, atomically)
 import           Data.ByteString (ByteString)
 import           Data.List.NonEmpty (NonEmpty((:|)))
-import           Data.Typeable (Typeable)
 import           Prelude hiding (compare)
 
 import           Ldap.Client.Internal
 import qualified Ldap.Asn1.Type as Type
 
 
-data CompareError =
-    CompareInvalidResponse Response
-  | CompareErrorCode Type.ResultCode
-    deriving (Show, Eq, Typeable)
-
-instance Exception CompareError
-
 compare :: Ldap -> Dn -> Attr -> ByteString -> IO Bool
 compare l dn k v =
   raise =<< compareEither l dn k v
 
-compareEither :: Ldap -> Dn -> Attr -> ByteString -> IO (Either CompareError Bool)
+compareEither :: Ldap -> Dn -> Attr -> ByteString -> IO (Either ResponseError Bool)
 compareEither l dn k v =
   wait =<< compareAsync l dn k v
 
-compareAsync :: Ldap -> Dn -> Attr -> ByteString -> IO (Async CompareError Bool)
+compareAsync :: Ldap -> Dn -> Attr -> ByteString -> IO (Async Bool)
 compareAsync l dn k v =
   atomically (compareAsyncSTM l dn k v)
 
-compareAsyncSTM :: Ldap -> Dn -> Attr -> ByteString -> STM (Async CompareError Bool)
+compareAsyncSTM :: Ldap -> Dn -> Attr -> ByteString -> STM (Async Bool)
 compareAsyncSTM l dn k v =
-  sendRequest l compareResult (compareRequest dn k v)
+  let req = compareRequest dn k v in sendRequest l (compareResult req) req
 
 compareRequest :: Dn -> Attr -> ByteString -> Request
 compareRequest (Dn dn) (Attr k) v =
@@ -47,9 +37,10 @@ compareRequest (Dn dn) (Attr k) v =
                         (Type.AttributeDescription (Type.LdapString k))
                         (Type.AssertionValue v))
 
-compareResult :: Response -> Either CompareError Bool
+compareResult :: Request -> Response -> Either ResponseError Bool
-compareResult (Type.CompareResponse (Type.LdapResult code _ _ _) :| [])
+compareResult req (Type.CompareResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
+                                                              (Type.LdapString msg) _) :| [])
   | Type.CompareTrue  <- code = Right True
   | Type.CompareFalse <- code = Right False
-  | otherwise = Left (CompareErrorCode code)
+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
-compareResult res = Left (CompareInvalidResponse res)
+compareResult req res = Left (ResponseInvalid req res)

src/Ldap/Client/Delete.hs

@@ -0,0 +1,40 @@
+module Ldap.Client.Delete
+  ( delete
+  , deleteEither
+  , deleteAsync
+  , deleteAsyncSTM
+  ) where
+
+import           Control.Concurrent.STM (STM, atomically)
+import           Data.List.NonEmpty (NonEmpty((:|)))
+
+import qualified Ldap.Asn1.Type as Type
+import           Ldap.Client.Internal
+
+
+delete :: Ldap -> Dn -> IO ()
+delete l dn =
+  raise =<< deleteEither l dn
+
+deleteEither :: Ldap -> Dn -> IO (Either ResponseError ())
+deleteEither l dn =
+  wait =<< deleteAsync l dn
+
+deleteAsync :: Ldap -> Dn -> IO (Async ())
+deleteAsync l dn =
+  atomically (deleteAsyncSTM l dn)
+
+deleteAsyncSTM :: Ldap -> Dn -> STM (Async ())
+deleteAsyncSTM l dn =
+  let req = deleteRequest dn in sendRequest l (deleteResult req) req
+
+deleteRequest :: Dn -> Request
+deleteRequest (Dn dn) =
+  Type.DeleteRequest (Type.LdapDn (Type.LdapString dn))
+
+deleteResult :: Request -> Response -> Either ResponseError ()
+deleteResult req (Type.DeleteResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
+                                                            (Type.LdapString msg) _) :| [])
+  | Type.Success <- code = Right ()
+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
+deleteResult req res = Left (ResponseInvalid req res)

src/Ldap/Client/Internal.hs

@@ -8,24 +8,13 @@ module Ldap.Client.Internal
   , ClientMessage(..)
   , Type.ResultCode(..)
   , Async
-    -- * Add Request
   , AttrList
-  , AddError(..)
-  , add
-  , addEither
-  , addAsync
-  , addAsyncSTM
-    -- * Delete Request
-  , DeleteError(..)
-  , delete
-  , deleteEither
-  , deleteAsync
-  , deleteAsyncSTM
     -- * Waiting for Request Completion
   , wait
   , waitSTM
     -- * Misc
   , Response
+  , ResponseError(..)
   , Request
   , raise
   , sendRequest
@@ -40,9 +29,8 @@ import           Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, readTMVar)
 import           Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
 import           Control.Exception (Exception, throwIO)
 import           Data.ByteString (ByteString)
-import           Data.List.NonEmpty (NonEmpty((:|)))
+import           Data.List.NonEmpty (NonEmpty)
 import           Data.Text (Text)
-import           Data.Typeable (Typeable)
 import           Network (PortNumber)
 
 import qualified Ldap.Asn1.Type as Type
@@ -63,9 +51,9 @@ type Request = Type.ProtocolClientOp
 type InMessage = Type.ProtocolServerOp
 type Response = NonEmpty InMessage
 
-data Async e a = Async (STM (Either e a))
+data Async a = Async (STM (Either ResponseError a))
 
-instance Functor (Async e) where
+instance Functor Async where
   fmap f (Async stm) = Async (fmap (fmap f) stm)
 
 
@@ -75,6 +63,13 @@ newtype Password = Password ByteString
     deriving (Show, Eq)
 
 
+data ResponseError =
+    ResponseInvalid Request Response
+  | ResponseErrorCode Request Type.ResultCode Dn Text
+    deriving (Show, Eq)
+
+instance Exception ResponseError
+
 
 
 newtype Attr = Attr Text
@@ -82,85 +77,20 @@ newtype Attr = Attr Text
 
 type AttrList f = [(Attr, f ByteString)]
 
-data AddError =
-    AddInvalidResponse Response
-  | AddErrorCode Type.ResultCode
-    deriving (Show, Eq, Typeable)
-
-instance Exception AddError
-
-add :: Ldap -> Dn -> AttrList NonEmpty -> IO ()
-add l dn as =
-  raise =<< addEither l dn as
-
-addEither :: Ldap -> Dn -> AttrList NonEmpty -> IO (Either AddError ())
-addEither l dn as =
-  wait =<< addAsync l dn as
-
-addAsync :: Ldap -> Dn -> AttrList NonEmpty -> IO (Async AddError ())
-addAsync l dn as =
-  atomically (addAsyncSTM l dn as)
-
-addAsyncSTM :: Ldap -> Dn -> AttrList NonEmpty -> STM (Async AddError ())
-addAsyncSTM l (Dn dn) as =
-  sendRequest l addResult
-                (Type.AddRequest (Type.LdapDn (Type.LdapString dn))
-                                 (Type.AttributeList (map f as)))
- where
-  f (Attr x, xs) = Type.Attribute (Type.AttributeDescription (Type.LdapString x))
-                                  (fmap Type.AttributeValue xs)
-
-addResult :: Response -> Either AddError ()
-addResult (Type.AddResponse (Type.LdapResult code _ _ _) :| [])
-  | Type.Success <- code = Right ()
-  | otherwise = Left (AddErrorCode code)
-addResult res = Left (AddInvalidResponse res)
-
 -- 'Attr' unwrapper. This is a separate function not to turn 'Attr''s
 -- 'Show' instance into complete and utter shit.
 unAttr :: Attr -> Text
 unAttr (Attr a) = a
 
 
-data DeleteError =
+wait :: Async a -> IO (Either ResponseError a)
-    DeleteInvalidResponse Response
-  | DeleteErrorCode Type.ResultCode
-    deriving (Show, Eq, Typeable)
-
-instance Exception DeleteError
-
-delete :: Ldap -> Dn -> IO ()
-delete l dn =
-  raise =<< deleteEither l dn
-
-deleteEither :: Ldap -> Dn -> IO (Either DeleteError ())
-deleteEither l dn =
-  wait =<< deleteAsync l dn
-
-deleteAsync :: Ldap -> Dn -> IO (Async DeleteError ())
-deleteAsync l dn =
-  atomically (deleteAsyncSTM l dn)
-
-deleteAsyncSTM :: Ldap -> Dn -> STM (Async DeleteError ())
-deleteAsyncSTM l (Dn dn) =
-  sendRequest l deleteResult
-                (Type.DeleteRequest (Type.LdapDn (Type.LdapString dn)))
-
-deleteResult :: Response -> Either DeleteError ()
-deleteResult (Type.DeleteResponse (Type.LdapResult code _ _ _) :| [])
-  | Type.Success <- code = Right ()
-  | otherwise = Left (DeleteErrorCode code)
-deleteResult res = Left (DeleteInvalidResponse res)
-
-
-wait :: Async e a -> IO (Either e a)
 wait = atomically . waitSTM
 
-waitSTM :: Async e a -> STM (Either e a)
+waitSTM :: Async a -> STM (Either ResponseError a)
 waitSTM (Async stm) = stm
 
 
-sendRequest :: Ldap -> (Response -> Either e a) -> Request -> STM (Async e a)
+sendRequest :: Ldap -> (Response -> Either ResponseError a) -> Request -> STM (Async a)
 sendRequest l p msg =
   do var <- newEmptyTMVar
      writeRequest l var msg

src/Ldap/Client/Modify.hs

@@ -1,53 +1,44 @@
 module Ldap.Client.Modify
-  ( ModifyError(..)
+  ( Operation(..)
-  , Operation(..)
   , modify
   , modifyEither
   , modifyAsync
   , modifyAsyncSTM
   ) where
 
-import           Control.Exception (Exception)
 import           Control.Monad.STM (STM, atomically)
 import           Data.ByteString (ByteString)
 import           Data.List.NonEmpty (NonEmpty((:|)))
-import           Data.Text (Text)
-import           Data.Typeable (Typeable)
 
 import qualified Ldap.Asn1.Type as Type
 import           Ldap.Client.Internal
 
 
-data ModifyError =
-    ModifyInvalidResponse Response
-  | ModifyErrorCode Type.ResultCode Dn Text
-    deriving (Show, Eq, Typeable)
-
 data Operation =
     Delete Attr [ByteString]
   | Add Attr [ByteString]
   | Replace Attr [ByteString]
     deriving (Show, Eq)
 
-
-instance Exception ModifyError
-
 modify :: Ldap -> Dn -> [Operation] -> IO ()
 modify l dn as =
   raise =<< modifyEither l dn as
 
-modifyEither :: Ldap -> Dn -> [Operation] -> IO (Either ModifyError ())
+modifyEither :: Ldap -> Dn -> [Operation] -> IO (Either ResponseError ())
 modifyEither l dn as =
   wait =<< modifyAsync l dn as
 
-modifyAsync :: Ldap -> Dn -> [Operation] -> IO (Async ModifyError ())
+modifyAsync :: Ldap -> Dn -> [Operation] -> IO (Async ())
 modifyAsync l dn as =
   atomically (modifyAsyncSTM l dn as)
 
-modifyAsyncSTM :: Ldap -> Dn -> [Operation] -> STM (Async ModifyError ())
+modifyAsyncSTM :: Ldap -> Dn -> [Operation] -> STM (Async ())
-modifyAsyncSTM l (Dn dn) xs =
+modifyAsyncSTM l dn xs =
-  sendRequest l modifyResult
+  let req = modifyRequest dn xs in sendRequest l (modifyResult req) req
-                (Type.ModifyRequest (Type.LdapDn (Type.LdapString dn)) (map f xs))
+
+modifyRequest :: Dn -> [Operation] -> Request
+modifyRequest (Dn dn) xs =
+  Type.ModifyRequest (Type.LdapDn (Type.LdapString dn)) (map f xs)
  where
   f (Delete (Attr k) vs) =
     (Type.Delete, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k))
@@ -59,8 +50,8 @@ modifyAsyncSTM l (Dn dn) xs =
     (Type.Replace, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k))
                                          (map Type.AttributeValue vs))
 
-modifyResult :: Response -> Either ModifyError ()
+modifyResult :: Request -> Response -> Either ResponseError ()
-modifyResult (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])
+modifyResult req (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])
   | Type.Success <- code = Right ()
-  | otherwise = Left (ModifyErrorCode code (Dn dn) msg)
+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
-modifyResult res = Left (ModifyInvalidResponse res)
+modifyResult req res = Left (ResponseInvalid req res)

src/Ldap/Client/Search.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Ldap.Client.Search
-  ( SearchError(..)
+  ( search
-  , search
   , searchEither
   , searchAsync
   , searchAsyncSTM
@@ -16,33 +15,19 @@ module Ldap.Client.Search
   , SearchEntry(..)
   ) where
 
-import           Control.Exception (Exception)
 import           Control.Monad.STM (STM, atomically)
 import           Data.ByteString (ByteString)
 import           Data.Int (Int32)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Maybe (mapMaybe)
-import           Data.Typeable (Typeable)
+import           Data.Semigroup (Semigroup(..))
 
 import qualified Ldap.Asn1.Type as Type
 import           Ldap.Client.Internal
 
 
-data SearchError =
+search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
-    SearchInvalidResponse Response
-  | SearchErrorCode Type.ResultCode
-    deriving (Show, Eq, Typeable)
-
-instance Exception SearchError
-
-search
-  :: Ldap
-  -> Dn
-  -> Mod Search
-  -> Filter
-  -> [Attr]
-  -> IO [SearchEntry]
 search l base opts flt attributes =
   raise =<< searchEither l base opts flt attributes
 
@@ -52,45 +37,17 @@ searchEither
   -> Mod Search
   -> Filter
   -> [Attr]
-  -> IO (Either SearchError [SearchEntry])
+  -> IO (Either ResponseError [SearchEntry])
 searchEither l base opts flt attributes =
   wait =<< searchAsync l base opts flt attributes
 
-searchAsync
+searchAsync :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO (Async [SearchEntry])
-  :: Ldap
-  -> Dn
-  -> Mod Search
-  -> Filter
-  -> [Attr]
-  -> IO (Async SearchError [SearchEntry])
 searchAsync l base opts flt attributes =
   atomically (searchAsyncSTM l base opts flt attributes)
 
-searchAsyncSTM
+searchAsyncSTM :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> STM (Async [SearchEntry])
-  :: Ldap
-  -> Dn
-  -> Mod Search
-  -> Filter
-  -> [Attr]
-  -> STM (Async SearchError [SearchEntry])
 searchAsyncSTM l base opts flt attributes =
-  sendRequest l searchResult (searchRequest base opts flt attributes)
+  let req = searchRequest base opts flt attributes in sendRequest l (searchResult req) req
-
-searchResult :: Response -> Either SearchError [SearchEntry]
-searchResult (Type.SearchResultDone (Type.LdapResult code _ _ _) :| xs)
-  | Type.Success <- code = Right (mapMaybe g xs)
-  | Type.AdminLimitExceeded <- code = Right (mapMaybe g xs)
-  | Type.SizeLimitExceeded <- code = Right (mapMaybe g xs)
-  | otherwise = Left (SearchErrorCode code)
- where
-  g (Type.SearchResultEntry (Type.LdapDn (Type.LdapString dn))
-                            (Type.PartialAttributeList ys)) =
-    Just (SearchEntry (Dn dn) (map h ys))
-  g _ = Nothing
-  h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x))
-                           y) = (Attr x, fmap j y)
-  j (Type.AttributeValue x) = x
-searchResult res = Left (SearchInvalidResponse res)
 
 searchRequest :: Dn -> Mod Search -> Filter -> [Attr] -> Request
 searchRequest (Dn base) (Mod m) flt attributes =
@@ -141,6 +98,23 @@ searchRequest (Dn base) (Mod m) flt attributes =
                                   (Type.AssertionValue y)
                                   b)
 
+searchResult :: Request -> Response -> Either ResponseError [SearchEntry]
+searchResult req (Type.SearchResultDone (Type.LdapResult code (Type.LdapDn (Type.LdapString dn'))
+                                                              (Type.LdapString msg) _) :| xs)
+  | Type.Success <- code = Right (mapMaybe g xs)
+  | Type.AdminLimitExceeded <- code = Right (mapMaybe g xs)
+  | Type.SizeLimitExceeded <- code = Right (mapMaybe g xs)
+  | otherwise = Left (ResponseErrorCode req code (Dn dn') msg)
+ where
+  g (Type.SearchResultEntry (Type.LdapDn (Type.LdapString dn))
+                            (Type.PartialAttributeList ys)) =
+    Just (SearchEntry (Dn dn) (map h ys))
+  g _ = Nothing
+  h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x))
+                           y) = (Attr x, fmap j y)
+  j (Type.AttributeValue x) = x
+searchResult req res = Left (ResponseInvalid req res)
+
 data Search = Search
   { _scope        :: Type.Scope
   , _derefAliases :: Type.DerefAliases
@@ -175,9 +149,12 @@ derefAliases x = Mod (\y -> y { _derefAliases = x })
 
 newtype Mod a = Mod (a -> a)
 
+instance Semigroup (Mod a) where
+  Mod f <> Mod g = Mod (g . f)
+
 instance Monoid (Mod a) where
   mempty = Mod id
-  Mod f `mappend` Mod g = Mod (g . f)
+  mappend = (<>)
 
 data Filter =
     Not Filter

test/Ldap/Client/AddSpec.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Ldap.Client.AddSpec (spec) where
+
+import           Data.Monoid ((<>))
+import           Test.Hspec
+
+import           Ldap.Client (Dn(..), Filter(..), Scope(..), Attr(..))
+import qualified Ldap.Client as Ldap
+
+import           SpecHelper (locally , dns , vulpix)
+
+
+spec :: Spec
+spec = do
+  let go l f = Ldap.search l (Dn "o=localhost")
+                             (Ldap.scope WholeSubtree <> Ldap.typesOnly True)
+                             f
+                             []
+
+  it "adds an entry" $ do
+    res <- locally $ \l -> do
+      Ldap.add l vulpix
+                 [ (Attr "cn",        ["vulpix"])
+                 , (Attr "evolution", ["0"])
+                 , (Attr "type",      ["fire"])
+                 ]
+      res <- go l (Attr "cn" := "vulpix")
+      dns res `shouldBe` [vulpix]
+    res `shouldBe` Right ()

test/Ldap/Client/BindSpec.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Ldap.Client.BindSpec (spec) where
 
-import Test.Hspec
+import           Test.Hspec
-import Ldap.Client as Ldap
+import qualified Ldap.Asn1.Type as Ldap.Type
+import           Ldap.Client as Ldap
 
-import SpecHelper (locally)
+import           SpecHelper (locally)
 
 
 spec :: Spec
@@ -17,7 +18,15 @@ spec = do
   it "tries to bind as ‘admin’ with the wrong password, unsuccessfully" $ do
     res <- locally $ \l -> do
       Ldap.bind l (Dn "cn=admin") (Password "public")
-    res `shouldBe` Left (Ldap.BindError (Ldap.BindErrorCode Ldap.InvalidCredentials))
+    res `shouldBe` Left
+      (Ldap.ResponseError
+        (Ldap.ResponseErrorCode
+          (Ldap.Type.BindRequest 3
+                                 (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=admin"))
+                                 (Ldap.Type.Simple "public"))
+          Ldap.InvalidCredentials
+          (Dn "cn=admin")
+          "Invalid Credentials"))
 
   it "binds as ‘pikachu’" $ do
     res <- locally $ \l -> do

test/Ldap/Client/CompareSpec.hs

@@ -1,8 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Ldap.Client.CompareSpec (spec) where
 
-import Test.Hspec
+import           Test.Hspec
-import Ldap.Client as Ldap
+import qualified Ldap.Asn1.Type as Ldap.Type
+import           Ldap.Client as Ldap
 
 import SpecHelper (locally, charmander, charizard)
 
@@ -25,4 +26,14 @@ spec = do
     res <- locally $ \l -> do
       res <- Ldap.compare l (Dn "cn=nope") (Attr "type") "flying"
       res `shouldBe` False
-    res `shouldBe` Left (CompareError (CompareErrorCode NoSuchObject))
+    res `shouldBe` Left
+      (Ldap.ResponseError
+        (Ldap.ResponseErrorCode
+          (Ldap.Type.CompareRequest
+                                 (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=nope"))
+                                 (Ldap.Type.AttributeValueAssertion
+                                    (Ldap.Type.AttributeDescription (Ldap.Type.LdapString "type"))
+                                    (Ldap.Type.AssertionValue "flying")))
+          Ldap.NoSuchObject
+          (Dn "")
+          "No tree found for: cn=nope"))

test/Ldap/Client/DeleteSpec.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Ldap.Client.DeleteSpec (spec) where
+
+import           Data.Monoid ((<>))
+import           Test.Hspec
+
+import           Ldap.Client (Dn(..), Filter(..), Scope(..), Attr(..))
+import qualified Ldap.Client as Ldap
+import qualified Ldap.Asn1.Type as Ldap.Type
+
+import           SpecHelper (locally, dns, pikachu, oddish)
+
+
+spec :: Spec
+spec = do
+  let go l f = Ldap.search l (Dn "o=localhost")
+                             (Ldap.scope WholeSubtree <> Ldap.typesOnly True)
+                             f
+                             []
+
+  it "deletes an entry" $ do
+    res <- locally $ \l -> do
+      Ldap.delete l pikachu
+      res <- go l (Attr "cn" := "pikachu")
+      dns res `shouldBe` []
+    res `shouldBe` Right ()
+
+  it "tries to delete an non-existing entry, unsuccessfully" $ do
+    res <- locally $ \l -> do
+      Ldap.delete l oddish
+    res `shouldBe` Left
+      (Ldap.ResponseError
+        (Ldap.ResponseErrorCode (Ldap.Type.DeleteRequest
+                                  (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=oddish,o=localhost")))
+                                Ldap.NoSuchObject
+                                (Dn "o=localhost")
+                                "cn=oddish,o=localhost"))

test/Ldap/Client/ModifySpec.hs

@@ -1,12 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Ldap.Client.ModifySpec (spec) where
 
-import Data.ByteString (ByteString)
+import           Data.ByteString (ByteString)
-import Data.Monoid ((<>))
+import           Data.Monoid ((<>))
-import Test.Hspec
+import           Test.Hspec
-import Ldap.Client as Ldap
+import qualified Ldap.Asn1.Type as Ldap.Type
+import           Ldap.Client as Ldap
 
-import SpecHelper (locally, charizard, pikachu)
+import           SpecHelper (locally, charizard, pikachu)
 
 
 spec :: Spec
@@ -32,7 +33,17 @@ spec = do
       res <- locally $ \l -> do
         Ldap.modify l pikachu [Attr "password" `Delete` []]
       res `shouldBe` Left
-        (ModifyError (ModifyErrorCode UnwillingToPerform (Dn "o=localhost") "cannot delete password"))
+        (ResponseError
+          (ResponseErrorCode
+            (Ldap.Type.ModifyRequest (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=pikachu,o=localhost"))
+                                     [( Ldap.Type.Delete
+                                     , Ldap.Type.PartialAttribute
+                                         (Ldap.Type.AttributeDescription (Ldap.Type.LdapString "password"))
+                                         []
+                                     )])
+                                     UnwillingToPerform
+                                     (Dn "o=localhost")
+                                     "cannot delete password"))
 
   context "add" $ do
     it "can feed ‘charizard’" $ do

test/Ldap/Client/SearchSpec.hs

@@ -2,11 +2,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Ldap.Client.SearchSpec (spec) where
 
-import Data.Monoid ((<>))
+import           Data.Monoid ((<>))
-import Test.Hspec
+import           Test.Hspec
-import Ldap.Client as Ldap
+import           Ldap.Client as Ldap
+import qualified Ldap.Asn1.Type as Ldap.Type
 
-import SpecHelper
+import           SpecHelper
   ( locally
   , dns
   , bulbasaur
@@ -36,7 +37,21 @@ spec = do
     res <- locally $ \l -> do
       Ldap.bind l pikachu (Password "i-choose-you")
       go l (Present (Attr "password"))
-    res `shouldBe` Left (Ldap.SearchError (Ldap.SearchErrorCode Ldap.InsufficientAccessRights))
+    let req = Ldap.Type.SearchRequest
+          (Ldap.Type.LdapDn (Ldap.Type.LdapString "o=localhost"))
+          Ldap.Type.WholeSubtree
+          Ldap.Type.NeverDerefAliases
+          0
+          0
+          True
+          (Ldap.Type.Present (Ldap.Type.AttributeDescription (Ldap.Type.LdapString "password")))
+          (Ldap.Type.AttributeSelection [])
+    res `shouldBe` Left
+      (Ldap.ResponseError
+        (Ldap.ResponseErrorCode req
+                                Ldap.InsufficientAccessRights
+                                (Dn "o=localhost")
+                                "Insufficient Access Rights"))
 
   it "‘present’ filter" $ do
     res <- locally $ \l -> do

test/Ldap/ClientSpec.hs

@@ -1,52 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Ldap.ClientSpec (spec) where
-
-import           Data.Monoid ((<>))
-import           Test.Hspec
-
-import           Ldap.Client (Dn(..), Filter(..), Scope(..), Attr(..))
-import qualified Ldap.Client as Ldap
-
-import           SpecHelper
-  ( locally
-  , dns
-  , pikachu
-  , vulpix
-  , oddish
-  )
-
-
-spec :: Spec
-spec = do
-  let go l f = Ldap.search l (Dn "o=localhost")
-                             (Ldap.scope WholeSubtree <> Ldap.typesOnly True)
-                             f
-                             []
-
-  context "add" $ do
-
-    it "adds an entry" $ do
-      res <- locally $ \l -> do
-        Ldap.add l vulpix
-                   [ (Attr "cn",        ["vulpix"])
-                   , (Attr "evolution", ["0"])
-                   , (Attr "type",      ["fire"])
-                   ]
-        res <- go l (Attr "cn" := "vulpix")
-        dns res `shouldBe` [vulpix]
-      res `shouldBe` Right ()
-
-  context "delete" $ do
-
-    it "deletes an entry" $ do
-      res <- locally $ \l -> do
-        Ldap.delete l pikachu
-        res <- go l (Attr "cn" := "pikachu")
-        dns res `shouldBe` []
-      res `shouldBe` Right ()
-
-    it "tries to delete an non-existing entry, unsuccessfully" $ do
-      res <- locally $ \l -> do
-        Ldap.delete l oddish
-      res `shouldBe` Left (Ldap.DeleteError (Ldap.DeleteErrorCode Ldap.NoSuchObject))