diff --git a/README.markdown b/README.markdown index 8e2c94c..dd15d59 100644 --- a/README.markdown +++ b/README.markdown @@ -15,7 +15,7 @@ Modify Operation | 4.6 | ✘ Add Operation | 4.7 | ✔ Delete Operation | 4.8 | ✔ Modify DN Operation | 4.9 | ✘ -Compare Operation | 4.10 | ✘ +Compare Operation | 4.10 | ✔ Abandon Operation | 4.11 | ✘ Extended Operation | 4.12 | ✘ IntermediateResponse Message | 4.13 | ✘ diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs index 9378002..55dc42e 100644 --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/src/Ldap/Asn1/FromAsn1.hs @@ -237,6 +237,8 @@ SearchResultDone ::= [APPLICATION 5] LDAPResult AddResponse ::= [APPLICATION 9] LDAPResult DelResponse ::= [APPLICATION 11] LDAPResult + +CompareResponse ::= [APPLICATION 15] LDAPResult -} instance FromAsn1 ProtocolServerOp where fromAsn1 = asum @@ -270,6 +272,12 @@ instance FromAsn1 ProtocolServerOp where result <- fromAsn1 Asn1.End (Asn1.Container Asn1.Application 11) <- next return (DeleteResponse result) + + , do + Asn1.Start (Asn1.Container Asn1.Application 15) <- next + result <- fromAsn1 + Asn1.End (Asn1.Container Asn1.Application 15) <- next + return (CompareResponse result) ] {- | diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index dab035b..c6c6760 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -156,6 +156,10 @@ AddRequest ::= [APPLICATION 8] SEQUENCE { attributes AttributeList } DelRequest ::= [APPLICATION 10] LDAPDN + +CompareRequest ::= [APPLICATION 14] SEQUENCE { + entry LDAPDN, + ava AttributeValueAssertion } -} instance ToAsn1 ProtocolClientOp where toAsn1 (BindRequest v n a) = @@ -187,6 +191,8 @@ instance ToAsn1 ProtocolClientOp where application 8 (toAsn1 dn <> toAsn1 as) toAsn1 (DeleteRequest (LdapDn (LdapString dn))) = other Asn1.Application 10 (Text.encodeUtf8 dn) + toAsn1 (CompareRequest dn av) = + application 14 (toAsn1 dn <> sequence (toAsn1 av)) {- | AuthenticationChoice ::= CHOICE { diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index 4bb0c7d..c9cf289 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/src/Ldap/Asn1/Type.hs @@ -22,6 +22,7 @@ data ProtocolClientOp = | SearchRequest LdapDn Scope DerefAliases Int32 Int32 Bool Filter AttributeSelection | AddRequest LdapDn AttributeList | DeleteRequest LdapDn + | CompareRequest LdapDn AttributeValueAssertion deriving (Show, Eq, Ord) data ProtocolServerOp = @@ -31,6 +32,7 @@ data ProtocolServerOp = | SearchResultDone (LdapResult) | AddResponse LdapResult | DeleteResponse LdapResult + | CompareResponse LdapResult deriving (Show, Eq, Ord) data AuthenticationChoice = Simple ByteString diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index f14e85c..015941b 100644 --- a/src/Ldap/Client.hs +++ b/src/Ldap/Client.hs @@ -31,15 +31,12 @@ module Ldap.Client , AttrList , AddError(..) , add - , addEither - , addAsync - , addAsyncSTM -- * Delete Request , DeleteError(..) , delete - , deleteEither - , deleteAsync - , deleteAsyncSTM + -- * Compare Request + , CompareError(..) + , compare -- * Waiting for Request Completion , wait , waitSTM @@ -64,6 +61,7 @@ import Data.Monoid (Endo(appEndo)) import Network.Connection (Connection) import qualified Network.Connection as Conn import qualified System.IO.Error as IO +import Prelude hiding (compare) import Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1)) import Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1) @@ -82,6 +80,7 @@ import Ldap.Client.Search , Filter(..) , SearchEntry(..) ) +import Ldap.Client.Compare (CompareError(..), compare) newLdap :: IO Ldap @@ -95,6 +94,7 @@ data LdapError = | SearchError SearchError | AddError AddError | DeleteError DeleteError + | CompareError CompareError deriving (Show, Eq) -- | The entrypoint into LDAP. @@ -117,6 +117,7 @@ with host port f = do , Handler (return . Left . SearchError) , Handler (return . Left . AddError) , Handler (return . Left . DeleteError) + , Handler (return . Left . CompareError) ] where params = Conn.ConnectionParams @@ -199,4 +200,7 @@ dispatch Ldap { client } inq outq = Type.DeleteResponse {} -> do traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results) return (Map.delete mid got, Map.delete mid results, counter) + Type.CompareResponse {} -> do + traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results) + return (Map.delete mid got, Map.delete mid results, counter) ]) diff --git a/src/Ldap/Client/Compare.hs b/src/Ldap/Client/Compare.hs new file mode 100644 index 0000000..269a8df --- /dev/null +++ b/src/Ldap/Client/Compare.hs @@ -0,0 +1,55 @@ +module Ldap.Client.Compare + ( CompareError(..) + , 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 l dn k v = + wait =<< compareAsync l dn k v + +compareAsync :: Ldap -> Dn -> Attr -> ByteString -> IO (Async CompareError Bool) +compareAsync l dn k v = + atomically (compareAsyncSTM l dn k v) + +compareAsyncSTM :: Ldap -> Dn -> Attr -> ByteString -> STM (Async CompareError Bool) +compareAsyncSTM l dn k v = + sendRequest l compareResult (compareRequest dn k v) + +compareRequest :: Dn -> Attr -> ByteString -> Request +compareRequest (Dn dn) (Attr k) v = + Type.CompareRequest (Type.LdapDn (Type.LdapString dn)) + (Type.AttributeValueAssertion + (Type.AttributeDescription (Type.LdapString k)) + (Type.AssertionValue v)) + +compareResult :: Response -> Either CompareError Bool +compareResult (Type.CompareResponse (Type.LdapResult code _ _ _) :| []) + | Type.CompareTrue <- code = Right True + | Type.CompareFalse <- code = Right False + | otherwise = Left (CompareErrorCode code) +compareResult res = Left (CompareInvalidResponse res) diff --git a/test/Ldap/Client/CompareSpec.hs b/test/Ldap/Client/CompareSpec.hs new file mode 100644 index 0000000..63d73aa --- /dev/null +++ b/test/Ldap/Client/CompareSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Ldap.Client.CompareSpec (spec) where + +import Test.Hspec +import Ldap.Client as Ldap + +import SpecHelper (locally, charmander, charizard) + + +spec :: Spec +spec = do + it "compares and wins" $ do + res <- locally $ \l -> do + res <- Ldap.compare l charizard (Attr "type") "fire" + res `shouldBe` True + res `shouldBe` Right () + + it "compares and looses" $ do + res <- locally $ \l -> do + res <- Ldap.compare l charmander (Attr "type") "flying" + res `shouldBe` False + res `shouldBe` Right () + + it "tries to compare non-existing object, unsuccessfully" $ do + res <- locally $ \l -> do + res <- Ldap.compare l (Dn "cn=nope") (Attr "type") "flying" + res `shouldBe` False + res `shouldBe` Left (CompareError (CompareErrorCode NoSuchObject)) diff --git a/test/Ldap/ClientSpec.hs b/test/Ldap/ClientSpec.hs index e1500da..f557a5e 100644 --- a/test/Ldap/ClientSpec.hs +++ b/test/Ldap/ClientSpec.hs @@ -46,7 +46,7 @@ spec = do dns res `shouldBe` [] res `shouldBe` Right () - it "tries to delete an unexisting entry, unsuccessfully" $ do + 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)) diff --git a/test/ldap.js b/test/ldap.js index d21b472..787f1d6 100755 --- a/test/ldap.js +++ b/test/ldap.js @@ -98,7 +98,7 @@ server.add('o=localhost', [], function(req, res, next) { server.del('o=localhost', [], function(req, res, next) { for (var i = 0; i < pokemon.length; i++) { - if (req.dn.toString() == pokemon[i].dn) { + if (req.dn.toString() === pokemon[i].dn) { pokemon.splice(i, 1); res.end(); return next(); @@ -108,6 +108,31 @@ server.del('o=localhost', [], function(req, res, next) { return next(new ldapjs.NoSuchObjectError(req.dn.toString())); }); +server.compare('o=localhost', [], function(req, res, next) { + for (var i = 0; i < pokemon.length; i++) { + if (req.dn.toString() === pokemon[i].dn) { + for (var attribute in pokemon[i].attributes) { + if (attribute === req.attribute) { + for (var j = 0; j < pokemon[i].attributes[attribute].length; j++) { + if (pokemon[i].attributes[attribute][j] === req.value) { + res.end(true); + return next(); + } + } + + res.end(false); + return next(); + } + } + + res.end(false); + return next(); + } + } + + return next(new ldapjs.NoSuchObjectError(req.dn.toString())); +}); + server.listen(port, function() { console.log("ldaps://localhost:%d", port); });