Support Compare

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        | ✘

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)
     ]
 
 {- |

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 {

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

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)
       ])

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)

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))

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))

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);
 });