From da54207774bc2f4330d4c53bffc5a0c683ee234b Mon Sep 17 00:00:00 2001 From: Matvey Aksenov Date: Thu, 23 Apr 2015 13:24:00 +0000 Subject: [PATCH] Implement the `Abandon` operation --- README.markdown | 2 +- ldap-client.cabal | 1 + src/Ldap/Asn1/Type.hs | 1 + src/Ldap/Client.hs | 14 ++++++------ src/Ldap/Client/Abandon.hs | 39 ++++++++++++++++++++++++++++++++++ src/Ldap/Client/Asn1/ToAsn1.hs | 6 ++++++ src/Ldap/Client/Internal.hs | 28 +++++++++++++++--------- 7 files changed, 74 insertions(+), 17 deletions(-) create mode 100644 src/Ldap/Client/Abandon.hs diff --git a/README.markdown b/README.markdown index 8b91d37..6f6adc7 100644 --- a/README.markdown +++ b/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] | ✔† diff --git a/ldap-client.cabal b/ldap-client.cabal index 2527a0e..04469e0 100644 --- a/ldap-client.cabal +++ b/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 diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index b8f954e..8431e49 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/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) diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index c4b207b..d50e11e 100644 --- a/src/Ldap/Client.hs +++ b/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 = diff --git a/src/Ldap/Client/Abandon.hs b/src/Ldap/Client/Abandon.hs new file mode 100644 index 0000000..caec351 --- /dev/null +++ b/src/Ldap/Client/Abandon.hs @@ -0,0 +1,39 @@ +-- | 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 diff --git a/src/Ldap/Client/Asn1/ToAsn1.hs b/src/Ldap/Client/Asn1/ToAsn1.hs index b866f2f..28a3371 100644 --- a/src/Ldap/Client/Asn1/ToAsn1.hs +++ b/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 <> diff --git a/src/Ldap/Client/Internal.hs b/src/Ldap/Client/Internal.hs index 15e3a91..b93518e 100644 --- a/src/Ldap/Client/Internal.hs +++ b/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"