From e087f3eb9951cac5caf65e59d5d0883dee570516 Mon Sep 17 00:00:00 2001 From: Matvey Aksenov Date: Wed, 1 Apr 2015 20:44:09 +0000 Subject: [PATCH] Support Delete --- README.markdown | 2 +- src/Ldap/Asn1/FromAsn1.hs | 10 +++++++++ src/Ldap/Asn1/ToAsn1.hs | 6 ++++- src/Ldap/Asn1/Type.hs | 2 ++ src/Ldap/Client.hs | 46 ++++++++++++++++++++++++++++++++++++++- test/Ldap/ClientSpec.hs | 15 +++++++++++++ test/ldap.js | 12 ++++++++++ 7 files changed, 90 insertions(+), 3 deletions(-) diff --git a/README.markdown b/README.markdown index 823e418..8e2c94c 100644 --- a/README.markdown +++ b/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 | ✘ diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs index 04cb1a0..9378002 100644 --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/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) ] {- | diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index 3c0ff06..dab035b 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/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 { diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index d57a90b..4bb0c7d 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/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 diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index 08d3c98..1105beb 100644 --- a/src/Ldap/Client.hs +++ b/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 diff --git a/test/Ldap/ClientSpec.hs b/test/Ldap/ClientSpec.hs index 6c05fb1..121468a 100644 --- a/test/Ldap/ClientSpec.hs +++ b/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" diff --git a/test/ldap.js b/test/ldap.js index d75ecf4..3056021 100755 --- a/test/ldap.js +++ b/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); });