Implement the Abandon operation

README.markdown

@@ -17,7 +17,7 @@ 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]    | ✘
+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-client.cabal

@@ -34,6 +34,7 @@ library
     Ldap.Asn1.ToAsn1
     Ldap.Asn1.Type
     Ldap.Client
+    Ldap.Client.Abandon
     Ldap.Client.Add
     Ldap.Client.Asn1.ToAsn1
     Ldap.Client.Bind

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)
 

src/Ldap/Client.hs

@@ -57,12 +57,13 @@ module Ldap.Client
   ) where
 
 #if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative ((<$>))
+import           Control.Applicative ((<$>), (<*>))
 #endif
 import qualified Control.Concurrent.Async as Async
 import           Control.Concurrent.STM (atomically, throwSTM)
 import           Control.Concurrent.STM.TMVar (putTMVar)
 import           Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue)
+import           Control.Concurrent.STM.TVar (newTVarIO)
 import           Control.Exception (Exception, Handler(..), bracket, throwIO, catch, catches)
 import           Control.Monad (forever)
 import qualified Data.ASN1.BinaryEncoding as Asn1
@@ -118,6 +119,7 @@ import           Ldap.Client.Extended (Oid(..), extended)
 newLdap :: IO Ldap
 newLdap = Ldap
   <$> newTQueueIO
+  <*> newTVarIO (Type.Id 0)
 
 -- | Various failures that can happen when working with LDAP.
 data LdapError =
@@ -214,11 +216,11 @@ dispatch
   -> TQueue (Type.LdapMessage Request)
   -> IO a
 dispatch Ldap { client } inq outq =
-  flip fix (Map.empty, 1) $ \loop (!req, !counter) ->
+  flip fix Map.empty $ \loop !req ->
     loop =<< atomically (asum
-      [ do New new var <- readTQueue client
-           writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing)
-           return (Map.insert (Type.Id counter) ([], var) req, counter + 1)
+      [ do 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
@@ -233,7 +235,7 @@ dispatch Ldap { client } inq outq =
              Type.CompareResponse {}       -> done mid op req
              Type.ExtendedResponse {}      -> probablyDisconnect mid op req
              Type.IntermediateResponse {}  -> saveUp mid op req
-           return (res, counter)
+           return res
       ])
  where
   saveUp mid op res =

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

@@ -243,6 +243,10 @@ CompareRequest ::= [APPLICATION 14] SEQUENCE {
      ava             AttributeValueAssertion }
 @
 
+@
+AbandonRequest ::= [APPLICATION 16] MessageID
+@
+
 @
 ExtendedRequest ::= [APPLICATION 23] SEQUENCE {
      requestName      [0] LDAPOID,
@@ -296,6 +300,8 @@ instance ToAsn1 ProtocolClientOp where
        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 <>

src/Ldap/Client/Internal.hs

@@ -6,7 +6,7 @@ module Ldap.Client.Internal
   , Ldap(..)
   , ClientMessage(..)
   , Type.ResultCode(..)
-  , Async
+  , Async(..)
   , AttrList
     -- * Waiting for Request Completion
   , wait
@@ -29,6 +29,7 @@ module Ldap.Client.Internal
 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)
@@ -51,18 +52,19 @@ data Host =
 -- | A token. All functions that interact with the Directory require one.
 data Ldap = Ldap
   { 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.
-data 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
@@ -103,16 +105,22 @@ 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 { client } var msg = writeTQueue client (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
@@ -138,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"