Support Delete

README.markdown

@@ -13,7 +13,7 @@ Notice of Disconnection      | 4.4.1       | ✘
 Search Operation             | 4.5         | ✔ (partial)
 Modify Operation             | 4.6         | ✘
 Add Operation                | 4.7         | ✔
-Delete Operation             | 4.8         | ✘
+Delete Operation             | 4.8         | ✔
 Modify DN Operation          | 4.9         | ✘
 Compare Operation            | 4.10        | ✘
 Abandon Operation            | 4.11        | ✘

src/Ldap/Asn1/FromAsn1.hs

@@ -233,6 +233,10 @@ SearchResultEntry ::= [APPLICATION 4] SEQUENCE {
      attributes      PartialAttributeList }
 
 SearchResultDone ::= [APPLICATION 5] LDAPResult
+
+AddResponse ::= [APPLICATION 9] LDAPResult
+
+DelResponse ::= [APPLICATION 11] LDAPResult
 -}
 instance FromAsn1 ProtocolServerOp where
   fromAsn1 = asum
@@ -260,6 +264,12 @@ instance FromAsn1 ProtocolServerOp where
       result <- fromAsn1
       Asn1.End (Asn1.Container Asn1.Application 9) <- next
       return (AddResponse result)
+
+    , do
+      Asn1.Start (Asn1.Container Asn1.Application 11) <- next
+      result <- fromAsn1
+      Asn1.End (Asn1.Container Asn1.Application 11) <- next
+      return (DeleteResponse result)
     ]
 
 {- |

src/Ldap/Asn1/ToAsn1.hs

@@ -35,7 +35,7 @@ LDAPMessage ::= SEQUENCE {
 -}
 instance ToAsn1 op => ToAsn1 (LdapMessage op) where
   toAsn1 (LdapMessage i op mc) =
-    sequence (toAsn1 i <> toAsn1 op <> context 0 (optional mc))
+    sequence (toAsn1 i <> toAsn1 op <> maybe mempty (context 0 . toAsn1) mc)
 
 {- |
 MessageID ::= INTEGER (0 ..  maxInt)
@@ -154,6 +154,8 @@ SearchRequest ::= [APPLICATION 3] SEQUENCE {
 AddRequest ::= [APPLICATION 8] SEQUENCE {
      entry           LDAPDN,
      attributes      AttributeList }
+
+DelRequest ::= [APPLICATION 10] LDAPDN
 -}
 instance ToAsn1 ProtocolClientOp where
   toAsn1 (BindRequest v n a) =
@@ -183,6 +185,8 @@ instance ToAsn1 ProtocolClientOp where
       DerefAlways            -> 3
   toAsn1 (AddRequest dn as) =
     application 8 (toAsn1 dn <> toAsn1 as)
+  toAsn1 (DeleteRequest (LdapDn (LdapString dn))) =
+    other Asn1.Application 10 (Text.encodeUtf8 dn)
 
 {- |
 AuthenticationChoice ::= CHOICE {

src/Ldap/Asn1/Type.hs

@@ -21,6 +21,7 @@ data ProtocolClientOp =
   | UnbindRequest
   | SearchRequest LdapDn Scope DerefAliases Int32 Int32 Bool Filter AttributeSelection
   | AddRequest LdapDn AttributeList
+  | DeleteRequest LdapDn
     deriving (Show, Eq, Ord)
 
 data ProtocolServerOp =
@@ -29,6 +30,7 @@ data ProtocolServerOp =
   | SearchResultReference (NonEmpty Uri)
   | SearchResultDone (LdapResult)
   | AddResponse LdapResult
+  | DeleteResponse LdapResult
     deriving (Show, Eq, Ord)
 
 data AuthenticationChoice = Simple ByteString

src/Ldap/Client.hs

@@ -44,6 +44,12 @@ module Ldap.Client
   , addEither
   , addAsync
   , addAsyncSTM
+    -- * Delete Request
+  , DeleteError(..)
+  , delete
+  , deleteEither
+  , deleteAsync
+  , deleteAsyncSTM
     -- * Waiting for Request Completion
   , wait
   , waitSTM
@@ -106,6 +112,8 @@ data LdapError =
   | ParseError Asn1.ASN1Error
   | BindError BindError
   | SearchError SearchError
+  | AddError AddError
+  | DeleteError DeleteError
     deriving (Show, Eq)
 
 -- | The entrypoint into LDAP.
@@ -126,6 +134,8 @@ with host port f = do
   , Handler (return . Left . ParseError)
   , Handler (return . Left . BindError)
   , Handler (return . Left . SearchError)
+  , Handler (return . Left . AddError)
+  , Handler (return . Left . DeleteError)
   ]
  where
   params = Conn.ConnectionParams
@@ -195,6 +205,9 @@ dispatch Ldap { client } inq outq =
              Type.AddResponse {} -> do
                traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
                return (Map.delete mid got, Map.delete mid results, counter)
+             Type.DeleteResponse {} -> do
+               traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
+               return (Map.delete mid got, Map.delete mid results, counter)
       ])
 
 
@@ -472,13 +485,44 @@ addAsyncSTM l (Dn dn) as =
   f (Attr x, xs) = Type.Attribute (Type.AttributeDescription (Type.LdapString x))
                                   (fmap Type.AttributeValue xs)
 
-addResult :: NonEmpty Type.ProtocolServerOp -> Either AddError ()
+addResult :: Response -> Either AddError ()
 addResult (Type.AddResponse (Type.LdapResult code _ _ _) :| [])
   | Type.Success <- code = Right ()
   | otherwise = Left (AddErrorCode code)
 addResult res = Left (AddInvalidResponse res)
 
 
+data DeleteError =
+    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
 

test/Ldap/ClientSpec.hs

@@ -156,6 +156,20 @@ spec = do
         dns res `shouldBe` [vulpix]
       res `shouldBe` Right ()
 
+  context "delete" $ do
+
+    it "deletes an entry" $ do
+      res <- locally $ \l -> do
+        Ldap.delete l pikachu
+        res <- search l (Attr "cn" := "pikachu")
+        dns res `shouldBe` []
+      res `shouldBe` Right ()
+
+    it "tries to delete an unexisting entry, unsuccessfully" $ do
+      res <- locally $ \l -> do
+        Ldap.delete l oddish
+      res `shouldBe` Left (Ldap.DeleteError (Ldap.DeleteErrorCode Ldap.NoSuchObject))
+
  where
   bulbasaur = Dn "cn=bulbasaur,o=localhost"
   ivysaur = Dn "cn=ivysaur,o=localhost"
@@ -171,6 +185,7 @@ spec = do
   butterfree = Dn "cn=butterfree,o=localhost"
   pikachu = Dn "cn=pikachu,o=localhost"
   vulpix = Dn "cn=vulpix,o=localhost"
+  oddish = Dn "cn=oddish,o=localhost"
 
 localhost :: Ldap.Host
 localhost = Ldap.Plain "localhost"

test/ldap.js

@@ -92,6 +92,18 @@ server.add('o=localhost', [], function(req, res, next) {
   return next();
 });
 
+server.del('o=localhost', [], function(req, res, next) {
+  for (var i = 0; i < pokemon.length; i++) {
+    if (req.dn.toString() == pokemon[i].dn) {
+      pokemon.splice(i, 1);
+      res.end();
+      return next();
+    }
+  }
+
+  return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
+});
+
 server.listen(port, function() {
   console.log("ldap://localhost:%d", port);
 });